diff options
| -rw-r--r-- | .depend | 344 | ||||
| -rw-r--r-- | .gitignore | 10 | ||||
| -rw-r--r-- | Changelog | 26 | ||||
| -rw-r--r-- | Makefile | 36 | ||||
| -rw-r--r-- | arm/Archi.v | 16 | ||||
| -rw-r--r-- | arm/Asm.v | 30 | ||||
| -rw-r--r-- | arm/Asmgen.v | 18 | ||||
| -rw-r--r-- | arm/Asmgenproof.v | 59 | ||||
| -rw-r--r-- | arm/Asmgenproof1.v | 126 | ||||
| -rw-r--r-- | arm/ConstpropOp.vp | 20 | ||||
| -rw-r--r-- | arm/ConstpropOpproof.v | 98 | ||||
| -rw-r--r-- | arm/Conventions1.v | 19 | ||||
| -rw-r--r-- | arm/NeedOp.v | 6 | ||||
| -rw-r--r-- | arm/Op.v | 189 | ||||
| -rw-r--r-- | arm/SelectLong.vp | 21 | ||||
| -rw-r--r-- | arm/SelectLongproof.v | 22 | ||||
| -rw-r--r-- | arm/SelectOp.vp | 10 | ||||
| -rw-r--r-- | arm/SelectOpproof.v | 17 | ||||
| -rw-r--r-- | arm/ValueAOp.v | 8 | ||||
| -rw-r--r-- | backend/Allocation.v | 120 | ||||
| -rw-r--r-- | backend/Allocproof.v | 400 | ||||
| -rw-r--r-- | backend/Asmgenproof0.v | 75 | ||||
| -rw-r--r-- | backend/Bounds.v | 43 | ||||
| -rw-r--r-- | backend/CSE.v | 10 | ||||
| -rw-r--r-- | backend/CSEproof.v | 64 | ||||
| -rw-r--r-- | backend/Cminor.v | 45 | ||||
| -rw-r--r-- | backend/CminorSel.v | 22 | ||||
| -rw-r--r-- | backend/Constprop.v | 12 | ||||
| -rw-r--r-- | backend/Constpropproof.v | 42 | ||||
| -rw-r--r-- | backend/Deadcodeproof.v | 32 | ||||
| -rw-r--r-- | backend/Debugvar.v | 2 | ||||
| -rw-r--r-- | backend/IRC.ml | 41 | ||||
| -rw-r--r-- | backend/IRC.mli | 4 | ||||
| -rw-r--r-- | backend/Inlining.v | 12 | ||||
| -rw-r--r-- | backend/Inliningproof.v | 50 | ||||
| -rw-r--r-- | backend/Inliningspec.v | 4 | ||||
| -rw-r--r-- | backend/LTL.v | 21 | ||||
| -rw-r--r-- | backend/Linear.v | 19 | ||||
| -rw-r--r-- | backend/Lineartyping.v | 3 | ||||
| -rw-r--r-- | backend/Mach.v | 46 | ||||
| -rw-r--r-- | backend/NeedDomain.v | 64 | ||||
| -rw-r--r-- | backend/PrintAsmaux.ml | 3 | ||||
| -rw-r--r-- | backend/RTL.v | 20 | ||||
| -rw-r--r-- | backend/RTLtyping.v | 18 | ||||
| -rw-r--r-- | backend/Regalloc.ml | 88 | ||||
| -rw-r--r-- | backend/SelectDiv.vp | 138 | ||||
| -rw-r--r-- | backend/SelectDivproof.v | 405 | ||||
| -rw-r--r-- | backend/Selection.v | 69 | ||||
| -rw-r--r-- | backend/Selectionproof.v | 161 | ||||
| -rw-r--r-- | backend/SplitLong.vp (renamed from backend/SelectLong.vp) | 109 | ||||
| -rw-r--r-- | backend/SplitLongproof.v (renamed from backend/SelectLongproof.v) | 298 | ||||
| -rw-r--r-- | backend/Stacking.v | 30 | ||||
| -rw-r--r-- | backend/Stackingproof.v | 180 | ||||
| -rw-r--r-- | backend/Tailcallproof.v | 26 | ||||
| -rw-r--r-- | backend/Unusedglobproof.v | 42 | ||||
| -rw-r--r-- | backend/ValueAnalysis.v | 40 | ||||
| -rw-r--r-- | backend/ValueDomain.v | 760 | ||||
| -rw-r--r-- | cfrontend/C2C.ml | 70 | ||||
| -rw-r--r-- | cfrontend/Cexec.v | 237 | ||||
| -rw-r--r-- | cfrontend/Clight.v | 32 | ||||
| -rw-r--r-- | cfrontend/Cminorgen.v | 6 | ||||
| -rw-r--r-- | cfrontend/Cminorgenproof.v | 174 | ||||
| -rw-r--r-- | cfrontend/Cop.v | 641 | ||||
| -rw-r--r-- | cfrontend/Csem.v | 30 | ||||
| -rw-r--r-- | cfrontend/Csharpminor.v | 2 | ||||
| -rw-r--r-- | cfrontend/Cshmgen.v | 123 | ||||
| -rw-r--r-- | cfrontend/Cshmgenproof.v | 481 | ||||
| -rw-r--r-- | cfrontend/Cstrategy.v | 16 | ||||
| -rw-r--r-- | cfrontend/Csyntax.v | 2 | ||||
| -rw-r--r-- | cfrontend/Ctypes.v | 50 | ||||
| -rw-r--r-- | cfrontend/Ctyping.v | 185 | ||||
| -rw-r--r-- | cfrontend/Initializers.v | 33 | ||||
| -rw-r--r-- | cfrontend/Initializersproof.v | 89 | ||||
| -rw-r--r-- | cfrontend/SimplExprproof.v | 22 | ||||
| -rw-r--r-- | cfrontend/SimplLocals.v | 2 | ||||
| -rw-r--r-- | cfrontend/SimplLocalsproof.v | 72 | ||||
| -rw-r--r-- | common/AST.v | 38 | ||||
| -rw-r--r-- | common/Determinism.v | 8 | ||||
| -rw-r--r-- | common/Events.v | 169 | ||||
| -rw-r--r-- | common/Globalenvs.v | 124 | ||||
| -rw-r--r-- | common/Memdata.v | 120 | ||||
| -rw-r--r-- | common/Memory.v | 166 | ||||
| -rw-r--r-- | common/Memtype.v | 38 | ||||
| -rw-r--r-- | common/Separation.v | 30 | ||||
| -rw-r--r-- | common/Values.v | 824 | ||||
| -rwxr-xr-x | configure | 114 | ||||
| -rw-r--r-- | cparser/PackedStructs.ml | 6 | ||||
| -rw-r--r-- | driver/Configuration.ml | 2 | ||||
| -rw-r--r-- | driver/Driver.ml | 9 | ||||
| -rw-r--r-- | driver/Interp.ml | 14 | ||||
| -rw-r--r-- | extraction/extraction.v | 1 | ||||
| -rw-r--r-- | ia32/ConstpropOp.vp | 227 | ||||
| -rw-r--r-- | ia32/ConstpropOpproof.v | 543 | ||||
| -rw-r--r-- | ia32/Conventions1.v | 240 | ||||
| -rw-r--r-- | ia32/Op.v | 1075 | ||||
| -rw-r--r-- | lib/Integers.v | 601 | ||||
| -rw-r--r-- | powerpc/Archi.v | 15 | ||||
| -rw-r--r-- | powerpc/Asm.v | 58 | ||||
| -rw-r--r-- | powerpc/Asmgen.v | 22 | ||||
| -rw-r--r-- | powerpc/Asmgenproof.v | 83 | ||||
| -rw-r--r-- | powerpc/Asmgenproof1.v | 125 | ||||
| -rw-r--r-- | powerpc/ConstpropOp.vp | 36 | ||||
| -rw-r--r-- | powerpc/ConstpropOpproof.v | 133 | ||||
| -rw-r--r-- | powerpc/Conventions1.v | 26 | ||||
| -rw-r--r-- | powerpc/NeedOp.v | 6 | ||||
| -rw-r--r-- | powerpc/Op.v | 163 | ||||
| -rw-r--r-- | powerpc/SelectLong.vp | 21 | ||||
| -rw-r--r-- | powerpc/SelectLongproof.v | 22 | ||||
| -rw-r--r-- | powerpc/SelectOp.vp | 20 | ||||
| -rw-r--r-- | powerpc/SelectOpproof.v | 34 | ||||
| -rw-r--r-- | powerpc/ValueAOp.v | 8 | ||||
| -rw-r--r-- | runtime/Makefile | 16 | ||||
| -rw-r--r-- | runtime/arm/i64_smulh.S | 77 | ||||
| -rw-r--r-- | runtime/arm/i64_umulh.S | 61 | ||||
| -rw-r--r-- | runtime/arm/sysdeps.h | 1 | ||||
| -rw-r--r-- | runtime/c/i64.h | 2 | ||||
| -rw-r--r-- | runtime/c/i64_smulh.c | 56 | ||||
| -rw-r--r-- | runtime/c/i64_umulh.c | 66 | ||||
| -rw-r--r-- | runtime/powerpc/i64_smul.s | 76 | ||||
| -rw-r--r-- | runtime/powerpc/i64_smulh.s | 79 | ||||
| -rw-r--r-- | runtime/powerpc/i64_umul.s | 64 | ||||
| -rw-r--r-- | runtime/powerpc/i64_umulh.s | 65 | ||||
| -rw-r--r-- | runtime/x86_32/i64_dtos.S (renamed from runtime/ia32/i64_dtos.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_dtou.S (renamed from runtime/ia32/i64_dtou.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_sar.S (renamed from runtime/ia32/i64_sar.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_sdiv.S (renamed from runtime/ia32/i64_sdiv.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_shl.S (renamed from runtime/ia32/i64_shl.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_shr.S (renamed from runtime/ia32/i64_shr.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_smod.S (renamed from runtime/ia32/i64_smod.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_smulh.S | 94 | ||||
| -rw-r--r-- | runtime/x86_32/i64_stod.S (renamed from runtime/ia32/i64_stod.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_stof.S (renamed from runtime/ia32/i64_stof.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_udiv.S (renamed from runtime/ia32/i64_udiv.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_udivmod.S (renamed from runtime/ia32/i64_udivmod.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_umod.S (renamed from runtime/ia32/i64_umod.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_umulh.S | 74 | ||||
| -rw-r--r-- | runtime/x86_32/i64_utod.S (renamed from runtime/ia32/i64_utod.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/i64_utof.S (renamed from runtime/ia32/i64_utof.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/sysdeps.h (renamed from runtime/ia32/sysdeps.h) | 0 | ||||
| -rw-r--r-- | runtime/x86_32/vararg.S (renamed from runtime/ia32/vararg.S) | 0 | ||||
| -rw-r--r-- | runtime/x86_64/i64_dtou.S | 56 | ||||
| -rw-r--r-- | runtime/x86_64/i64_utod.S | 56 | ||||
| -rw-r--r-- | runtime/x86_64/i64_utof.S | 56 | ||||
| -rw-r--r-- | runtime/x86_64/sysdeps.h | 75 | ||||
| -rw-r--r-- | runtime/x86_64/vararg.S | 148 | ||||
| -rw-r--r-- | test/regression/Makefile | 17 | ||||
| -rw-r--r-- | test/regression/Results/builtins-x86 (renamed from test/regression/Results/builtins-ia32) | 1 | ||||
| -rw-r--r-- | test/regression/Results/initializers-32 (renamed from test/regression/Results/initializers) | 0 | ||||
| -rw-r--r-- | test/regression/Results/initializers-64 | 30 | ||||
| -rw-r--r-- | test/regression/Results/int64 | 2160 | ||||
| -rw-r--r-- | test/regression/Results/packedstruct1-32 (renamed from test/regression/Results/packedstruct1) | 0 | ||||
| -rw-r--r-- | test/regression/Results/packedstruct1-64 | 25 | ||||
| -rw-r--r-- | test/regression/Results/sizeof1-32 (renamed from test/regression/Results/sizeof1) | 0 | ||||
| -rw-r--r-- | test/regression/Results/sizeof1-64 | 3 | ||||
| -rwxr-xr-x | test/regression/Runtest | 49 | ||||
| -rw-r--r-- | test/regression/alias.c | 10 | ||||
| -rw-r--r-- | test/regression/builtins-x86.c (renamed from test/regression/builtins-ia32.c) | 2 | ||||
| -rw-r--r-- | test/regression/extasm.c | 12 | ||||
| -rw-r--r-- | test/regression/initializers2.c | 2 | ||||
| -rw-r--r-- | test/regression/int64.c | 12 | ||||
| -rw-r--r-- | test/regression/sizeof1.c | 6 | ||||
| -rw-r--r-- | test/regression/sizeof2.c | 4 | ||||
| -rw-r--r-- | x86/Asm.v (renamed from ia32/Asm.v) | 551 | ||||
| -rw-r--r-- | x86/AsmToJSON.ml (renamed from ia32/AsmToJSON.ml) | 0 | ||||
| -rw-r--r-- | x86/AsmToJSON.mli (renamed from ia32/AsmToJSON.mli) | 0 | ||||
| -rw-r--r-- | x86/Asmexpand.ml (renamed from ia32/Asmexpand.ml) | 420 | ||||
| -rw-r--r-- | x86/Asmgen.v (renamed from ia32/Asmgen.v) | 369 | ||||
| -rw-r--r-- | x86/Asmgenproof.v (renamed from ia32/Asmgenproof.v) | 131 | ||||
| -rw-r--r-- | x86/Asmgenproof1.v (renamed from ia32/Asmgenproof1.v) | 800 | ||||
| -rw-r--r-- | x86/CBuiltins.ml (renamed from ia32/CBuiltins.ml) | 15 | ||||
| -rw-r--r-- | x86/CombineOp.v (renamed from ia32/CombineOp.v) | 49 | ||||
| -rw-r--r-- | x86/CombineOpproof.v (renamed from ia32/CombineOpproof.v) | 48 | ||||
| -rw-r--r-- | x86/ConstpropOp.vp | 404 | ||||
| -rw-r--r-- | x86/ConstpropOpproof.v | 883 | ||||
| -rw-r--r-- | x86/Conventions1.v | 473 | ||||
| -rw-r--r-- | x86/Machregs.v (renamed from ia32/Machregs.v) | 124 | ||||
| -rw-r--r-- | x86/Machregsaux.ml (renamed from ia32/Machregsaux.ml) | 0 | ||||
| -rw-r--r-- | x86/Machregsaux.mli (renamed from ia32/Machregsaux.mli) | 0 | ||||
| -rw-r--r-- | x86/NeedOp.v (renamed from ia32/NeedOp.v) | 114 | ||||
| -rw-r--r-- | x86/Op.v | 1452 | ||||
| -rw-r--r-- | x86/PrintOp.ml (renamed from ia32/PrintOp.ml) | 73 | ||||
| -rw-r--r-- | x86/SelectLong.vp | 347 | ||||
| -rw-r--r-- | x86/SelectLongproof.v | 555 | ||||
| -rw-r--r-- | x86/SelectOp.vp (renamed from ia32/SelectOp.vp) | 79 | ||||
| -rw-r--r-- | x86/SelectOpproof.v (renamed from ia32/SelectOpproof.v) | 330 | ||||
| -rw-r--r-- | x86/Stacklayout.v (renamed from ia32/Stacklayout.v) | 70 | ||||
| -rw-r--r-- | x86/TargetPrinter.ml (renamed from ia32/TargetPrinter.ml) | 574 | ||||
| -rw-r--r-- | x86/ValueAOp.v (renamed from ia32/ValueAOp.v) | 134 | ||||
| -rw-r--r-- | x86/extractionMachdep.v (renamed from ia32/extractionMachdep.v) | 10 | ||||
| -rw-r--r-- | x86_32/Archi.v | 54 | ||||
| -rw-r--r-- | x86_64/Archi.v (renamed from ia32/Archi.v) | 21 |
191 files changed, 16450 insertions, 7066 deletions
diff --git a/.depend b/.depend deleted file mode 100644 index b5adfa69..00000000 --- a/.depend +++ /dev/null @@ -1,344 +0,0 @@ -lib/Axioms.vo lib/Axioms.glob lib/Axioms.v.beautified: lib/Axioms.v -lib/Axioms.vio: lib/Axioms.v -lib/Coqlib.vo lib/Coqlib.glob lib/Coqlib.v.beautified: lib/Coqlib.v -lib/Coqlib.vio: lib/Coqlib.v -lib/Intv.vo lib/Intv.glob lib/Intv.v.beautified: lib/Intv.v lib/Coqlib.vo -lib/Intv.vio: lib/Intv.v lib/Coqlib.vio -lib/Maps.vo lib/Maps.glob lib/Maps.v.beautified: lib/Maps.v lib/Coqlib.vo -lib/Maps.vio: lib/Maps.v lib/Coqlib.vio -lib/Heaps.vo lib/Heaps.glob lib/Heaps.v.beautified: lib/Heaps.v lib/Coqlib.vo lib/Ordered.vo -lib/Heaps.vio: lib/Heaps.v lib/Coqlib.vio lib/Ordered.vio -lib/Lattice.vo lib/Lattice.glob lib/Lattice.v.beautified: lib/Lattice.v lib/Coqlib.vo lib/Maps.vo -lib/Lattice.vio: lib/Lattice.v lib/Coqlib.vio lib/Maps.vio -lib/Ordered.vo lib/Ordered.glob lib/Ordered.v.beautified: lib/Ordered.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo -lib/Ordered.vio: lib/Ordered.v lib/Coqlib.vio lib/Maps.vio lib/Integers.vio -lib/Iteration.vo lib/Iteration.glob lib/Iteration.v.beautified: lib/Iteration.v lib/Axioms.vo lib/Coqlib.vo lib/Wfsimpl.vo -lib/Iteration.vio: lib/Iteration.v lib/Axioms.vio lib/Coqlib.vio lib/Wfsimpl.vio -lib/Integers.vo lib/Integers.glob lib/Integers.v.beautified: lib/Integers.v lib/Coqlib.vo -lib/Integers.vio: lib/Integers.v lib/Coqlib.vio -$(ARCH)/Archi.vo $(ARCH)/Archi.glob $(ARCH)/Archi.v.beautified: $(ARCH)/Archi.v flocq/Appli/Fappli_IEEE.vo flocq/Appli/Fappli_IEEE_bits.vo -$(ARCH)/Archi.vio: $(ARCH)/Archi.v flocq/Appli/Fappli_IEEE.vio flocq/Appli/Fappli_IEEE_bits.vio -lib/Fappli_IEEE_extra.vo lib/Fappli_IEEE_extra.glob lib/Fappli_IEEE_extra.v.beautified: lib/Fappli_IEEE_extra.v flocq/Core/Fcore.vo flocq/Core/Fcore_digits.vo flocq/Calc/Fcalc_digits.vo flocq/Calc/Fcalc_ops.vo flocq/Calc/Fcalc_round.vo flocq/Calc/Fcalc_bracket.vo flocq/Prop/Fprop_Sterbenz.vo flocq/Appli/Fappli_IEEE.vo flocq/Appli/Fappli_rnd_odd.vo -lib/Fappli_IEEE_extra.vio: lib/Fappli_IEEE_extra.v flocq/Core/Fcore.vio flocq/Core/Fcore_digits.vio flocq/Calc/Fcalc_digits.vio flocq/Calc/Fcalc_ops.vio flocq/Calc/Fcalc_round.vio flocq/Calc/Fcalc_bracket.vio flocq/Prop/Fprop_Sterbenz.vio flocq/Appli/Fappli_IEEE.vio flocq/Appli/Fappli_rnd_odd.vio -lib/Floats.vo lib/Floats.glob lib/Floats.v.beautified: lib/Floats.v lib/Coqlib.vo lib/Integers.vo flocq/Appli/Fappli_IEEE.vo flocq/Appli/Fappli_IEEE_bits.vo lib/Fappli_IEEE_extra.vo flocq/Core/Fcore.vo $(ARCH)/Archi.vo -lib/Floats.vio: lib/Floats.v lib/Coqlib.vio lib/Integers.vio flocq/Appli/Fappli_IEEE.vio flocq/Appli/Fappli_IEEE_bits.vio lib/Fappli_IEEE_extra.vio flocq/Core/Fcore.vio $(ARCH)/Archi.vio -lib/Parmov.vo lib/Parmov.glob lib/Parmov.v.beautified: lib/Parmov.v lib/Axioms.vo lib/Coqlib.vo -lib/Parmov.vio: lib/Parmov.v lib/Axioms.vio lib/Coqlib.vio -lib/UnionFind.vo lib/UnionFind.glob lib/UnionFind.v.beautified: lib/UnionFind.v lib/Coqlib.vo -lib/UnionFind.vio: lib/UnionFind.v lib/Coqlib.vio -lib/Wfsimpl.vo lib/Wfsimpl.glob lib/Wfsimpl.v.beautified: lib/Wfsimpl.v lib/Axioms.vo -lib/Wfsimpl.vio: lib/Wfsimpl.v lib/Axioms.vio -lib/Postorder.vo lib/Postorder.glob lib/Postorder.v.beautified: lib/Postorder.v lib/Coqlib.vo lib/Maps.vo lib/Iteration.vo -lib/Postorder.vio: lib/Postorder.v lib/Coqlib.vio lib/Maps.vio lib/Iteration.vio -lib/FSetAVLplus.vo lib/FSetAVLplus.glob lib/FSetAVLplus.v.beautified: lib/FSetAVLplus.v lib/Coqlib.vo -lib/FSetAVLplus.vio: lib/FSetAVLplus.v lib/Coqlib.vio -lib/IntvSets.vo lib/IntvSets.glob lib/IntvSets.v.beautified: lib/IntvSets.v lib/Coqlib.vo -lib/IntvSets.vio: lib/IntvSets.v lib/Coqlib.vio -lib/Decidableplus.vo lib/Decidableplus.glob lib/Decidableplus.v.beautified: lib/Decidableplus.v lib/Coqlib.vo -lib/Decidableplus.vio: lib/Decidableplus.v lib/Coqlib.vio -common/Errors.vo common/Errors.glob common/Errors.v.beautified: common/Errors.v lib/Coqlib.vo -common/Errors.vio: common/Errors.v lib/Coqlib.vio -common/AST.vo common/AST.glob common/AST.v.beautified: common/AST.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo -common/AST.vio: common/AST.v lib/Coqlib.vio lib/Maps.vio common/Errors.vio lib/Integers.vio lib/Floats.vio -common/Linking.vo common/Linking.glob common/Linking.v.beautified: common/Linking.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo -common/Linking.vio: common/Linking.v lib/Coqlib.vio lib/Maps.vio common/Errors.vio common/AST.vio -common/Events.vo common/Events.glob common/Events.v.beautified: common/Events.v lib/Coqlib.vo lib/Intv.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo -common/Events.vio: common/Events.v lib/Coqlib.vio lib/Intv.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Globalenvs.vio -common/Globalenvs.vo common/Globalenvs.glob common/Globalenvs.v.beautified: common/Globalenvs.v lib/Axioms.vo lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo common/Linking.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo -common/Globalenvs.vio: common/Globalenvs.v lib/Axioms.vio lib/Coqlib.vio common/Errors.vio lib/Maps.vio common/AST.vio common/Linking.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio -common/Memdata.vo common/Memdata.glob common/Memdata.v.beautified: common/Memdata.v lib/Coqlib.vo $(ARCH)/Archi.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo -common/Memdata.vio: common/Memdata.v lib/Coqlib.vio $(ARCH)/Archi.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio -common/Memtype.vo common/Memtype.glob common/Memtype.v.beautified: common/Memtype.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo -common/Memtype.vio: common/Memtype.v lib/Coqlib.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memdata.vio -common/Memory.vo common/Memory.glob common/Memory.v.beautified: common/Memory.v lib/Axioms.vo lib/Coqlib.vo lib/Intv.vo lib/Maps.vo $(ARCH)/Archi.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memtype.vo -common/Memory.vio: common/Memory.v lib/Axioms.vio lib/Coqlib.vio lib/Intv.vio lib/Maps.vio $(ARCH)/Archi.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memdata.vio common/Memtype.vio -common/Values.vo common/Values.glob common/Values.v.beautified: common/Values.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo -common/Values.vio: common/Values.v lib/Coqlib.vio common/AST.vio lib/Integers.vio lib/Floats.vio -common/Smallstep.vo common/Smallstep.glob common/Smallstep.v.beautified: common/Smallstep.v lib/Coqlib.vo common/Events.vo common/Globalenvs.vo lib/Integers.vo -common/Smallstep.vio: common/Smallstep.v lib/Coqlib.vio common/Events.vio common/Globalenvs.vio lib/Integers.vio -common/Behaviors.vo common/Behaviors.glob common/Behaviors.v.beautified: common/Behaviors.v lib/Coqlib.vo common/Events.vo common/Globalenvs.vo lib/Integers.vo common/Smallstep.vo -common/Behaviors.vio: common/Behaviors.v lib/Coqlib.vio common/Events.vio common/Globalenvs.vio lib/Integers.vio common/Smallstep.vio -common/Switch.vo common/Switch.glob common/Switch.v.beautified: common/Switch.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo common/Values.vo -common/Switch.vio: common/Switch.v lib/Coqlib.vio lib/Maps.vio lib/Integers.vio common/Values.vio -common/Determinism.vo common/Determinism.glob common/Determinism.v.beautified: common/Determinism.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Behaviors.vo -common/Determinism.vio: common/Determinism.v lib/Coqlib.vio common/AST.vio lib/Integers.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio common/Behaviors.vio -common/Unityping.vo common/Unityping.glob common/Unityping.v.beautified: common/Unityping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo -common/Unityping.vio: common/Unityping.v lib/Coqlib.vio lib/Maps.vio common/Errors.vio -common/Separation.vo common/Separation.glob common/Separation.v.beautified: common/Separation.v lib/Coqlib.vo lib/Decidableplus.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo -common/Separation.vio: common/Separation.v lib/Coqlib.vio lib/Decidableplus.vio common/AST.vio lib/Integers.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio -backend/Cminor.vo backend/Cminor.glob backend/Cminor.v.beautified: backend/Cminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Events.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo -backend/Cminor.vio: backend/Cminor.v lib/Coqlib.vio lib/Maps.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Events.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Smallstep.vio common/Switch.vio -$(ARCH)/Op.vo $(ARCH)/Op.glob $(ARCH)/Op.v.beautified: $(ARCH)/Op.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo -$(ARCH)/Op.vio: $(ARCH)/Op.v lib/Coqlib.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio -backend/CminorSel.vo backend/CminorSel.glob backend/CminorSel.v.beautified: backend/CminorSel.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Events.vo common/Values.vo common/Memory.vo backend/Cminor.vo $(ARCH)/Op.vo common/Globalenvs.vo common/Smallstep.vo -backend/CminorSel.vio: backend/CminorSel.v lib/Coqlib.vio lib/Maps.vio common/AST.vio lib/Integers.vio common/Events.vio common/Values.vio common/Memory.vio backend/Cminor.vio $(ARCH)/Op.vio common/Globalenvs.vio common/Smallstep.vio -$(ARCH)/SelectOp.vo $(ARCH)/SelectOp.glob $(ARCH)/SelectOp.v.beautified: $(ARCH)/SelectOp.v lib/Coqlib.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/CminorSel.vo -$(ARCH)/SelectOp.vio: $(ARCH)/SelectOp.v lib/Coqlib.vio driver/Compopts.vio common/AST.vio lib/Integers.vio lib/Floats.vio $(ARCH)/Op.vio backend/CminorSel.vio -backend/SelectDiv.vo backend/SelectDiv.glob backend/SelectDiv.v.beautified: backend/SelectDiv.v lib/Coqlib.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo -backend/SelectDiv.vio: backend/SelectDiv.v lib/Coqlib.vio driver/Compopts.vio common/AST.vio lib/Integers.vio lib/Floats.vio $(ARCH)/Op.vio backend/CminorSel.vio $(ARCH)/SelectOp.vio -backend/SelectLong.vo backend/SelectLong.glob backend/SelectLong.v.beautified: backend/SelectLong.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo -backend/SelectLong.vio: backend/SelectLong.v lib/Coqlib.vio common/AST.vio lib/Integers.vio lib/Floats.vio $(ARCH)/Op.vio backend/CminorSel.vio $(ARCH)/SelectOp.vio -backend/Selection.vo backend/Selection.glob backend/Selection.v.beautified: backend/Selection.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Globalenvs.vo common/Switch.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/SelectDiv.vo backend/SelectLong.vo $(ARCH)/Machregs.vo -backend/Selection.vio: backend/Selection.v lib/Coqlib.vio lib/Maps.vio common/AST.vio common/Errors.vio lib/Integers.vio common/Globalenvs.vio common/Switch.vio backend/Cminor.vio $(ARCH)/Op.vio backend/CminorSel.vio $(ARCH)/SelectOp.vio backend/SelectDiv.vio backend/SelectLong.vio $(ARCH)/Machregs.vio -$(ARCH)/SelectOpproof.vo $(ARCH)/SelectOpproof.glob $(ARCH)/SelectOpproof.v.beautified: $(ARCH)/SelectOpproof.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo -$(ARCH)/SelectOpproof.vio: $(ARCH)/SelectOpproof.v lib/Coqlib.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Globalenvs.vio backend/Cminor.vio $(ARCH)/Op.vio backend/CminorSel.vio $(ARCH)/SelectOp.vio -backend/SelectDivproof.vo backend/SelectDivproof.glob backend/SelectDivproof.v.beautified: backend/SelectDivproof.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo $(ARCH)/SelectOpproof.vo backend/SelectDiv.vo -backend/SelectDivproof.vio: backend/SelectDivproof.v lib/Coqlib.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio backend/Cminor.vio $(ARCH)/Op.vio backend/CminorSel.vio $(ARCH)/SelectOp.vio $(ARCH)/SelectOpproof.vio backend/SelectDiv.vio -backend/SelectLongproof.vo backend/SelectLongproof.glob backend/SelectLongproof.v.beautified: backend/SelectLongproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo $(ARCH)/SelectOpproof.vo backend/SelectLong.vo -backend/SelectLongproof.vio: backend/SelectLongproof.v lib/Coqlib.vio lib/Maps.vio common/AST.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio backend/Cminor.vio $(ARCH)/Op.vio backend/CminorSel.vio $(ARCH)/SelectOp.vio $(ARCH)/SelectOpproof.vio backend/SelectLong.vio -backend/Selectionproof.vo backend/Selectionproof.glob backend/Selectionproof.v.beautified: backend/Selectionproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Linking.vo common/Errors.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/SelectDiv.vo backend/SelectLong.vo backend/Selection.vo $(ARCH)/SelectOpproof.vo backend/SelectDivproof.vo backend/SelectLongproof.vo -backend/Selectionproof.vio: backend/Selectionproof.v lib/Coqlib.vio lib/Maps.vio common/AST.vio common/Linking.vio common/Errors.vio lib/Integers.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio common/Switch.vio backend/Cminor.vio $(ARCH)/Op.vio backend/CminorSel.vio $(ARCH)/SelectOp.vio backend/SelectDiv.vio backend/SelectLong.vio backend/Selection.vio $(ARCH)/SelectOpproof.vio backend/SelectDivproof.vio backend/SelectLongproof.vio -backend/Registers.vo backend/Registers.glob backend/Registers.v.beautified: backend/Registers.v lib/Coqlib.vo common/AST.vo lib/Maps.vo lib/Ordered.vo common/Values.vo -backend/Registers.vio: backend/Registers.v lib/Coqlib.vio common/AST.vio lib/Maps.vio lib/Ordered.vio common/Values.vio -backend/RTL.vo backend/RTL.glob backend/RTL.v.beautified: backend/RTL.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo -backend/RTL.vio: backend/RTL.v lib/Coqlib.vio lib/Maps.vio common/AST.vio lib/Integers.vio common/Values.vio common/Events.vio common/Memory.vio common/Globalenvs.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Registers.vio -backend/RTLgen.vo backend/RTLgen.glob backend/RTLgen.v.beautified: backend/RTLgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Switch.vo $(ARCH)/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo -backend/RTLgen.vio: backend/RTLgen.v lib/Coqlib.vio common/Errors.vio lib/Maps.vio common/AST.vio lib/Integers.vio common/Switch.vio $(ARCH)/Op.vio backend/Registers.vio backend/CminorSel.vio backend/RTL.vio -backend/RTLgenspec.vo backend/RTLgenspec.glob backend/RTLgenspec.v.beautified: backend/RTLgenspec.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Switch.vo $(ARCH)/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo -backend/RTLgenspec.vio: backend/RTLgenspec.v lib/Coqlib.vio common/Errors.vio lib/Maps.vio common/AST.vio lib/Integers.vio common/Switch.vio $(ARCH)/Op.vio backend/Registers.vio backend/CminorSel.vio backend/RTL.vio backend/RTLgen.vio -backend/RTLgenproof.vo backend/RTLgenproof.glob backend/RTLgenproof.v.beautified: backend/RTLgenproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Linking.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo common/Switch.vo backend/Registers.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo backend/RTLgenspec.vo common/Errors.vo -backend/RTLgenproof.vio: backend/RTLgenproof.v lib/Coqlib.vio lib/Maps.vio common/AST.vio common/Linking.vio lib/Integers.vio common/Values.vio common/Memory.vio common/Events.vio common/Smallstep.vio common/Globalenvs.vio common/Switch.vio backend/Registers.vio backend/Cminor.vio $(ARCH)/Op.vio backend/CminorSel.vio backend/RTL.vio backend/RTLgen.vio backend/RTLgenspec.vio common/Errors.vio -backend/Tailcall.vo backend/Tailcall.glob backend/Tailcall.v.beautified: backend/Tailcall.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/Conventions.vo -backend/Tailcall.vio: backend/Tailcall.v lib/Coqlib.vio lib/Maps.vio common/AST.vio backend/Registers.vio $(ARCH)/Op.vio backend/RTL.vio backend/Conventions.vio -backend/Tailcallproof.vo backend/Tailcallproof.glob backend/Tailcallproof.v.beautified: backend/Tailcallproof.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Conventions.vo backend/Tailcall.vo -backend/Tailcallproof.vio: backend/Tailcallproof.v lib/Coqlib.vio lib/Maps.vio lib/Integers.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/Conventions.vio backend/Tailcall.vio -backend/Inlining.vo backend/Inlining.glob backend/Inlining.v.beautified: backend/Inlining.v lib/Coqlib.vo lib/Wfsimpl.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo common/Linking.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo -backend/Inlining.vio: backend/Inlining.v lib/Coqlib.vio lib/Wfsimpl.vio lib/Maps.vio common/Errors.vio lib/Integers.vio common/AST.vio common/Linking.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio -backend/Inliningspec.vo backend/Inliningspec.glob backend/Inliningspec.v.beautified: backend/Inliningspec.v lib/Coqlib.vo lib/Wfsimpl.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo common/Linking.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Inlining.vo -backend/Inliningspec.vio: backend/Inliningspec.v lib/Coqlib.vio lib/Wfsimpl.vio lib/Maps.vio common/Errors.vio lib/Integers.vio common/AST.vio common/Linking.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/Inlining.vio -backend/Inliningproof.vo backend/Inliningproof.glob backend/Inliningproof.v.beautified: backend/Inliningproof.v lib/Coqlib.vo lib/Wfsimpl.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Inlining.vo backend/Inliningspec.vo -backend/Inliningproof.vio: backend/Inliningproof.v lib/Coqlib.vio lib/Wfsimpl.vio lib/Maps.vio common/Errors.vio lib/Integers.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/Inlining.vio backend/Inliningspec.vio -backend/Renumber.vo backend/Renumber.glob backend/Renumber.v.beautified: backend/Renumber.v lib/Coqlib.vo lib/Maps.vo lib/Postorder.vo backend/RTL.vo -backend/Renumber.vio: backend/Renumber.v lib/Coqlib.vio lib/Maps.vio lib/Postorder.vio backend/RTL.vio -backend/Renumberproof.vo backend/Renumberproof.glob backend/Renumberproof.v.beautified: backend/Renumberproof.v lib/Coqlib.vo lib/Maps.vo lib/Postorder.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Renumber.vo -backend/Renumberproof.vio: backend/Renumberproof.v lib/Coqlib.vio lib/Maps.vio lib/Postorder.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/Renumber.vio -backend/RTLtyping.vo backend/RTLtyping.glob backend/RTLtyping.v.beautified: backend/RTLtyping.v lib/Coqlib.vo common/Errors.vo common/Unityping.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo common/Globalenvs.vo common/Values.vo lib/Integers.vo common/Memory.vo common/Events.vo backend/RTL.vo backend/Conventions.vo -backend/RTLtyping.vio: backend/RTLtyping.v lib/Coqlib.vio common/Errors.vio common/Unityping.vio lib/Maps.vio common/AST.vio $(ARCH)/Op.vio backend/Registers.vio common/Globalenvs.vio common/Values.vio lib/Integers.vio common/Memory.vio common/Events.vio backend/RTL.vio backend/Conventions.vio -backend/Kildall.vo backend/Kildall.glob backend/Kildall.v.beautified: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo lib/Heaps.vo -backend/Kildall.vio: backend/Kildall.v lib/Coqlib.vio lib/Iteration.vio lib/Maps.vio lib/Lattice.vio lib/Heaps.vio -backend/Liveness.vo backend/Liveness.glob backend/Liveness.v.beautified: backend/Liveness.v lib/Coqlib.vo lib/Maps.vo lib/Lattice.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo -backend/Liveness.vio: backend/Liveness.v lib/Coqlib.vio lib/Maps.vio lib/Lattice.vio common/AST.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/Kildall.vio -backend/ValueDomain.vo backend/ValueDomain.glob backend/ValueDomain.v.beautified: backend/ValueDomain.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo driver/Compopts.vo common/AST.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo backend/Registers.vo backend/RTL.vo -backend/ValueDomain.vio: backend/ValueDomain.v lib/Coqlib.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio lib/Lattice.vio driver/Compopts.vio common/AST.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio backend/Registers.vio backend/RTL.vio -$(ARCH)/ValueAOp.vo $(ARCH)/ValueAOp.glob $(ARCH)/ValueAOp.v.beautified: $(ARCH)/ValueAOp.v lib/Coqlib.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/ValueDomain.vo backend/RTL.vo -$(ARCH)/ValueAOp.vio: $(ARCH)/ValueAOp.v lib/Coqlib.vio driver/Compopts.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Globalenvs.vio $(ARCH)/Op.vio backend/ValueDomain.vio backend/RTL.vio -backend/ValueAnalysis.vo backend/ValueAnalysis.glob backend/ValueAnalysis.v.beautified: backend/ValueAnalysis.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo driver/Compopts.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/Liveness.vo lib/Axioms.vo -backend/ValueAnalysis.vio: backend/ValueAnalysis.v lib/Coqlib.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio lib/Lattice.vio backend/Kildall.vio driver/Compopts.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio backend/Registers.vio $(ARCH)/Op.vio backend/RTL.vio backend/ValueDomain.vio $(ARCH)/ValueAOp.vio backend/Liveness.vio lib/Axioms.vio -$(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOp.glob $(ARCH)/ConstpropOp.v.beautified: $(ARCH)/ConstpropOp.v lib/Coqlib.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/Registers.vo backend/ValueDomain.vo -$(ARCH)/ConstpropOp.vio: $(ARCH)/ConstpropOp.v lib/Coqlib.vio driver/Compopts.vio common/AST.vio lib/Integers.vio lib/Floats.vio $(ARCH)/Op.vio backend/Registers.vio backend/ValueDomain.vio -backend/Constprop.vo backend/Constprop.glob backend/Constprop.v.beautified: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo driver/Compopts.vo $(ARCH)/Machregs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Liveness.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo $(ARCH)/ConstpropOp.vo -backend/Constprop.vio: backend/Constprop.v lib/Coqlib.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio lib/Lattice.vio backend/Kildall.vio common/AST.vio common/Linking.vio driver/Compopts.vio $(ARCH)/Machregs.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/Liveness.vio backend/ValueDomain.vio $(ARCH)/ValueAOp.vio backend/ValueAnalysis.vio $(ARCH)/ConstpropOp.vio -$(ARCH)/ConstpropOpproof.vo $(ARCH)/ConstpropOpproof.glob $(ARCH)/ConstpropOpproof.v.beautified: $(ARCH)/ConstpropOpproof.v lib/Coqlib.vo driver/Compopts.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/ValueDomain.vo $(ARCH)/ConstpropOp.vo -$(ARCH)/ConstpropOpproof.vio: $(ARCH)/ConstpropOpproof.v lib/Coqlib.vio driver/Compopts.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/ValueDomain.vio $(ARCH)/ConstpropOp.vio -backend/Constpropproof.vo backend/Constpropproof.glob backend/Constpropproof.v.beautified: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo driver/Compopts.vo $(ARCH)/Machregs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Liveness.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo $(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOpproof.vo backend/Constprop.vo -backend/Constpropproof.vio: backend/Constpropproof.v lib/Coqlib.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio lib/Lattice.vio backend/Kildall.vio common/AST.vio common/Linking.vio common/Values.vio common/Events.vio common/Memory.vio common/Globalenvs.vio common/Smallstep.vio driver/Compopts.vio $(ARCH)/Machregs.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/Liveness.vio backend/ValueDomain.vio $(ARCH)/ValueAOp.vio backend/ValueAnalysis.vio $(ARCH)/ConstpropOp.vio $(ARCH)/ConstpropOpproof.vio backend/Constprop.vio -backend/CSEdomain.vo backend/CSEdomain.glob backend/CSEdomain.v.beautified: backend/CSEdomain.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo -backend/CSEdomain.vio: backend/CSEdomain.v lib/Coqlib.vio lib/Maps.vio common/AST.vio common/Values.vio common/Memory.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio -$(ARCH)/CombineOp.vo $(ARCH)/CombineOp.glob $(ARCH)/CombineOp.v.beautified: $(ARCH)/CombineOp.v lib/Coqlib.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/CSEdomain.vo -$(ARCH)/CombineOp.vio: $(ARCH)/CombineOp.v lib/Coqlib.vio common/AST.vio lib/Integers.vio $(ARCH)/Op.vio backend/CSEdomain.vio -backend/CSE.vo backend/CSE.glob backend/CSE.v.beautified: backend/CSE.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/CSEdomain.vo $(ARCH)/CombineOp.vo -backend/CSE.vio: backend/CSE.v lib/Coqlib.vio lib/Maps.vio common/Errors.vio lib/Integers.vio lib/Floats.vio lib/Lattice.vio backend/Kildall.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/ValueDomain.vio backend/ValueAnalysis.vio backend/CSEdomain.vio $(ARCH)/CombineOp.vio -$(ARCH)/CombineOpproof.vo $(ARCH)/CombineOpproof.glob $(ARCH)/CombineOpproof.v.beautified: $(ARCH)/CombineOpproof.v lib/Coqlib.vo lib/Integers.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo backend/RTL.vo backend/CSEdomain.vo $(ARCH)/CombineOp.vo -$(ARCH)/CombineOpproof.vio: $(ARCH)/CombineOpproof.v lib/Coqlib.vio lib/Integers.vio common/Values.vio common/Memory.vio $(ARCH)/Op.vio backend/RTL.vio backend/CSEdomain.vio $(ARCH)/CombineOp.vio -backend/CSEproof.vo backend/CSEproof.glob backend/CSEproof.v.beautified: backend/CSEproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo backend/CSEdomain.vo $(ARCH)/CombineOp.vo $(ARCH)/CombineOpproof.vo backend/CSE.vo -backend/CSEproof.vio: backend/CSEproof.v lib/Coqlib.vio lib/Maps.vio common/Errors.vio lib/Integers.vio lib/Floats.vio lib/Lattice.vio backend/Kildall.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/ValueDomain.vio $(ARCH)/ValueAOp.vio backend/ValueAnalysis.vio backend/CSEdomain.vio $(ARCH)/CombineOp.vio $(ARCH)/CombineOpproof.vio backend/CSE.vio -backend/NeedDomain.vo backend/NeedDomain.glob backend/NeedDomain.v.beautified: backend/NeedDomain.v lib/Coqlib.vo lib/Maps.vo lib/IntvSets.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo lib/Lattice.vo backend/Registers.vo backend/ValueDomain.vo $(ARCH)/Op.vo backend/RTL.vo -backend/NeedDomain.vio: backend/NeedDomain.v lib/Coqlib.vio lib/Maps.vio lib/IntvSets.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio lib/Lattice.vio backend/Registers.vio backend/ValueDomain.vio $(ARCH)/Op.vio backend/RTL.vio -$(ARCH)/NeedOp.vo $(ARCH)/NeedOp.glob $(ARCH)/NeedOp.v.beautified: $(ARCH)/NeedOp.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/NeedDomain.vo backend/RTL.vo -$(ARCH)/NeedOp.vio: $(ARCH)/NeedOp.v lib/Coqlib.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Globalenvs.vio $(ARCH)/Op.vio backend/NeedDomain.vio backend/RTL.vio -backend/Deadcode.vo backend/Deadcode.glob backend/Deadcode.v.beautified: backend/Deadcode.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo common/Memory.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/NeedDomain.vo $(ARCH)/NeedOp.vo -backend/Deadcode.vio: backend/Deadcode.v lib/Coqlib.vio lib/Maps.vio common/Errors.vio lib/Integers.vio lib/Floats.vio lib/Lattice.vio backend/Kildall.vio common/AST.vio common/Linking.vio common/Memory.vio backend/Registers.vio $(ARCH)/Op.vio backend/RTL.vio backend/ValueDomain.vio backend/ValueAnalysis.vio backend/NeedDomain.vio $(ARCH)/NeedOp.vio -backend/Deadcodeproof.vo backend/Deadcodeproof.glob backend/Deadcodeproof.v.beautified: backend/Deadcodeproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/NeedDomain.vo $(ARCH)/NeedOp.vo backend/Deadcode.vo -backend/Deadcodeproof.vio: backend/Deadcodeproof.v lib/Coqlib.vio lib/Maps.vio common/Errors.vio lib/Integers.vio lib/Floats.vio lib/Lattice.vio backend/Kildall.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio common/Smallstep.vio backend/Registers.vio $(ARCH)/Op.vio backend/RTL.vio backend/ValueDomain.vio backend/ValueAnalysis.vio backend/NeedDomain.vio $(ARCH)/NeedOp.vio backend/Deadcode.vio -backend/Unusedglob.vo backend/Unusedglob.glob backend/Unusedglob.v.beautified: backend/Unusedglob.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo lib/Iteration.vo common/Errors.vo common/AST.vo common/Linking.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo -backend/Unusedglob.vio: backend/Unusedglob.v lib/Coqlib.vio lib/Maps.vio lib/Ordered.vio lib/Iteration.vio common/Errors.vio common/AST.vio common/Linking.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio -backend/Unusedglobproof.vo backend/Unusedglobproof.glob backend/Unusedglobproof.v.beautified: backend/Unusedglobproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo lib/Iteration.vo common/Errors.vo common/AST.vo common/Linking.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Unusedglob.vo -backend/Unusedglobproof.vio: backend/Unusedglobproof.v lib/Coqlib.vio lib/Maps.vio lib/Ordered.vio lib/Iteration.vio common/Errors.vio common/AST.vio common/Linking.vio lib/Integers.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/Unusedglob.vio -$(ARCH)/Machregs.vo $(ARCH)/Machregs.glob $(ARCH)/Machregs.v.beautified: $(ARCH)/Machregs.v lib/Coqlib.vo lib/Decidableplus.vo lib/Maps.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo -$(ARCH)/Machregs.vio: $(ARCH)/Machregs.v lib/Coqlib.vio lib/Decidableplus.vio lib/Maps.vio common/AST.vio lib/Integers.vio $(ARCH)/Op.vio -backend/Locations.vo backend/Locations.glob backend/Locations.v.beautified: backend/Locations.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/AST.vo common/Values.vo $(ARCH)/Machregs.vo -backend/Locations.vio: backend/Locations.v lib/Coqlib.vio lib/Maps.vio lib/Ordered.vio common/AST.vio common/Values.vio $(ARCH)/Machregs.vio -$(ARCH)/Conventions1.vo $(ARCH)/Conventions1.glob $(ARCH)/Conventions1.v.beautified: $(ARCH)/Conventions1.v lib/Coqlib.vo lib/Decidableplus.vo common/AST.vo common/Events.vo backend/Locations.vo -$(ARCH)/Conventions1.vio: $(ARCH)/Conventions1.v lib/Coqlib.vio lib/Decidableplus.vio common/AST.vio common/Events.vio backend/Locations.vio -backend/Conventions.vo backend/Conventions.glob backend/Conventions.v.beautified: backend/Conventions.v lib/Coqlib.vo common/AST.vo backend/Locations.vo $(ARCH)/Conventions1.vo -backend/Conventions.vio: backend/Conventions.v lib/Coqlib.vio common/AST.vio backend/Locations.vio $(ARCH)/Conventions1.vio -backend/LTL.vo backend/LTL.glob backend/LTL.v.beautified: backend/LTL.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo -backend/LTL.vio: backend/LTL.v lib/Coqlib.vio lib/Maps.vio common/AST.vio lib/Integers.vio common/Values.vio common/Events.vio common/Memory.vio common/Globalenvs.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Locations.vio backend/Conventions.vio -backend/Allocation.vo backend/Allocation.glob backend/Allocation.v.beautified: backend/Allocation.v lib/FSetAVLplus.vo lib/Coqlib.vo lib/Ordered.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo lib/Lattice.vo backend/Kildall.vo common/Memdata.vo $(ARCH)/Archi.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Locations.vo backend/Conventions.vo backend/RTLtyping.vo backend/LTL.vo -backend/Allocation.vio: backend/Allocation.v lib/FSetAVLplus.vio lib/Coqlib.vio lib/Ordered.vio lib/Maps.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/AST.vio lib/Lattice.vio backend/Kildall.vio common/Memdata.vio $(ARCH)/Archi.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/Locations.vio backend/Conventions.vio backend/RTLtyping.vio backend/LTL.vio -backend/Allocproof.vo backend/Allocproof.glob backend/Allocproof.v.beautified: backend/Allocproof.v lib/Coqlib.vo lib/Ordered.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo lib/Lattice.vo backend/Kildall.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Archi.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Locations.vo backend/Conventions.vo backend/RTLtyping.vo backend/LTL.vo backend/Allocation.vo -backend/Allocproof.vio: backend/Allocproof.v lib/Coqlib.vio lib/Ordered.vio lib/Maps.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/AST.vio common/Linking.vio lib/Lattice.vio backend/Kildall.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio common/Smallstep.vio $(ARCH)/Archi.vio $(ARCH)/Op.vio backend/Registers.vio backend/RTL.vio backend/Locations.vio backend/Conventions.vio backend/RTLtyping.vio backend/LTL.vio backend/Allocation.vio -backend/Tunneling.vo backend/Tunneling.glob backend/Tunneling.v.beautified: backend/Tunneling.v lib/Coqlib.vo lib/Maps.vo lib/UnionFind.vo common/AST.vo backend/LTL.vo -backend/Tunneling.vio: backend/Tunneling.v lib/Coqlib.vio lib/Maps.vio lib/UnionFind.vio common/AST.vio backend/LTL.vio -backend/Tunnelingproof.vo backend/Tunnelingproof.glob backend/Tunnelingproof.v.beautified: backend/Tunnelingproof.v lib/Coqlib.vo lib/Maps.vo lib/UnionFind.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Tunneling.vo -backend/Tunnelingproof.vio: backend/Tunnelingproof.v lib/Coqlib.vio lib/Maps.vio lib/UnionFind.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Locations.vio backend/LTL.vio backend/Tunneling.vio -backend/Linear.vo backend/Linear.glob backend/Linear.v.beautified: backend/Linear.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo -backend/Linear.vio: backend/Linear.v lib/Coqlib.vio common/AST.vio lib/Integers.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Locations.vio backend/LTL.vio backend/Conventions.vio -backend/Lineartyping.vo backend/Lineartyping.glob backend/Lineartyping.v.beautified: backend/Lineartyping.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo common/Memory.vo common/Events.vo $(ARCH)/Op.vo $(ARCH)/Machregs.vo backend/Locations.vo backend/Conventions.vo backend/LTL.vo backend/Linear.vo -backend/Lineartyping.vio: backend/Lineartyping.v lib/Coqlib.vio common/AST.vio lib/Integers.vio common/Values.vio common/Globalenvs.vio common/Memory.vio common/Events.vio $(ARCH)/Op.vio $(ARCH)/Machregs.vio backend/Locations.vio backend/Conventions.vio backend/LTL.vio backend/Linear.vio -backend/Linearize.vo backend/Linearize.glob backend/Linearize.v.beautified: backend/Linearize.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/Errors.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo -backend/Linearize.vio: backend/Linearize.v lib/Coqlib.vio lib/Maps.vio lib/Ordered.vio common/Errors.vio lib/Lattice.vio backend/Kildall.vio common/AST.vio $(ARCH)/Op.vio backend/Locations.vio backend/LTL.vio backend/Linear.vio -backend/Linearizeproof.vo backend/Linearizeproof.glob backend/Linearizeproof.v.beautified: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/Errors.vo lib/Lattice.vo backend/Kildall.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Linearize.vo -backend/Linearizeproof.vio: backend/Linearizeproof.v lib/Coqlib.vio lib/Maps.vio lib/Ordered.vio common/Errors.vio lib/Lattice.vio backend/Kildall.vio lib/Integers.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Locations.vio backend/LTL.vio backend/Linear.vio backend/Linearize.vio -backend/CleanupLabels.vo backend/CleanupLabels.glob backend/CleanupLabels.v.beautified: backend/CleanupLabels.v lib/Coqlib.vo lib/Ordered.vo backend/Linear.vo -backend/CleanupLabels.vio: backend/CleanupLabels.v lib/Coqlib.vio lib/Ordered.vio backend/Linear.vio -backend/CleanupLabelsproof.vo backend/CleanupLabelsproof.glob backend/CleanupLabelsproof.v.beautified: backend/CleanupLabelsproof.v lib/Coqlib.vo lib/Ordered.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/CleanupLabels.vo -backend/CleanupLabelsproof.vio: backend/CleanupLabelsproof.v lib/Coqlib.vio lib/Ordered.vio lib/Integers.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Locations.vio backend/Linear.vio backend/CleanupLabels.vio -backend/Debugvar.vo backend/Debugvar.glob backend/Debugvar.v.beautified: backend/Debugvar.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo lib/Iteration.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo $(ARCH)/Machregs.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo -backend/Debugvar.vio: backend/Debugvar.v lib/Axioms.vio lib/Coqlib.vio lib/Maps.vio lib/Iteration.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/AST.vio $(ARCH)/Machregs.vio backend/Locations.vio backend/Conventions.vio backend/Linear.vio -backend/Debugvarproof.vo backend/Debugvarproof.glob backend/Debugvarproof.v.beautified: backend/Debugvarproof.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo lib/Iteration.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Machregs.vo backend/Locations.vo backend/Conventions.vo $(ARCH)/Op.vo backend/Linear.vo backend/Debugvar.vo -backend/Debugvarproof.vio: backend/Debugvarproof.v lib/Axioms.vio lib/Coqlib.vio lib/Maps.vio lib/Iteration.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio $(ARCH)/Machregs.vio backend/Locations.vio backend/Conventions.vio $(ARCH)/Op.vio backend/Linear.vio backend/Debugvar.vio -backend/Mach.vo backend/Mach.glob backend/Mach.v.beautified: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo $(ARCH)/Stacklayout.vo -backend/Mach.vio: backend/Mach.v lib/Coqlib.vio lib/Maps.vio common/AST.vio lib/Integers.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Locations.vio backend/Conventions.vio $(ARCH)/Stacklayout.vio -backend/Bounds.vo backend/Bounds.glob backend/Bounds.v.beautified: backend/Bounds.v lib/Coqlib.vo lib/Ordered.vo lib/Intv.vo common/AST.vo $(ARCH)/Op.vo $(ARCH)/Machregs.vo backend/Locations.vo backend/Linear.vo backend/Conventions.vo -backend/Bounds.vio: backend/Bounds.v lib/Coqlib.vio lib/Ordered.vio lib/Intv.vio common/AST.vio $(ARCH)/Op.vio $(ARCH)/Machregs.vio backend/Locations.vio backend/Linear.vio backend/Conventions.vio -$(ARCH)/Stacklayout.vo $(ARCH)/Stacklayout.glob $(ARCH)/Stacklayout.v.beautified: $(ARCH)/Stacklayout.v lib/Coqlib.vo common/Memory.vo common/Separation.vo backend/Bounds.vo -$(ARCH)/Stacklayout.vio: $(ARCH)/Stacklayout.v lib/Coqlib.vio common/Memory.vio common/Separation.vio backend/Bounds.vio -backend/Stacking.vo backend/Stacking.glob backend/Stacking.v.beautified: backend/Stacking.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Mach.vo backend/Bounds.vo backend/Conventions.vo $(ARCH)/Stacklayout.vo backend/Lineartyping.vo -backend/Stacking.vio: backend/Stacking.v lib/Coqlib.vio common/Errors.vio lib/Integers.vio common/AST.vio $(ARCH)/Op.vio backend/Locations.vio backend/Linear.vio backend/Mach.vio backend/Bounds.vio backend/Conventions.vio $(ARCH)/Stacklayout.vio backend/Lineartyping.vio -backend/Stackingproof.vo backend/Stackingproof.glob backend/Stackingproof.v.beautified: backend/Stackingproof.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Separation.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/LTL.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Mach.vo backend/Bounds.vo backend/Conventions.vo $(ARCH)/Stacklayout.vo backend/Lineartyping.vo backend/Stacking.vo -backend/Stackingproof.vio: backend/Stackingproof.v lib/Coqlib.vio common/Errors.vio lib/Integers.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Separation.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio backend/LTL.vio $(ARCH)/Op.vio backend/Locations.vio backend/Linear.vio backend/Mach.vio backend/Bounds.vio backend/Conventions.vio $(ARCH)/Stacklayout.vio backend/Lineartyping.vio backend/Stacking.vio -$(ARCH)/Asm.vo $(ARCH)/Asm.glob $(ARCH)/Asm.v.beautified: $(ARCH)/Asm.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo $(ARCH)/Stacklayout.vo backend/Conventions.vo -$(ARCH)/Asm.vio: $(ARCH)/Asm.v lib/Coqlib.vio lib/Maps.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio backend/Locations.vio $(ARCH)/Stacklayout.vio backend/Conventions.vio -$(ARCH)/Asmgen.vo $(ARCH)/Asmgen.glob $(ARCH)/Asmgen.v.beautified: $(ARCH)/Asmgen.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Memdata.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo -$(ARCH)/Asmgen.vio: $(ARCH)/Asmgen.v lib/Coqlib.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/AST.vio common/Memdata.vio $(ARCH)/Op.vio backend/Locations.vio backend/Mach.vio $(ARCH)/Asm.vio -backend/Asmgenproof0.vo backend/Asmgenproof0.glob backend/Asmgenproof0.v.beautified: backend/Asmgenproof0.v lib/Coqlib.vo lib/Intv.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Conventions.vo -backend/Asmgenproof0.vio: backend/Asmgenproof0.v lib/Coqlib.vio lib/Intv.vio common/AST.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio common/Smallstep.vio backend/Locations.vio backend/Mach.vio $(ARCH)/Asm.vio $(ARCH)/Asmgen.vio backend/Conventions.vio -$(ARCH)/Asmgenproof1.vo $(ARCH)/Asmgenproof1.glob $(ARCH)/Asmgenproof1.v.beautified: $(ARCH)/Asmgenproof1.v lib/Coqlib.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Asmgenproof0.vo backend/Conventions.vo -$(ARCH)/Asmgenproof1.vio: $(ARCH)/Asmgenproof1.v lib/Coqlib.vio common/AST.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Globalenvs.vio $(ARCH)/Op.vio backend/Locations.vio backend/Mach.vio $(ARCH)/Asm.vio $(ARCH)/Asmgen.vio backend/Asmgenproof0.vio backend/Conventions.vio -$(ARCH)/Asmgenproof.vo $(ARCH)/Asmgenproof.glob $(ARCH)/Asmgenproof.v.beautified: $(ARCH)/Asmgenproof.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Conventions.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Asmgenproof0.vo $(ARCH)/Asmgenproof1.vo -$(ARCH)/Asmgenproof.vio: $(ARCH)/Asmgenproof.v lib/Coqlib.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio $(ARCH)/Op.vio backend/Locations.vio backend/Mach.vio backend/Conventions.vio $(ARCH)/Asm.vio $(ARCH)/Asmgen.vio backend/Asmgenproof0.vio $(ARCH)/Asmgenproof1.vio -cfrontend/Ctypes.vo cfrontend/Ctypes.glob cfrontend/Ctypes.v.beautified: cfrontend/Ctypes.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Linking.vo $(ARCH)/Archi.vo -cfrontend/Ctypes.vio: cfrontend/Ctypes.v lib/Axioms.vio lib/Coqlib.vio lib/Maps.vio common/Errors.vio common/AST.vio common/Linking.vio $(ARCH)/Archi.vio -cfrontend/Cop.vo cfrontend/Cop.glob cfrontend/Cop.v.beautified: cfrontend/Cop.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo cfrontend/Ctypes.vo -cfrontend/Cop.vio: cfrontend/Cop.v lib/Coqlib.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio cfrontend/Ctypes.vio -cfrontend/Csyntax.vo cfrontend/Csyntax.glob cfrontend/Csyntax.v.beautified: cfrontend/Csyntax.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Errors.vo common/AST.vo common/Linking.vo common/Values.vo cfrontend/Ctypes.vo cfrontend/Cop.vo -cfrontend/Csyntax.vio: cfrontend/Csyntax.v lib/Coqlib.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio common/Errors.vio common/AST.vio common/Linking.vio common/Values.vio cfrontend/Ctypes.vio cfrontend/Cop.vio -cfrontend/Csem.vo cfrontend/Csem.glob cfrontend/Csem.v.beautified: cfrontend/Csem.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo common/Smallstep.vo -cfrontend/Csem.vio: cfrontend/Csem.v lib/Coqlib.vio common/Errors.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/AST.vio common/Memory.vio common/Events.vio common/Globalenvs.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Csyntax.vio common/Smallstep.vio -cfrontend/Ctyping.vo cfrontend/Ctyping.glob cfrontend/Ctyping.v.beautified: cfrontend/Ctyping.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Errors.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo -cfrontend/Ctyping.vio: cfrontend/Ctyping.v lib/Coqlib.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio common/Errors.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Csyntax.vio cfrontend/Csem.vio -cfrontend/Cstrategy.vo cfrontend/Cstrategy.glob cfrontend/Cstrategy.v.beautified: cfrontend/Cstrategy.v lib/Axioms.vo lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo -cfrontend/Cstrategy.vio: cfrontend/Cstrategy.v lib/Axioms.vio lib/Coqlib.vio common/Errors.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/AST.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Csyntax.vio cfrontend/Csem.vio -cfrontend/Cexec.vo cfrontend/Cexec.glob cfrontend/Cexec.v.beautified: cfrontend/Cexec.v lib/Axioms.vo lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Determinism.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo -cfrontend/Cexec.vio: cfrontend/Cexec.v lib/Axioms.vio lib/Coqlib.vio common/Errors.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/AST.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Determinism.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Csyntax.vio cfrontend/Csem.vio cfrontend/Cstrategy.vio -cfrontend/Initializers.vo cfrontend/Initializers.glob cfrontend/Initializers.v.beautified: cfrontend/Initializers.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Globalenvs.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo -cfrontend/Initializers.vio: cfrontend/Initializers.v lib/Coqlib.vio lib/Maps.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/AST.vio common/Memory.vio common/Globalenvs.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Csyntax.vio -cfrontend/Initializersproof.vo cfrontend/Initializersproof.glob cfrontend/Initializersproof.v.beautified: cfrontend/Initializersproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Initializers.vo -cfrontend/Initializersproof.vio: cfrontend/Initializersproof.v lib/Coqlib.vio common/Errors.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/AST.vio common/Memory.vio common/Globalenvs.vio common/Events.vio common/Smallstep.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Csyntax.vio cfrontend/Csem.vio cfrontend/Initializers.vio -cfrontend/SimplExpr.vo cfrontend/SimplExpr.glob cfrontend/SimplExpr.v.beautified: cfrontend/SimplExpr.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Clight.vo -cfrontend/SimplExpr.vio: cfrontend/SimplExpr.v lib/Coqlib.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/AST.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Csyntax.vio cfrontend/Clight.vio -cfrontend/SimplExprspec.vo cfrontend/SimplExprspec.glob cfrontend/SimplExprspec.v.beautified: cfrontend/SimplExprspec.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo common/Memory.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Clight.vo cfrontend/SimplExpr.vo -cfrontend/SimplExprspec.vio: cfrontend/SimplExprspec.v lib/Coqlib.vio lib/Maps.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/AST.vio common/Linking.vio common/Memory.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Csyntax.vio cfrontend/Clight.vio cfrontend/SimplExpr.vio -cfrontend/SimplExprproof.vo cfrontend/SimplExprproof.glob cfrontend/SimplExprproof.v.beautified: cfrontend/SimplExprproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo cfrontend/SimplExpr.vo cfrontend/SimplExprspec.vo -cfrontend/SimplExprproof.vio: cfrontend/SimplExprproof.v lib/Coqlib.vio lib/Maps.vio common/Errors.vio lib/Integers.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Csyntax.vio cfrontend/Csem.vio cfrontend/Cstrategy.vio cfrontend/Clight.vio cfrontend/SimplExpr.vio cfrontend/SimplExprspec.vio -cfrontend/Clight.vo cfrontend/Clight.glob cfrontend/Clight.v.beautified: cfrontend/Clight.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo -cfrontend/Clight.vio: cfrontend/Clight.v lib/Coqlib.vio common/Errors.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/AST.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio cfrontend/Ctypes.vio cfrontend/Cop.vio -cfrontend/ClightBigstep.vo cfrontend/ClightBigstep.glob cfrontend/ClightBigstep.v.beautified: cfrontend/ClightBigstep.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo -cfrontend/ClightBigstep.vio: cfrontend/ClightBigstep.v lib/Coqlib.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/AST.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Clight.vio -cfrontend/SimplLocals.vo cfrontend/SimplLocals.glob cfrontend/SimplLocals.v.beautified: cfrontend/SimplLocals.v lib/Coqlib.vo lib/Ordered.vo common/Errors.vo common/AST.vo common/Linking.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo driver/Compopts.vo -cfrontend/SimplLocals.vio: cfrontend/SimplLocals.v lib/Coqlib.vio lib/Ordered.vio common/Errors.vio common/AST.vio common/Linking.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Clight.vio driver/Compopts.vio -cfrontend/SimplLocalsproof.vo cfrontend/SimplLocalsproof.glob cfrontend/SimplLocalsproof.v.beautified: cfrontend/SimplLocalsproof.v lib/Coqlib.vo common/Errors.vo lib/Ordered.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo cfrontend/SimplLocals.vo -cfrontend/SimplLocalsproof.vio: cfrontend/SimplLocalsproof.v lib/Coqlib.vio common/Errors.vio lib/Ordered.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Globalenvs.vio common/Events.vio common/Smallstep.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Clight.vio cfrontend/SimplLocals.vio -cfrontend/Cshmgen.vo cfrontend/Cshmgen.glob cfrontend/Cshmgen.v.beautified: cfrontend/Cshmgen.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo -cfrontend/Cshmgen.vio: cfrontend/Cshmgen.v lib/Coqlib.vio lib/Maps.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/AST.vio common/Linking.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Clight.vio backend/Cminor.vio cfrontend/Csharpminor.vio -cfrontend/Cshmgenproof.vo cfrontend/Cshmgenproof.glob cfrontend/Cshmgenproof.v.beautified: cfrontend/Cshmgenproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo -cfrontend/Cshmgenproof.vio: cfrontend/Cshmgenproof.v lib/Coqlib.vio common/Errors.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio common/AST.vio common/Linking.vio common/Values.vio common/Events.vio common/Memory.vio common/Globalenvs.vio common/Smallstep.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Clight.vio backend/Cminor.vio cfrontend/Csharpminor.vio cfrontend/Cshmgen.vio -cfrontend/Csharpminor.vo cfrontend/Csharpminor.glob cfrontend/Csharpminor.v.beautified: cfrontend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Switch.vo backend/Cminor.vo common/Smallstep.vo -cfrontend/Csharpminor.vio: cfrontend/Csharpminor.v lib/Coqlib.vio lib/Maps.vio common/AST.vio lib/Integers.vio lib/Floats.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Switch.vio backend/Cminor.vio common/Smallstep.vio -cfrontend/Cminorgen.vo cfrontend/Cminorgen.glob cfrontend/Cminorgen.v.beautified: cfrontend/Cminorgen.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo cfrontend/Csharpminor.vo backend/Cminor.vo -cfrontend/Cminorgen.vio: cfrontend/Cminorgen.v lib/Coqlib.vio lib/Maps.vio lib/Ordered.vio common/Errors.vio lib/Integers.vio lib/Floats.vio common/AST.vio common/Linking.vio cfrontend/Csharpminor.vio backend/Cminor.vio -cfrontend/Cminorgenproof.vo cfrontend/Cminorgenproof.glob cfrontend/Cminorgenproof.v.beautified: cfrontend/Cminorgenproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/Errors.vo lib/Integers.vo lib/Floats.vo lib/Intv.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csharpminor.vo common/Switch.vo backend/Cminor.vo cfrontend/Cminorgen.vo -cfrontend/Cminorgenproof.vio: cfrontend/Cminorgenproof.v lib/Coqlib.vio lib/Maps.vio lib/Ordered.vio common/Errors.vio lib/Integers.vio lib/Floats.vio lib/Intv.vio common/AST.vio common/Linking.vio common/Values.vio common/Memory.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio cfrontend/Csharpminor.vio common/Switch.vio backend/Cminor.vio cfrontend/Cminorgen.vio -driver/Compopts.vo driver/Compopts.glob driver/Compopts.v.beautified: driver/Compopts.v -driver/Compopts.vio: driver/Compopts.v -driver/Compiler.vo driver/Compiler.glob driver/Compiler.v.beautified: driver/Compiler.v lib/Coqlib.vo common/Errors.vo common/AST.vo common/Linking.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Cexec.vo cfrontend/Clight.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/SimplLocals.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/Inlining.vo backend/Renumber.vo backend/Constprop.vo backend/CSE.vo backend/Deadcode.vo backend/Unusedglob.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Debugvar.vo backend/Stacking.vo $(ARCH)/Asmgen.vo cfrontend/SimplExprproof.vo cfrontend/SimplLocalsproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/Inliningproof.vo backend/Renumberproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Deadcodeproof.vo backend/Unusedglobproof.vo backend/Allocproof.vo backend/Tunnelingproof.vo backend/Linearizeproof.vo backend/CleanupLabelsproof.vo backend/Debugvarproof.vo backend/Stackingproof.vo $(ARCH)/Asmgenproof.vo driver/Compopts.vo -driver/Compiler.vio: driver/Compiler.v lib/Coqlib.vio common/Errors.vio common/AST.vio common/Linking.vio common/Smallstep.vio cfrontend/Ctypes.vio cfrontend/Csyntax.vio cfrontend/Csem.vio cfrontend/Cstrategy.vio cfrontend/Cexec.vio cfrontend/Clight.vio cfrontend/Csharpminor.vio backend/Cminor.vio backend/CminorSel.vio backend/RTL.vio backend/LTL.vio backend/Linear.vio backend/Mach.vio $(ARCH)/Asm.vio cfrontend/Initializers.vio cfrontend/SimplExpr.vio cfrontend/SimplLocals.vio cfrontend/Cshmgen.vio cfrontend/Cminorgen.vio backend/Selection.vio backend/RTLgen.vio backend/Tailcall.vio backend/Inlining.vio backend/Renumber.vio backend/Constprop.vio backend/CSE.vio backend/Deadcode.vio backend/Unusedglob.vio backend/Allocation.vio backend/Tunneling.vio backend/Linearize.vio backend/CleanupLabels.vio backend/Debugvar.vio backend/Stacking.vio $(ARCH)/Asmgen.vio cfrontend/SimplExprproof.vio cfrontend/SimplLocalsproof.vio cfrontend/Cshmgenproof.vio cfrontend/Cminorgenproof.vio backend/Selectionproof.vio backend/RTLgenproof.vio backend/Tailcallproof.vio backend/Inliningproof.vio backend/Renumberproof.vio backend/Constpropproof.vio backend/CSEproof.vio backend/Deadcodeproof.vio backend/Unusedglobproof.vio backend/Allocproof.vio backend/Tunnelingproof.vio backend/Linearizeproof.vio backend/CleanupLabelsproof.vio backend/Debugvarproof.vio backend/Stackingproof.vio $(ARCH)/Asmgenproof.vio driver/Compopts.vio -driver/Complements.vo driver/Complements.glob driver/Complements.v.beautified: driver/Complements.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Behaviors.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo backend/Cminor.vo backend/RTL.vo $(ARCH)/Asm.vo driver/Compiler.vo common/Errors.vo -driver/Complements.vio: driver/Complements.v lib/Coqlib.vio common/AST.vio lib/Integers.vio common/Values.vio common/Events.vio common/Globalenvs.vio common/Smallstep.vio common/Behaviors.vio cfrontend/Csyntax.vio cfrontend/Csem.vio cfrontend/Cstrategy.vio cfrontend/Clight.vio backend/Cminor.vio backend/RTL.vio $(ARCH)/Asm.vio driver/Compiler.vio common/Errors.vio -flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_Raux.glob flocq/Core/Fcore_Raux.v.beautified: flocq/Core/Fcore_Raux.v flocq/Core/Fcore_Zaux.vo -flocq/Core/Fcore_Raux.vio: flocq/Core/Fcore_Raux.v flocq/Core/Fcore_Zaux.vio -flocq/Core/Fcore_Zaux.vo flocq/Core/Fcore_Zaux.glob flocq/Core/Fcore_Zaux.v.beautified: flocq/Core/Fcore_Zaux.v -flocq/Core/Fcore_Zaux.vio: flocq/Core/Fcore_Zaux.v -flocq/Core/Fcore_defs.vo flocq/Core/Fcore_defs.glob flocq/Core/Fcore_defs.v.beautified: flocq/Core/Fcore_defs.v flocq/Core/Fcore_Raux.vo -flocq/Core/Fcore_defs.vio: flocq/Core/Fcore_defs.v flocq/Core/Fcore_Raux.vio -flocq/Core/Fcore_digits.vo flocq/Core/Fcore_digits.glob flocq/Core/Fcore_digits.v.beautified: flocq/Core/Fcore_digits.v flocq/Core/Fcore_Zaux.vo -flocq/Core/Fcore_digits.vio: flocq/Core/Fcore_digits.v flocq/Core/Fcore_Zaux.vio -flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_float_prop.glob flocq/Core/Fcore_float_prop.v.beautified: flocq/Core/Fcore_float_prop.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo -flocq/Core/Fcore_float_prop.vio: flocq/Core/Fcore_float_prop.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio -flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_FIX.glob flocq/Core/Fcore_FIX.v.beautified: flocq/Core/Fcore_FIX.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_rnd_ne.vo -flocq/Core/Fcore_FIX.vio: flocq/Core/Fcore_FIX.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_rnd.vio flocq/Core/Fcore_generic_fmt.vio flocq/Core/Fcore_ulp.vio flocq/Core/Fcore_rnd_ne.vio -flocq/Core/Fcore_FLT.vo flocq/Core/Fcore_FLT.glob flocq/Core/Fcore_FLT.v.beautified: flocq/Core/Fcore_FLT.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_rnd_ne.vo -flocq/Core/Fcore_FLT.vio: flocq/Core/Fcore_FLT.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_rnd.vio flocq/Core/Fcore_generic_fmt.vio flocq/Core/Fcore_float_prop.vio flocq/Core/Fcore_FLX.vio flocq/Core/Fcore_FIX.vio flocq/Core/Fcore_ulp.vio flocq/Core/Fcore_rnd_ne.vio -flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FLX.glob flocq/Core/Fcore_FLX.v.beautified: flocq/Core/Fcore_FLX.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_rnd_ne.vo -flocq/Core/Fcore_FLX.vio: flocq/Core/Fcore_FLX.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_rnd.vio flocq/Core/Fcore_generic_fmt.vio flocq/Core/Fcore_float_prop.vio flocq/Core/Fcore_FIX.vio flocq/Core/Fcore_ulp.vio flocq/Core/Fcore_rnd_ne.vio -flocq/Core/Fcore_FTZ.vo flocq/Core/Fcore_FTZ.glob flocq/Core/Fcore_FTZ.v.beautified: flocq/Core/Fcore_FTZ.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_FLX.vo -flocq/Core/Fcore_FTZ.vio: flocq/Core/Fcore_FTZ.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_rnd.vio flocq/Core/Fcore_generic_fmt.vio flocq/Core/Fcore_float_prop.vio flocq/Core/Fcore_ulp.vio flocq/Core/Fcore_FLX.vio -flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_generic_fmt.glob flocq/Core/Fcore_generic_fmt.v.beautified: flocq/Core/Fcore_generic_fmt.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_float_prop.vo -flocq/Core/Fcore_generic_fmt.vio: flocq/Core/Fcore_generic_fmt.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_rnd.vio flocq/Core/Fcore_float_prop.vio -flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_rnd.glob flocq/Core/Fcore_rnd.v.beautified: flocq/Core/Fcore_rnd.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo -flocq/Core/Fcore_rnd.vio: flocq/Core/Fcore_rnd.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio -flocq/Core/Fcore_rnd_ne.vo flocq/Core/Fcore_rnd_ne.glob flocq/Core/Fcore_rnd_ne.v.beautified: flocq/Core/Fcore_rnd_ne.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_ulp.vo -flocq/Core/Fcore_rnd_ne.vio: flocq/Core/Fcore_rnd_ne.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_rnd.vio flocq/Core/Fcore_generic_fmt.vio flocq/Core/Fcore_float_prop.vio flocq/Core/Fcore_ulp.vio -flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_ulp.glob flocq/Core/Fcore_ulp.v.beautified: flocq/Core/Fcore_ulp.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo -flocq/Core/Fcore_ulp.vio: flocq/Core/Fcore_ulp.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_rnd.vio flocq/Core/Fcore_generic_fmt.vio flocq/Core/Fcore_float_prop.vio -flocq/Core/Fcore.vo flocq/Core/Fcore.glob flocq/Core/Fcore.v.beautified: flocq/Core/Fcore.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_rnd_ne.vo flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FLT.vo flocq/Core/Fcore_ulp.vo -flocq/Core/Fcore.vio: flocq/Core/Fcore.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_float_prop.vio flocq/Core/Fcore_rnd.vio flocq/Core/Fcore_generic_fmt.vio flocq/Core/Fcore_rnd_ne.vio flocq/Core/Fcore_FIX.vio flocq/Core/Fcore_FLX.vio flocq/Core/Fcore_FLT.vio flocq/Core/Fcore_ulp.vio -flocq/Calc/Fcalc_bracket.vo flocq/Calc/Fcalc_bracket.glob flocq/Calc/Fcalc_bracket.v.beautified: flocq/Calc/Fcalc_bracket.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_float_prop.vo -flocq/Calc/Fcalc_bracket.vio: flocq/Calc/Fcalc_bracket.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_float_prop.vio -flocq/Calc/Fcalc_digits.vo flocq/Calc/Fcalc_digits.glob flocq/Calc/Fcalc_digits.v.beautified: flocq/Calc/Fcalc_digits.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_digits.vo -flocq/Calc/Fcalc_digits.vio: flocq/Calc/Fcalc_digits.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_float_prop.vio flocq/Core/Fcore_digits.vio -flocq/Calc/Fcalc_div.vo flocq/Calc/Fcalc_div.glob flocq/Calc/Fcalc_div.v.beautified: flocq/Calc/Fcalc_div.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_digits.vo flocq/Calc/Fcalc_bracket.vo flocq/Calc/Fcalc_digits.vo -flocq/Calc/Fcalc_div.vio: flocq/Calc/Fcalc_div.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_float_prop.vio flocq/Core/Fcore_digits.vio flocq/Calc/Fcalc_bracket.vio flocq/Calc/Fcalc_digits.vio -flocq/Calc/Fcalc_ops.vo flocq/Calc/Fcalc_ops.glob flocq/Calc/Fcalc_ops.v.beautified: flocq/Calc/Fcalc_ops.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_float_prop.vo -flocq/Calc/Fcalc_ops.vio: flocq/Calc/Fcalc_ops.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_float_prop.vio -flocq/Calc/Fcalc_round.vo flocq/Calc/Fcalc_round.glob flocq/Calc/Fcalc_round.v.beautified: flocq/Calc/Fcalc_round.v flocq/Core/Fcore.vo flocq/Core/Fcore_digits.vo flocq/Calc/Fcalc_bracket.vo flocq/Calc/Fcalc_digits.vo -flocq/Calc/Fcalc_round.vio: flocq/Calc/Fcalc_round.v flocq/Core/Fcore.vio flocq/Core/Fcore_digits.vio flocq/Calc/Fcalc_bracket.vio flocq/Calc/Fcalc_digits.vio -flocq/Calc/Fcalc_sqrt.vo flocq/Calc/Fcalc_sqrt.glob flocq/Calc/Fcalc_sqrt.v.beautified: flocq/Calc/Fcalc_sqrt.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_digits.vo flocq/Core/Fcore_float_prop.vo flocq/Calc/Fcalc_bracket.vo flocq/Calc/Fcalc_digits.vo -flocq/Calc/Fcalc_sqrt.vio: flocq/Calc/Fcalc_sqrt.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_digits.vio flocq/Core/Fcore_float_prop.vio flocq/Calc/Fcalc_bracket.vio flocq/Calc/Fcalc_digits.vio -flocq/Prop/Fprop_div_sqrt_error.vo flocq/Prop/Fprop_div_sqrt_error.glob flocq/Prop/Fprop_div_sqrt_error.v.beautified: flocq/Prop/Fprop_div_sqrt_error.v flocq/Core/Fcore.vo flocq/Calc/Fcalc_ops.vo flocq/Prop/Fprop_relative.vo -flocq/Prop/Fprop_div_sqrt_error.vio: flocq/Prop/Fprop_div_sqrt_error.v flocq/Core/Fcore.vio flocq/Calc/Fcalc_ops.vio flocq/Prop/Fprop_relative.vio -flocq/Prop/Fprop_mult_error.vo flocq/Prop/Fprop_mult_error.glob flocq/Prop/Fprop_mult_error.v.beautified: flocq/Prop/Fprop_mult_error.v flocq/Core/Fcore.vo flocq/Calc/Fcalc_ops.vo -flocq/Prop/Fprop_mult_error.vio: flocq/Prop/Fprop_mult_error.v flocq/Core/Fcore.vio flocq/Calc/Fcalc_ops.vio -flocq/Prop/Fprop_plus_error.vo flocq/Prop/Fprop_plus_error.glob flocq/Prop/Fprop_plus_error.v.beautified: flocq/Prop/Fprop_plus_error.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FLT.vo flocq/Calc/Fcalc_ops.vo -flocq/Prop/Fprop_plus_error.vio: flocq/Prop/Fprop_plus_error.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_float_prop.vio flocq/Core/Fcore_generic_fmt.vio flocq/Core/Fcore_FIX.vio flocq/Core/Fcore_FLX.vio flocq/Core/Fcore_FLT.vio flocq/Calc/Fcalc_ops.vio -flocq/Prop/Fprop_relative.vo flocq/Prop/Fprop_relative.glob flocq/Prop/Fprop_relative.v.beautified: flocq/Prop/Fprop_relative.v flocq/Core/Fcore.vo -flocq/Prop/Fprop_relative.vio: flocq/Prop/Fprop_relative.v flocq/Core/Fcore.vio -flocq/Prop/Fprop_Sterbenz.vo flocq/Prop/Fprop_Sterbenz.glob flocq/Prop/Fprop_Sterbenz.v.beautified: flocq/Prop/Fprop_Sterbenz.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_generic_fmt.vo flocq/Calc/Fcalc_ops.vo -flocq/Prop/Fprop_Sterbenz.vio: flocq/Prop/Fprop_Sterbenz.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_generic_fmt.vio flocq/Calc/Fcalc_ops.vio -flocq/Appli/Fappli_rnd_odd.vo flocq/Appli/Fappli_rnd_odd.glob flocq/Appli/Fappli_rnd_odd.v.beautified: flocq/Appli/Fappli_rnd_odd.v flocq/Core/Fcore.vo flocq/Calc/Fcalc_ops.vo -flocq/Appli/Fappli_rnd_odd.vio: flocq/Appli/Fappli_rnd_odd.v flocq/Core/Fcore.vio flocq/Calc/Fcalc_ops.vio -flocq/Appli/Fappli_double_round.vo flocq/Appli/Fappli_double_round.glob flocq/Appli/Fappli_double_round.v.beautified: flocq/Appli/Fappli_double_round.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_generic_fmt.vo flocq/Calc/Fcalc_ops.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FLT.vo flocq/Core/Fcore_FTZ.vo -flocq/Appli/Fappli_double_round.vio: flocq/Appli/Fappli_double_round.v flocq/Core/Fcore_Raux.vio flocq/Core/Fcore_defs.vio flocq/Core/Fcore_generic_fmt.vio flocq/Calc/Fcalc_ops.vio flocq/Core/Fcore_ulp.vio flocq/Core/Fcore_FLX.vio flocq/Core/Fcore_FLT.vio flocq/Core/Fcore_FTZ.vio -flocq/Appli/Fappli_IEEE.vo flocq/Appli/Fappli_IEEE.glob flocq/Appli/Fappli_IEEE.v.beautified: flocq/Appli/Fappli_IEEE.v flocq/Core/Fcore.vo flocq/Core/Fcore_digits.vo flocq/Calc/Fcalc_digits.vo flocq/Calc/Fcalc_round.vo flocq/Calc/Fcalc_bracket.vo flocq/Calc/Fcalc_ops.vo flocq/Calc/Fcalc_div.vo flocq/Calc/Fcalc_sqrt.vo flocq/Prop/Fprop_relative.vo -flocq/Appli/Fappli_IEEE.vio: flocq/Appli/Fappli_IEEE.v flocq/Core/Fcore.vio flocq/Core/Fcore_digits.vio flocq/Calc/Fcalc_digits.vio flocq/Calc/Fcalc_round.vio flocq/Calc/Fcalc_bracket.vio flocq/Calc/Fcalc_ops.vio flocq/Calc/Fcalc_div.vio flocq/Calc/Fcalc_sqrt.vio flocq/Prop/Fprop_relative.vio -flocq/Appli/Fappli_IEEE_bits.vo flocq/Appli/Fappli_IEEE_bits.glob flocq/Appli/Fappli_IEEE_bits.v.beautified: flocq/Appli/Fappli_IEEE_bits.v flocq/Core/Fcore.vo flocq/Core/Fcore_digits.vo flocq/Calc/Fcalc_digits.vo flocq/Appli/Fappli_IEEE.vo -flocq/Appli/Fappli_IEEE_bits.vio: flocq/Appli/Fappli_IEEE_bits.v flocq/Core/Fcore.vio flocq/Core/Fcore_digits.vio flocq/Calc/Fcalc_digits.vio flocq/Appli/Fappli_IEEE.vio -cparser/validator/Alphabet.vo cparser/validator/Alphabet.glob cparser/validator/Alphabet.v.beautified: cparser/validator/Alphabet.v -cparser/validator/Alphabet.vio: cparser/validator/Alphabet.v -cparser/validator/Interpreter_complete.vo cparser/validator/Interpreter_complete.glob cparser/validator/Interpreter_complete.v.beautified: cparser/validator/Interpreter_complete.v cparser/validator/Alphabet.vo cparser/validator/Grammar.vo cparser/validator/Automaton.vo cparser/validator/Interpreter.vo cparser/validator/Validator_complete.vo -cparser/validator/Interpreter_complete.vio: cparser/validator/Interpreter_complete.v cparser/validator/Alphabet.vio cparser/validator/Grammar.vio cparser/validator/Automaton.vio cparser/validator/Interpreter.vio cparser/validator/Validator_complete.vio -cparser/validator/Interpreter.vo cparser/validator/Interpreter.glob cparser/validator/Interpreter.v.beautified: cparser/validator/Interpreter.v cparser/validator/Automaton.vo cparser/validator/Alphabet.vo -cparser/validator/Interpreter.vio: cparser/validator/Interpreter.v cparser/validator/Automaton.vio cparser/validator/Alphabet.vio -cparser/validator/Validator_complete.vo cparser/validator/Validator_complete.glob cparser/validator/Validator_complete.v.beautified: cparser/validator/Validator_complete.v cparser/validator/Automaton.vo cparser/validator/Alphabet.vo -cparser/validator/Validator_complete.vio: cparser/validator/Validator_complete.v cparser/validator/Automaton.vio cparser/validator/Alphabet.vio -cparser/validator/Automaton.vo cparser/validator/Automaton.glob cparser/validator/Automaton.v.beautified: cparser/validator/Automaton.v cparser/validator/Grammar.vo cparser/validator/Alphabet.vo -cparser/validator/Automaton.vio: cparser/validator/Automaton.v cparser/validator/Grammar.vio cparser/validator/Alphabet.vio -cparser/validator/Interpreter_correct.vo cparser/validator/Interpreter_correct.glob cparser/validator/Interpreter_correct.v.beautified: cparser/validator/Interpreter_correct.v cparser/validator/Alphabet.vo cparser/validator/Grammar.vo cparser/validator/Automaton.vo cparser/validator/Interpreter.vo -cparser/validator/Interpreter_correct.vio: cparser/validator/Interpreter_correct.v cparser/validator/Alphabet.vio cparser/validator/Grammar.vio cparser/validator/Automaton.vio cparser/validator/Interpreter.vio -cparser/validator/Main.vo cparser/validator/Main.glob cparser/validator/Main.v.beautified: cparser/validator/Main.v cparser/validator/Grammar.vo cparser/validator/Automaton.vo cparser/validator/Interpreter_safe.vo cparser/validator/Interpreter_correct.vo cparser/validator/Interpreter_complete.vo -cparser/validator/Main.vio: cparser/validator/Main.v cparser/validator/Grammar.vio cparser/validator/Automaton.vio cparser/validator/Interpreter_safe.vio cparser/validator/Interpreter_correct.vio cparser/validator/Interpreter_complete.vio -cparser/validator/Validator_safe.vo cparser/validator/Validator_safe.glob cparser/validator/Validator_safe.v.beautified: cparser/validator/Validator_safe.v cparser/validator/Automaton.vo cparser/validator/Alphabet.vo -cparser/validator/Validator_safe.vio: cparser/validator/Validator_safe.v cparser/validator/Automaton.vio cparser/validator/Alphabet.vio -cparser/validator/Grammar.vo cparser/validator/Grammar.glob cparser/validator/Grammar.v.beautified: cparser/validator/Grammar.v cparser/validator/Alphabet.vo cparser/validator/Tuples.vo -cparser/validator/Grammar.vio: cparser/validator/Grammar.v cparser/validator/Alphabet.vio cparser/validator/Tuples.vio -cparser/validator/Interpreter_safe.vo cparser/validator/Interpreter_safe.glob cparser/validator/Interpreter_safe.v.beautified: cparser/validator/Interpreter_safe.v cparser/validator/Alphabet.vo cparser/validator/Grammar.vo cparser/validator/Automaton.vo cparser/validator/Validator_safe.vo cparser/validator/Interpreter.vo -cparser/validator/Interpreter_safe.vio: cparser/validator/Interpreter_safe.v cparser/validator/Alphabet.vio cparser/validator/Grammar.vio cparser/validator/Automaton.vio cparser/validator/Validator_safe.vio cparser/validator/Interpreter.vio -cparser/validator/Tuples.vo cparser/validator/Tuples.glob cparser/validator/Tuples.v.beautified: cparser/validator/Tuples.v -cparser/validator/Tuples.vio: cparser/validator/Tuples.v -cparser/Cabs.vo cparser/Cabs.glob cparser/Cabs.v.beautified: cparser/Cabs.v -cparser/Cabs.vio: cparser/Cabs.v -cparser/Parser.vo cparser/Parser.glob cparser/Parser.v.beautified: cparser/Parser.v cparser/Cabs.vo cparser/validator/Tuples.vo cparser/validator/Alphabet.vo cparser/validator/Grammar.vo cparser/validator/Automaton.vo cparser/validator/Main.vo -cparser/Parser.vio: cparser/Parser.v cparser/Cabs.vio cparser/validator/Tuples.vio cparser/validator/Alphabet.vio cparser/validator/Grammar.vio cparser/validator/Automaton.vio cparser/validator/Main.vio -exportclight/Clightdefs.vo exportclight/Clightdefs.glob exportclight/Clightdefs.v.beautified: exportclight/Clightdefs.v lib/Integers.vo lib/Floats.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo lib/Maps.vo common/Errors.vo -exportclight/Clightdefs.vio: exportclight/Clightdefs.v lib/Integers.vio lib/Floats.vio common/AST.vio cfrontend/Ctypes.vio cfrontend/Cop.vio cfrontend/Clight.vio lib/Maps.vio common/Errors.vio @@ -24,16 +24,20 @@ tools/ndfun tools/modorder Makefile.config # Generated files +.depend .depend.extr compcert.ini -ia32/ConstpropOp.v -ia32/SelectOp.v +x86/ConstpropOp.v +x86/SelectOp.v +x86/SelectLong.v powerpc/ConstpropOp.v powerpc/SelectOp.v +powerpc/SelectLong.v arm/ConstpropOp.v arm/SelectOp.v +arm/SelectLong.v backend/SelectDiv.v -backend/SelectLong.v +backend/SplitLong.v backend/CMlexer.ml backend/CMparser.ml backend/CMparser.mli @@ -1,3 +1,25 @@ +Working version +=============== + +Major improvements: + +- Added support for 64-bit target platforms, including pointers that + are 64-bit wide, and the ability to use 64-bit integer registers and + arithmetic operations. This support does not replace but comes in + addition to CompCert's original support for 32-bit target platforms, + with 32-bit pointers and emulation of 64-bit integer arithmetic + using pairs of 32-bit integers. In terms of C data models, CompCert + used to be restricted to the ILP32LL64 model; now it also supports + I32LP64 and IL32LLP64. + +- The x86 port of CompCert was extended to produce x86-64 bit code in + addition to the original x86-32 bit (IA32) code. (This is the first + instantiation of the new support for 64-bit targets described + above.) Support for x86-64 is currently available for Linux and MacOS X. + (Run the configure script with 'x86_64-linux' or 'x86_64-macosx'.) + + + Release 2.7.1, 2016-07-18 ========================= @@ -7,9 +29,9 @@ Bug fixing: - Fixed a compile-time assertion failure involving builtins taking a 64-bit integer parameter and given an unsigned 32-bit integer argument. -- Updates to the Cminor parser. +- Updates to the Cminor parser. + - Release 2.7, 2016-06-29 ======================= @@ -15,11 +15,17 @@ include Makefile.config -DIRS=lib common $(ARCH) backend cfrontend driver debug\ +ifeq ($(wildcard $(ARCH)_$(BITSIZE)),) +ARCHDIRS=$(ARCH) +else +ARCHDIRS=$(ARCH)_$(BITSIZE) $(ARCH) +endif + +DIRS=lib common $(ARCHDIRS) backend cfrontend driver debug\ flocq/Core flocq/Prop flocq/Calc flocq/Appli exportclight \ cparser cparser/validator -RECDIRS=lib common $(ARCH) backend cfrontend driver flocq exportclight cparser +RECDIRS=lib common $(ARCHDIRS) backend cfrontend driver flocq exportclight cparser COQINCLUDES=$(foreach d, $(RECDIRS), -R $(d) compcert.$(d)) @@ -65,8 +71,9 @@ COMMON=Errors.v AST.v Linking.v \ BACKEND=\ Cminor.v Op.v CminorSel.v \ - SelectOp.v SelectDiv.v SelectLong.v Selection.v \ - SelectOpproof.v SelectDivproof.v SelectLongproof.v Selectionproof.v \ + SelectOp.v SelectDiv.v SplitLong.v SelectLong.v Selection.v \ + SelectOpproof.v SelectDivproof.v SplitLongproof.v \ + SelectLongproof.v Selectionproof.v \ Registers.v RTL.v \ RTLgen.v RTLgenspec.v RTLgenproof.v \ Tailcall.v Tailcallproof.v \ @@ -118,7 +125,15 @@ DRIVER=Compopts.v Compiler.v Complements.v FILES=$(VLIB) $(COMMON) $(BACKEND) $(CFRONTEND) $(DRIVER) $(FLOCQ) \ $(PARSERVALIDATOR) $(PARSER) +# Generated source files + +GENERATED=\ + $(ARCH)/ConstpropOp.v $(ARCH)/SelectOp.v $(ARCH)/SelectLong.v \ + backend/SelectDiv.v backend/SplitLong.v \ + cparser/Parser.v + all: + @test -f .depend || $(MAKE) depend $(MAKE) proof $(MAKE) extraction $(MAKE) ccomp @@ -220,10 +235,11 @@ driver/Version.ml: VERSION cparser/Parser.v: cparser/Parser.vy $(MENHIR) --coq cparser/Parser.vy -depend: $(FILES) exportclight/Clightdefs.v - $(COQDEP) $^ \ - | sed -e 's|$(ARCH)/|$$(ARCH)/|g' \ - > .depend +depend: $(GENERATED) depend1 + +depend1: $(FILES) exportclight/Clightdefs.v + @echo "Analyzing Coq dependencies" + @$(COQDEP) $^ > .depend install: install -d $(BINDIR) @@ -245,7 +261,7 @@ clean: rm -f compcert.ini rm -f extraction/STAMP extraction/*.ml extraction/*.mli .depend.extr rm -f tools/ndfun tools/modorder tools/*.cm? tools/*.o - rm -f $(ARCH)/ConstpropOp.v $(ARCH)/SelectOp.v backend/SelectDiv.v backend/SelectLong.v + rm -f $(GENERATED) .depend $(MAKE) -f Makefile.extr clean $(MAKE) -C runtime clean $(MAKE) -C test clean @@ -268,6 +284,6 @@ check-proof: $(FILES) print-includes: @echo $(COQINCLUDES) -include .depend +-include .depend FORCE: diff --git a/arm/Archi.v b/arm/Archi.v index fedc55f5..64afb3ec 100644 --- a/arm/Archi.v +++ b/arm/Archi.v @@ -20,10 +20,19 @@ Require Import ZArith. Require Import Fappli_IEEE. Require Import Fappli_IEEE_bits. +Definition ptr64 := false. + Parameter big_endian: bool. -Notation align_int64 := 8%Z (only parsing). -Notation align_float64 := 8%Z (only parsing). +Definition align_int64 := 8%Z. +Definition align_float64 := 8%Z. + +Definition splitlong := true. + +Lemma splitlong_ptr32: splitlong = true -> ptr64 = false. +Proof. + unfold splitlong, ptr64; congruence. +Qed. Program Definition default_pl_64 : bool * nan_pl 53 := (false, iter_nat 51 _ xO xH). @@ -45,7 +54,8 @@ Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_p Definition float_of_single_preserves_sNaN := false. -Global Opaque default_pl_64 choose_binop_pl_64 +Global Opaque ptr64 big_endian splitlong + default_pl_64 choose_binop_pl_64 default_pl_32 choose_binop_pl_32 float_of_single_preserves_sNaN. @@ -199,10 +199,10 @@ Inductive instruction : Type := | Pfsts: freg -> ireg -> int -> instruction (**r float32 store *) (* Pseudo-instructions *) - | Pallocframe: Z -> int -> instruction (**r allocate new stack frame *) - | Pfreeframe: Z -> int -> instruction (**r deallocate stack frame and restore previous frame *) + | Pallocframe: Z -> ptrofs -> instruction (**r allocate new stack frame *) + | Pfreeframe: Z -> ptrofs -> instruction (**r deallocate stack frame and restore previous frame *) | Plabel: label -> instruction (**r define a code label *) - | Ploadsymbol: ireg -> ident -> int -> instruction (**r load the address of a symbol *) + | Ploadsymbol: ireg -> ident -> ptrofs -> instruction (**r load the address of a symbol *) | Pmovite: testcond -> ireg -> shift_op -> shift_op -> instruction (**r integer conditional move *) | Pbtbl: ireg -> list label -> instruction (**r N-way branch through a jump table *) | Pbuiltin: external_function -> list (builtin_arg preg) -> builtin_res preg -> instruction (**r built-in function (pseudo) *) @@ -376,7 +376,7 @@ Inductive outcome: Type := instruction ([nextinstr]) or branching to a label ([goto_label]). *) Definition nextinstr (rs: regset) := - rs#PC <- (Val.add rs#PC Vone). + rs#PC <- (Val.offset_ptr rs#PC Ptrofs.one). Definition nextinstr_nf (rs: regset) := nextinstr (undef_flags rs). @@ -386,7 +386,7 @@ Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := | None => Stuck | Some pos => match rs#PC with - | Vptr b ofs => Next (rs#PC <- (Vptr b (Int.repr pos))) m + | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m | _ => Stuck end end. @@ -564,11 +564,11 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | None => Stuck end | Pbsymb id sg => - Next (rs#PC <- (Genv.symbol_address ge id Int.zero)) m + Next (rs#PC <- (Genv.symbol_address ge id Ptrofs.zero)) m | Pbreg r sg => Next (rs#PC <- (rs#r)) m | Pblsymb id sg => - Next (rs#IR14 <- (Val.add rs#PC Vone) #PC <- (Genv.symbol_address ge id Int.zero)) m + Next (rs#IR14 <- (Val.add rs#PC Vone) #PC <- (Genv.symbol_address ge id Ptrofs.zero)) m | Pblreg r sg => Next (rs#IR14 <- (Val.add rs#PC Vone) #PC <- (rs#r)) m | Pbic r1 r2 so => @@ -716,13 +716,13 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (* Pseudo-instructions *) | Pallocframe sz pos => let (m1, stk) := Mem.alloc m 0 sz in - let sp := (Vptr stk Int.zero) in - match Mem.storev Mint32 m1 (Val.add sp (Vint pos)) rs#IR13 with + let sp := (Vptr stk Ptrofs.zero) in + match Mem.storev Mint32 m1 (Val.offset_ptr sp pos) rs#IR13 with | None => Stuck | Some m2 => Next (nextinstr (rs #IR12 <- (rs#IR13) #IR13 <- sp)) m2 end | Pfreeframe sz pos => - match Mem.loadv Mint32 m (Val.add rs#IR13 (Vint pos)) with + match Mem.loadv Mint32 m (Val.offset_ptr rs#IR13 pos) with | None => Stuck | Some v => match rs#IR13 with @@ -810,7 +810,7 @@ Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := | extcall_arg_stack: forall ofs ty bofs v, bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> Mem.loadv (chunk_of_type ty) m - (Val.add (rs (IR IR13)) (Vint (Int.repr bofs))) = Some v -> + (Val.offset_ptr (rs (IR IR13)) (Ptrofs.repr bofs)) = Some v -> extcall_arg rs m (S Outgoing ofs ty) v. Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := @@ -839,14 +839,14 @@ Inductive step: state -> trace -> state -> Prop := forall b ofs f i rs m rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Int.unsigned ofs) (fn_code f) = Some i -> + find_instr (Ptrofs.unsigned ofs) (fn_code f) = Some i -> exec_instr f i rs m = Next rs' m' -> step (State rs m) E0 (State rs' m') | exec_step_builtin: forall b ofs f ef args res rs m vargs t vres rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Int.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> + find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> eval_builtin_args ge rs (rs SP) m args vargs -> external_call ef ge vargs m t vres m' -> rs' = nextinstr @@ -855,7 +855,7 @@ Inductive step: state -> trace -> state -> Prop := step (State rs m) t (State rs' m') | exec_step_external: forall b ef args res rs m t rs' m', - rs PC = Vptr b Int.zero -> + rs PC = Vptr b Ptrofs.zero -> Genv.find_funct_ptr ge b = Some (External ef) -> external_call ef ge args m t res m' -> extcall_arguments rs m (ef_sig ef) args -> @@ -871,7 +871,7 @@ Inductive initial_state (p: program): state -> Prop := let ge := Genv.globalenv p in let rs0 := (Pregmap.init Vundef) - # PC <- (Genv.symbol_address ge p.(prog_main) Int.zero) + # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) # IR14 <- Vzero # IR13 <- Vzero in Genv.init_mem p = Some m0 -> diff --git a/arm/Asmgen.v b/arm/Asmgen.v index 90d3b189..bbfad3c9 100644 --- a/arm/Asmgen.v +++ b/arm/Asmgen.v @@ -362,7 +362,7 @@ Definition transl_op OK (Ploadsymbol r s ofs :: k) | Oaddrstack n, nil => do r <- ireg_of res; - OK (addimm r IR13 n k) + OK (addimm r IR13 (Ptrofs.to_int n) k) | Ocast8signed, a1 :: nil => do r <- ireg_of res; do r1 <- ireg_of a1; OK (if thumb tt then @@ -565,10 +565,11 @@ Definition indexed_memory_access then mk_instr base n :: k else addimm IR14 base (Int.sub n n1) (mk_instr IR14 n1 :: k). -Definition loadind_int (base: ireg) (ofs: int) (dst: ireg) (k: code) := - indexed_memory_access (fun base n => Pldr dst base (SOimm n)) mk_immed_mem_word base ofs k. +Definition loadind_int (base: ireg) (ofs: ptrofs) (dst: ireg) (k: code) := + indexed_memory_access (fun base n => Pldr dst base (SOimm n)) mk_immed_mem_word base (Ptrofs.to_int ofs) k. -Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) := +Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := + let ofs := Ptrofs.to_int ofs in match ty, preg_of dst with | Tint, IR r => OK (indexed_memory_access (fun base n => Pldr r base (SOimm n)) mk_immed_mem_word base ofs k) @@ -584,7 +585,8 @@ Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) := Error (msg "Asmgen.loadind") end. -Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) := +Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) := + let ofs := Ptrofs.to_int ofs in match ty, preg_of src with | Tint, IR r => OK (indexed_memory_access (fun base n => Pstr r base (SOimm n)) mk_immed_mem_word base ofs k) @@ -628,7 +630,7 @@ Definition transl_memory_access Error (msg "Asmgen.Aindexed2shift") end | Ainstack n, nil => - OK (indexed_memory_access mk_instr_imm mk_immed IR13 n k) + OK (indexed_memory_access mk_instr_imm mk_immed IR13 (Ptrofs.to_int n) k) | _, _ => Error(msg "Asmgen.transl_memory_access") end. @@ -788,11 +790,11 @@ Definition transl_function (f: Mach.function) := do c <- transl_code f f.(Mach.fn_code) true; OK (mkfunction f.(Mach.fn_sig) (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) :: - Pstr IR14 IR13 (SOimm f.(fn_retaddr_ofs)) :: c)). + Pstr IR14 IR13 (SOimm (Ptrofs.to_int f.(fn_retaddr_ofs))) :: c)). Definition transf_function (f: Mach.function) : res Asm.function := do tf <- transl_function f; - if zlt Int.max_unsigned (list_length_z tf.(fn_code)) + if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) then Error (msg "code size exceeded") else OK tf. diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v index 431743c6..ade121c5 100644 --- a/arm/Asmgenproof.v +++ b/arm/Asmgenproof.v @@ -18,6 +18,8 @@ Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Mach Conventions Asm. Require Import Asmgen Asmgenproof0 Asmgenproof1. +Local Transparent Archi.ptr64. + Definition match_prog (p: Mach.program) (tp: Asm.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. @@ -64,9 +66,9 @@ Qed. Lemma transf_function_no_overflow: forall f tf, - transf_function f = OK tf -> list_length_z (fn_code tf) <= Int.max_unsigned. + transf_function f = OK tf -> list_length_z (fn_code tf) <= Ptrofs.max_unsigned. Proof. - intros. monadInv H. destruct (zlt Int.max_unsigned (list_length_z (fn_code x))); inv EQ0. omega. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0. omega. Qed. Lemma exec_straight_exec: @@ -335,7 +337,7 @@ Lemma transl_find_label: | Some c => exists tc, find_label lbl (fn_code tf) = Some tc /\ transl_code f c false = OK tc end. Proof. - intros. monadInv H. destruct (zlt Int.max_unsigned (list_length_z (fn_code x))); inv EQ0. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0. monadInv EQ. simpl. eapply transl_code_label; eauto. Qed. @@ -360,10 +362,10 @@ Proof. intros [tc [A B]]. exploit label_pos_code_tail; eauto. instantiate (1 := 0). intros [pos' [P [Q R]]]. - exists tc; exists (rs#PC <- (Vptr b (Int.repr pos'))). + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). split. unfold goto_label. rewrite P. rewrite H1. auto. split. rewrite Pregmap.gss. constructor; auto. - rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in Q. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. auto. omega. generalize (transf_function_no_overflow _ _ H0). omega. intros. apply Pregmap.gso; auto. @@ -379,7 +381,7 @@ Proof. - intros. exploit transl_instr_label; eauto. destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor. - intros. monadInv H0. - destruct (zlt Int.max_unsigned (list_length_z (fn_code x))); inv EQ0. monadInv EQ. + destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0. monadInv EQ. exists x; exists true; split; auto. repeat constructor. - exact transf_function_no_overflow. Qed. @@ -418,7 +420,7 @@ Inductive match_states: Mach.state -> Asm.state -> Prop := (STACKS: match_stack ge s) (MEXT: Mem.extends m m') (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Int.zero) + (ATPC: rs PC = Vptr fb Ptrofs.zero) (ATLR: rs RA = parent_ra s), match_states (Mach.Callstate s fb ms m) (Asm.State rs m') @@ -624,13 +626,13 @@ Opaque loadind. eapply transf_function_no_overflow; eauto. destruct ros as [rf|fid]; simpl in H; monadInv H5. + (* Indirect call *) - assert (rs rf = Vptr f' Int.zero). + assert (rs rf = Vptr f' Ptrofs.zero). destruct (rs rf); try discriminate. - revert H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Int.zero). + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Int.add ofs Int.one)) fb f c false tf x). + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). econstructor; eauto. exploit return_address_offset_correct; eauto. intros; subst ra. left; econstructor; split. @@ -644,7 +646,7 @@ Opaque loadind. Simpl. rewrite <- H2. auto. + (* Direct call *) generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Int.add ofs Int.one)) fb f c false tf x). + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). econstructor; eauto. exploit return_address_offset_correct; eauto. intros; subst ra. left; econstructor; split. @@ -660,7 +662,7 @@ Opaque loadind. - (* Mtailcall *) assert (f0 = f) by congruence. subst f0. inversion AT; subst. - assert (NOOV: list_length_z (fn_code tf) <= Int.max_unsigned). + assert (NOOV: list_length_z (fn_code tf) <= Ptrofs.max_unsigned). eapply transf_function_no_overflow; eauto. exploit Mem.loadv_extends. eauto. eexact H1. auto. unfold chunk_of_type. rewrite (sp_val _ _ _ AG). intros [parent' [A B]]. @@ -682,16 +684,16 @@ Opaque loadind. exploit loadind_int_correct. eexact C. intros [rs1 [P [Q R]]]. econstructor; split. eapply exec_straight_trans. eexact P. apply exec_straight_one. - simpl. rewrite R; auto with asmgen. unfold chunk_of_type in A. rewrite A. + simpl. rewrite R; auto with asmgen. unfold chunk_of_type in A; simpl in A. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto. auto. split. Simpl. split. Simpl. intros. Simpl. } destruct ros as [rf|fid]; simpl in H; monadInv H7. + (* Indirect call *) - assert (rs rf = Vptr f' Int.zero). + assert (rs rf = Vptr f' Ptrofs.zero). destruct (rs rf); try discriminate. - revert H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Int.zero). + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. destruct (X (Pbreg x0 sig :: x)) as [rs2 [P [Q [R S]]]]. exploit exec_straight_steps_2. eexact P. eauto. eauto. eapply functions_transl; eauto. eauto. @@ -850,7 +852,7 @@ Opaque loadind. - (* internal function *) exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Int.max_unsigned (list_length_z (fn_code x0))); inversion EQ1. clear EQ1. + destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x0))); inversion EQ1. clear EQ1. monadInv EQ0. unfold store_stack in *. exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl. @@ -860,24 +862,27 @@ Opaque loadind. exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. intros [m3' [P Q]]. (* Execution of function prologue *) - set (rs2 := nextinstr (rs0#IR12 <- (parent_sp s) #IR13 <- (Vptr stk Int.zero))). + set (rs2 := nextinstr (rs0#IR12 <- (parent_sp s) #IR13 <- (Vptr stk Ptrofs.zero))). set (rs3 := nextinstr rs2). assert (EXEC_PROLOGUE: exec_straight tge x (fn_code x) rs0 m' x1 rs3 m3'). - rewrite <- H5 at 2; unfold fn_code. + replace (fn_code x) + with (Pallocframe (fn_stacksize f) (fn_link_ofs f) :: Pstr IR14 IR13 (SOimm (Ptrofs.to_int (fn_retaddr_ofs f))) :: x1) + by (rewrite <- H5; auto). apply exec_straight_two with rs2 m2'. unfold exec_instr. rewrite C. fold sp. - rewrite <- (sp_val _ _ _ AG). unfold chunk_of_type in F. rewrite F. auto. + rewrite <- (sp_val _ _ _ AG). unfold Tptr, chunk_of_type, Archi.ptr64 in F. rewrite F. auto. simpl. auto. simpl. unfold exec_store. change (rs2 IR14) with (rs0 IR14). - rewrite Int.add_zero_l. simpl. unfold chunk_of_type in P. simpl in P. - rewrite Int.add_zero_l in P. rewrite ATLR. rewrite P. auto. auto. auto. + rewrite Ptrofs.add_zero_l. simpl. unfold Tptr, chunk_of_type, Archi.ptr64 in P. simpl in P. + rewrite Ptrofs.add_zero_l in P. rewrite ATLR. rewrite Ptrofs.of_int_to_int by auto. + rewrite P. auto. auto. auto. left; exists (State rs3 m3'); split. eapply exec_straight_steps_1; eauto. omega. constructor. econstructor; eauto. - change (rs3 PC) with (Val.add (Val.add (rs0 PC) Vone) Vone). + change (rs3 PC) with (Val.offset_ptr (Val.offset_ptr (rs0 PC) Ptrofs.one) Ptrofs.one). rewrite ATPC. simpl. constructor; eauto. subst x. eapply code_tail_next_int. omega. eapply code_tail_next_int. omega. constructor. @@ -915,12 +920,12 @@ Proof. econstructor; split. econstructor. eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Int.zero) - with (Vptr fb Int.zero). + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). econstructor; eauto. constructor. apply Mem.extends_refl. - split. auto. simpl. unfold Vzero; congruence. intros. rewrite Regmap.gi. auto. + split. auto. simpl. unfold Vnullptr; simpl; congruence. intros. rewrite Regmap.gi. auto. unfold Genv.symbol_address. rewrite (match_program_main TRANSF). rewrite symbols_preserved. diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v index 76a7b080..252a294a 100644 --- a/arm/Asmgenproof1.v +++ b/arm/Asmgenproof1.v @@ -30,6 +30,8 @@ Require Import Asmgen. Require Import Conventions. Require Import Asmgenproof0. +Local Transparent Archi.ptr64. + (** Useful properties of the R14 registers. *) Lemma ireg_of_not_R14: @@ -49,7 +51,7 @@ Hint Resolve ireg_of_not_R14': asmgen. (** [undef_flags] and [nextinstr_nf] *) Lemma nextinstr_nf_pc: - forall rs, (nextinstr_nf rs)#PC = Val.add rs#PC Vone. + forall rs, (nextinstr_nf rs)#PC = Val.offset_ptr rs#PC Ptrofs.one. Proof. intros. reflexivity. Qed. @@ -520,49 +522,55 @@ Qed. 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 -> + Mem.loadv Mint32 m (Val.offset_ptr rs#base ofs) = Some v -> exists rs', exec_straight ge fn (loadind_int base ofs dst k) rs m k rs' m /\ rs'#dst = v /\ forall r, if_preg r = true -> r <> IR14 -> r <> dst -> rs'#r = rs#r. Proof. - intros; unfold loadind_int. apply indexed_memory_access_correct; intros. + intros; unfold loadind_int. + assert (Val.offset_ptr (rs base) ofs = Val.add (rs base) (Vint (Ptrofs.to_int ofs))). + { destruct (rs base); try discriminate. simpl. f_equal; f_equal. symmetry; auto with ptrofs. } + apply indexed_memory_access_correct; intros. econstructor; split. - apply exec_straight_one. simpl. unfold exec_load. rewrite H0; rewrite H; eauto. auto. + apply exec_straight_one. simpl. unfold exec_load. rewrite H1, <- H0, H. eauto. auto. split; intros; Simpl. Qed. Lemma loadind_correct: forall (base: ireg) ofs ty dst k c (rs: regset) m v, loadind base ofs ty dst k = OK c -> - Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v -> + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> exists rs', exec_straight ge fn c rs m k rs' m /\ rs'#(preg_of dst) = v /\ forall r, if_preg r = true -> r <> IR14 -> r <> preg_of dst -> rs'#r = rs#r. Proof. - unfold loadind; intros. destruct ty; destruct (preg_of dst); inv H; simpl in H0. + unfold loadind; intros. + assert (Val.offset_ptr (rs base) ofs = Val.add (rs base) (Vint (Ptrofs.to_int ofs))). + { destruct (rs base); try discriminate. simpl. f_equal; f_equal. symmetry; auto with ptrofs. } + destruct ty; destruct (preg_of dst); inv H; simpl in H0. - (* int *) apply loadind_int_correct; auto. - (* float *) apply indexed_memory_access_correct; intros. econstructor; split. - apply exec_straight_one. simpl. unfold exec_load. rewrite H. rewrite H0. eauto. auto. + apply exec_straight_one. simpl. unfold exec_load. rewrite H, <- H1, H0. eauto. auto. split; intros; Simpl. - (* single *) apply indexed_memory_access_correct; intros. econstructor; split. - apply exec_straight_one. simpl. unfold exec_load. rewrite H. rewrite H0. eauto. auto. + apply exec_straight_one. simpl. unfold exec_load. rewrite H, <- H1, H0. eauto. auto. split; intros; Simpl. - (* any32 *) apply indexed_memory_access_correct; intros. econstructor; split. - apply exec_straight_one. simpl. unfold exec_load. rewrite H. rewrite H0. eauto. auto. + apply exec_straight_one. simpl. unfold exec_load. rewrite H, <- H1, H0. eauto. auto. split; intros; Simpl. - (* any64 *) apply indexed_memory_access_correct; intros. econstructor; split. - apply exec_straight_one. simpl. unfold exec_load. rewrite H. rewrite H0. eauto. auto. + apply exec_straight_one. simpl. unfold exec_load. rewrite H, <- H1, H0. eauto. auto. split; intros; Simpl. Qed. @@ -571,43 +579,40 @@ Qed. Lemma storeind_correct: forall (base: ireg) ofs ty src k c (rs: regset) m m', storeind src base ofs ty k = OK c -> - Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' -> + Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) (rs#(preg_of src)) = Some m' -> exists rs', exec_straight ge fn c rs m k rs' m' /\ forall r, if_preg r = true -> r <> IR14 -> rs'#r = rs#r. Proof. unfold storeind; intros. assert (DATA: data_preg (preg_of src) = true) by eauto with asmgen. + assert (Val.offset_ptr (rs base) ofs = Val.add (rs base) (Vint (Ptrofs.to_int ofs))). + { destruct (rs base); try discriminate. simpl. f_equal; f_equal. symmetry; auto with ptrofs. } destruct ty; destruct (preg_of src); inv H; simpl in H0. - (* int *) apply indexed_memory_access_correct; intros. econstructor; split. - apply exec_straight_one. simpl. unfold exec_store. - rewrite H. rewrite H1; auto with asmgen. rewrite H0; eauto. auto. + apply exec_straight_one. simpl. unfold exec_store. rewrite H, <- H1, H2, H0 by auto with asmgen; eauto. auto. intros; Simpl. - (* float *) apply indexed_memory_access_correct; intros. econstructor; split. - apply exec_straight_one. simpl. unfold exec_store. - rewrite H. rewrite H1; auto with asmgen. rewrite H0; eauto. auto. + apply exec_straight_one. simpl. unfold exec_store. rewrite H, <- H1, H2, H0 by auto with asmgen; eauto. auto. intros; Simpl. - (* single *) apply indexed_memory_access_correct; intros. econstructor; split. - apply exec_straight_one. simpl. unfold exec_store. - rewrite H. rewrite H1; auto with asmgen. rewrite H0; eauto. auto. + apply exec_straight_one. simpl. unfold exec_store. rewrite H, <- H1, H2, H0 by auto with asmgen; eauto. auto. intros; Simpl. - (* any32 *) apply indexed_memory_access_correct; intros. econstructor; split. - apply exec_straight_one. simpl. unfold exec_store. - rewrite H. rewrite H1; auto with asmgen. rewrite H0; eauto. auto. + apply exec_straight_one. simpl. unfold exec_store. rewrite H, <- H1, H2, H0 by auto with asmgen; eauto. auto. intros; Simpl. - (* any64 *) apply indexed_memory_access_correct; intros. econstructor; split. - apply exec_straight_one. simpl. unfold exec_store. - rewrite H. rewrite H1; auto with asmgen. rewrite H0; eauto. auto. + apply exec_straight_one. simpl. unfold exec_store. rewrite H, <- H1, H2, H0 by auto with asmgen; eauto. auto. intros; Simpl. Qed. @@ -731,32 +736,32 @@ Proof. destruct (Int.ltu i i0); reflexivity. (* int ptr *) destruct (Int.eq i Int.zero && - (Mem.valid_pointer m b0 (Int.unsigned i0) || Mem.valid_pointer m b0 (Int.unsigned i0 - 1))) eqn:?; try discriminate. + (Mem.valid_pointer m b0 (Ptrofs.unsigned i0) || Mem.valid_pointer m b0 (Ptrofs.unsigned i0 - 1))) eqn:?; try discriminate. destruct c; simpl in *; inv H1. rewrite Heqb1; reflexivity. rewrite Heqb1; reflexivity. (* ptr int *) destruct (Int.eq i0 Int.zero && - (Mem.valid_pointer m b0 (Int.unsigned i) || Mem.valid_pointer m b0 (Int.unsigned i - 1))) eqn:?; try discriminate. + (Mem.valid_pointer m b0 (Ptrofs.unsigned i) || Mem.valid_pointer m b0 (Ptrofs.unsigned i - 1))) eqn:?; try discriminate. destruct c; simpl in *; inv H1. rewrite Heqb1; reflexivity. rewrite Heqb1; reflexivity. (* ptr ptr *) simpl. - fold (Mem.weak_valid_pointer m b0 (Int.unsigned i)) in *. - fold (Mem.weak_valid_pointer m b1 (Int.unsigned i0)) in *. + fold (Mem.weak_valid_pointer m b0 (Ptrofs.unsigned i)) in *. + fold (Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i0)) in *. destruct (eq_block b0 b1). - destruct (Mem.weak_valid_pointer m b0 (Int.unsigned i) && - Mem.weak_valid_pointer m b1 (Int.unsigned i0)); inversion H1. + destruct (Mem.weak_valid_pointer m b0 (Ptrofs.unsigned i) && + Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i0)); inversion H1. destruct c; simpl; auto. - destruct (Int.eq i i0); reflexivity. - destruct (Int.eq i i0); auto. - destruct (Int.ltu i i0); auto. - rewrite (int_not_ltu i i0). destruct (Int.ltu i i0); simpl; destruct (Int.eq i i0); auto. - rewrite (int_ltu_not i i0). destruct (Int.ltu i i0); destruct (Int.eq i i0); reflexivity. - destruct (Int.ltu i i0); reflexivity. - destruct (Mem.valid_pointer m b0 (Int.unsigned i) && - Mem.valid_pointer m b1 (Int.unsigned i0)); try discriminate. + destruct (Ptrofs.eq i i0); reflexivity. + destruct (Ptrofs.eq i i0); auto. + destruct (Ptrofs.ltu i i0); auto. + rewrite (Ptrofs.not_ltu i i0). destruct (Ptrofs.ltu i i0); simpl; destruct (Ptrofs.eq i i0); auto. + rewrite (Ptrofs.ltu_not i i0). destruct (Ptrofs.ltu i i0); destruct (Ptrofs.eq i i0); reflexivity. + destruct (Ptrofs.ltu i i0); reflexivity. + destruct (Mem.valid_pointer m b0 (Ptrofs.unsigned i) && + Mem.valid_pointer m b1 (Ptrofs.unsigned i0)); try discriminate. destruct c; simpl in *; inv H1; reflexivity. Qed. @@ -785,7 +790,7 @@ Qed. Lemma compare_float_nextpc: forall rs v1 v2, - nextinstr (compare_float rs v1 v2) PC = Val.add (rs PC) Vone. + nextinstr (compare_float rs v1 v2) PC = Val.offset_ptr (rs PC) Ptrofs.one. Proof. intros. unfold compare_float. destruct v1; destruct v2; reflexivity. Qed. @@ -891,7 +896,7 @@ Qed. Lemma compare_float32_nextpc: forall rs v1 v2, - nextinstr (compare_float32 rs v1 v2) PC = Val.add (rs PC) Vone. + nextinstr (compare_float32 rs v1 v2) PC = Val.offset_ptr (rs PC) Ptrofs.one. Proof. intros. unfold compare_float32. destruct v1; destruct v2; reflexivity. Qed. @@ -1138,7 +1143,7 @@ Lemma transl_op_correct_same: forall op args res k c (rs: regset) m v, transl_op op args res k = OK c -> eval_operation ge rs#IR13 op (map rs (map preg_of args)) m = Some v -> - match op with Ocmp _ => False | _ => True end -> + match op with Ocmp _ => False | Oaddrstack _ => False | _ => True end -> exists rs', exec_straight ge fn c rs m k rs' m /\ rs'#(preg_of res) = v @@ -1155,9 +1160,7 @@ Proof. generalize (loadimm_correct x i k rs m). intros [rs' [A [B C]]]. exists rs'; auto with asmgen. (* Oaddrstack *) - generalize (addimm_correct x IR13 i k rs m). - intros [rs' [EX [RES OTH]]]. - exists rs'; auto with asmgen. + contradiction. (* Ocast8signed *) destruct (thumb tt). econstructor; split. apply exec_straight_one; simpl; eauto. intuition Simpl. @@ -1296,19 +1299,29 @@ Lemma transl_op_correct: /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs'#r = rs#r. Proof. intros. - assert (EITHER: match op with Ocmp _ => False | _ => True end \/ exists cmp, op = Ocmp cmp). - destruct op; auto. right; exists c0; auto. - destruct EITHER as [A | [cmp A]]. - exploit transl_op_correct_same; eauto. intros [rs' [P [Q R]]]. - subst v. exists rs'; eauto. - (* Ocmp *) - subst op. simpl in H. monadInv H. simpl in H0. inv H0. + assert (SAME: + (exists rs', exec_straight ge fn c rs m k rs' m + /\ rs'#(preg_of res) = v + /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs'#r = rs#r) -> + exists rs', exec_straight ge fn c rs m k rs' m + /\ Val.lessdef v rs'#(preg_of res) + /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs'#r = rs#r). + { intros (rs' & A & B & C). subst v; exists rs'; auto. } + destruct op; try (apply SAME; eapply transl_op_correct_same; eauto; fail). +- (* Oaddrstack *) + clear SAME; simpl in *; ArgsInv. + destruct (addimm_correct x IR13 (Ptrofs.to_int i) k rs m) as [rs' [EX [RES OTH]]]. + exists rs'; split. auto. split. + rewrite RES; inv H0. destruct (rs IR13); simpl; auto. rewrite Ptrofs.of_int_to_int; auto. + intros; apply OTH; eauto with asmgen. +- (* Ocmp *) + clear SAME. simpl in H. monadInv H. simpl in H0. inv H0. rewrite (ireg_of_eq _ _ EQ). exploit transl_cond_correct; eauto. instantiate (1 := rs). instantiate (1 := m). intros [rs1 [A [B C]]]. econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. split; intros; Simpl. - destruct (eval_condition cmp rs ## (preg_of ## args) m) as [b|]; simpl; auto. + destruct (eval_condition c0 rs ## (preg_of ## args) m) as [b|]; simpl; auto. destruct B as [B1 B2]; rewrite B1. destruct b; auto. Qed. @@ -1317,7 +1330,10 @@ 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. + intros. destruct v1; destruct v2; simpl; auto. + rewrite Int.add_zero; auto. + rewrite Ptrofs.add_zero; auto. + rewrite Ptrofs.add_zero; auto. Qed. Lemma transl_memory_access_correct: @@ -1327,6 +1343,7 @@ Lemma transl_memory_access_correct: addr args k c (rs: regset) a m m', transl_memory_access mk_instr_imm mk_instr_gen mk_immed addr args k = OK c -> eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a -> + match a with Vptr _ _ => True | _ => False end -> (forall (r1: ireg) (rs1: regset) n k, Val.add rs1#r1 (Vint n) = a -> (forall (r: preg), if_preg r = true -> r <> IR14 -> rs1 r = rs r) -> @@ -1343,7 +1360,7 @@ Lemma transl_memory_access_correct: exists rs', exec_straight ge fn c rs m k rs' m' /\ P rs'. Proof. - intros until m'; intros TR EA MK1 MK2. + intros until m'; intros TR EA ADDR MK1 MK2. unfold transl_memory_access in TR; destruct addr; ArgsInv; simpl in EA; inv EA. (* Aindexed *) apply indexed_memory_access_correct. exact MK1. @@ -1354,7 +1371,8 @@ Proof. destruct mk_instr_gen as [mk | ]; monadInv TR. apply MK2. erewrite ! ireg_of_eq; eauto. rewrite transl_shift_correct. auto. (* Ainstack *) - inv TR. apply indexed_memory_access_correct. exact MK1. + inv TR. apply indexed_memory_access_correct. intros. eapply MK1; eauto. + rewrite H. destruct (rs IR13); try contradiction. simpl. f_equal; f_equal. auto with ptrofs. Qed. Lemma transl_load_int_correct: @@ -1372,6 +1390,7 @@ Lemma transl_load_int_correct: Proof. intros. monadInv H. erewrite ireg_of_eq by eauto. eapply transl_memory_access_correct; eauto. + destruct a; discriminate || trivial. intros; simpl. econstructor; split. apply exec_straight_one. rewrite H2. unfold exec_load. simpl eval_shift_op. rewrite H. rewrite H1. eauto. auto. split. Simpl. intros; Simpl. @@ -1396,6 +1415,7 @@ Lemma transl_load_float_correct: Proof. intros. monadInv H. erewrite freg_of_eq by eauto. eapply transl_memory_access_correct; eauto. + destruct a; discriminate || trivial. intros; simpl. econstructor; split. apply exec_straight_one. rewrite H2. unfold exec_load. rewrite H. rewrite H1. eauto. auto. split. Simpl. intros; Simpl. @@ -1417,6 +1437,7 @@ Proof. intros. assert (DR: data_preg (preg_of src) = true) by eauto with asmgen. monadInv H. erewrite ireg_of_eq in * by eauto. eapply transl_memory_access_correct; eauto. + destruct a; discriminate || trivial. intros; simpl. econstructor; split. apply exec_straight_one. rewrite H2. unfold exec_store. simpl eval_shift_op. rewrite H. rewrite H3; eauto with asmgen. rewrite H1. eauto. auto. @@ -1442,6 +1463,7 @@ Proof. intros. assert (DR: data_preg (preg_of src) = true) by eauto with asmgen. monadInv H. erewrite freg_of_eq in * by eauto. eapply transl_memory_access_correct; eauto. + destruct a; discriminate || trivial. intros; simpl. econstructor; split. apply exec_straight_one. rewrite H2. unfold exec_store. rewrite H. rewrite H3; auto with asmgen. rewrite H1. eauto. auto. intros; Simpl. diff --git a/arm/ConstpropOp.vp b/arm/ConstpropOp.vp index 872493a6..e0f0889f 100644 --- a/arm/ConstpropOp.vp +++ b/arm/ConstpropOp.vp @@ -22,6 +22,18 @@ Require Import Op. Require Import Registers. Require Import ValueDomain. +(** * Converting known values to constants *) + +Definition const_for_result (a: aval) : option operation := + match a with + | I n => Some(Ointconst n) + | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None + | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None + | Ptr(Gl id ofs) => Some (Oaddrsymbol id ofs) + | Ptr(Stk ofs) => Some(Oaddrstack ofs) + | _ => None + end. + (** * Operator strength reduction *) (** We now define auxiliary functions for strength reduction of @@ -237,19 +249,19 @@ Nondetfunction addr_strength_reduction (addr: addressing) (args: list reg) (vl: list aval) := match addr, args, vl with | Aindexed2, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil => - (Ainstack (Int.add n1 n2), nil) + (Ainstack (Ptrofs.add n1 (Ptrofs.of_int n2)), nil) | Aindexed2, r1 :: r2 :: nil, I n1 :: Ptr(Stk n2) :: nil => - (Ainstack (Int.add n1 n2), nil) + (Ainstack (Ptrofs.add (Ptrofs.of_int n1) n2), nil) | Aindexed2, r1 :: r2 :: nil, I n1 :: v2 :: nil => (Aindexed n1, r2 :: nil) | Aindexed2, r1 :: r2 :: nil, v1 :: I n2 :: nil => (Aindexed n2, r1 :: nil) | Aindexed2shift s, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil => - (Ainstack (Int.add n1 (eval_static_shift s n2)), nil) + (Ainstack (Ptrofs.add n1 (Ptrofs.of_int (eval_static_shift s n2))), nil) | Aindexed2shift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => (Aindexed (eval_static_shift s n2), r1 :: nil) | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => - (Ainstack (Int.add n1 n), nil) + (Ainstack (Ptrofs.add n1 (Ptrofs.of_int n)), nil) | _, _, _ => (addr, args) end. diff --git a/arm/ConstpropOpproof.v b/arm/ConstpropOpproof.v index 0b7643c6..e1ae80a2 100644 --- a/arm/ConstpropOpproof.v +++ b/arm/ConstpropOpproof.v @@ -27,6 +27,8 @@ Require Import RTL. Require Import ValueDomain. Require Import ConstpropOp. +Local Transparent Archi.ptr64. + (** * Correctness of strength reduction *) (** We now show that strength reduction over operators and addressing @@ -95,6 +97,28 @@ Ltac SimplVM := | _ => idtac end. +Lemma const_for_result_correct: + forall a op v, + const_for_result a = Some op -> + vmatch bc v a -> + exists v', eval_operation ge (Vptr sp Ptrofs.zero) op nil m = Some v' /\ Val.lessdef v v'. +Proof. + unfold const_for_result; intros. + destruct a; inv H; SimplVM. +- (* integer *) + exists (Vint n); auto. +- (* float *) + destruct (generate_float_constants tt); inv H2. exists (Vfloat f); auto. +- (* single *) + destruct (generate_float_constants tt); inv H2. exists (Vsingle f); auto. +- (* pointer *) + destruct p; try discriminate; SimplVM. + + (* global *) + inv H2. exists (Genv.symbol_address ge id ofs); auto. + + (* stack *) + inv H2. exists (Vptr sp ofs); split; auto. simpl. rewrite Ptrofs.add_zero_l; auto. +Qed. + Lemma eval_static_shift_correct: forall s n, eval_shift s (Vint n) = Vint (eval_static_shift s n). Proof. @@ -146,7 +170,7 @@ Lemma make_cmp_base_correct: forall c args vl, vl = map (fun r => AE.get r ae) args -> let (op', args') := make_cmp_base c args vl in - exists v, eval_operation ge (Vptr sp Int.zero) op' rs##args' m = Some v + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' rs##args' m = Some v /\ Val.lessdef (Val.of_optbool (eval_condition c rs##args m)) v. Proof. intros. unfold make_cmp_base. @@ -159,7 +183,7 @@ Lemma make_cmp_correct: forall c args vl, vl = map (fun r => AE.get r ae) args -> let (op', args') := make_cmp c args vl in - exists v, eval_operation ge (Vptr sp Int.zero) op' rs##args' m = Some v + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' rs##args' m = Some v /\ Val.lessdef (Val.of_optbool (eval_condition c rs##args m)) v. Proof. intros c args vl. @@ -191,11 +215,12 @@ Qed. Lemma make_addimm_correct: forall n r, let (op, args) := make_addimm n r in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v. Proof. intros. unfold make_addimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto. + subst. exists (rs#r); split; auto. + destruct (rs#r); simpl; auto. rewrite Int.add_zero; auto. rewrite Ptrofs.add_zero; auto. exists (Val.add rs#r (Vint n)); auto. Qed. @@ -203,7 +228,7 @@ Lemma make_shlimm_correct: forall n r1 r2, rs#r2 = Vint n -> let (op, args) := make_shlimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v. Proof. Opaque mk_shift_amount. intros; unfold make_shlimm. @@ -218,7 +243,7 @@ Lemma make_shrimm_correct: forall n r1 r2, rs#r2 = Vint n -> let (op, args) := make_shrimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v. Proof. intros; unfold make_shrimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. @@ -232,7 +257,7 @@ Lemma make_shruimm_correct: forall n r1 r2, rs#r2 = Vint n -> let (op, args) := make_shruimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v. Proof. intros; unfold make_shruimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. @@ -246,7 +271,7 @@ Lemma make_mulimm_correct: forall n r1 r2, rs#r2 = Vint n -> let (op, args) := make_mulimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v. Proof. intros; unfold make_mulimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. @@ -265,7 +290,7 @@ Lemma make_divimm_correct: Val.divs rs#r1 rs#r2 = Some v -> rs#r2 = Vint n -> let (op, args) := make_divimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some w /\ Val.lessdef v w. + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_divimm. destruct (Int.is_power2 n) eqn:?. @@ -280,7 +305,7 @@ Lemma make_divuimm_correct: Val.divu rs#r1 rs#r2 = Some v -> rs#r2 = Vint n -> let (op, args) := make_divuimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some w /\ Val.lessdef v w. + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_divuimm. destruct (Int.is_power2 n) eqn:?. @@ -295,7 +320,7 @@ Lemma make_andimm_correct: forall n r x, vmatch bc rs#r x -> let (op, args) := make_andimm n r x in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v. Proof. intros; unfold make_andimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. @@ -320,7 +345,7 @@ Qed. Lemma make_orimm_correct: forall n r, let (op, args) := make_orimm n r in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v. Proof. intros; unfold make_orimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. @@ -333,7 +358,7 @@ Qed. Lemma make_xorimm_correct: forall n r, let (op, args) := make_xorimm n r in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v. Proof. intros; unfold make_xorimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. @@ -348,7 +373,7 @@ Lemma make_mulfimm_correct: forall n r1 r2, rs#r2 = Vfloat n -> let (op, args) := make_mulfimm n r1 r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v. Proof. intros; unfold make_mulfimm. destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. @@ -361,7 +386,7 @@ Lemma make_mulfimm_correct_2: forall n r1 r2, rs#r1 = Vfloat n -> let (op, args) := make_mulfimm n r2 r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v. Proof. intros; unfold make_mulfimm. destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. @@ -375,7 +400,7 @@ Lemma make_mulfsimm_correct: forall n r1 r2, rs#r2 = Vsingle n -> let (op, args) := make_mulfsimm n r1 r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulfs rs#r1 rs#r2) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulfs rs#r1 rs#r2) v. Proof. intros; unfold make_mulfsimm. destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. @@ -388,7 +413,7 @@ Lemma make_mulfsimm_correct_2: forall n r1 r2, rs#r1 = Vsingle n -> let (op, args) := make_mulfsimm n r2 r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulfs rs#r1 rs#r2) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulfs rs#r1 rs#r2) v. Proof. intros; unfold make_mulfsimm. destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. @@ -402,7 +427,7 @@ Lemma make_cast8signed_correct: forall r x, vmatch bc rs#r x -> let (op, args) := make_cast8signed r x in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.sign_ext 8 rs#r) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.sign_ext 8 rs#r) v. Proof. intros; unfold make_cast8signed. destruct (vincl x (Sgn Ptop 8)) eqn:INCL. exists rs#r; split; auto. @@ -416,7 +441,7 @@ Lemma make_cast16signed_correct: forall r x, vmatch bc rs#r x -> let (op, args) := make_cast16signed r x in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.sign_ext 16 rs#r) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.sign_ext 16 rs#r) v. Proof. intros; unfold make_cast16signed. destruct (vincl x (Sgn Ptop 16)) eqn:INCL. exists rs#r; split; auto. @@ -429,9 +454,9 @@ Qed. Lemma op_strength_reduction_correct: forall op args vl v, vl = map (fun r => AE.get r ae) args -> - eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v -> + eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v -> let (op', args') := op_strength_reduction op args vl in - exists w, eval_operation ge (Vptr sp Int.zero) op' rs##args' m = Some w /\ Val.lessdef v w. + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op' rs##args' m = Some w /\ Val.lessdef v w. Proof. intros until v; unfold op_strength_reduction; case (op_strength_reduction_match op args vl); simpl; intros. @@ -440,8 +465,7 @@ Proof. (* cast8signed *) InvApproxRegs; SimplVM; inv H0. apply make_cast16signed_correct; auto. (* add *) - InvApproxRegs; SimplVM. inv H0. - fold (Val.add (Vint n1) rs#r2). rewrite Val.add_commut. apply make_addimm_correct. + InvApproxRegs; SimplVM. rewrite Val.add_commut in H0. inv H0. apply make_addimm_correct. InvApproxRegs; SimplVM. inv H0. apply make_addimm_correct. (* addshift *) InvApproxRegs; SimplVM. inv H0. rewrite eval_static_shift_correct. apply make_addimm_correct. @@ -504,28 +528,30 @@ Qed. Lemma addr_strength_reduction_correct: forall addr args vl res, vl = map (fun r => AE.get r ae) args -> - eval_addressing ge (Vptr sp Int.zero) addr rs##args = Some res -> + eval_addressing ge (Vptr sp Ptrofs.zero) addr rs##args = Some res -> let (addr', args') := addr_strength_reduction addr args vl in - exists res', eval_addressing ge (Vptr sp Int.zero) addr' rs##args' = Some res' /\ Val.lessdef res res'. + exists res', eval_addressing ge (Vptr sp Ptrofs.zero) addr' rs##args' = Some res' /\ Val.lessdef res res'. Proof. intros until res. unfold addr_strength_reduction. destruct (addr_strength_reduction_match addr args vl); simpl; intros VL EA; InvApproxRegs; SimplVM; try (inv EA). -- rewrite Int.add_zero_l. - change (Vptr sp (Int.add n1 n2)) with (Val.add (Vptr sp n1) (Vint n2)). +- rewrite Ptrofs.add_zero_l. + change (Vptr sp (Ptrofs.add n1 (Ptrofs.of_int n2))) with (Val.add (Vptr sp n1) (Vint n2)). econstructor; split; eauto. apply Val.add_lessdef; auto. -- fold (Val.add (Vint n1) rs#r2). rewrite Int.add_zero_l. rewrite Int.add_commut. - change (Vptr sp (Int.add n2 n1)) with (Val.add (Vptr sp n2) (Vint n1)). - rewrite Val.add_commut. econstructor; split; eauto. apply Val.add_lessdef; auto. -- fold (Val.add (Vint n1) rs#r2). - rewrite Val.add_commut. econstructor; split; eauto. +- rewrite Ptrofs.add_zero_l. econstructor; split; eauto. rewrite Ptrofs.add_commut. + change (Val.lessdef (Val.add (Vint n1) rs#r2) (Val.add (Vptr sp n2) (Vint n1))). + rewrite Val.add_commut; apply Val.add_lessdef; auto. +- econstructor; split; eauto. + change (Val.lessdef (Val.add (Vint n1) rs#r2) (Val.add rs#r2 (Vint n1))). + rewrite Val.add_commut; apply Val.add_lessdef; auto. - econstructor; split; eauto. -- rewrite eval_static_shift_correct. rewrite Int.add_zero_l. - change (Vptr sp (Int.add n1 (eval_static_shift s n2))) +- rewrite eval_static_shift_correct. rewrite Ptrofs.add_zero_l. econstructor; split; eauto. + change (Vptr sp (Ptrofs.add n1 (Ptrofs.of_int (eval_static_shift s n2)))) with (Val.add (Vptr sp n1) (Vint (eval_static_shift s n2))). - econstructor; split; eauto. apply Val.add_lessdef; auto. + apply Val.add_lessdef; auto. - rewrite eval_static_shift_correct. econstructor; split; eauto. -- rewrite Int.add_zero_l. change (Vptr sp (Int.add n1 n)) with (Val.add (Vptr sp n1) (Vint n)). +- rewrite Ptrofs.add_zero_l. + change (Vptr sp (Ptrofs.add n1 (Ptrofs.of_int n))) with (Val.add (Vptr sp n1) (Vint n)). econstructor; split; eauto. apply Val.add_lessdef; auto. - exists res; auto. Qed. diff --git a/arm/Conventions1.v b/arm/Conventions1.v index 888861a5..ecf03e1d 100644 --- a/arm/Conventions1.v +++ b/arm/Conventions1.v @@ -60,6 +60,15 @@ Definition destroyed_at_call := Definition dummy_int_reg := R0. (**r Used in [Coloring]. *) Definition dummy_float_reg := F0. (**r Used in [Coloring]. *) +Definition is_float_reg (r: mreg): bool := + match r with + | R0 | R1 | R2 | R3 + | R4 | R5 | R6 | R7 + | R8 | R9 | R10 | R11 | R12 => false + | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 + | F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15 => true + end. + (** * Function calling conventions *) (** The functions in this section determine the locations (machine registers @@ -127,7 +136,7 @@ Lemma loc_result_pair: forall sg, match loc_result sg with | One _ => True - | Twolong r1 r2 => r1 <> r2 /\ sg.(sig_res) = Some Tlong /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true + | Twolong r1 r2 => r1 <> r2 /\ sg.(sig_res) = Some Tlong /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true /\ Archi.splitlong = true end. Proof. intros; unfold loc_result; destruct (sig_res sg) as [[]|]; destruct Archi.big_endian; auto. @@ -135,6 +144,14 @@ Proof. intuition congruence. Qed. +(** The location of the result depends only on the result part of the signature *) + +Lemma loc_result_exten: + forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2. +Proof. + intros. unfold loc_result. rewrite H; auto. +Qed. + (** ** Location of function arguments *) (** For the "hardfloat" configuration, we use the following calling conventions, diff --git a/arm/NeedOp.v b/arm/NeedOp.v index 41b80941..dee7cae1 100644 --- a/arm/NeedOp.v +++ b/arm/NeedOp.v @@ -145,11 +145,11 @@ Qed. Lemma needs_of_operation_sound: forall op args v nv args', - eval_operation ge (Vptr sp Int.zero) op args m = Some v -> + eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v -> vagree_list args args' (needs_of_operation op nv) -> nv <> Nothing -> exists v', - eval_operation ge (Vptr sp Int.zero) op args' m' = Some v' + eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v' /\ vagree v v' nv. Proof. unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail); @@ -188,7 +188,7 @@ Qed. Lemma operation_is_redundant_sound: forall op nv arg1 args v arg1' args', operation_is_redundant op nv = true -> - eval_operation ge (Vptr sp Int.zero) op (arg1 :: args) m = Some v -> + eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m = Some v -> vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) -> vagree v arg1' nv. Proof. @@ -35,6 +35,7 @@ Require Import Globalenvs. Require Import Events. Set Implicit Arguments. +Local Transparent Archi.ptr64. Record shift_amount: Type := { s_amount: int; @@ -74,8 +75,8 @@ Inductive operation : Type := | Ointconst: int -> operation (**r [rd] is set to the given integer constant *) | Ofloatconst: float -> operation (**r [rd] is set to the given 64-bit float constant *) | Osingleconst: float32 -> operation (**r [rd] is set to the given 32-bit 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 *) + | Oaddrsymbol: ident -> ptrofs -> operation (**r [rd] is set to the the address of the symbol plus the offset *) + | Oaddrstack: ptrofs -> 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] *) | Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *) @@ -148,7 +149,7 @@ Inductive addressing: Type := | 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] *) + | Ainstack: ptrofs -> addressing. (**r Address is [stack_pointer + offset] *) (** Comparison functions (used in module [CSE]). *) @@ -173,10 +174,8 @@ Defined. Definition eq_operation (x y: operation): {x=y} + {x<>y}. Proof. - generalize Int.eq_dec; intro. - generalize Float.eq_dec; intro. - generalize Float32.eq_dec; intro. - assert (forall (x y: ident), {x=y}+{x<>y}). exact peq. + generalize Int.eq_dec Ptrofs.eq_dec ident_eq; intros. + generalize Float.eq_dec Float32.eq_dec; intros. generalize eq_shift; intro. generalize eq_condition; intro. decide equality. @@ -184,7 +183,7 @@ Defined. Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. Proof. - generalize Int.eq_dec; intro. + generalize Int.eq_dec Ptrofs.eq_dec; intro. generalize eq_shift; intro. decide equality. Defined. @@ -235,7 +234,7 @@ Definition eval_operation | Ofloatconst n, nil => Some (Vfloat n) | Osingleconst n, nil => Some (Vsingle n) | Oaddrsymbol s ofs, nil => Some (Genv.symbol_address genv s ofs) - | Oaddrstack ofs, nil => Some (Val.add sp (Vint ofs)) + | Oaddrstack ofs, nil => Some (Val.offset_ptr sp ofs) | Ocast8signed, v1::nil => Some (Val.sign_ext 8 v1) | Ocast16signed, v1::nil => Some (Val.sign_ext 16 v1) | Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2) @@ -305,10 +304,24 @@ Definition eval_addressing | Aindexed n, v1 :: nil => Some (Val.add v1 (Vint n)) | Aindexed2, v1 :: v2 :: nil => Some (Val.add v1 v2) | Aindexed2shift s, v1 :: v2 :: nil => Some (Val.add v1 (eval_shift s v2)) - | Ainstack ofs, nil => Some (Val.add sp (Vint ofs)) + | Ainstack ofs, nil => Some (Val.offset_ptr sp ofs) | _, _ => None end. +Remark eval_addressing_Ainstack: + forall (F V: Type) (genv: Genv.t F V) sp ofs, + eval_addressing genv sp (Ainstack ofs) nil = Some (Val.offset_ptr sp ofs). +Proof. + intros. reflexivity. +Qed. + +Remark eval_addressing_Ainstack_inv: + forall (F V: Type) (genv: Genv.t F V) sp ofs vl v, + eval_addressing genv sp (Ainstack ofs) vl = Some v -> vl = nil /\ v = Val.offset_ptr sp ofs. +Proof. + unfold eval_addressing; intros; destruct vl; inv H; auto. +Qed. + Ltac FuncInv := match goal with | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => @@ -430,7 +443,7 @@ Lemma type_of_operation_sound: op <> Omove -> eval_operation genv sp op vl m = Some v -> Val.has_type v (snd (type_of_operation op)). -Proof with (try exact I). +Proof with (try exact I; try reflexivity). assert (S: forall s v, Val.has_type (eval_shift s v) Tint). intros. unfold eval_shift. destruct s; destruct v; simpl; auto; rewrite s_range; exact I. intros. @@ -588,15 +601,15 @@ Qed. (** Shifting stack-relative references. This is used in [Stacking]. *) -Definition shift_stack_addressing (delta: int) (addr: addressing) := +Definition shift_stack_addressing (delta: Z) (addr: addressing) := match addr with - | Ainstack ofs => Ainstack (Int.add delta ofs) + | Ainstack ofs => Ainstack (Ptrofs.add (Ptrofs.repr delta) ofs) | _ => addr end. -Definition shift_stack_operation (delta: int) (op: operation) := +Definition shift_stack_operation (delta: Z) (op: operation) := match op with - | Oaddrstack ofs => Oaddrstack (Int.add delta ofs) + | Oaddrstack ofs => Oaddrstack (Ptrofs.add (Ptrofs.repr delta) ofs) | _ => op end. @@ -614,79 +627,43 @@ Qed. Lemma eval_shift_stack_addressing: forall F V (ge: Genv.t F V) sp addr vl delta, - eval_addressing ge sp (shift_stack_addressing delta addr) vl = - eval_addressing ge (Val.add sp (Vint delta)) addr vl. + eval_addressing ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl = + eval_addressing ge (Vptr sp (Ptrofs.repr delta)) addr vl. Proof. intros. destruct addr; simpl; auto. - rewrite Val.add_assoc. simpl. auto. + rewrite Ptrofs.add_zero_l; auto. Qed. Lemma eval_shift_stack_operation: forall F V (ge: Genv.t F V) sp op vl m delta, - eval_operation ge sp (shift_stack_operation delta op) vl m = - eval_operation ge (Val.add sp (Vint delta)) op vl m. + eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m = + eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m. Proof. intros. destruct op; simpl; auto. - rewrite Val.add_assoc. simpl. auto. + rewrite Ptrofs.add_zero_l; auto. Qed. (** Offset an addressing mode [addr] by a quantity [delta], so that it designates the pointer [delta] bytes past the pointer designated by [addr]. May be undefined, in which case [None] is returned. *) -Definition offset_addressing (addr: addressing) (delta: int) : option addressing := +Definition offset_addressing (addr: addressing) (delta: Z) : option addressing := match addr with - | Aindexed n => Some(Aindexed (Int.add n delta)) + | Aindexed n => Some(Aindexed (Int.add n (Int.repr delta))) | Aindexed2 => None | Aindexed2shift s => None - | Ainstack n => Some(Ainstack (Int.add n delta)) + | Ainstack n => Some(Ainstack (Ptrofs.add n (Ptrofs.repr delta))) end. Lemma eval_offset_addressing: forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v, offset_addressing addr delta = Some addr' -> eval_addressing ge sp addr args = Some v -> - eval_addressing ge sp addr' args = Some(Val.add v (Vint delta)). + eval_addressing ge sp addr' args = Some(Val.add v (Vint (Int.repr delta))). Proof. intros. destruct addr; simpl in H; inv H; simpl in *; FuncInv; subst. rewrite Val.add_assoc; auto. - rewrite Val.add_assoc. auto. -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 V: Type) (ge: Genv.t F V) sp addr args v m, - (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. - 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. + destruct sp; simpl; auto. rewrite Ptrofs.add_assoc. do 4 f_equal. symmetry; auto with ptrofs. Qed. (** Two-address operations. There are none in the ARM architecture. *) @@ -781,30 +758,30 @@ Variable m2: mem. Hypothesis valid_pointer_inj: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Hypothesis weak_valid_pointer_inj: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Hypothesis weak_valid_pointer_no_overflow: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. Hypothesis valid_different_pointers_inj: forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, b1 <> b2 -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> f b1 = Some (b1', delta1) -> f b2 = Some (b2', delta2) -> b1' <> b2' \/ - Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)). + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). Ltac InvInject := match goal with @@ -871,20 +848,20 @@ Lemma eval_operation_inj: Proof. intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. apply GL; simpl; auto. - apply Values.Val.add_inject; auto. + apply Val.offset_ptr_inject; auto. inv H4; simpl; auto. inv H4; simpl; auto. - apply Values.Val.add_inject; auto. - apply Values.Val.add_inject; auto. apply eval_shift_inj; auto. - apply Values.Val.add_inject; auto. + apply Val.add_inject; auto. + apply Val.add_inject; auto. apply eval_shift_inj; auto. + apply Val.add_inject; auto. - apply Values.Val.sub_inject; auto. - apply Values.Val.sub_inject; auto. apply eval_shift_inj; auto. - apply Values.Val.sub_inject; auto. apply eval_shift_inj; auto. - apply (@Values.Val.sub_inject f (Vint i) (Vint i) v v'); auto. + apply Val.sub_inject; auto. + apply Val.sub_inject; auto. apply eval_shift_inj; auto. + apply Val.sub_inject; auto. apply eval_shift_inj; auto. + apply (@Val.sub_inject f (Vint i) (Vint i) v v'); auto. inv H4; inv H2; simpl; auto. - apply Values.Val.add_inject; auto. inv H4; inv H2; simpl; auto. + apply Val.add_inject; auto. inv H4; inv H2; simpl; auto. inv H4; inv H2; simpl; auto. inv H4; inv H2; simpl; auto. inv H4; inv H3; simpl in H1; inv H1. simpl. @@ -965,10 +942,10 @@ Lemma eval_addressing_inj: exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. Proof. intros. destruct addr; simpl in H2; simpl; FuncInv; InvInject; TrivialExists. - apply Values.Val.add_inject; auto. - apply Values.Val.add_inject; auto. - apply Values.Val.add_inject; auto. apply eval_shift_inj; auto. - apply Values.Val.add_inject; auto. + apply Val.add_inject; auto. + apply Val.add_inject; auto. + apply Val.add_inject; auto. apply eval_shift_inj; auto. + apply Val.offset_ptr_inject; auto. Qed. End EVAL_COMPAT. @@ -984,40 +961,40 @@ Remark valid_pointer_extends: forall m1 m2, Mem.extends m1 m2 -> forall b1 ofs b2 delta, Some(b1, 0) = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Proof. - intros. inv H0. rewrite Int.add_zero. eapply Mem.valid_pointer_extends; eauto. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.valid_pointer_extends; eauto. Qed. Remark weak_valid_pointer_extends: forall m1 m2, Mem.extends m1 m2 -> forall b1 ofs b2 delta, Some(b1, 0) = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Proof. - intros. inv H0. rewrite Int.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. Qed. Remark weak_valid_pointer_no_overflow_extends: forall m1 b1 ofs b2 delta, Some(b1, 0) = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. Proof. - intros. inv H. rewrite Zplus_0_r. apply Int.unsigned_range_2. + intros. inv H. rewrite Zplus_0_r. apply Ptrofs.unsigned_range_2. Qed. Remark valid_different_pointers_extends: forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, b1 <> b2 -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> Some(b1, 0) = Some (b1', delta1) -> Some(b2, 0) = Some (b2', delta2) -> b1' <> b2' \/ - Int.unsigned(Int.add ofs1 (Int.repr delta1)) <> Int.unsigned(Int.add ofs2 (Int.repr delta2)). + Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)). Proof. intros. inv H2; inv H3. auto. Qed. @@ -1096,7 +1073,7 @@ Remark symbol_address_inject: Proof. intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto. exploit (proj1 globals); eauto. intros. - econstructor; eauto. rewrite Int.add_zero; auto. + econstructor; eauto. rewrite Ptrofs.add_zero; auto. Qed. Lemma eval_condition_inject: @@ -1116,34 +1093,36 @@ Qed. Lemma eval_addressing_inject: forall addr vl1 vl2 v1, Val.inject_list f vl1 vl2 -> - eval_addressing genv (Vptr sp1 Int.zero) addr vl1 = Some v1 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 -> exists v2, - eval_addressing genv (Vptr sp2 Int.zero) (shift_stack_addressing (Int.repr delta) addr) vl2 = Some v2 + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = Some v2 /\ Val.inject f v1 v2. Proof. intros. - rewrite eval_shift_stack_addressing. simpl. - eapply eval_addressing_inj with (sp1 := Vptr sp1 Int.zero); eauto. - intros; apply symbol_address_inject. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. Qed. Lemma eval_operation_inject: forall op vl1 vl2 v1 m1 m2, Val.inject_list f vl1 vl2 -> Mem.inject f m1 m2 -> - eval_operation genv (Vptr sp1 Int.zero) op vl1 m1 = Some v1 -> + eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 -> exists v2, - eval_operation genv (Vptr sp2 Int.zero) (shift_stack_operation (Int.repr delta) op) vl2 m2 = Some v2 + eval_operation genv (Vptr sp2 Ptrofs.zero) (shift_stack_operation delta op) vl2 m2 = Some v2 /\ Val.inject f v1 v2. Proof. intros. rewrite eval_shift_stack_operation. simpl. - eapply eval_operation_inj with (sp1 := Vptr sp1 Int.zero) (m1 := m1); eauto. + eapply eval_operation_inj with (sp1 := Vptr sp1 Ptrofs.zero) (m1 := m1); eauto. intros; eapply Mem.valid_pointer_inject_val; eauto. intros; eapply Mem.weak_valid_pointer_inject_val; eauto. intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. intros; eapply Mem.different_pointers_inject; eauto. intros; apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. Qed. End EVAL_INJECT. diff --git a/arm/SelectLong.vp b/arm/SelectLong.vp new file mode 100644 index 00000000..cc7a38f6 --- /dev/null +++ b/arm/SelectLong.vp @@ -0,0 +1,21 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for 64-bit integer operations *) + +Require Import Coqlib. +Require Import Compopts. +Require Import AST Integers Floats. +Require Import Op CminorSel. +Require Import SelectOp SplitLong. + +(** This file is empty because we use the default implementation provided in [SplitLong]. *) diff --git a/arm/SelectLongproof.v b/arm/SelectLongproof.v new file mode 100644 index 00000000..a82c082c --- /dev/null +++ b/arm/SelectLongproof.v @@ -0,0 +1,22 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for 64-bit integer operations *) + +Require Import String Coqlib Maps Integers Floats Errors. +Require Archi. +Require Import AST Values Memory Globalenvs Events. +Require Import Cminor Op CminorSel. +Require Import SelectOp SelectOpproof SplitLong SplitLongproof. +Require Import SelectLong. + +(** This file is empty because we use the default implementation provided in [SplitLong]. *) diff --git a/arm/SelectOp.vp b/arm/SelectOp.vp index aec737ad..80a5d753 100644 --- a/arm/SelectOp.vp +++ b/arm/SelectOp.vp @@ -48,10 +48,10 @@ Open Local Scope cminorsel_scope. (** ** Constants **) -Definition addrsymbol (id: ident) (ofs: int) := +Definition addrsymbol (id: ident) (ofs: ptrofs) := Eop (Oaddrsymbol id ofs) Enil. -Definition addrstack (ofs: int) := +Definition addrstack (ofs: ptrofs) := Eop (Oaddrstack ofs) Enil. (** ** Integer logical negation *) @@ -72,8 +72,8 @@ Nondetfunction 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 (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil + | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) | _ => Eop (Oaddimm n) (e ::: Enil) end. @@ -501,6 +501,6 @@ Nondetfunction builtin_arg (e: expr) := | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs | Eload chunk (Aindexed ofs1) (Eop (Oaddrsymbol id ofs) Enil ::: Enil) => - BA_loadglobal chunk id (Int.add ofs ofs1) + BA_loadglobal chunk id (Ptrofs.add ofs (Ptrofs.of_int ofs1)) | _ => BA e end. diff --git a/arm/SelectOpproof.v b/arm/SelectOpproof.v index 297e1f64..e520b3cf 100644 --- a/arm/SelectOpproof.v +++ b/arm/SelectOpproof.v @@ -26,6 +26,7 @@ Require Import CminorSel. Require Import SelectOp. Open Local Scope cminorsel_scope. +Local Transparent Archi.ptr64. (** * Useful lemmas and tactics *) @@ -123,7 +124,7 @@ Qed. Theorem eval_addrstack: forall le ofs, - exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.add sp (Vint ofs)) v. + exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.offset_ptr sp ofs) v. Proof. intros. unfold addrstack. econstructor; split. EvalOp. simpl; eauto. @@ -147,11 +148,11 @@ Proof. red; unfold addimm; intros until x. predSpec Int.eq Int.eq_spec n Int.zero. subst n. intros. exists x; split; auto. - destruct x; simpl; auto. rewrite Int.add_zero. auto. rewrite Int.add_zero. auto. + destruct x; simpl; auto. rewrite Int.add_zero. auto. rewrite Ptrofs.add_zero. auto. case (addimm_match a); intros; InvEval; simpl; TrivialExists; simpl. rewrite Int.add_commut. auto. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. rewrite Int.add_commut; auto. - rewrite Val.add_assoc. rewrite Int.add_commut. auto. + unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. rewrite Ptrofs.add_commut; auto. + destruct sp; simpl; auto. rewrite Ptrofs.add_assoc. do 3 f_equal. apply Ptrofs.add_commut. subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. Qed. @@ -856,12 +857,12 @@ Proof. destruct (can_use_Aindexed2shift chunk); simpl. exists (v1 :: v0 :: nil); split. eauto with evalexpr. congruence. exists (Vptr b ofs :: nil); split. constructor. EvalOp. simpl. congruence. constructor. - simpl. rewrite Int.add_zero; auto. + simpl. rewrite Ptrofs.add_zero; auto. destruct (can_use_Aindexed2 chunk); simpl. exists (v1 :: v0 :: nil); split. eauto with evalexpr. congruence. exists (Vptr b ofs :: nil); split. constructor. EvalOp. simpl. congruence. constructor. - simpl. rewrite Int.add_zero; auto. - exists (v :: nil); split. eauto with evalexpr. subst. simpl. rewrite Int.add_zero; auto. + simpl. rewrite Ptrofs.add_zero; auto. + exists (v :: nil); split. eauto with evalexpr. subst. simpl. rewrite Ptrofs.add_zero; auto. Qed. Theorem eval_builtin_arg: @@ -876,7 +877,7 @@ Proof. - simpl in H5. inv H5. constructor. - subst v. constructor; auto. - inv H. InvEval. simpl in H6; inv H6. constructor; auto. -- inv H. InvEval. simpl in H6. rewrite <- Genv.shift_symbol_address in H6. +- inv H. InvEval. simpl in H6. rewrite <- Genv.shift_symbol_address_32 in H6 by auto. inv H6. constructor; auto. - constructor; auto. Qed. diff --git a/arm/ValueAOp.v b/arm/ValueAOp.v index 64a34329..e19ddd6d 100644 --- a/arm/ValueAOp.v +++ b/arm/ValueAOp.v @@ -183,18 +183,18 @@ Ltac InvHyps := Theorem eval_static_addressing_sound: forall addr vargs vres aargs, - eval_addressing ge (Vptr sp Int.zero) addr vargs = Some vres -> + eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> list_forall2 (vmatch bc) vargs aargs -> vmatch bc vres (eval_static_addressing addr aargs). Proof. unfold eval_addressing, eval_static_addressing; intros; destruct addr; InvHyps; eauto with va. - rewrite Int.add_zero_l; auto with va. + rewrite Ptrofs.add_zero_l; auto with va. Qed. Theorem eval_static_operation_sound: forall op vargs m vres aargs, - eval_operation ge (Vptr sp Int.zero) op vargs m = Some vres -> + eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> list_forall2 (vmatch bc) vargs aargs -> vmatch bc vres (eval_static_operation op aargs). Proof. @@ -202,7 +202,7 @@ Proof. destruct op; InvHyps; eauto with va. destruct (propagate_float_constants tt); constructor. destruct (propagate_float_constants tt); constructor. - rewrite Int.add_zero_l; eauto with va. + rewrite Ptrofs.add_zero_l; eauto with va. fold (Val.sub (Vint i) a1). auto with va. apply of_optbool_sound. eapply eval_static_condition_sound; eauto. Qed. diff --git a/backend/Allocation.v b/backend/Allocation.v index 0d25d84a..f561ef4e 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -39,7 +39,8 @@ Require Import Op Registers RTL Locations Conventions RTLtyping LTL. maching between an RTL instruction and an LTL basic block. *) -Definition moves := list (loc * loc)%type. +Definition move := (loc * loc)%type. +Definition moves := list move. Inductive block_shape: Type := | BSnop (mv: moves) (s: node) @@ -89,6 +90,25 @@ Inductive block_shape: Type := | BSreturn (arg: option reg) (mv: moves). +(** Classify operations into moves, 64-bit split integer operations, and other + arithmetic/logical operations. *) + +Inductive operation_kind {A: Type}: operation -> list A -> Type := + | operation_Omove: forall arg, operation_kind Omove (arg :: nil) + | operation_Omakelong: forall arg1 arg2, operation_kind Omakelong (arg1 :: arg2 :: nil) + | operation_Olowlong: forall arg, operation_kind Olowlong (arg :: nil) + | operation_Ohighlong: forall arg, operation_kind Ohighlong (arg :: nil) + | operation_other: forall op args, operation_kind op args. + +Definition classify_operation {A: Type} (op: operation) (args: list A) : operation_kind op args := + match op, args with + | Omove, arg::nil => operation_Omove arg + | Omakelong, arg1::arg2::nil => operation_Omakelong arg1 arg2 + | Olowlong, arg::nil => operation_Olowlong arg + | Ohighlong, arg::nil => operation_Ohighlong arg + | op, args => operation_other op args + end. + (** Extract the move instructions at the beginning of block [b]. Return the list of moves and the suffix of [b] after the moves. *) @@ -100,8 +120,10 @@ Fixpoint extract_moves (accu: moves) (b: bblock) {struct b} : moves * bblock := extract_moves ((R src, S sl ofs ty) :: accu) b' | Lop op args res :: b' => match is_move_operation op args with - | Some arg => extract_moves ((R arg, R res) :: accu) b' - | None => (List.rev accu, b) + | Some arg => + extract_moves ((R arg, R res) :: accu) b' + | None => + (List.rev accu, b) end | _ => (List.rev accu, b) @@ -123,29 +145,23 @@ Notation "'assertion' A ; B" := (if A then B else None) Local Open Scope option_monad_scope. -(** Classify operations into moves, 64-bit integer operations, and other - arithmetic/logical operations. *) - -Inductive operation_kind: operation -> list reg -> Type := - | operation_Omove: forall arg, operation_kind Omove (arg :: nil) - | operation_Omakelong: forall arg1 arg2, operation_kind Omakelong (arg1 :: arg2 :: nil) - | operation_Olowlong: forall arg, operation_kind Olowlong (arg :: nil) - | operation_Ohighlong: forall arg, operation_kind Ohighlong (arg :: nil) - | operation_other: forall op args, operation_kind op args. - -Definition classify_operation (op: operation) (args: list reg) : operation_kind op args := - match op, args with - | Omove, arg::nil => operation_Omove arg - | Omakelong, arg1::arg2::nil => operation_Omakelong arg1 arg2 - | Olowlong, arg::nil => operation_Olowlong arg - | Ohighlong, arg::nil => operation_Ohighlong arg - | op, args => operation_other op args - end. - (** Check RTL instruction [i] against LTL basic block [b]. On success, return [Some] with a [block_shape] describing the correspondence. On error, return [None]. *) +Definition pair_Iop_block (op: operation) (args: list reg) (res: reg) (s: node) (b: LTL.bblock) := + let (mv1, b1) := extract_moves nil b in + match b1 with + | Lop op' args' res' :: b2 => + let (mv2, b3) := extract_moves nil b2 in + assertion (eq_operation op op'); + assertion (check_succ s b3); + Some(BSop op args res mv1 args' res' mv2 s) + | _ => + assertion (check_succ s b1); + Some(BSopdead op args res mv1 s) + end. + Definition pair_instr_block (i: RTL.instruction) (b: LTL.bblock) : option block_shape := match i with @@ -158,32 +174,31 @@ Definition pair_instr_block let (mv, b1) := extract_moves nil b in assertion (check_succ s b1); Some(BSmove arg res mv s) | operation_Omakelong arg1 arg2 => - let (mv, b1) := extract_moves nil b in - assertion (check_succ s b1); Some(BSmakelong arg1 arg2 res mv s) + if Archi.splitlong then + (let (mv, b1) := extract_moves nil b in + assertion (check_succ s b1); Some(BSmakelong arg1 arg2 res mv s)) + else + pair_Iop_block op args res s b | operation_Olowlong arg => - let (mv, b1) := extract_moves nil b in - assertion (check_succ s b1); Some(BSlowlong arg res mv s) + if Archi.splitlong then + (let (mv, b1) := extract_moves nil b in + assertion (check_succ s b1); Some(BSlowlong arg res mv s)) + else + pair_Iop_block op args res s b | operation_Ohighlong arg => - let (mv, b1) := extract_moves nil b in - assertion (check_succ s b1); Some(BShighlong arg res mv s) + if Archi.splitlong then + (let (mv, b1) := extract_moves nil b in + assertion (check_succ s b1); Some(BShighlong arg res mv s)) + else + pair_Iop_block op args res s b | operation_other _ _ => - let (mv1, b1) := extract_moves nil b in - match b1 with - | Lop op' args' res' :: b2 => - let (mv2, b3) := extract_moves nil b2 in - assertion (eq_operation op op'); - assertion (check_succ s b3); - Some(BSop op args res mv1 args' res' mv2 s) - | _ => - assertion (check_succ s b1); - Some(BSopdead op args res mv1 s) - end + pair_Iop_block op args res s b end | Iload chunk addr args dst s => let (mv1, b1) := extract_moves nil b in match b1 with | Lload chunk' addr' args' dst' :: b2 => - if chunk_eq chunk Mint64 then + if chunk_eq chunk Mint64 && Archi.splitlong then assertion (chunk_eq chunk' Mint32); let (mv2, b3) := extract_moves nil b2 in match b3 with @@ -191,7 +206,7 @@ Definition pair_instr_block let (mv3, b5) := extract_moves nil b4 in assertion (chunk_eq chunk'' Mint32); assertion (eq_addressing addr addr'); - assertion (option_eq eq_addressing (offset_addressing addr (Int.repr 4)) (Some addr'')); + assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr'')); assertion (check_succ s b5); Some(BSload2 addr addr'' args dst mv1 args' dst' mv2 args'' dst'' mv3 s) | _ => @@ -199,7 +214,7 @@ Definition pair_instr_block if (eq_addressing addr addr') then Some(BSload2_1 addr args dst mv1 args' dst' mv2 s) else - (assertion (option_eq eq_addressing (offset_addressing addr (Int.repr 4)) (Some addr')); + (assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr')); Some(BSload2_2 addr addr' args dst mv1 args' dst' mv2 s)) end else ( @@ -216,14 +231,14 @@ Definition pair_instr_block let (mv1, b1) := extract_moves nil b in match b1 with | Lstore chunk' addr' args' src' :: b2 => - if chunk_eq chunk Mint64 then + if chunk_eq chunk Mint64 && Archi.splitlong then let (mv2, b3) := extract_moves nil b2 in match b3 with | Lstore chunk'' addr'' args'' src'' :: b4 => assertion (chunk_eq chunk' Mint32); assertion (chunk_eq chunk'' Mint32); assertion (eq_addressing addr addr'); - assertion (option_eq eq_addressing (offset_addressing addr (Int.repr 4)) (Some addr'')); + assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr'')); assertion (check_succ s b4); Some(BSstore2 addr addr'' args src mv1 args' src' mv2 args'' src'' s) | _ => None @@ -622,7 +637,9 @@ Function add_equations_args (rl: list reg) (tyl: list typ) (ll: list (rpair loc) | r1 :: rl, ty :: tyl, One l1 :: ll => add_equations_args rl tyl ll (add_equation (Eq Full r1 l1) e) | r1 :: rl, Tlong :: tyl, Twolong l1 l2 :: ll => - add_equations_args rl tyl ll (add_equation (Eq Low r1 l2) (add_equation (Eq High r1 l1) e)) + if Archi.splitlong then + add_equations_args rl tyl ll (add_equation (Eq Low r1 l2) (add_equation (Eq High r1 l1) e)) + else None | _, _, _ => None end. @@ -634,7 +651,9 @@ Function add_equations_res (r: reg) (oty: option typ) (p: rpair mreg) (e: eqs) : | One mr, _ => Some (add_equation (Eq Full r (R mr)) e) | Twolong mr1 mr2, Some Tlong => - Some (add_equation (Eq Low r (R mr2)) (add_equation (Eq High r (R mr1)) e)) + if Archi.splitlong then + Some (add_equation (Eq Low r (R mr2)) (add_equation (Eq High r (R mr1)) e)) + else None | _, _ => None end. @@ -673,6 +692,7 @@ Fixpoint add_equations_builtin_arg Some (add_equation (Eq Full r l) e) | BA r, BA_splitlong (BA lhi) (BA llo) => assertion (typ_eq (env r) Tlong); + assertion (Archi.splitlong); Some (add_equation (Eq Low r llo) (add_equation (Eq High r lhi) e)) | BA_int n, BA_int n' => assertion (Int.eq_dec n n'); Some e @@ -684,19 +704,19 @@ Fixpoint add_equations_builtin_arg assertion (Float32.eq_dec f f'); Some e | BA_loadstack chunk ofs, BA_loadstack chunk' ofs' => assertion (chunk_eq chunk chunk'); - assertion (Int.eq_dec ofs ofs'); + assertion (Ptrofs.eq_dec ofs ofs'); Some e | BA_addrstack ofs, BA_addrstack ofs' => - assertion (Int.eq_dec ofs ofs'); + assertion (Ptrofs.eq_dec ofs ofs'); Some e | BA_loadglobal chunk id ofs, BA_loadglobal chunk' id' ofs' => assertion (chunk_eq chunk chunk'); assertion (ident_eq id id'); - assertion (Int.eq_dec ofs ofs'); + assertion (Ptrofs.eq_dec ofs ofs'); Some e | BA_addrglobal id ofs, BA_addrglobal id' ofs' => assertion (ident_eq id id'); - assertion (Int.eq_dec ofs ofs'); + assertion (Ptrofs.eq_dec ofs ofs'); Some e | BA_splitlong hi lo, BA_splitlong hi' lo' => do e1 <- add_equations_builtin_arg env hi hi' e; diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 47dac12f..888945ec 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -32,8 +32,8 @@ Qed. (** * Soundness of structural checks *) -Definition expand_move (sd: loc * loc) : instruction := - match sd with +Definition expand_move (m: move) : instruction := + match m with | (R src, R dst) => Lop Omove (src::nil) dst | (S sl ofs ty, R dst) => Lgetstack sl ofs ty dst | (R src, S sl ofs ty) => Lsetstack src sl ofs ty @@ -43,14 +43,14 @@ Definition expand_move (sd: loc * loc) : instruction := Definition expand_moves (mv: moves) (k: bblock) : bblock := List.map expand_move mv ++ k. -Definition wf_move (sd: loc * loc) : Prop := - match sd with +Definition wf_move (m: move) : Prop := + match m with | (S _ _ _, S _ _ _) => False | _ => True end. Definition wf_moves (mv: moves) : Prop := - forall sd, In sd mv -> wf_move sd. + List.Forall wf_move mv. Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Prop := | ebs_nop: forall mv s k, @@ -64,17 +64,17 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr (Iop Omove (src :: nil) dst s) (expand_moves mv (Lbranch s :: k)) | ebs_makelong: forall src1 src2 dst mv s k, - wf_moves mv -> + wf_moves mv -> Archi.splitlong = true -> expand_block_shape (BSmakelong src1 src2 dst mv s) (Iop Omakelong (src1 :: src2 :: nil) dst s) (expand_moves mv (Lbranch s :: k)) | ebs_lowlong: forall src dst mv s k, - wf_moves mv -> + wf_moves mv -> Archi.splitlong = true -> expand_block_shape (BSlowlong src dst mv s) (Iop Olowlong (src :: nil) dst s) (expand_moves mv (Lbranch s :: k)) | ebs_highlong: forall src dst mv s k, - wf_moves mv -> + wf_moves mv -> Archi.splitlong = true -> expand_block_shape (BShighlong src dst mv s) (Iop Ohighlong (src :: nil) dst s) (expand_moves mv (Lbranch s :: k)) @@ -97,7 +97,7 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr (Lload chunk addr args' dst' :: expand_moves mv2 (Lbranch s :: k))) | ebs_load2: forall addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s k, wf_moves mv1 -> wf_moves mv2 -> wf_moves mv3 -> - offset_addressing addr (Int.repr 4) = Some addr2 -> + Archi.splitlong = true -> offset_addressing addr 4 = Some addr2 -> expand_block_shape (BSload2 addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s) (Iload Mint64 addr args dst s) (expand_moves mv1 @@ -107,6 +107,7 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr expand_moves mv3 (Lbranch s :: k)))) | ebs_load2_1: forall addr args dst mv1 args' dst' mv2 s k, wf_moves mv1 -> wf_moves mv2 -> + Archi.splitlong = true -> expand_block_shape (BSload2_1 addr args dst mv1 args' dst' mv2 s) (Iload Mint64 addr args dst s) (expand_moves mv1 @@ -114,7 +115,7 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr expand_moves mv2 (Lbranch s :: k))) | ebs_load2_2: forall addr addr2 args dst mv1 args' dst' mv2 s k, wf_moves mv1 -> wf_moves mv2 -> - offset_addressing addr (Int.repr 4) = Some addr2 -> + Archi.splitlong = true -> offset_addressing addr 4 = Some addr2 -> expand_block_shape (BSload2_2 addr addr2 args dst mv1 args' dst' mv2 s) (Iload Mint64 addr args dst s) (expand_moves mv1 @@ -133,7 +134,7 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr (Lstore chunk addr args' src' :: Lbranch s :: k)) | ebs_store2: forall addr addr2 args src mv1 args1' src1' mv2 args2' src2' s k, wf_moves mv1 -> wf_moves mv2 -> - offset_addressing addr (Int.repr 4) = Some addr2 -> + Archi.splitlong = true -> offset_addressing addr 4 = Some addr2 -> expand_block_shape (BSstore2 addr addr2 args src mv1 args1' src1' mv2 args2' src2' s) (Istore Mint64 addr args src s) (expand_moves mv1 @@ -196,6 +197,13 @@ Ltac MonadInv := idtac end. +Remark expand_moves_cons: + forall m accu b, + expand_moves (rev (m :: accu)) b = expand_moves (rev accu) (expand_move m :: b). +Proof. + unfold expand_moves; intros. simpl. rewrite map_app. rewrite app_ass. auto. +Qed. + Lemma extract_moves_sound: forall b mv b', extract_moves nil b = (mv, b') -> @@ -205,39 +213,27 @@ Proof. forall accu b, wf_moves accu -> wf_moves (List.rev accu) /\ expand_moves (List.rev accu) b = expand_moves (List.rev accu) b). - intros; split; auto. - red; intros. apply H. rewrite <- in_rev in H0; auto. + { intros; split; auto. unfold wf_moves in *; rewrite Forall_forall in *. + intros. apply H. rewrite <- in_rev in H0; auto. } assert (IND: forall b accu mv b', extract_moves accu b = (mv, b') -> wf_moves accu -> wf_moves mv /\ expand_moves (List.rev accu) b = expand_moves mv b'). - induction b; simpl; intros. - inv H. auto. - destruct a; try (inv H; apply BASE; auto; fail). - destruct (is_move_operation op args) as [arg|] eqn:E. + { induction b; simpl; intros. + - inv H. auto. + - destruct a; try (inv H; apply BASE; auto; fail). + + destruct (is_move_operation op args) as [arg|] eqn:E. exploit is_move_operation_correct; eauto. intros [A B]; subst. (* reg-reg move *) - exploit IHb; eauto. - red; intros. destruct H1; auto. subst sd; exact I. - intros [P Q]. - split; auto. rewrite <- Q. simpl. unfold expand_moves. rewrite map_app. - rewrite app_ass. simpl. auto. + exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. inv H; apply BASE; auto. - (* stack-reg move *) - exploit IHb; eauto. - red; intros. destruct H1; auto. subst sd; exact I. - intros [P Q]. - split; auto. rewrite <- Q. simpl. unfold expand_moves. rewrite map_app. - rewrite app_ass. simpl. auto. - (* reg-stack move *) - exploit IHb; eauto. - red; intros. destruct H1; auto. subst sd; exact I. - intros [P Q]. - split; auto. rewrite <- Q. simpl. unfold expand_moves. rewrite map_app. - rewrite app_ass. simpl. auto. - - intros. exploit IND; eauto. red; intros. elim H0. + + (* stack-reg move *) + exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. + + (* reg-stack move *) + exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. + } + intros. exploit IND; eauto. constructor. Qed. Lemma check_succ_sound: @@ -253,7 +249,7 @@ Ltac UseParsingLemmas := | [ H: extract_moves nil _ = (_, _) |- _ ] => destruct (extract_moves_sound _ _ _ H); clear H; subst; UseParsingLemmas | [ H: check_succ _ _ = true |- _ ] => - try discriminate; + try (discriminate H); destruct (check_succ_sound _ _ H); clear H; subst; UseParsingLemmas | _ => idtac end. @@ -262,59 +258,64 @@ Lemma pair_instr_block_sound: forall i b bsh, pair_instr_block i b = Some bsh -> expand_block_shape bsh i b. Proof. + assert (OP: forall op args res s b bsh, + pair_Iop_block op args res s b = Some bsh -> expand_block_shape bsh (Iop op args res s) b). + { + unfold pair_Iop_block; intros. MonadInv. destruct b0. + MonadInv; UseParsingLemmas. + destruct i; MonadInv; UseParsingLemmas. + eapply ebs_op; eauto. + inv H0. eapply ebs_op_dead; eauto. } + intros; destruct i; simpl in H; MonadInv; UseParsingLemmas. -(* nop *) +- (* nop *) econstructor; eauto. -(* op *) +- (* op *) destruct (classify_operation o l). - (* move *) ++ (* move *) MonadInv; UseParsingLemmas. econstructor; eauto. - (* makelong *) ++ (* makelong *) + destruct Archi.splitlong eqn:SL; eauto. MonadInv; UseParsingLemmas. econstructor; eauto. - (* lowlong *) ++ (* lowlong *) + destruct Archi.splitlong eqn:SL; eauto. MonadInv; UseParsingLemmas. econstructor; eauto. - (* highlong *) ++ (* highlong *) + destruct Archi.splitlong eqn:SL; eauto. MonadInv; UseParsingLemmas. econstructor; eauto. - (* other ops *) - MonadInv. destruct b0. - MonadInv; UseParsingLemmas. - destruct i; MonadInv; UseParsingLemmas. - eapply ebs_op; eauto. - inv H0. eapply ebs_op_dead; eauto. -(* load *) - destruct b0. - MonadInv; UseParsingLemmas. - destruct i; MonadInv; UseParsingLemmas. - destruct (chunk_eq m Mint64). - MonadInv; UseParsingLemmas. - destruct b; MonadInv; UseParsingLemmas. destruct i; MonadInv; UseParsingLemmas. - eapply ebs_load2; eauto. - destruct (eq_addressing a addr). - MonadInv. inv H2. eapply ebs_load2_1; eauto. - MonadInv. inv H2. eapply ebs_load2_2; eauto. - MonadInv; UseParsingLemmas. eapply ebs_load; eauto. ++ (* other ops *) + eauto. +- (* load *) + destruct b0 as [ | [] b0]; MonadInv; UseParsingLemmas. + destruct (chunk_eq m Mint64 && Archi.splitlong) eqn:A; MonadInv; UseParsingLemmas. + destruct b as [ | [] b]; MonadInv; UseParsingLemmas. + InvBooleans. subst m. eapply ebs_load2; eauto. + InvBooleans. subst m. + destruct (eq_addressing a addr). + inv H; inv H2. eapply ebs_load2_1; eauto. + destruct (option_eq eq_addressing (offset_addressing a 4) (Some addr)). + inv H; inv H2. eapply ebs_load2_2; eauto. + discriminate. + eapply ebs_load; eauto. inv H. eapply ebs_load_dead; eauto. -(* store *) +- (* store *) destruct b0; MonadInv. destruct i; MonadInv; UseParsingLemmas. - destruct (chunk_eq m Mint64). - MonadInv; UseParsingLemmas. - destruct b; MonadInv. destruct i; MonadInv; UseParsingLemmas. - eapply ebs_store2; eauto. - MonadInv; UseParsingLemmas. + destruct (chunk_eq m Mint64 && Archi.splitlong) eqn:A; MonadInv; UseParsingLemmas. + destruct b as [ | [] b]; MonadInv; UseParsingLemmas. + InvBooleans. subst m. eapply ebs_store2; eauto. eapply ebs_store; eauto. -(* call *) - destruct b0; MonadInv. destruct i; MonadInv; UseParsingLemmas. econstructor; eauto. -(* tailcall *) - destruct b0; MonadInv. destruct i; MonadInv; UseParsingLemmas. econstructor; eauto. -(* builtin *) - destruct b1; MonadInv. destruct i; MonadInv; UseParsingLemmas. - econstructor; eauto. -(* cond *) - destruct b0; MonadInv. destruct i; MonadInv; UseParsingLemmas. econstructor; eauto. -(* jumptable *) - destruct b0; MonadInv. destruct i; MonadInv; UseParsingLemmas. econstructor; eauto. -(* return *) - destruct b0; MonadInv. destruct i; MonadInv; UseParsingLemmas. econstructor; eauto. +- (* call *) + destruct b0 as [|[] ]; MonadInv; UseParsingLemmas. econstructor; eauto. +- (* tailcall *) + destruct b0 as [|[] ]; MonadInv; UseParsingLemmas. econstructor; eauto. +- (* builtin *) + destruct b1 as [|[] ]; MonadInv; UseParsingLemmas. econstructor; eauto. +- (* cond *) + destruct b0 as [|[]]; MonadInv; UseParsingLemmas. econstructor; eauto. +- (* jumptable *) + destruct b0 as [|[]]; MonadInv; UseParsingLemmas. econstructor; eauto. +- (* return *) + destruct b0 as [|[]]; MonadInv; UseParsingLemmas. econstructor; eauto. Qed. Lemma matching_instr_block: @@ -419,16 +420,18 @@ Proof. - eapply add_equation_satisf; eauto. - eapply add_equation_satisf. eapply add_equation_satisf. eauto. - congruence. +- congruence. Qed. Lemma val_longofwords_eq: forall v, - Val.has_type v Tlong -> + Val.has_type v Tlong -> Archi.splitlong = true -> Val.longofwords (Val.hiword v) (Val.loword v) = v. Proof. intros. red in H. destruct v; try contradiction. - reflexivity. - simpl. rewrite Int64.ofwords_recompose. auto. +- reflexivity. +- simpl. rewrite Int64.ofwords_recompose. auto. +- rewrite Archi.splitlong_ptr32 in H by auto. congruence. Qed. Lemma add_equations_args_lessdef: @@ -443,12 +446,13 @@ Proof. - destruct H1. constructor; auto. eapply add_equation_lessdef with (q := Eq Full r1 l1). eapply add_equations_args_satisf; eauto. - destruct H1. constructor; auto. - rewrite <- (val_longofwords_eq (rs#r1)); auto. apply Val.longofwords_lessdef. + rewrite <- (val_longofwords_eq (rs#r1)) by auto. apply Val.longofwords_lessdef. eapply add_equation_lessdef with (q := Eq High r1 l1). eapply add_equation_satisf. eapply add_equations_args_satisf; eauto. eapply add_equation_lessdef with (q := Eq Low r1 l2). eapply add_equations_args_satisf; eauto. - discriminate. +- discriminate. Qed. Lemma add_equation_ros_satisf: @@ -694,6 +698,14 @@ Proof. eapply reg_unconstrained_sound; eauto. Qed. +Remark in_elements_between_1: + forall r1 s q, + EqSet.In q (EqSet.elements_between (select_reg_l r1) (select_reg_h r1) s) <-> EqSet.In q s /\ ereg q = r1. +Proof. + intros. rewrite EqSet.elements_between_iff, select_reg_charact. tauto. + exact (select_reg_l_monotone r1). exact (select_reg_h_monotone r1). +Qed. + Lemma in_subst_reg: forall r1 r2 q (e: eqs), EqSet.In q e -> @@ -702,14 +714,9 @@ Lemma in_subst_reg: Proof. intros r1 r2 q e0 IN0. unfold subst_reg. set (f := fun (q: EqSet.elt) e => add_equation (Eq (ekind q) r2 (eloc q)) (remove_equation q e)). + generalize (in_elements_between_1 r1 e0). set (elt := EqSet.elements_between (select_reg_l r1) (select_reg_h r1) e0). - assert (IN_ELT: forall q, EqSet.In q elt <-> EqSet.In q e0 /\ ereg q = r1). - { - intros. unfold elt. rewrite EqSet.elements_between_iff. - rewrite select_reg_charact. tauto. - exact (select_reg_l_monotone r1). - exact (select_reg_h_monotone r1). - } + intros IN_ELT. set (P := fun e1 e2 => EqSet.In q e1 -> EqSet.In (Eq (ekind q) r2 (eloc q)) e2). @@ -730,9 +737,7 @@ Proof. { apply ESP.fold_rec; unfold Q; intros. - auto. - - simpl. red in H2. rewrite H2 in H4. - rewrite ESF.add_iff. rewrite ESF.remove_iff. - right. split. apply H3. tauto. tauto. + - simpl. red in H2. rewrite H2 in H4. ESD.fsetdec. } destruct (ESP.In_dec q elt). left. split. apply IN_ELT. auto. apply H. auto. @@ -761,14 +766,9 @@ Proof. if IndexedEqKind.eq (ekind q) k1 then add_equation (Eq k2 r2 (eloc q)) (remove_equation q e) else e). + generalize (in_elements_between_1 r1 e0). set (elt := EqSet.elements_between (select_reg_l r1) (select_reg_h r1) e0). - assert (IN_ELT: forall q, EqSet.In q elt <-> EqSet.In q e0 /\ ereg q = r1). - { - intros. unfold elt. rewrite EqSet.elements_between_iff. - rewrite select_reg_charact. tauto. - exact (select_reg_l_monotone r1). - exact (select_reg_h_monotone r1). - } + intros IN_ELT. set (P := fun e1 e2 => EqSet.In q e1 -> ekind q = k1 -> EqSet.In (Eq k2 r2 (eloc q)) e2). @@ -796,7 +796,7 @@ Proof. destruct (IndexedEqKind.eq (ekind x) k1). simpl. rewrite ESF.add_iff. rewrite ESF.remove_iff. right. split. apply H3. tauto. intuition congruence. - apply H3. intuition. + apply H3. intuition auto. } destruct (ESP.In_dec q elt). destruct (IndexedEqKind.eq (ekind q) k1). @@ -863,68 +863,65 @@ Module ESF2 := FSetFacts.Facts(EqSet2). Module ESP2 := FSetProperties.Properties(EqSet2). Module ESD2 := FSetDecide.Decide(EqSet2). +Lemma partial_fold_ind: + forall (A: Type) (P: EqSet2.t -> A -> Prop) f init final s, + EqSet2.fold + (fun q opte => + match opte with + | None => None + | Some e => f q e + end) + s (Some init) = Some final -> + (forall s', EqSet2.Empty s' -> P s' init) -> + (forall x a' a'' s' s'', + EqSet2.In x s -> ~EqSet2.In x s' -> ESP2.Add x s' s'' -> + f x a' = Some a'' -> P s' a' -> P s'' a'') -> + P s final. +Proof. + intros. + set (g := fun q opte => match opte with Some e => f q e | None => None end) in *. + set (Q := fun s1 opte => match opte with None => True | Some e => P s1 e end). + change (Q s (Some final)). + rewrite <- H. apply ESP2.fold_rec; unfold Q, g; intros. + - auto. + - destruct a as [e|]; auto. destruct (f x e) as [e'|] eqn:F; auto. eapply H1; eauto. +Qed. + Lemma in_subst_loc: forall l1 l2 q (e e': eqs), EqSet.In q e -> subst_loc l1 l2 e = Some e' -> (eloc q = l1 /\ EqSet.In (Eq (ekind q) (ereg q) l2) e') \/ (Loc.diff l1 (eloc q) /\ EqSet.In q e'). Proof. - intros l1 l2 q e0 e0'. - unfold subst_loc. - set (f := fun (q0 : EqSet2.elt) (opte : option eqs) => - match opte with - | Some e => - if Loc.eq l1 (eloc q0) - then - Some - (add_equation {| ekind := ekind q0; ereg := ereg q0; eloc := l2 |} - (remove_equation q0 e)) - else None - | None => None - end). - set (elt := EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e0)). - intros IN SUBST. - set (P := fun e1 (opte: option eqs) => - match opte with - | None => True - | Some e2 => - EqSet2.In q e1 -> - eloc q = l1 /\ EqSet.In (Eq (ekind q) (ereg q) l2) e2 - end). - assert (P elt (EqSet2.fold f elt (Some e0))). - { - apply ESP2.fold_rec; unfold P; intros. - - ESD2.fsetdec. - - destruct a as [e2|]; simpl; auto. - destruct (Loc.eq l1 (eloc x)); auto. - unfold add_equation, remove_equation; simpl. - red in H1. rewrite H1. intros [A|A]. - + subst x. split. auto. ESD.fsetdec. - + exploit H2; eauto. intros [B C]. split. auto. - rewrite ESF.add_iff. rewrite ESF.remove_iff. - destruct (OrderedEquation.eq_dec x {| ekind := ekind q; ereg := ereg q; eloc := l2 |}). - left. rewrite e1; auto. - right; auto. - } - set (Q := fun e1 (opte: option eqs) => - match opte with - | None => True - | Some e2 => ~EqSet2.In q e1 -> EqSet.In q e2 - end). - assert (Q elt (EqSet2.fold f elt (Some e0))). - { - apply ESP2.fold_rec; unfold Q; intros. - - auto. - - destruct a as [e2|]; simpl; auto. - destruct (Loc.eq l1 (eloc x)); auto. - red in H2. rewrite H2; intros. - unfold add_equation, remove_equation; simpl. - rewrite ESF.add_iff. rewrite ESF.remove_iff. - right; split. apply H3. tauto. tauto. + unfold subst_loc; intros l1 l2 q e0 e0' IN SUBST. + set (elt := EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e0)) in *. + set (f := fun q0 e => + if Loc.eq l1 (eloc q0) then + Some (add_equation + {| ekind := ekind q0; ereg := ereg q0; eloc := l2 |} + (remove_equation q0 e)) + else None). + set (P := fun e1 e2 => EqSet2.In q e1 -> eloc q = l1 /\ EqSet.In (Eq (ekind q) (ereg q) l2) e2). + assert (A: P elt e0'). + { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. + - unfold P; intros. ESD2.fsetdec. + - unfold P, f; intros. destruct (Loc.eq l1 (eloc x)); inversion H2; subst a''; clear H2. + simpl. rewrite ESF.add_iff, ESF.remove_iff. + apply H1 in H4; destruct H4. + subst x; rewrite e; auto. + apply H3 in H2; destruct H2. split. congruence. + destruct (OrderedEquation.eq_dec x {| ekind := ekind q; ereg := ereg q; eloc := l2 |}); auto. + subst x; auto. } - rewrite SUBST in H; rewrite SUBST in H0; simpl in *. + set (Q := fun e1 e2 => ~EqSet2.In q e1 -> EqSet.In q e2). + assert (B: Q elt e0'). + { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. + - unfold Q; intros. auto. + - unfold Q, f; intros. destruct (Loc.eq l1 (eloc x)); inversion H2; subst a''; clear H2. + simpl. rewrite ESF.add_iff, ESF.remove_iff. + red in H1. rewrite H1 in H4. intuition auto. } destruct (ESP2.In_dec q elt). - left. apply H; auto. + left. apply A; auto. right. split; auto. rewrite <- select_loc_charact. destruct (select_loc_l l1 q) eqn: LL; auto. @@ -1287,14 +1284,15 @@ Qed. Lemma loadv_int64_split: forall m a v, - Mem.loadv Mint64 m a = Some v -> + Mem.loadv Mint64 m a = Some v -> Archi.splitlong = true -> exists v1 v2, Mem.loadv Mint32 m a = Some (if Archi.big_endian then v1 else v2) - /\ Mem.loadv Mint32 m (Val.add a (Vint (Int.repr 4))) = Some (if Archi.big_endian then v2 else v1) + /\ Mem.loadv Mint32 m (Val.add a (Vint (Int.repr 4))) = Some (if Archi.big_endian then v2 else v1) /\ Val.lessdef (Val.hiword v) v1 /\ Val.lessdef (Val.loword v) v2. Proof. - intros. exploit Mem.loadv_int64_split; eauto. intros (v1 & v2 & A & B & C). + intros. apply Archi.splitlong_ptr32 in H0. + exploit Mem.loadv_int64_split; eauto. intros (v1 & v2 & A & B & C). exists v1, v2. split; auto. split; auto. inv C; auto. destruct v1, v2; simpl; auto. rewrite Int64.hi_ofwords, Int64.lo_ofwords; auto. @@ -1328,6 +1326,7 @@ Proof. exists (Val.longofwords (ls x0) (ls x1)); split; auto with barg. rewrite <- (val_longofwords_eq rs#x). apply Val.longofwords_lessdef; auto. rewrite <- e0; apply WT. + assumption. - econstructor; eauto with barg. - econstructor; eauto with barg. - econstructor; eauto with barg. @@ -1639,24 +1638,23 @@ Opaque destroyed_by_op. (* base *) - unfold expand_moves; simpl. inv H. exists ls; split. apply star_refl. auto. (* step *) -- destruct a as [src dst]. unfold expand_moves. simpl. - destruct (track_moves env mv e) as [e1|] eqn:?; MonadInv. - assert (wf_moves mv). red; intros. apply H0; auto with coqlib. +- assert (wf_moves mv) by (inv H0; auto). + destruct a as (src, dst); unfold expand_moves; simpl; MonadInv. destruct src as [rsrc | ssrc]; destruct dst as [rdst | sdst]. - (* reg-reg *) -+ exploit IHmv; eauto. eapply subst_loc_undef_satisf; eauto. +* (* reg-reg *) + exploit IHmv; eauto. eapply subst_loc_undef_satisf; eauto. intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. econstructor. simpl. eauto. auto. auto. - (* reg->stack *) -+ exploit IHmv; eauto. eapply subst_loc_undef_satisf; eauto. +* (* reg->stack *) + exploit IHmv; eauto. eapply subst_loc_undef_satisf; eauto. intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. econstructor. simpl. eauto. auto. - (* stack->reg *) -+ simpl in Heqb. exploit IHmv; eauto. eapply subst_loc_undef_satisf; eauto. +* (* stack->reg *) + simpl in Heqb. exploit IHmv; eauto. eapply subst_loc_undef_satisf; eauto. intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. econstructor. auto. auto. - (* stack->stack *) -+ exploit H0; auto with coqlib. unfold wf_move. tauto. +* (* stack->stack *) + inv H0. simpl in H6. contradiction. Qed. (** The simulation relation *) @@ -1730,7 +1728,7 @@ Proof. constructor. congruence. econstructor; eauto. unfold proj_sig_res in *. rewrite H0; auto. - intros. unfold loc_result in H; rewrite H0 in H; eauto. + intros. rewrite (loc_result_exten sg' sg) in H by auto. eauto. Qed. Ltac UseShape := @@ -1742,22 +1740,17 @@ Ltac UseShape := Remark addressing_not_long: forall env f addr args dst s r, - wt_instr f env (Iload Mint64 addr args dst s) -> + wt_instr f env (Iload Mint64 addr args dst s) -> Archi.splitlong = true -> In r args -> r <> dst. Proof. - intros. - assert (forall ty, In ty (type_of_addressing addr) -> ty = Tint). - { intros. destruct addr; simpl in H1; intuition. } - inv H. - assert (env r = Tint). - { generalize args (type_of_addressing addr) H0 H1 H5. - induction args0; simpl; intros. - contradiction. - destruct l. discriminate. inv H4. - destruct H2. subst a. apply H3; auto with coqlib. - eauto with coqlib. - } - red; intros; subst r. rewrite H in H8; discriminate. + intros. inv H. + assert (A: forall ty, In ty (type_of_addressing addr) -> ty = Tptr). + { intros. destruct addr; simpl in H; intuition. } + assert (B: In (env r) (type_of_addressing addr)). + { rewrite <- H5. apply in_map; auto. } + assert (C: env r = Tint). + { apply A in B. rewrite B. unfold Tptr. rewrite Archi.splitlong_ptr32 by auto. auto. } + red; intros; subst r. rewrite C in H8; discriminate. Qed. (** The proof of semantic preservation is a simulation argument of the @@ -1771,7 +1764,7 @@ Proof. induction 1; intros WT S1' MS; inv MS; try UseShape. (* nop *) - exploit exec_moves; eauto. intros [ls1 [X Y]]. +- exploit exec_moves; eauto. intros [ls1 [X Y]]. econstructor; split. eapply plus_left. econstructor; eauto. eapply star_right. eexact X. econstructor; eauto. @@ -1901,8 +1894,11 @@ Proof. eapply addressing_not_long; eauto. } exploit eval_addressing_lessdef. eexact LD3. - eapply eval_offset_addressing; eauto. intros [a2' [F2 G2]]. - exploit Mem.loadv_extends. eauto. eexact LOAD2. eexact G2. intros (v2'' & LOAD2' & LD4). + eapply eval_offset_addressing; eauto; apply Archi.splitlong_ptr32; auto. + intros [a2' [F2 G2]]. + assert (LOADX: exists v2'', Mem.loadv Mint32 m' a2' = Some v2'' /\ Val.lessdef v2' v2''). + { discriminate || (eapply Mem.loadv_extends; [eauto|eexact LOAD2|eexact G2]). } + destruct LOADX as (v2'' & LOAD2' & LD4). set (ls4 := Locmap.set (R dst2') v2'' (undef_regs (destroyed_by_load Mint32 addr2) ls3)). assert (SAT4: satisf (rs#dst <- v) ls4 e0). { eapply loc_unconstrained_satisf. eapply can_undef_satisf; eauto. @@ -1966,8 +1962,11 @@ Proof. assert (LD1: Val.lessdef_list rs##args (reglist ls1 args')). { eapply add_equations_lessdef; eauto. } exploit eval_addressing_lessdef. eexact LD1. - eapply eval_offset_addressing; eauto. intros [a1' [F1 G1]]. - exploit Mem.loadv_extends. eauto. eexact LOAD2. eexact G1. intros (v2'' & LOAD2' & LD2). + eapply eval_offset_addressing; eauto; apply Archi.splitlong_ptr32; auto. + intros [a1' [F1 G1]]. + assert (LOADX: exists v2'', Mem.loadv Mint32 m' a1' = Some v2'' /\ Val.lessdef v2' v2''). + { discriminate || (eapply Mem.loadv_extends; [eauto|eexact LOAD2|eexact G1]). } + destruct LOADX as (v2'' & LOAD2' & LD2). set (ls2 := Locmap.set (R dst') v2'' (undef_regs (destroyed_by_load Mint32 addr2) ls1)). assert (SAT2: satisf (rs#dst <- v) ls2 e0). { eapply parallel_assignment_satisf; eauto. @@ -2015,7 +2014,8 @@ Proof. econstructor; eauto. (* store 2 *) -- exploit Mem.storev_int64_split; eauto. +- assert (SF: Archi.ptr64 = false) by (apply Archi.splitlong_ptr32; auto). + exploit Mem.storev_int64_split; eauto. replace (if Archi.big_endian then Val.hiword rs#src else Val.loword rs#src) with (sel_val kind_first_word rs#src) by (unfold kind_first_word; destruct Archi.big_endian; reflexivity). @@ -2043,10 +2043,12 @@ Proof. exploit eval_addressing_lessdef. eexact LD3. eauto. intros [a2' [F2 G2]]. assert (F2': eval_addressing tge sp addr (reglist ls3 args2') = Some a2'). rewrite <- F2. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_offset_addressing. eauto. eexact F2'. intros F2''. - exploit Mem.storev_extends. eexact EXT1. eexact STORE2. - apply Val.add_lessdef. eexact G2. eauto. eauto. - intros [m2' [STORE2' EXT2]]. + exploit (eval_offset_addressing tge); eauto. intros F2''. + assert (STOREX: exists m2', Mem.storev Mint32 m1' (Val.add a2' (Vint (Int.repr 4))) (ls3 (R src2')) = Some m2' /\ Mem.extends m' m2'). + { try discriminate; + (eapply Mem.storev_extends; + [eexact EXT1 | eexact STORE2 | apply Val.add_lessdef; [eexact G2|eauto] | eauto]). } + destruct STOREX as [m2' [STORE2' EXT2]]. econstructor; split. eapply plus_left. econstructor; eauto. eapply star_trans. eexact X. @@ -2054,7 +2056,7 @@ Proof. econstructor. eexact F1'. eexact STORE1'. instantiate (1 := ls2). auto. eapply star_trans. eexact U. eapply star_two. - econstructor. eexact F2''. eexact STORE2'. eauto. + eapply exec_Lstore with (m' := m2'). eexact F2''. discriminate||exact STORE2'. eauto. constructor. eauto. eauto. eauto. eauto. traceEq. exploit satisf_successors; eauto. simpl; eauto. eapply can_undef_satisf. eauto. @@ -2229,7 +2231,7 @@ Proof. econstructor; eauto. simpl. destruct (loc_result (ef_sig ef)) eqn:RES; simpl. rewrite Locmap.gss; auto. - generalize (loc_result_pair (ef_sig ef)); rewrite RES; intros (A & B & C & D). + generalize (loc_result_pair (ef_sig ef)); rewrite RES; intros (A & B & C & D & E). exploit external_call_well_typed; eauto. unfold proj_sig_res; rewrite B. intros WTRES'. rewrite Locmap.gss. rewrite Locmap.gso by (red; auto). rewrite Locmap.gss. rewrite val_longofwords_eq by auto. auto. @@ -2275,8 +2277,8 @@ Lemma final_states_simulation: match_states st1 st2 -> RTL.final_state st1 r -> LTL.final_state st2 r. Proof. intros. inv H0. inv H. inv STACKS. - econstructor. - unfold loc_result in RES; rewrite H in RES. simpl in RES. inv RES. auto. + econstructor. rewrite <- (loc_result_exten sg). inv RES; auto. + rewrite H; auto. Qed. Lemma wt_prog: wt_program prog. diff --git a/backend/Asmgenproof0.v b/backend/Asmgenproof0.v index 30d6990e..2c7994e9 100644 --- a/backend/Asmgenproof0.v +++ b/backend/Asmgenproof0.v @@ -81,7 +81,7 @@ Qed. Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. Lemma nextinstr_pc: - forall rs, (nextinstr rs)#PC = Val.add rs#PC Vone. + forall rs, (nextinstr rs)#PC = Val.offset_ptr rs#PC Ptrofs.one. Proof. intros. apply Pregmap.gss. Qed. @@ -100,7 +100,7 @@ Qed. Lemma nextinstr_set_preg: forall rs m v, - (nextinstr (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone. + (nextinstr (rs#(preg_of m) <- v))#PC = Val.offset_ptr rs#PC Ptrofs.one. Proof. intros. unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_PC. @@ -491,13 +491,12 @@ Qed. Lemma code_tail_next_int: forall fn ofs i c, - list_length_z fn <= Int.max_unsigned -> - code_tail (Int.unsigned ofs) fn (i :: c) -> - code_tail (Int.unsigned (Int.add ofs Int.one)) fn c. + list_length_z fn <= Ptrofs.max_unsigned -> + code_tail (Ptrofs.unsigned ofs) fn (i :: c) -> + code_tail (Ptrofs.unsigned (Ptrofs.add ofs Ptrofs.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. + intros. rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_one. + rewrite Ptrofs.unsigned_repr. apply code_tail_next with i; auto. generalize (code_tail_bounds_2 _ _ _ _ H0). omega. Qed. @@ -513,7 +512,7 @@ Inductive transl_code_at_pc (ge: Mach.genv): Genv.find_funct_ptr ge b = Some(Internal f) -> transf_function f = Errors.OK tf -> transl_code f c ep = OK tc -> - code_tail (Int.unsigned ofs) (fn_code tf) tc -> + code_tail (Ptrofs.unsigned ofs) (fn_code tf) tc -> transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. (** Equivalence between [transl_code] and [transl_code']. *) @@ -563,11 +562,11 @@ Qed. >> *) -Definition return_address_offset (f: Mach.function) (c: Mach.code) (ofs: int) : Prop := +Definition return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := forall tf tc, transf_function f = OK tf -> transl_code f c false = OK tc -> - code_tail (Int.unsigned ofs) (fn_code tf) tc. + code_tail (Ptrofs.unsigned ofs) (fn_code tf) tc. (** 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 @@ -590,7 +589,7 @@ Hypothesis transf_function_inv: forall f tf, transf_function f = OK tf -> exists tc, exists ep, transl_code f (Mach.fn_code f) ep = OK tc /\ is_tail tc (fn_code tf). Hypothesis transf_function_len: - forall f tf, transf_function f = OK tf -> list_length_z (fn_code tf) <= Int.max_unsigned. + forall f tf, transf_function f = OK tf -> list_length_z (fn_code tf) <= Ptrofs.max_unsigned. Lemma transl_code_tail: forall f c1 c2, is_tail c1 c2 -> @@ -618,11 +617,11 @@ Opaque transl_instr. apply is_tail_trans with tc2; auto. eapply transl_instr_tail; eauto. } exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. - exists (Int.repr ofs). red; intros. - rewrite Int.unsigned_repr. congruence. + exists (Ptrofs.repr ofs). red; intros. + rewrite Ptrofs.unsigned_repr. congruence. exploit code_tail_bounds_1; eauto. apply transf_function_len in TF. omega. -+ exists Int.zero; red; intros. congruence. ++ exists Ptrofs.zero; red; intros. congruence. Qed. End RETADDR_EXISTS. @@ -651,8 +650,8 @@ Lemma return_address_offset_correct: Proof. intros. inv H. red in H0. exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. - rewrite <- (Int.repr_unsigned ofs). - rewrite <- (Int.repr_unsigned ofs'). + rewrite <- (Ptrofs.repr_unsigned ofs). + rewrite <- (Ptrofs.repr_unsigned ofs'). congruence. Qed. @@ -758,12 +757,12 @@ Inductive exec_straight: code -> regset -> mem -> | exec_straight_one: forall i1 c rs1 m1 rs2 m2, exec_instr ge fn i1 rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.add rs1#PC Vone -> + rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> 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 = Next rs2 m2 -> - rs2#PC = Val.add rs1#PC Vone -> + rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> exec_straight c rs2 m2 c' rs3 m3 -> exec_straight (i :: c) rs1 m1 c' rs3 m3. @@ -782,8 +781,8 @@ Lemma exec_straight_two: forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, exec_instr ge fn i1 rs1 m1 = Next rs2 m2 -> exec_instr ge fn i2 rs2 m2 = Next rs3 m3 -> - rs2#PC = Val.add rs1#PC Vone -> - rs3#PC = Val.add rs2#PC Vone -> + rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> + rs3#PC = Val.offset_ptr rs2#PC Ptrofs.one -> exec_straight (i1 :: i2 :: c) rs1 m1 c rs3 m3. Proof. intros. apply exec_straight_step with rs2 m2; auto. @@ -795,9 +794,9 @@ Lemma exec_straight_three: exec_instr ge fn i1 rs1 m1 = Next rs2 m2 -> exec_instr ge fn i2 rs2 m2 = Next rs3 m3 -> exec_instr ge fn i3 rs3 m3 = Next rs4 m4 -> - rs2#PC = Val.add rs1#PC Vone -> - rs3#PC = Val.add rs2#PC Vone -> - rs4#PC = Val.add rs3#PC Vone -> + rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> + rs3#PC = Val.offset_ptr rs2#PC Ptrofs.one -> + rs4#PC = Val.offset_ptr rs3#PC Ptrofs.one -> exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4. Proof. intros. apply exec_straight_step with rs2 m2; auto. @@ -810,11 +809,11 @@ Qed. Lemma exec_straight_steps_1: forall c rs m c' rs' m', exec_straight c rs m c' rs' m' -> - list_length_z (fn_code fn) <= Int.max_unsigned -> + list_length_z (fn_code fn) <= Ptrofs.max_unsigned -> forall b ofs, rs#PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Int.unsigned ofs) (fn_code fn) c -> + code_tail (Ptrofs.unsigned ofs) (fn_code fn) c -> plus step ge (State rs m) E0 (State rs' m'). Proof. induction 1; intros. @@ -824,7 +823,7 @@ Proof. eapply plus_left'. econstructor; eauto. eapply find_instr_tail. eauto. - apply IHexec_straight with b (Int.add ofs Int.one). + apply IHexec_straight with b (Ptrofs.add ofs Ptrofs.one). auto. rewrite H0. rewrite H3. reflexivity. auto. apply code_tail_next_int with i; auto. @@ -834,20 +833,20 @@ Qed. Lemma exec_straight_steps_2: forall c rs m c' rs' m', exec_straight c rs m c' rs' m' -> - list_length_z (fn_code fn) <= Int.max_unsigned -> + list_length_z (fn_code fn) <= Ptrofs.max_unsigned -> forall b ofs, rs#PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Int.unsigned ofs) (fn_code fn) c -> + code_tail (Ptrofs.unsigned ofs) (fn_code fn) c -> exists ofs', rs'#PC = Vptr b ofs' - /\ code_tail (Int.unsigned ofs') (fn_code fn) c'. + /\ code_tail (Ptrofs.unsigned ofs') (fn_code fn) c'. Proof. induction 1; intros. - exists (Int.add ofs Int.one). split. + exists (Ptrofs.add ofs Ptrofs.one). split. rewrite H0. rewrite H2. auto. apply code_tail_next_int with i1; auto. - apply IHexec_straight with (Int.add ofs Int.one). + apply IHexec_straight with (Ptrofs.add ofs Ptrofs.one). auto. rewrite H0. rewrite H3. reflexivity. auto. apply code_tail_next_int with i; auto. Qed. @@ -871,10 +870,18 @@ Inductive match_stack: list Mach.stackframe -> Prop := match_stack (Stackframe fb sp ra c :: s). Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. -Proof. induction 1; simpl. unfold Vzero; congruence. auto. Qed. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + auto. +Qed. Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. -Proof. induction 1; simpl. unfold Vzero; congruence. inv H0. congruence. Qed. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + inv H0. congruence. +Qed. Lemma lessdef_parent_sp: forall s v, diff --git a/backend/Bounds.v b/backend/Bounds.v index 178ff6ed..8a383380 100644 --- a/backend/Bounds.v +++ b/backend/Bounds.v @@ -444,6 +444,7 @@ Definition size_callee_save_area (b: bounds) (ofs: Z) : Z := Lemma size_callee_save_area_rec_incr: forall l ofs, ofs <= size_callee_save_area_rec l ofs. Proof. +Local Opaque mreg_type. induction l as [ | r l]; intros; simpl. - omega. - eapply Zle_trans. 2: apply IHl. @@ -472,45 +473,3 @@ Record frame_env : Type := mk_frame_env { fe_stack_data: Z; fe_used_callee_save: list mreg }. - -(* -Record frame_env_properties (b: bounds) (fe: frame_env) (fe_ofs_arg: Z) := mk_frame_env_properties { - (** Separation property *) - fe_separated: - Intv.pairwise_disjoint ( - (fe.(fe_ofs_link), fe.(fe_ofs_link) + 4) - :: (fe.(fe_ofs_retaddr), fe.(fe_ofs_retaddr) + 4) - :: (fe.(fe_ofs_local), fe.(fe_ofs_local) + 4 * b.(bound_local)) - :: (fe_ofs_arg, fe_ofs_arg + 4 * b.(bound_outgoing)) - :: (fe.(fe_ofs_callee_save), size_callee_save_area b fe.(fe_ofs_callee_save)) - :: (fe.(fe_stack_data), fe.(fe_stack_data) + b.(bound_stack_data)) - :: nil); - (** Inclusion properties *) - fe_incl_link: - Intv.incl (fe.(fe_ofs_link), fe.(fe_ofs_link) + 4) (0, fe.(fe_size)); - fe_incl_retaddr: - Intv.incl (fe.(fe_ofs_retaddr), fe.(fe_ofs_retaddr) + 4) (0, fe.(fe_size)); - fe_incl_local: - Intv.incl (fe.(fe_ofs_local), fe.(fe_ofs_local) + 4 * b.(bound_local)) (0, fe.(fe_size)); - fe_incl_outgoing: - Intv.incl (fe_ofs_arg, fe_ofs_arg + 4 * b.(bound_outgoing)) (0, fe.(fe_size)); - fe_incl_callee_save: - Intv.incl (fe.(fe_ofs_callee_save), size_callee_save_area b fe.(fe_ofs_callee_save)) (0, fe.(fe_size)); - fe_incl_stack_data: - Intv.incl (fe.(fe_stack_data), fe.(fe_stack_data) + b.(bound_stack_data)) (0, fe.(fe_size)); - (** Alignment properties *) - fe_align_link: - (4 | fe.(fe_ofs_link)); - fe_align_retaddr: - (4 | fe.(fe_ofs_retaddr)); - fe_align_local: - (8 | fe.(fe_ofs_local)); - fe_align_stack_data: - (8 | fe.(fe_stack_data)); - fe_align_size: - (4 | fe.(fe_size)); - (** Callee-save registers *) - fe_used_callee_save_eq: - fe.(fe_used_callee_save) = b.(used_callee_save) -}. -*) diff --git a/backend/CSE.v b/backend/CSE.v index d6b89557..4fa1bd6c 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -327,14 +327,14 @@ Definition kill_loads_after_storebytes Definition shift_memcpy_eq (src sz delta: Z) (e: equation) := match e with | Eq l strict (Load chunk (Ainstack i) _) => - let i := Int.unsigned i in + let i := Ptrofs.unsigned i in let j := i + delta in if zle src i && zle (i + size_chunk chunk) (src + sz) && zeq (Zmod delta (align_chunk chunk)) 0 && zle 0 j - && zle j Int.max_unsigned - then Some(Eq l strict (Load chunk (Ainstack (Int.repr j)) nil)) + && zle j Ptrofs.max_unsigned + then Some(Eq l strict (Load chunk (Ainstack (Ptrofs.repr j)) nil)) else None | _ => None end. @@ -353,8 +353,8 @@ Definition add_memcpy (n1 n2: numbering) (asrc adst: aptr) (sz: Z) := match asrc, adst with | Stk src, Stk dst => {| num_next := n2.(num_next); - num_eqs := add_memcpy_eqs (Int.unsigned src) sz - (Int.unsigned dst - Int.unsigned src) + num_eqs := add_memcpy_eqs (Ptrofs.unsigned src) sz + (Ptrofs.unsigned dst - Ptrofs.unsigned src) n1.(num_eqs) n2.(num_eqs); num_reg := n2.(num_reg); num_val := n2.(num_val) |} diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 2c144249..bf152e82 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -462,14 +462,14 @@ Qed. Lemma kill_loads_after_store_holds: forall valu ge sp rs m n addr args a chunk v m' bc approx ae am, - numbering_holds valu ge (Vptr sp Int.zero) rs m n -> - eval_addressing ge (Vptr sp Int.zero) addr rs##args = Some a -> + numbering_holds valu ge (Vptr sp Ptrofs.zero) rs m n -> + eval_addressing ge (Vptr sp Ptrofs.zero) addr rs##args = Some a -> Mem.storev chunk m a v = Some m' -> genv_match bc ge -> bc sp = BCstack -> ematch bc rs ae -> approx = VA.State ae am -> - numbering_holds valu ge (Vptr sp Int.zero) rs m' + numbering_holds valu ge (Vptr sp Ptrofs.zero) rs m' (kill_loads_after_store approx n chunk addr args). Proof. intros. apply kill_equations_hold with m; auto. @@ -493,11 +493,15 @@ Lemma store_normalized_range_sound: vmatch bc v (store_normalized_range chunk) -> Val.lessdef (Val.load_result chunk v) v. Proof. - intros. destruct chunk; simpl in *; destruct v; auto. + intros. unfold Val.load_result; remember Archi.ptr64 as ptr64. + destruct chunk; simpl in *; destruct v; auto. - inv H. rewrite is_sgn_sign_ext in H4 by omega. rewrite H4; auto. - inv H. rewrite is_uns_zero_ext in H4 by omega. rewrite H4; auto. - inv H. rewrite is_sgn_sign_ext in H4 by omega. rewrite H4; auto. - inv H. rewrite is_uns_zero_ext in H4 by omega. rewrite H4; auto. +- destruct ptr64; auto. +- destruct ptr64; auto. +- destruct ptr64; auto. Qed. Lemma add_store_result_hold: @@ -533,15 +537,15 @@ Qed. Lemma kill_loads_after_storebytes_holds: forall valu ge sp rs m n dst b ofs bytes m' bc approx ae am sz, - numbering_holds valu ge (Vptr sp Int.zero) rs m n -> + numbering_holds valu ge (Vptr sp Ptrofs.zero) rs m n -> pmatch bc b ofs dst -> - Mem.storebytes m b (Int.unsigned ofs) bytes = Some m' -> + Mem.storebytes m b (Ptrofs.unsigned ofs) bytes = Some m' -> genv_match bc ge -> bc sp = BCstack -> ematch bc rs ae -> approx = VA.State ae am -> length bytes = nat_of_Z sz -> sz >= 0 -> - numbering_holds valu ge (Vptr sp Int.zero) rs m' + numbering_holds valu ge (Vptr sp Ptrofs.zero) rs m' (kill_loads_after_storebytes approx n dst sz). Proof. intros. apply kill_equations_hold with m; auto. @@ -619,10 +623,11 @@ Lemma shift_memcpy_eq_wf: Proof with (try discriminate). unfold shift_memcpy_eq; intros. destruct e. destruct r... destruct a... - destruct (zle src (Int.unsigned i) && - zle (Int.unsigned i + size_chunk m) (src + sz) && - zeq (delta mod align_chunk m) 0 && zle 0 (Int.unsigned i + delta) && - zle (Int.unsigned i + delta) Int.max_unsigned)... + try (rename i into ofs). + destruct (zle src (Ptrofs.unsigned ofs) && + zle (Ptrofs.unsigned ofs + size_chunk m) (src + sz) && + zeq (delta mod align_chunk m) 0 && zle 0 (Ptrofs.unsigned ofs + delta) && + zle (Ptrofs.unsigned ofs + delta) Ptrofs.max_unsigned)... inv H. destruct H0. split. auto. red; simpl; tauto. Qed. @@ -631,35 +636,40 @@ Lemma shift_memcpy_eq_holds: shift_memcpy_eq src sz (dst - src) e = Some e' -> Mem.loadbytes m sp src sz = Some bytes -> Mem.storebytes m sp dst bytes = Some m' -> - equation_holds valu ge (Vptr sp Int.zero) m e -> - equation_holds valu ge (Vptr sp Int.zero) m' e'. + equation_holds valu ge (Vptr sp Ptrofs.zero) m e -> + equation_holds valu ge (Vptr sp Ptrofs.zero) m' e'. Proof with (try discriminate). intros. set (delta := dst - src) in *. unfold shift_memcpy_eq in H. destruct e as [l strict rhs] eqn:E. destruct rhs as [op vl | chunk addr vl]... destruct addr... - set (i1 := Int.unsigned i) in *. set (j := i1 + delta) in *. + try (rename i into ofs). + set (i1 := Ptrofs.unsigned ofs) in *. set (j := i1 + delta) in *. destruct (zle src i1)... destruct (zle (i1 + size_chunk chunk) (src + sz))... destruct (zeq (delta mod align_chunk chunk) 0)... destruct (zle 0 j)... - destruct (zle j Int.max_unsigned)... + destruct (zle j Ptrofs.max_unsigned)... simpl in H; inv H. assert (LD: forall v, - Mem.loadv chunk m (Vptr sp i) = Some v -> - Mem.loadv chunk m' (Vptr sp (Int.repr j)) = Some v). + Mem.loadv chunk m (Vptr sp ofs) = Some v -> + Mem.loadv chunk m' (Vptr sp (Ptrofs.repr j)) = Some v). { - simpl; intros. rewrite Int.unsigned_repr by omega. + simpl; intros. rewrite Ptrofs.unsigned_repr by omega. unfold j, delta. eapply load_memcpy; eauto. apply Zmod_divide; auto. generalize (align_chunk_pos chunk); omega. } inv H2. -+ inv H3. destruct vl... simpl in H6. rewrite Int.add_zero_l in H6. inv H6. - apply eq_holds_strict. econstructor. simpl. rewrite Int.add_zero_l. eauto. ++ inv H3. exploit eval_addressing_Ainstack_inv; eauto. intros [E1 E2]. + simpl in E2; rewrite Ptrofs.add_zero_l in E2. subst a. + apply eq_holds_strict. econstructor. rewrite eval_addressing_Ainstack. + simpl. rewrite Ptrofs.add_zero_l. eauto. apply LD; auto. -+ inv H4. destruct vl... simpl in H7. rewrite Int.add_zero_l in H7. inv H7. ++ inv H4. exploit eval_addressing_Ainstack_inv; eauto. intros [E1 E2]. + simpl in E2; rewrite Ptrofs.add_zero_l in E2. subst a. apply eq_holds_lessdef with v; auto. - econstructor. simpl. rewrite Int.add_zero_l. eauto. apply LD; auto. + econstructor. rewrite eval_addressing_Ainstack. simpl. rewrite Ptrofs.add_zero_l. eauto. + apply LD; auto. Qed. Lemma add_memcpy_eqs_charact: @@ -677,15 +687,15 @@ Qed. Lemma add_memcpy_holds: forall m bsrc osrc sz bytes bdst odst m' valu ge sp rs n1 n2 bc asrc adst, - Mem.loadbytes m bsrc (Int.unsigned osrc) sz = Some bytes -> - Mem.storebytes m bdst (Int.unsigned odst) bytes = Some m' -> - numbering_holds valu ge (Vptr sp Int.zero) rs m n1 -> - numbering_holds valu ge (Vptr sp Int.zero) rs m' n2 -> + Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz = Some bytes -> + Mem.storebytes m bdst (Ptrofs.unsigned odst) bytes = Some m' -> + numbering_holds valu ge (Vptr sp Ptrofs.zero) rs m n1 -> + numbering_holds valu ge (Vptr sp Ptrofs.zero) rs m' n2 -> pmatch bc bsrc osrc asrc -> pmatch bc bdst odst adst -> bc sp = BCstack -> Ple (num_next n1) (num_next n2) -> - numbering_holds valu ge (Vptr sp Int.zero) rs m' (add_memcpy n1 n2 asrc adst sz). + numbering_holds valu ge (Vptr sp Ptrofs.zero) rs m' (add_memcpy n1 n2 asrc adst sz). Proof. intros. unfold add_memcpy. destruct asrc; auto; destruct adst; auto. diff --git a/backend/Cminor.v b/backend/Cminor.v index 0d959531..e238140b 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -38,8 +38,8 @@ Inductive constant : Type := | Ofloatconst: float -> constant (**r double-precision floating-point constant *) | Osingleconst: float32 -> constant (**r single-precision floating-point constant *) | Olongconst: int64 -> constant (**r long integer constant *) - | Oaddrsymbol: ident -> int -> constant (**r address of the symbol plus the offset *) - | Oaddrstack: int -> constant. (**r stack pointer plus the given offset *) + | Oaddrsymbol: ident -> ptrofs -> constant (**r address of the symbol plus the offset *) + | Oaddrstack: ptrofs -> constant. (**r stack pointer plus the given offset *) Inductive unary_operation : Type := | Ocast8unsigned: unary_operation (**r 8-bit zero extension *) @@ -257,11 +257,8 @@ Definition eval_constant (sp: val) (cst: constant) : option val := | Ofloatconst n => Some (Vfloat n) | Osingleconst n => Some (Vsingle n) | Olongconst n => Some (Vlong n) - | Oaddrsymbol s ofs => - Some(match Genv.find_symbol ge s with - | None => Vundef - | Some b => Vptr b ofs end) - | Oaddrstack ofs => Some (Val.add sp (Vint ofs)) + | Oaddrsymbol s ofs => Some (Genv.symbol_address ge s ofs) + | Oaddrstack ofs => Some (Val.offset_ptr sp ofs) end. Definition eval_unop (op: unary_operation) (arg: val) : option val := @@ -343,7 +340,7 @@ Definition eval_binop | Ocmpf c => Some (Val.cmpf c arg1 arg2) | Ocmpfs c => Some (Val.cmpfs c arg1 arg2) | Ocmpl c => Val.cmpl c arg1 arg2 - | Ocmplu c => Val.cmplu c arg1 arg2 + | Ocmplu c => Val.cmplu (Mem.valid_pointer m) c arg1 arg2 end. (** Evaluation of an expression: [eval_expr ge sp e m a v] @@ -444,7 +441,7 @@ Inductive step: state -> trace -> state -> Prop := | step_skip_call: forall f k sp e m m', is_call_cont k -> Mem.free m sp 0 f.(fn_stackspace) = Some m' -> - step (State f Sskip k (Vptr sp Int.zero) e m) + step (State f Sskip k (Vptr sp Ptrofs.zero) e m) E0 (Returnstate Vundef k m') | step_assign: forall f id a k sp e m v, @@ -468,12 +465,12 @@ Inductive step: state -> trace -> state -> Prop := E0 (Callstate fd vargs (Kcall optid f sp e k) m) | step_tailcall: forall f sig a bl k sp e m vf vargs fd m', - eval_expr (Vptr sp Int.zero) e m a vf -> - eval_exprlist (Vptr sp Int.zero) e m bl vargs -> + eval_expr (Vptr sp Ptrofs.zero) e m a vf -> + eval_exprlist (Vptr sp Ptrofs.zero) e m bl vargs -> Genv.find_funct ge vf = Some fd -> funsig fd = sig -> Mem.free m sp 0 f.(fn_stackspace) = Some m' -> - step (State f (Stailcall sig a bl) k (Vptr sp Int.zero) e m) + step (State f (Stailcall sig a bl) k (Vptr sp Ptrofs.zero) e m) E0 (Callstate fd vargs (call_cont k) m') | step_builtin: forall f optid ef bl k sp e m vargs t vres m', @@ -518,12 +515,12 @@ Inductive step: state -> trace -> state -> Prop := | step_return_0: forall f k sp e m m', Mem.free m sp 0 f.(fn_stackspace) = Some m' -> - step (State f (Sreturn None) k (Vptr sp Int.zero) e m) + step (State f (Sreturn None) k (Vptr sp Ptrofs.zero) e m) E0 (Returnstate Vundef (call_cont k) m') | step_return_1: forall f a k sp e m v m', - eval_expr (Vptr sp Int.zero) e m a v -> + eval_expr (Vptr sp Ptrofs.zero) e m a v -> Mem.free m sp 0 f.(fn_stackspace) = Some m' -> - step (State f (Sreturn (Some a)) k (Vptr sp Int.zero) e m) + step (State f (Sreturn (Some a)) k (Vptr sp Ptrofs.zero) e m) E0 (Returnstate v (call_cont k) m') | step_label: forall f lbl s k sp e m, @@ -539,7 +536,7 @@ Inductive step: state -> trace -> state -> Prop := Mem.alloc m 0 f.(fn_stackspace) = (m', sp) -> set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> step (Callstate (Internal f) vargs k m) - E0 (State f f.(fn_body) k (Vptr sp Int.zero) e m') + E0 (State f f.(fn_body) k (Vptr sp Ptrofs.zero) e m') | step_external_function: forall ef vargs k m t vres m', external_call ef ge vargs m t vres m' -> step (Callstate (External ef) vargs k m) @@ -649,7 +646,7 @@ Inductive eval_funcall: forall m f vargs m1 sp e t e2 m2 out vres m3, Mem.alloc m 0 f.(fn_stackspace) = (m1, sp) -> set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> - exec_stmt f (Vptr sp Int.zero) e m1 f.(fn_body) t e2 m2 out -> + exec_stmt f (Vptr sp Ptrofs.zero) e m1 f.(fn_body) t e2 m2 out -> outcome_result_value out f.(fn_sig).(sig_res) vres -> outcome_free_mem out m2 sp f.(fn_stackspace) m3 -> eval_funcall m (Internal f) vargs t m3 vres @@ -748,13 +745,13 @@ with exec_stmt: exec_stmt f sp e m (Sreturn (Some a)) E0 e m (Out_return (Some v)) | exec_Stailcall: forall f sp e m sig a bl vf vargs fd t m' m'' vres, - eval_expr ge (Vptr sp Int.zero) e m a vf -> - eval_exprlist ge (Vptr sp Int.zero) e m bl vargs -> + eval_expr ge (Vptr sp Ptrofs.zero) e m a vf -> + eval_exprlist ge (Vptr sp Ptrofs.zero) e m bl vargs -> Genv.find_funct ge vf = Some fd -> funsig fd = sig -> Mem.free m sp 0 f.(fn_stackspace) = Some m' -> eval_funcall m' fd vargs t m'' vres -> - exec_stmt f (Vptr sp Int.zero) e m (Stailcall sig a bl) t e m'' (Out_tailcall_return vres). + exec_stmt f (Vptr sp Ptrofs.zero) e m (Stailcall sig a bl) t e m'' (Out_tailcall_return vres). Scheme eval_funcall_ind2 := Minimality for eval_funcall Sort Prop with exec_stmt_ind2 := Minimality for exec_stmt Sort Prop. @@ -774,7 +771,7 @@ CoInductive evalinf_funcall: forall m f vargs m1 sp e t, Mem.alloc m 0 f.(fn_stackspace) = (m1, sp) -> set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> - execinf_stmt f (Vptr sp Int.zero) e m1 f.(fn_body) t -> + execinf_stmt f (Vptr sp Ptrofs.zero) e m1 f.(fn_body) t -> evalinf_funcall m (Internal f) vargs t (** [execinf_stmt ge sp e m s t] means that statement [s] diverges. @@ -823,13 +820,13 @@ with execinf_stmt: execinf_stmt f sp e m (Sblock s) t | execinf_Stailcall: forall f sp e m sig a bl vf vargs fd m' t, - eval_expr ge (Vptr sp Int.zero) e m a vf -> - eval_exprlist ge (Vptr sp Int.zero) e m bl vargs -> + eval_expr ge (Vptr sp Ptrofs.zero) e m a vf -> + eval_exprlist ge (Vptr sp Ptrofs.zero) e m bl vargs -> Genv.find_funct ge vf = Some fd -> funsig fd = sig -> Mem.free m sp 0 f.(fn_stackspace) = Some m' -> evalinf_funcall m' fd vargs t -> - execinf_stmt f (Vptr sp Int.zero) e m (Stailcall sig a bl) t. + execinf_stmt f (Vptr sp Ptrofs.zero) e m (Stailcall sig a bl) t. End NATURALSEM. diff --git a/backend/CminorSel.v b/backend/CminorSel.v index d654502b..9439c269 100644 --- a/backend/CminorSel.v +++ b/backend/CminorSel.v @@ -246,7 +246,7 @@ Inductive eval_expr_or_symbol: letenv -> expr + ident -> val -> Prop := eval_expr_or_symbol le (inl _ e) v | eval_eos_s: forall le id b, Genv.find_symbol ge id = Some b -> - eval_expr_or_symbol le (inr _ id) (Vptr b Int.zero). + eval_expr_or_symbol le (inr _ id) (Vptr b Ptrofs.zero). Inductive eval_builtin_arg: builtin_arg expr -> val -> Prop := | eval_BA: forall a v, @@ -261,10 +261,10 @@ Inductive eval_builtin_arg: builtin_arg expr -> val -> Prop := | eval_BA_single: forall n, eval_builtin_arg (BA_single n) (Vsingle n) | eval_BA_loadstack: forall chunk ofs v, - Mem.loadv chunk m (Val.add sp (Vint ofs)) = Some v -> + Mem.loadv chunk m (Val.offset_ptr sp ofs) = Some v -> eval_builtin_arg (BA_loadstack chunk ofs) v | eval_BA_addrstack: forall ofs, - eval_builtin_arg (BA_addrstack ofs) (Val.add sp (Vint ofs)) + eval_builtin_arg (BA_addrstack ofs) (Val.offset_ptr sp ofs) | eval_BA_loadglobal: forall chunk id ofs v, Mem.loadv chunk m (Genv.symbol_address ge id ofs) = Some v -> eval_builtin_arg (BA_loadglobal chunk id ofs) v @@ -338,7 +338,7 @@ Inductive step: state -> trace -> state -> Prop := | step_skip_call: forall f k sp e m m', is_call_cont k -> Mem.free m sp 0 f.(fn_stackspace) = Some m' -> - step (State f Sskip k (Vptr sp Int.zero) e m) + step (State f Sskip k (Vptr sp Ptrofs.zero) e m) E0 (Returnstate Vundef k m') | step_assign: forall f id a k sp e m v, @@ -363,12 +363,12 @@ Inductive step: state -> trace -> state -> Prop := E0 (Callstate fd vargs (Kcall optid f sp e k) m) | step_tailcall: forall f sig a bl k sp e m vf vargs fd m', - eval_expr_or_symbol (Vptr sp Int.zero) e m nil a vf -> - eval_exprlist (Vptr sp Int.zero) e m nil bl vargs -> + eval_expr_or_symbol (Vptr sp Ptrofs.zero) e m nil a vf -> + eval_exprlist (Vptr sp Ptrofs.zero) e m nil bl vargs -> Genv.find_funct ge vf = Some fd -> funsig fd = sig -> Mem.free m sp 0 f.(fn_stackspace) = Some m' -> - step (State f (Stailcall sig a bl) k (Vptr sp Int.zero) e m) + step (State f (Stailcall sig a bl) k (Vptr sp Ptrofs.zero) e m) E0 (Callstate fd vargs (call_cont k) m') | step_builtin: forall f res ef al k sp e m vl t v m', @@ -411,12 +411,12 @@ Inductive step: state -> trace -> state -> Prop := | step_return_0: forall f k sp e m m', Mem.free m sp 0 f.(fn_stackspace) = Some m' -> - step (State f (Sreturn None) k (Vptr sp Int.zero) e m) + step (State f (Sreturn None) k (Vptr sp Ptrofs.zero) e m) E0 (Returnstate Vundef (call_cont k) m') | step_return_1: forall f a k sp e m v m', - eval_expr (Vptr sp Int.zero) e m nil a v -> + eval_expr (Vptr sp Ptrofs.zero) e m nil a v -> Mem.free m sp 0 f.(fn_stackspace) = Some m' -> - step (State f (Sreturn (Some a)) k (Vptr sp Int.zero) e m) + step (State f (Sreturn (Some a)) k (Vptr sp Ptrofs.zero) e m) E0 (Returnstate v (call_cont k) m') | step_label: forall f lbl s k sp e m, @@ -432,7 +432,7 @@ Inductive step: state -> trace -> state -> Prop := Mem.alloc m 0 f.(fn_stackspace) = (m', sp) -> set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> step (Callstate (Internal f) vargs k m) - E0 (State f f.(fn_body) k (Vptr sp Int.zero) e m') + E0 (State f f.(fn_body) k (Vptr sp Ptrofs.zero) e m') | step_external_function: forall ef vargs k m t vres m', external_call ef ge vargs m t vres m' -> step (Callstate (External ef) vargs k m) diff --git a/backend/Constprop.v b/backend/Constprop.v index 4de80b7a..151f8418 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -56,22 +56,12 @@ Definition transf_ros (ae: AE.t) (ros: reg + ident) : reg + ident := match ros with | inl r => match areg ae r with - | Ptr(Gl symb ofs) => if Int.eq ofs Int.zero then inr _ symb else ros + | Ptr(Gl symb ofs) => if Ptrofs.eq ofs Ptrofs.zero then inr _ symb else ros | _ => ros end | inr s => ros end. -Definition const_for_result (a: aval) : option operation := - match a with - | I n => Some(Ointconst n) - | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None - | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None - | Ptr(Gl symb ofs) => Some(Oaddrsymbol symb ofs) - | Ptr(Stk ofs) => Some(Oaddrstack ofs) - | _ => None - end. - Fixpoint successor_rec (n: nat) (f: function) (ae: AE.t) (pc: node) : node := match n with | O => pc diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index 4e76c641..fd9cfaa5 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -107,7 +107,7 @@ Proof. simpl. inv LD. apply functions_translated; auto. rewrite <- H0 in FF; discriminate. } destruct (areg ae r); auto. destruct p; auto. - predSpec Int.eq Int.eq_spec ofs Int.zero; intros; auto. + predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero; intros; auto. subst ofs. exploit vmatch_ptr_gl; eauto. intros LD'. inv LD'; try discriminate. rewrite H1 in FF. unfold Genv.symbol_address in FF. simpl. rewrite symbols_preserved. @@ -127,26 +127,12 @@ Lemma const_for_result_correct: vmatch bc v a -> bc sp = BCstack -> genv_match bc ge -> - exists v', eval_operation tge (Vptr sp Int.zero) op nil m = Some v' /\ Val.lessdef v v'. + exists v', eval_operation tge (Vptr sp Ptrofs.zero) op nil m = Some v' /\ Val.lessdef v v'. Proof. - unfold const_for_result; intros. - destruct a; try discriminate. -- (* integer *) - inv H. inv H0. exists (Vint n); auto. -- (* float *) - destruct (Compopts.generate_float_constants tt); inv H. inv H0. exists (Vfloat f); auto. -- (* single *) - destruct (Compopts.generate_float_constants tt); inv H. inv H0. exists (Vsingle f); auto. -- (* pointer *) - destruct p; try discriminate. - + (* global *) - inv H. exists (Genv.symbol_address ge id ofs); split. - unfold Genv.symbol_address. rewrite <- symbols_preserved. reflexivity. - eapply vmatch_ptr_gl; eauto. - + (* stack *) - inv H. exists (Vptr sp ofs); split. - simpl; rewrite Int.add_zero_l; auto. - eapply vmatch_ptr_stk; eauto. + intros. exploit ConstpropOpproof.const_for_result_correct; eauto. intros (v' & A & B). + exists v'; split. + rewrite <- A; apply eval_operation_preserved. exact symbols_preserved. + auto. Qed. Inductive match_pc (f: function) (rs: regset) (m: mem): nat -> node -> node -> Prop := @@ -399,12 +385,12 @@ Proof. assert(OP: let (op', args') := op_strength_reduction op args (aregs ae args) in exists v', - eval_operation ge (Vptr sp0 Int.zero) op' rs ## args' m = Some v' /\ + eval_operation ge (Vptr sp0 Ptrofs.zero) op' rs ## args' m = Some v' /\ Val.lessdef v v'). { eapply op_strength_reduction_correct with (ae := ae); eauto with va. } destruct (op_strength_reduction op args (aregs ae args)) as [op' args']. destruct OP as [v' [EV' LD']]. - assert (EV'': exists v'', eval_operation ge (Vptr sp0 Int.zero) op' rs'##args' m' = Some v'' /\ Val.lessdef v' v''). + assert (EV'': exists v'', eval_operation ge (Vptr sp0 Ptrofs.zero) op' rs'##args' m' = Some v'' /\ Val.lessdef v' v''). { eapply eval_operation_lessdef; eauto. eapply regs_lessdef_regs; eauto. } destruct EV'' as [v'' [EV'' LD'']]. left; econstructor; econstructor; split. @@ -431,14 +417,14 @@ Proof. assert (ADDR: let (addr', args') := addr_strength_reduction addr args (aregs ae args) in exists a', - eval_addressing ge (Vptr sp0 Int.zero) addr' rs ## args' = Some a' /\ + eval_addressing ge (Vptr sp0 Ptrofs.zero) addr' rs ## args' = Some a' /\ Val.lessdef a a'). { eapply addr_strength_reduction_correct with (ae := ae); eauto with va. } destruct (addr_strength_reduction addr args (aregs ae args)) as [addr' args']. destruct ADDR as (a' & P & Q). exploit eval_addressing_lessdef. eapply regs_lessdef_regs; eauto. eexact P. intros (a'' & U & V). - assert (W: eval_addressing tge (Vptr sp0 Int.zero) addr' rs'##args' = Some a''). + assert (W: eval_addressing tge (Vptr sp0 Ptrofs.zero) addr' rs'##args' = Some a''). { rewrite <- U. apply eval_addressing_preserved. exact symbols_preserved. } exploit Mem.loadv_extends. eauto. eauto. apply Val.lessdef_trans with a'; eauto. intros (v' & X & Y). @@ -451,14 +437,14 @@ Proof. assert (ADDR: let (addr', args') := addr_strength_reduction addr args (aregs ae args) in exists a', - eval_addressing ge (Vptr sp0 Int.zero) addr' rs ## args' = Some a' /\ + eval_addressing ge (Vptr sp0 Ptrofs.zero) addr' rs ## args' = Some a' /\ Val.lessdef a a'). { eapply addr_strength_reduction_correct with (ae := ae); eauto with va. } destruct (addr_strength_reduction addr args (aregs ae args)) as [addr' args']. destruct ADDR as (a' & P & Q). exploit eval_addressing_lessdef. eapply regs_lessdef_regs; eauto. eexact P. intros (a'' & U & V). - assert (W: eval_addressing tge (Vptr sp0 Int.zero) addr' rs'##args' = Some a''). + assert (W: eval_addressing tge (Vptr sp0 Ptrofs.zero) addr' rs'##args' = Some a''). { rewrite <- U. apply eval_addressing_preserved. exact symbols_preserved. } exploit Mem.storev_extends. eauto. eauto. apply Val.lessdef_trans with a'; eauto. apply REGS. intros (m2' & X & Y). @@ -510,7 +496,7 @@ Opaque builtin_strength_reduction. generalize (cond_strength_reduction_correct bc ae rs m EM cond args (aregs ae args) (refl_equal _)). destruct (cond_strength_reduction cond args (aregs ae args)) as [cond' args']. intros EV1 TCODE. - left; exists O; exists (State s' (transf_function (romem_for cu) f) (Vptr sp0 Int.zero) (if b then ifso else ifnot) rs' m'); split. + left; exists O; exists (State s' (transf_function (romem_for cu) f) (Vptr sp0 Ptrofs.zero) (if b then ifso else ifnot) rs' m'); split. destruct (resolve_branch ac) eqn: RB. assert (b0 = b) by (eapply resolve_branch_sound; eauto). subst b0. destruct b; eapply exec_Inop; eauto. @@ -534,7 +520,7 @@ Opaque builtin_strength_reduction. rewrite H1. auto. } assert (rs'#arg = Vint n). { generalize (REGS arg). rewrite H0. intros LD; inv LD; auto. } - left; exists O; exists (State s' (transf_function (romem_for cu) f) (Vptr sp0 Int.zero) pc' rs' m'); split. + left; exists O; exists (State s' (transf_function (romem_for cu) f) (Vptr sp0 Ptrofs.zero) pc' rs' m'); split. destruct A. eapply exec_Ijumptable; eauto. eapply exec_Inop; eauto. eapply match_states_succ; eauto. diff --git a/backend/Deadcodeproof.v b/backend/Deadcodeproof.v index 5c293ee1..52f1f112 100644 --- a/backend/Deadcodeproof.v +++ b/backend/Deadcodeproof.v @@ -489,8 +489,8 @@ Inductive match_stackframes: stackframe -> stackframe -> Prop := Val.lessdef v tv -> eagree (e#res <- v) (te#res<- tv) (fst (transfer f (vanalyze cu f) pc an!!pc))), - match_stackframes (Stackframe res f (Vptr sp Int.zero) pc e) - (Stackframe res tf (Vptr sp Int.zero) pc te). + match_stackframes (Stackframe res f (Vptr sp Ptrofs.zero) pc e) + (Stackframe res tf (Vptr sp Ptrofs.zero) pc te). Inductive match_states: state -> state -> Prop := | match_regular_states: @@ -501,8 +501,8 @@ Inductive match_states: state -> state -> Prop := (ANL: analyze (vanalyze cu f) f = Some an) (ENV: eagree e te (fst (transfer f (vanalyze cu f) pc an!!pc))) (MEM: magree m tm (nlive ge sp (snd (transfer f (vanalyze cu f) pc an!!pc)))), - match_states (State s f (Vptr sp Int.zero) pc e m) - (State ts tf (Vptr sp Int.zero) pc te tm) + match_states (State s f (Vptr sp Ptrofs.zero) pc e m) + (State ts tf (Vptr sp Ptrofs.zero) pc te tm) | match_call_states: forall s f args m ts tf targs tm cu (STACKS: list_forall2 match_stackframes s ts) @@ -544,8 +544,8 @@ Lemma match_succ_states: (ANPC: an!!pc = (ne, nm)) (ENV: eagree e te ne) (MEM: magree m tm (nlive ge sp nm)), - match_states (State s f (Vptr sp Int.zero) pc' e m) - (State ts tf (Vptr sp Int.zero) pc' te tm). + match_states (State s f (Vptr sp Ptrofs.zero) pc' e m) + (State ts tf (Vptr sp Ptrofs.zero) pc' te tm). Proof. intros. exploit analyze_successors; eauto. rewrite ANPC; simpl. intros [A B]. econstructor; eauto. @@ -567,7 +567,7 @@ Qed. Lemma transfer_builtin_arg_sound: forall bc e e' sp m m' a v, - eval_builtin_arg ge (fun r => e#r) (Vptr sp Int.zero) m a v -> + eval_builtin_arg ge (fun r => e#r) (Vptr sp Ptrofs.zero) m a v -> forall nv ne1 nm1 ne2 nm2, transfer_builtin_arg nv (ne1, nm1) a = (ne2, nm2) -> eagree e e' ne2 -> @@ -575,7 +575,7 @@ Lemma transfer_builtin_arg_sound: genv_match bc ge -> bc sp = BCstack -> exists v', - eval_builtin_arg ge (fun r => e'#r) (Vptr sp Int.zero) m' a v' + eval_builtin_arg ge (fun r => e'#r) (Vptr sp Ptrofs.zero) m' a v' /\ vagree v v' nv /\ eagree e e' ne1 /\ magree m m' (nlive ge sp nm1). @@ -587,11 +587,11 @@ Proof. - exists (Vfloat n); intuition auto. constructor. apply vagree_same. - exists (Vsingle n); intuition auto. constructor. apply vagree_same. - simpl in H. exploit magree_load; eauto. - intros. eapply nlive_add; eauto with va. rewrite Int.add_zero_l in H0; auto. + intros. eapply nlive_add; eauto with va. rewrite Ptrofs.add_zero_l in H0; auto. intros (v' & A & B). exists v'; intuition auto. constructor; auto. apply vagree_lessdef; auto. eapply magree_monotone; eauto. intros; eapply incl_nmem_add; eauto. -- exists (Vptr sp (Int.add Int.zero ofs)); intuition auto with na. constructor. +- exists (Vptr sp (Ptrofs.add Ptrofs.zero ofs)); intuition auto with na. constructor. - unfold Senv.symbol_address in H; simpl in H. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; simpl in H; try discriminate. exploit magree_load; eauto. @@ -613,7 +613,7 @@ Qed. Lemma transfer_builtin_args_sound: forall e sp m e' m' bc al vl, - eval_builtin_args ge (fun r => e#r) (Vptr sp Int.zero) m al vl -> + eval_builtin_args ge (fun r => e#r) (Vptr sp Ptrofs.zero) m al vl -> forall ne1 nm1 ne2 nm2, transfer_builtin_args (ne1, nm1) al = (ne2, nm2) -> eagree e e' ne2 -> @@ -621,7 +621,7 @@ Lemma transfer_builtin_args_sound: genv_match bc ge -> bc sp = BCstack -> exists vl', - eval_builtin_args ge (fun r => e'#r) (Vptr sp Int.zero) m' al vl' + eval_builtin_args ge (fun r => e'#r) (Vptr sp Ptrofs.zero) m' al vl' /\ Val.lessdef_list vl vl' /\ eagree e e' ne1 /\ magree m m' (nlive ge sp nm1). @@ -639,8 +639,8 @@ Lemma can_eval_builtin_arg: forall sp e m e' m' P, magree m m' P -> forall a v, - eval_builtin_arg ge (fun r => e#r) (Vptr sp Int.zero) m a v -> - exists v', eval_builtin_arg tge (fun r => e'#r) (Vptr sp Int.zero) m' a v'. + eval_builtin_arg ge (fun r => e#r) (Vptr sp Ptrofs.zero) m a v -> + exists v', eval_builtin_arg tge (fun r => e'#r) (Vptr sp Ptrofs.zero) m' a v'. Proof. intros until P; intros MA. assert (LD: forall chunk addr v, @@ -663,8 +663,8 @@ Lemma can_eval_builtin_args: forall sp e m e' m' P, magree m m' P -> forall al vl, - eval_builtin_args ge (fun r => e#r) (Vptr sp Int.zero) m al vl -> - exists vl', eval_builtin_args tge (fun r => e'#r) (Vptr sp Int.zero) m' al vl'. + eval_builtin_args ge (fun r => e#r) (Vptr sp Ptrofs.zero) m al vl -> + exists vl', eval_builtin_args tge (fun r => e'#r) (Vptr sp Ptrofs.zero) m' al vl'. Proof. induction 2. - exists (@nil val); constructor. diff --git a/backend/Debugvar.v b/backend/Debugvar.v index 5d31831a..1f361030 100644 --- a/backend/Debugvar.v +++ b/backend/Debugvar.v @@ -136,7 +136,7 @@ Definition kill_at_call (s: avail) : avail := Definition eq_arg (a1 a2: builtin_arg loc) : {a1=a2} + {a1<>a2}. Proof. - generalize Loc.eq ident_eq Int.eq_dec Int64.eq_dec Float.eq_dec Float32.eq_dec chunk_eq; + generalize Loc.eq ident_eq Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec chunk_eq; decide equality. Defined. Global Opaque eq_arg. diff --git a/backend/IRC.ml b/backend/IRC.ml index 036b4ac5..43955897 100644 --- a/backend/IRC.ml +++ b/backend/IRC.ml @@ -238,9 +238,16 @@ type graph = { by giving it a negative spill cost. *) let class_of_type = function - | Tint | Tany32 -> 0 - | Tfloat | Tsingle | Tany64 -> 1 - | Tlong -> assert false + | Tint | Tlong -> 0 + | Tfloat | Tsingle -> 1 + | Tany32 | Tany64 -> assert false + +let class_of_reg r = + if Conventions1.is_float_reg r then 1 else 0 + +let class_of_loc = function + | R r -> class_of_reg r + | S(_, _, ty) -> class_of_type ty let no_spill_class = 2 @@ -319,7 +326,7 @@ let newNodeOfLoc g l = let ty = Loc.coq_type l in g.nextIdent <- g.nextIdent + 1; { ident = g.nextIdent; typ = ty; - var = L l; regclass = class_of_type ty; + var = L l; regclass = class_of_loc l; accesses = 0; spillcost = 0.0; adjlist = []; degree = 0; movelist = []; extra_adj = []; extra_pref = []; alias = None; @@ -828,20 +835,26 @@ let compare_slots s1 s2 = | S(_, ofs1, _), S(_, ofs2, _) -> Z.compare ofs1 ofs2 | _, _ -> assert false +let align a b = (a + b - 1) land (-b) (* assuming b is a power of 2 *) + let find_slot conflicts typ = + let sz = Z.to_int (Locations.typesize typ) in + let al = Z.to_int (Locations.typealign typ) in let rec find curr = function | [] -> - S(Local, curr, typ) + S(Local, Z.of_uint curr, typ) | S(Local, ofs, typ') :: l -> - if Z.le (Z.add curr (Locations.typesize typ)) ofs then - S(Local, curr, typ) + let ofs = Z.to_int ofs in + if curr + sz <= ofs then + S(Local, Z.of_uint curr, typ) else begin - let ofs' = Z.add ofs (Locations.typesize typ') in - find (if Z.le ofs' curr then curr else ofs') l + let sz' = Z.to_int (Locations.typesize typ') in + let ofs' = align (ofs + sz') al in + find (if ofs' <= curr then curr else ofs') l end | _ :: l -> find curr l - in find Z.zero (List.stable_sort compare_slots conflicts) + in find 0 (List.stable_sort compare_slots conflicts) (* Record locations assigned to interfering nodes *) @@ -891,10 +904,10 @@ let location_of_var g v = | None -> assert false | Some l -> l with Not_found -> - match ty with - | Tint -> R dummy_int_reg - | Tfloat | Tsingle -> R dummy_float_reg - | Tlong | Tany32 | Tany64 -> assert false + match class_of_type ty with + | 0 -> R dummy_int_reg + | 1 -> R dummy_float_reg + | _ -> assert false (* The exported interface *) diff --git a/backend/IRC.mli b/backend/IRC.mli index d27dedaa..30b6d5c1 100644 --- a/backend/IRC.mli +++ b/backend/IRC.mli @@ -41,3 +41,7 @@ val coloring: graph -> (var -> loc) (* Machine registers that are reserved and not available for allocation. *) val reserved_registers: mreg list ref + +(* Auxiliaries to deal with register classes *) +val class_of_type: AST.typ -> int +val class_of_loc: loc -> int diff --git a/backend/Inlining.v b/backend/Inlining.v index 5c8f4419..61776743 100644 --- a/backend/Inlining.v +++ b/backend/Inlining.v @@ -192,16 +192,16 @@ Definition sregs (ctx: context) (rl: list reg) := List.map (sreg ctx) rl. Definition sros (ctx: context) (ros: reg + ident) := sum_left_map (sreg ctx) ros. Definition sop (ctx: context) (op: operation) := - shift_stack_operation (Int.repr ctx.(dstk)) op. + shift_stack_operation ctx.(dstk) op. Definition saddr (ctx: context) (addr: addressing) := - shift_stack_addressing (Int.repr ctx.(dstk)) addr. + shift_stack_addressing ctx.(dstk) addr. Fixpoint sbuiltinarg (ctx: context) (a: builtin_arg reg) : builtin_arg reg := match a with | BA x => BA (sreg ctx x) - | BA_loadstack chunk ofs => BA_loadstack chunk (Int.add ofs (Int.repr ctx.(dstk))) - | BA_addrstack ofs => BA_addrstack (Int.add ofs (Int.repr ctx.(dstk))) + | BA_loadstack chunk ofs => BA_loadstack chunk (Ptrofs.add ofs (Ptrofs.repr ctx.(dstk))) + | BA_addrstack ofs => BA_addrstack (Ptrofs.add ofs (Ptrofs.repr ctx.(dstk))) | BA_splitlong hi lo => BA_splitlong (sbuiltinarg ctx hi) (sbuiltinarg ctx lo) | _ => a end. @@ -437,13 +437,13 @@ Definition expand_function (fenv: funenv) (f: function): mon context := Local Open Scope string_scope. (** Inlining can increase the size of the function's stack block. We must - make sure that the new size does not exceed [Int.max_unsigned], otherwise + make sure that the new size does not exceed [Ptrofs.max_unsigned], otherwise address computations within the stack would overflow and produce incorrect results. *) Definition transf_function (fenv: funenv) (f: function) : Errors.res function := let '(R ctx s _) := expand_function fenv f initstate in - if zlt s.(st_stksize) Int.max_unsigned then + if zlt s.(st_stksize) Ptrofs.max_unsigned then OK (mkfunction f.(fn_sig) (sregs ctx f.(fn_params)) s.(st_stksize) diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v index 91f4a3f5..d06fa997 100644 --- a/backend/Inliningproof.v +++ b/backend/Inliningproof.v @@ -411,8 +411,8 @@ Lemma tr_builtin_arg: F sp = Some(sp', ctx.(dstk)) -> Mem.inject F m m' -> forall a v, - eval_builtin_arg ge (fun r => rs#r) (Vptr sp Int.zero) m a v -> - exists v', eval_builtin_arg tge (fun r => rs'#r) (Vptr sp' Int.zero) m' (sbuiltinarg ctx a) v' + eval_builtin_arg ge (fun r => rs#r) (Vptr sp Ptrofs.zero) m a v -> + exists v', eval_builtin_arg tge (fun r => rs'#r) (Vptr sp' Ptrofs.zero) m' (sbuiltinarg ctx a) v' /\ Val.inject F v v'. Proof. intros until m'; intros MG AG SP MI. induction 1; simpl. @@ -422,20 +422,20 @@ Proof. - econstructor; eauto with barg. - econstructor; eauto with barg. - exploit Mem.loadv_inject; eauto. - instantiate (1 := Vptr sp' (Int.add ofs (Int.repr (dstk ctx)))). - simpl. econstructor; eauto. rewrite Int.add_zero_l; auto. - intros (v' & A & B). exists v'; split; auto. constructor. simpl. rewrite Int.add_zero_l; auto. -- econstructor; split. constructor. simpl. econstructor; eauto. rewrite ! Int.add_zero_l; auto. + instantiate (1 := Vptr sp' (Ptrofs.add ofs (Ptrofs.repr (dstk ctx)))). + simpl. econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. + intros (v' & A & B). exists v'; split; auto. constructor. simpl. rewrite Ptrofs.add_zero_l; auto. +- econstructor; split. constructor. simpl. econstructor; eauto. rewrite ! Ptrofs.add_zero_l; auto. - assert (Val.inject F (Senv.symbol_address ge id ofs) (Senv.symbol_address tge id ofs)). { unfold Senv.symbol_address; simpl; unfold Genv.symbol_address. rewrite symbols_preserved. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. - inv MG. econstructor. eauto. rewrite Int.add_zero; auto. } + inv MG. econstructor. eauto. rewrite Ptrofs.add_zero; auto. } exploit Mem.loadv_inject; eauto. intros (v' & A & B). exists v'; eauto with barg. - econstructor; split. constructor. unfold Senv.symbol_address; simpl; unfold Genv.symbol_address. rewrite symbols_preserved. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. - inv MG. econstructor. eauto. rewrite Int.add_zero; auto. + inv MG. econstructor. eauto. rewrite Ptrofs.add_zero; auto. - destruct IHeval_builtin_arg1 as (v1 & A1 & B1). destruct IHeval_builtin_arg2 as (v2 & A2 & B2). econstructor; split. eauto with barg. apply Val.longofwords_inject; auto. @@ -448,8 +448,8 @@ Lemma tr_builtin_args: F sp = Some(sp', ctx.(dstk)) -> Mem.inject F m m' -> forall al vl, - eval_builtin_args ge (fun r => rs#r) (Vptr sp Int.zero) m al vl -> - exists vl', eval_builtin_args tge (fun r => rs'#r) (Vptr sp' Int.zero) m' (map (sbuiltinarg ctx) al) vl' + eval_builtin_args ge (fun r => rs#r) (Vptr sp Ptrofs.zero) m al vl -> + exists vl', eval_builtin_args tge (fun r => rs'#r) (Vptr sp' Ptrofs.zero) m' (map (sbuiltinarg ctx) al) vl' /\ Val.inject_list F vl vl'. Proof. induction 5; simpl. @@ -474,24 +474,24 @@ Inductive match_stacks (F: meminj) (m m': mem): (AG: agree_regs F ctx rs rs') (SP: F sp = Some(sp', ctx.(dstk))) (PRIV: range_private F m m' sp' (ctx.(dstk) + ctx.(mstk)) f'.(fn_stacksize)) - (SSZ1: 0 <= f'.(fn_stacksize) < Int.max_unsigned) + (SSZ1: 0 <= f'.(fn_stacksize) < Ptrofs.max_unsigned) (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)) (RES: Ple res ctx.(mreg)) (BELOW: Plt sp' bound), match_stacks F m m' - (Stackframe res f (Vptr sp Int.zero) pc rs :: stk) - (Stackframe (sreg ctx res) f' (Vptr sp' Int.zero) (spc ctx pc) rs' :: stk') + (Stackframe res f (Vptr sp Ptrofs.zero) pc rs :: stk) + (Stackframe (sreg ctx res) f' (Vptr sp' Ptrofs.zero) (spc ctx pc) rs' :: stk') bound | match_stacks_untailcall: forall stk res f' sp' rpc rs' stk' bound ctx (MS: match_stacks_inside F m m' stk stk' f' ctx sp' rs') (PRIV: range_private F m m' sp' ctx.(dstk) f'.(fn_stacksize)) - (SSZ1: 0 <= f'.(fn_stacksize) < Int.max_unsigned) + (SSZ1: 0 <= f'.(fn_stacksize) < Ptrofs.max_unsigned) (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)) (RET: ctx.(retinfo) = Some (rpc, res)) (BELOW: Plt sp' bound), match_stacks F m m' stk - (Stackframe res f' (Vptr sp' Int.zero) rpc rs' :: stk') + (Stackframe res f' (Vptr sp' Ptrofs.zero) rpc rs' :: stk') bound with match_stacks_inside (F: meminj) (m m': mem): @@ -512,7 +512,7 @@ with match_stacks_inside (F: meminj) (m m': mem): (RET: ctx.(retinfo) = Some (spc ctx' pc, sreg ctx' res)) (BELOW: context_below ctx' ctx) (SBELOW: context_stack_call ctx' ctx), - match_stacks_inside F m m' (Stackframe res f (Vptr sp Int.zero) pc rs :: stk) + match_stacks_inside F m m' (Stackframe res f (Vptr sp Ptrofs.zero) pc rs :: stk) stk' f' ctx sp' rs'. (** Properties of match_stacks *) @@ -863,10 +863,10 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := (MINJ: Mem.inject F m m') (VB: Mem.valid_block m' sp') (PRIV: range_private F m m' sp' (ctx.(dstk) + ctx.(mstk)) f'.(fn_stacksize)) - (SSZ1: 0 <= f'.(fn_stacksize) < Int.max_unsigned) + (SSZ1: 0 <= f'.(fn_stacksize) < Ptrofs.max_unsigned) (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)), - match_states (State stk f (Vptr sp Int.zero) pc rs m) - (State stk' f' (Vptr sp' Int.zero) (spc ctx pc) rs' m') + match_states (State stk f (Vptr sp Ptrofs.zero) pc rs m) + (State stk' f' (Vptr sp' Ptrofs.zero) (spc ctx pc) rs' m') | match_call_states: forall stk fd args m stk' fd' args' m' cunit F (MS: match_stacks F m m' stk stk' (Mem.nextblock m')) (LINK: linkorder cunit prog) @@ -886,10 +886,10 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := (MINJ: Mem.inject F m m') (VB: Mem.valid_block m' sp') (PRIV: range_private F m m' sp' ctx.(dstk) f'.(fn_stacksize)) - (SSZ1: 0 <= f'.(fn_stacksize) < Int.max_unsigned) + (SSZ1: 0 <= f'.(fn_stacksize) < Ptrofs.max_unsigned) (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)), match_states (Callstate stk (Internal f) vargs m) - (State stk' f' (Vptr sp' Int.zero) pc' rs' m') + (State stk' f' (Vptr sp' Ptrofs.zero) pc' rs' m') | match_return_states: forall stk v m stk' v' m' F (MS: match_stacks F m m' stk stk' (Mem.nextblock m')) (VINJ: Val.inject F v v') @@ -904,10 +904,10 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := (MINJ: Mem.inject F m m') (VB: Mem.valid_block m' sp') (PRIV: range_private F m m' sp' ctx.(dstk) f'.(fn_stacksize)) - (SSZ1: 0 <= f'.(fn_stacksize) < Int.max_unsigned) + (SSZ1: 0 <= f'.(fn_stacksize) < Ptrofs.max_unsigned) (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)), match_states (Returnstate stk v m) - (State stk' f' (Vptr sp' Int.zero) pc' rs' m'). + (State stk' f' (Vptr sp' Ptrofs.zero) pc' rs' m'). (** ** Forward simulation *) @@ -964,7 +964,7 @@ Proof. eauto. fold (saddr ctx addr). intros [a' [P Q]]. exploit Mem.loadv_inject; eauto. intros [v' [U V]]. - assert (eval_addressing tge (Vptr sp' Int.zero) (saddr ctx addr) rs' ## (sregs ctx args) = Some a'). + assert (eval_addressing tge (Vptr sp' Ptrofs.zero) (saddr ctx addr) rs' ## (sregs ctx args) = Some a'). rewrite <- P. apply eval_addressing_preserved. exact symbols_preserved. left; econstructor; split. eapply plus_one. eapply exec_Iload; eauto. @@ -982,7 +982,7 @@ Proof. fold saddr. intros [a' [P Q]]. exploit Mem.storev_mapped_inject; eauto. eapply agree_val_reg; eauto. intros [m1' [U V]]. - assert (eval_addressing tge (Vptr sp' Int.zero) (saddr ctx addr) rs' ## (sregs ctx args) = Some a'). + assert (eval_addressing tge (Vptr sp' Ptrofs.zero) (saddr ctx addr) rs' ## (sregs ctx args) = Some a'). rewrite <- P. apply eval_addressing_preserved. exact symbols_preserved. left; econstructor; split. eapply plus_one. eapply exec_Istore; eauto. diff --git a/backend/Inliningspec.v b/backend/Inliningspec.v index f56d6d18..331f8b06 100644 --- a/backend/Inliningspec.v +++ b/backend/Inliningspec.v @@ -693,7 +693,7 @@ Inductive tr_function: program -> function -> function -> Prop := f'.(fn_sig) = f.(fn_sig) -> f'.(fn_params) = sregs ctx f.(fn_params) -> f'.(fn_entrypoint) = spc ctx f.(fn_entrypoint) -> - 0 <= fn_stacksize f' < Int.max_unsigned -> + 0 <= fn_stacksize f' < Ptrofs.max_unsigned -> tr_function p f f'. Lemma tr_function_linkorder: @@ -713,7 +713,7 @@ Proof. intros. unfold transf_function in H. set (fenv := funenv_program cunit) in *. destruct (expand_function fenv f initstate) as [ctx s i] eqn:?. - destruct (zlt (st_stksize s) Int.max_unsigned); inv H. + destruct (zlt (st_stksize s) Ptrofs.max_unsigned); inv H. monadInv Heqr. set (ctx := initcontext x x0 (max_reg_function f) (fn_stacksize f)) in *. Opaque initstate. destruct INCR3. inversion EQ1. inversion EQ. diff --git a/backend/LTL.v b/backend/LTL.v index 5f7116ae..8567a891 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -15,18 +15,9 @@ LTL (``Location Transfer Language'') is the target language for register allocation and the source language for linearization. *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Events. -Require Import Memory. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import Conventions. +Require Import Coqlib Maps. +Require Import AST Integers Values Events Memory Globalenvs Smallstep. +Require Import Op Locations Conventions. (** * Abstract syntax *) @@ -233,7 +224,7 @@ Inductive step: state -> trace -> state -> Prop := find_function ros rs' = Some fd -> funsig fd = sig -> Mem.free m sp 0 f.(fn_stacksize) = Some m' -> - step (Block s f (Vptr sp Int.zero) (Ltailcall sig ros :: bb) rs m) + step (Block s f (Vptr sp Ptrofs.zero) (Ltailcall sig ros :: bb) rs m) E0 (Callstate s fd rs' m') | exec_Lbuiltin: forall s f sp ef args res bb rs m vargs t vres rs' m', eval_builtin_args ge rs sp m args vargs -> @@ -258,13 +249,13 @@ Inductive step: state -> trace -> state -> Prop := E0 (State s f sp pc rs' m) | exec_Lreturn: forall s f sp bb rs m m', Mem.free m sp 0 f.(fn_stacksize) = Some m' -> - step (Block s f (Vptr sp Int.zero) (Lreturn :: bb) rs m) + step (Block s f (Vptr sp Ptrofs.zero) (Lreturn :: bb) rs m) E0 (Returnstate s (return_regs (parent_locset s) rs) m') | exec_function_internal: forall s f rs m m' sp rs', Mem.alloc m 0 f.(fn_stacksize) = (m', sp) -> rs' = undef_regs destroyed_at_function_entry (call_regs rs) -> step (Callstate s (Internal f) rs m) - E0 (State s f (Vptr sp Int.zero) f.(fn_entrypoint) rs' m') + E0 (State s f (Vptr sp Ptrofs.zero) f.(fn_entrypoint) rs' m') | exec_function_external: forall s ef t args res rs m rs' m', args = map (fun p => Locmap.getpair p rs) (loc_arguments (ef_sig ef)) -> external_call ef ge args m t res m' -> diff --git a/backend/Linear.v b/backend/Linear.v index da1b4c04..55f92d16 100644 --- a/backend/Linear.v +++ b/backend/Linear.v @@ -17,17 +17,8 @@ instructions with explicit labels and ``goto'' instructions. *) Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import LTL. -Require Import Conventions. +Require Import AST Integers Values Memory Events Globalenvs Smallstep. +Require Import Op Locations LTL Conventions. (** * Abstract syntax *) @@ -194,7 +185,7 @@ Inductive step: state -> trace -> state -> Prop := find_function ros rs' = Some f' -> sig = funsig f' -> Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - step (State s f (Vptr stk Int.zero) (Ltailcall sig ros :: b) rs m) + step (State s f (Vptr stk Ptrofs.zero) (Ltailcall sig ros :: b) rs m) E0 (Callstate s f' rs' m') | exec_Lbuiltin: forall s f sp rs m ef args res b vargs t vres rs' m', @@ -236,14 +227,14 @@ Inductive step: state -> trace -> state -> Prop := | exec_Lreturn: forall s f stk b rs m m', Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - step (State s f (Vptr stk Int.zero) (Lreturn :: b) rs m) + step (State s f (Vptr stk Ptrofs.zero) (Lreturn :: b) rs m) E0 (Returnstate s (return_regs (parent_locset s) rs) m') | exec_function_internal: forall s f rs m rs' m' stk, Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> rs' = undef_regs destroyed_at_function_entry (call_regs rs) -> step (Callstate s (Internal f) rs m) - E0 (State s f (Vptr stk Int.zero) f.(fn_code) rs' m') + E0 (State s f (Vptr stk Ptrofs.zero) f.(fn_code) rs' m') | exec_function_external: forall s ef args res rs1 rs2 m t m', args = map (fun p => Locmap.getpair p rs1) (loc_arguments (ef_sig ef)) -> diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index 123c6b5a..e13ffb40 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -164,7 +164,7 @@ Proof. intros. generalize (loc_result_pair sg) (loc_result_type sg). destruct (loc_result sg); simpl Locmap.setpair. - intros. apply wt_setreg; auto. eapply Val.has_subtype; eauto. -- intros (A & B & C & D) E. +- intros (A & B & C & D & E) F. apply wt_setreg. eapply Val.has_subtype; eauto. destruct v; exact I. apply wt_setreg. eapply Val.has_subtype; eauto. destruct v; exact I. auto. @@ -267,6 +267,7 @@ Qed. Theorem step_type_preservation: forall S1 t S2, step ge S1 t S2 -> wt_state S1 -> wt_state S2. Proof. +Local Opaque mreg_type. induction 1; intros WTS; inv WTS. - (* getstack *) simpl in *; InvBooleans. diff --git a/backend/Mach.v b/backend/Mach.v index 3e15c97c..212088f3 100644 --- a/backend/Mach.v +++ b/backend/Mach.v @@ -52,9 +52,9 @@ Require Stacklayout. Definition label := positive. Inductive instruction: Type := - | Mgetstack: int -> typ -> mreg -> instruction - | Msetstack: mreg -> int -> typ -> instruction - | Mgetparam: int -> typ -> mreg -> instruction + | Mgetstack: ptrofs -> typ -> mreg -> instruction + | Msetstack: mreg -> ptrofs -> typ -> instruction + | Mgetparam: ptrofs -> typ -> mreg -> instruction | Mop: operation -> list mreg -> mreg -> instruction | Mload: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Mstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction @@ -73,8 +73,8 @@ Record function: Type := mkfunction { fn_sig: signature; fn_code: code; fn_stacksize: Z; - fn_link_ofs: int; - fn_retaddr_ofs: int }. + fn_link_ofs: ptrofs; + fn_retaddr_ofs: ptrofs }. Definition fundef := AST.fundef function. @@ -118,11 +118,11 @@ value of the return address that the Asm code generated later will store in the reserved location. *) -Definition load_stack (m: mem) (sp: val) (ty: typ) (ofs: int) := - Mem.loadv (chunk_of_type ty) m (Val.add sp (Vint ofs)). +Definition load_stack (m: mem) (sp: val) (ty: typ) (ofs: ptrofs) := + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr sp ofs). -Definition store_stack (m: mem) (sp: val) (ty: typ) (ofs: int) (v: val) := - Mem.storev (chunk_of_type ty) m (Val.add sp (Vint ofs)) v. +Definition store_stack (m: mem) (sp: val) (ty: typ) (ofs: ptrofs) (v: val) := + Mem.storev (chunk_of_type ty) m (Val.offset_ptr sp ofs) v. Module RegEq. Definition t := mreg. @@ -198,7 +198,7 @@ Qed. Section RELSEM. -Variable return_address_offset: function -> code -> int -> Prop. +Variable return_address_offset: function -> code -> ptrofs -> Prop. Variable ge: genv. @@ -207,7 +207,7 @@ Definition find_function_ptr match ros with | inl r => match rs r with - | Vptr b ofs => if Int.eq ofs Int.zero then Some b else None + | Vptr b ofs => if Ptrofs.eq ofs Ptrofs.zero then Some b else None | _ => None end | inr symb => @@ -220,7 +220,7 @@ Inductive extcall_arg (rs: regset) (m: mem) (sp: val): loc -> val -> Prop := | extcall_arg_reg: forall r, extcall_arg rs m sp (R r) (rs r) | extcall_arg_stack: forall ofs ty v, - load_stack m sp ty (Int.repr (Stacklayout.fe_ofs_arg + 4 * ofs)) = Some v -> + load_stack m sp ty (Ptrofs.repr (Stacklayout.fe_ofs_arg + 4 * ofs)) = Some v -> extcall_arg rs m sp (S Outgoing ofs ty) v. Inductive extcall_arg_pair (rs: regset) (m: mem) (sp: val): rpair loc -> val -> Prop := @@ -271,13 +271,13 @@ Inductive state: Type := Definition parent_sp (s: list stackframe) : val := match s with - | nil => Vzero + | nil => Vnullptr | Stackframe f sp ra c :: s' => sp end. Definition parent_ra (s: list stackframe) : val := match s with - | nil => Vzero + | nil => Vnullptr | Stackframe f sp ra c :: s' => ra end. @@ -300,7 +300,7 @@ Inductive step: state -> trace -> state -> Prop := | exec_Mgetparam: forall s fb f sp ofs ty dst c rs m v rs', Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m sp Tint f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m sp Tptr f.(fn_link_ofs) = Some (parent_sp s) -> load_stack m (parent_sp s) ty ofs = Some v -> rs' = (rs # temp_for_parent_frame <- Vundef # dst <- v) -> step (State s fb sp (Mgetparam ofs ty dst :: c) rs m) @@ -337,8 +337,8 @@ Inductive step: state -> trace -> state -> Prop := forall s fb stk soff sig ros c rs m f f' m', find_function_ptr ge ros rs = Some f' -> Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> - load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> Mem.free m stk 0 f.(fn_stacksize) = Some m' -> step (State s fb (Vptr stk soff) (Mtailcall sig ros :: c) rs m) E0 (Callstate s f' rs m') @@ -381,8 +381,8 @@ Inductive step: state -> trace -> state -> Prop := | exec_Mreturn: forall s fb stk soff c rs m f m', Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> - load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> Mem.free m stk 0 f.(fn_stacksize) = Some m' -> step (State s fb (Vptr stk soff) (Mreturn :: c) rs m) E0 (Returnstate s rs m') @@ -390,9 +390,9 @@ Inductive step: state -> trace -> state -> Prop := forall s fb rs m f m1 m2 m3 stk rs', Genv.find_funct_ptr ge fb = Some (Internal f) -> Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> - let sp := Vptr stk Int.zero 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 -> + let sp := Vptr stk Ptrofs.zero in + store_stack m1 sp Tptr f.(fn_link_ofs) (parent_sp s) = Some m2 -> + store_stack m2 sp Tptr f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> rs' = undef_regs destroyed_at_function_entry rs -> step (Callstate s fb rs m) E0 (State s fb sp f.(fn_code) rs' m3) @@ -424,5 +424,5 @@ Inductive final_state: state -> int -> Prop := rs r = Vint retcode -> final_state (Returnstate nil rs m) retcode. -Definition semantics (rao: function -> code -> int -> Prop) (p: program) := +Definition semantics (rao: function -> code -> ptrofs -> Prop) (p: program) := Semantics (step rao) (initial_state p) final_state (Genv.globalenv p). diff --git a/backend/NeedDomain.v b/backend/NeedDomain.v index 442352e7..a53040f9 100644 --- a/backend/NeedDomain.v +++ b/backend/NeedDomain.v @@ -379,6 +379,7 @@ Ltac InvAgree := match goal with | [ H: False |- _ ] => contradiction | [ H: match ?v with Vundef => _ | Vint _ => _ | Vlong _ => _ | Vfloat _ => _ | Vsingle _ => _ | Vptr _ _ => _ end |- _ ] => destruct v + | [ |- context [if Archi.ptr64 then _ else _] ] => destruct Archi.ptr64 eqn:? end). (** And immediate, or immediate *) @@ -608,7 +609,8 @@ Lemma add_sound: Proof. unfold modarith; intros. destruct x; simpl in *. - auto. -- unfold Val.add; InvAgree. apply eqmod_iagree. apply Int.eqmod_add; apply iagree_eqmod; auto. +- unfold Val.add; InvAgree. + apply eqmod_iagree. apply Int.eqmod_add; apply iagree_eqmod; auto. - inv H; auto. inv H0; auto. destruct w1; auto. Qed. @@ -802,20 +804,20 @@ Hypothesis PERM: forall b ofs k p, Mem.perm m1 b ofs k p -> Mem.perm m2 b ofs k Let valid_pointer_inj: forall b1 ofs b2 delta, inject_id b1 = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Proof. - unfold inject_id; intros. inv H. rewrite Int.add_zero. + unfold inject_id; intros. inv H. rewrite Ptrofs.add_zero. rewrite Mem.valid_pointer_nonempty_perm in *. eauto. Qed. Let weak_valid_pointer_inj: forall b1 ofs b2 delta, inject_id b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Proof. - unfold inject_id; intros. inv H. rewrite Int.add_zero. + unfold inject_id; intros. inv H. rewrite Ptrofs.add_zero. rewrite Mem.weak_valid_pointer_spec in *. rewrite ! Mem.valid_pointer_nonempty_perm in *. destruct H0; [left|right]; eauto. @@ -824,21 +826,21 @@ Qed. Let weak_valid_pointer_no_overflow: forall b1 ofs b2 delta, inject_id b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. Proof. - unfold inject_id; intros. inv H. rewrite Zplus_0_r. apply Int.unsigned_range_2. + unfold inject_id; intros. inv H. rewrite Zplus_0_r. apply Ptrofs.unsigned_range_2. Qed. Let valid_different_pointers_inj: forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, b1 <> b2 -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> inject_id b1 = Some (b1', delta1) -> inject_id b2 = Some (b2', delta2) -> b1' <> b2' \/ - Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)). + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). Proof. unfold inject_id; intros. left; congruence. Qed. @@ -855,13 +857,13 @@ Qed. Lemma default_needs_of_operation_sound: forall op args1 v1 args2 nv, - eval_operation ge (Vptr sp Int.zero) op args1 m1 = Some v1 -> + eval_operation ge (Vptr sp Ptrofs.zero) op args1 m1 = Some v1 -> vagree_list args1 args2 nil \/ vagree_list args1 args2 (default nv :: nil) \/ vagree_list args1 args2 (default nv :: default nv :: nil) -> nv <> Nothing -> exists v2, - eval_operation ge (Vptr sp Int.zero) op args2 m2 = Some v2 + eval_operation ge (Vptr sp Ptrofs.zero) op args2 m2 = Some v2 /\ vagree v1 v2 nv. Proof. intros. assert (default nv = All) by (destruct nv; simpl; congruence). @@ -875,7 +877,7 @@ Proof. exploit (@eval_operation_inj _ _ _ _ ge ge inject_id). eassumption. auto. auto. auto. instantiate (1 := op). intros. apply val_inject_lessdef; auto. - apply val_inject_lessdef. instantiate (1 := Vptr sp Int.zero). instantiate (1 := Vptr sp Int.zero). auto. + apply val_inject_lessdef. instantiate (1 := Vptr sp Ptrofs.zero). instantiate (1 := Vptr sp Ptrofs.zero). auto. apply val_inject_list_lessdef; eauto. eauto. intros (v2 & A & B). exists v2; split; auto. @@ -1135,13 +1137,13 @@ Definition nmem_add (nm: nmem) (p: aptr) (sz: Z) : nmem := match p with | Gl id ofs => match gl!id with - | Some iv => NMem stk (PTree.set id (ISet.remove (Int.unsigned ofs) (Int.unsigned ofs + sz) iv) gl) + | Some iv => NMem stk (PTree.set id (ISet.remove (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) iv) gl) | None => nm end | Glo id => NMem stk (PTree.remove id gl) | Stk ofs => - NMem (ISet.remove (Int.unsigned ofs) (Int.unsigned ofs + sz) stk) gl + NMem (ISet.remove (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) stk) gl | Stack => NMem ISet.empty gl | _ => nmem_all @@ -1153,7 +1155,7 @@ Lemma nlive_add: genv_match bc ge -> bc sp = BCstack -> pmatch bc b ofs p -> - Int.unsigned ofs <= i < Int.unsigned ofs + sz -> + Ptrofs.unsigned ofs <= i < Ptrofs.unsigned ofs + sz -> nlive (nmem_add nm p sz) b i. Proof. intros. unfold nmem_add. destruct nm. apply nlive_all. @@ -1221,12 +1223,12 @@ Definition nmem_remove (nm: nmem) (p: aptr) (sz: Z) : nmem := | Gl id ofs => let iv' := match gl!id with - | Some iv => ISet.add (Int.unsigned ofs) (Int.unsigned ofs + sz) iv - | None => ISet.interval (Int.unsigned ofs) (Int.unsigned ofs + sz) + | Some iv => ISet.add (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) iv + | None => ISet.interval (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) end in NMem stk (PTree.set id iv' gl) | Stk ofs => - NMem (ISet.add (Int.unsigned ofs) (Int.unsigned ofs + sz) stk) gl + NMem (ISet.add (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) stk) gl | _ => nm end end. @@ -1237,17 +1239,17 @@ Lemma nlive_remove: bc sp = BCstack -> pmatch bc b ofs p -> nlive nm b' i -> - b' <> b \/ i < Int.unsigned ofs \/ Int.unsigned ofs + sz <= i -> + b' <> b \/ i < Ptrofs.unsigned ofs \/ Ptrofs.unsigned ofs + sz <= i -> nlive (nmem_remove nm p sz) b' i. Proof. intros. inversion H2; subst. unfold nmem_remove; inv H1; auto. - (* Gl id ofs *) set (iv' := match gl!id with | Some iv => - ISet.add (Int.unsigned ofs) (Int.unsigned ofs + sz) iv + ISet.add (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) iv | None => - ISet.interval (Int.unsigned ofs) - (Int.unsigned ofs + sz) + ISet.interval (Ptrofs.unsigned ofs) + (Ptrofs.unsigned ofs + sz) end). assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto). split; simpl; auto; intros. @@ -1272,11 +1274,11 @@ Definition nmem_contains (nm: nmem) (p: aptr) (sz: Z) := match p with | Gl id ofs => match gl!id with - | Some iv => negb (ISet.contains (Int.unsigned ofs) (Int.unsigned ofs + sz) iv) + | Some iv => negb (ISet.contains (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) iv) | None => true end | Stk ofs => - negb (ISet.contains (Int.unsigned ofs) (Int.unsigned ofs + sz) stk) + negb (ISet.contains (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) stk) | _ => true (**r conservative answer *) end end. @@ -1287,7 +1289,7 @@ Lemma nlive_contains: bc sp = BCstack -> pmatch bc b ofs p -> nmem_contains nm p sz = false -> - Int.unsigned ofs <= i < Int.unsigned ofs + sz -> + Ptrofs.unsigned ofs <= i < Ptrofs.unsigned ofs + sz -> ~(nlive nm b i). Proof. unfold nmem_contains; intros. red; intros L; inv L. @@ -1295,10 +1297,10 @@ Proof. - (* Gl id ofs *) assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto). destruct gl!id as [iv|] eqn:HG; inv H2. - destruct (ISet.contains (Int.unsigned ofs) (Int.unsigned ofs + sz) iv) eqn:IC; try discriminate. + destruct (ISet.contains (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) iv) eqn:IC; try discriminate. rewrite ISet.contains_spec in IC. eelim GL; eauto. - (* Stk ofs *) - destruct (ISet.contains (Int.unsigned ofs) (Int.unsigned ofs + sz) stk) eqn:IC; try discriminate. + destruct (ISet.contains (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + sz) stk) eqn:IC; try discriminate. rewrite ISet.contains_spec in IC. eelim STK; eauto. eapply bc_stack; eauto. Qed. diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 148c5300..b220659c 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -138,6 +138,9 @@ let cfi_section = let coqint oc n = fprintf oc "%ld" (camlint_of_coqint n) +let coqint64 oc n = + fprintf oc "%Ld" (camlint64_of_coqint n) + (** Programmer-supplied annotations (__builtin_annot). *) let re_annot_param = Str.regexp "%%\\|%[1-9][0-9]*" diff --git a/backend/RTL.v b/backend/RTL.v index a39d37cb..d191918c 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -16,17 +16,9 @@ intermediate language after Cminor and CminorSel. *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Events. -Require Import Memory. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Registers. +Require Import Coqlib Maps. +Require Import AST Integers Values Events Memory Globalenvs Smallstep. +Require Import Op Registers. (** * Abstract syntax *) @@ -246,7 +238,7 @@ Inductive step: state -> trace -> state -> Prop := find_function ros rs = Some fd -> funsig fd = sig -> Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - step (State s f (Vptr stk Int.zero) pc rs m) + step (State s f (Vptr stk Ptrofs.zero) pc rs m) E0 (Callstate s fd rs##args m') | exec_Ibuiltin: forall s f sp pc rs m ef args res pc' vargs t vres m', @@ -273,7 +265,7 @@ Inductive step: state -> trace -> state -> Prop := forall s f stk pc rs m or m', (fn_code f)!pc = Some(Ireturn or) -> Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - step (State s f (Vptr stk Int.zero) pc rs m) + step (State s f (Vptr stk Ptrofs.zero) pc rs m) E0 (Returnstate s (regmap_optget or Vundef rs) m') | exec_function_internal: forall s f args m m' stk, @@ -281,7 +273,7 @@ Inductive step: state -> trace -> state -> Prop := step (Callstate s (Internal f) args m) E0 (State s f - (Vptr stk Int.zero) + (Vptr stk Ptrofs.zero) f.(fn_entrypoint) (init_regs args f.(fn_params)) m') diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index dec1b988..f9f01d49 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -73,9 +73,9 @@ Definition type_of_builtin_arg (a: builtin_arg reg) : typ := | BA_float _ => Tfloat | BA_single _ => Tsingle | BA_loadstack chunk ofs => type_of_chunk chunk - | BA_addrstack ofs => Tint + | BA_addrstack ofs => Tptr | BA_loadglobal chunk id ofs => type_of_chunk chunk - | BA_addrglobal id ofs => Tint + | BA_addrglobal id ofs => Tptr | BA_splitlong hi lo => Tlong end. @@ -116,14 +116,14 @@ Inductive wt_instr : instruction -> Prop := wt_instr (Istore chunk addr args src s) | wt_Icall: forall sig ros args res s, - match ros with inl r => env r = Tint | inr s => True end -> + match ros with inl r => env r = Tptr | inr s => True end -> map env args = sig.(sig_args) -> env res = proj_sig_res sig -> valid_successor s -> wt_instr (Icall sig ros args res s) | wt_Itailcall: forall sig ros args, - match ros with inl r => env r = Tint | inr s => True end -> + match ros with inl r => env r = Tptr | inr s => True end -> map env args = sig.(sig_args) -> sig.(sig_res) = funct.(fn_sig).(sig_res) -> tailcall_possible sig -> @@ -227,7 +227,7 @@ Fixpoint check_successors (sl: list node): res unit := Definition type_ros (e: S.typenv) (ros: reg + ident) : res S.typenv := match ros with - | inl r => S.set e r Tint + | inl r => S.set e r Tptr | inr s => OK e end. @@ -245,9 +245,9 @@ Definition type_builtin_arg (e: S.typenv) (a: builtin_arg reg) (ty: typ) : res S | BA_float _ => type_expect e ty Tfloat | BA_single _ => type_expect e ty Tsingle | BA_loadstack chunk ofs => type_expect e ty (type_of_chunk chunk) - | BA_addrstack ofs => type_expect e ty Tint + | BA_addrstack ofs => type_expect e ty Tptr | BA_loadglobal chunk id ofs => type_expect e ty (type_of_chunk chunk) - | BA_addrglobal id ofs => type_expect e ty Tint + | BA_addrglobal id ofs => type_expect e ty Tptr | BA_splitlong hi lo => type_expect e ty Tlong end. @@ -367,7 +367,7 @@ Hint Resolve type_ros_incr: ty. Lemma type_ros_sound: forall e ros e' te, type_ros e ros = OK e' -> S.satisf te e' -> - match ros with inl r => te r = Tint | inr s => True end. + match ros with inl r => te r = Tptr | inr s => True end. Proof. unfold type_ros; intros. destruct ros. eapply S.set_sound; eauto. @@ -594,7 +594,7 @@ Qed. Lemma type_ros_complete: forall te ros e, S.satisf te e -> - match ros with inl r => te r = Tint | inr s => True end -> + match ros with inl r => te r = Tptr | inr s => True end -> exists e', type_ros e ros = OK e' /\ S.satisf te e'. Proof. intros; destruct ros; simpl. diff --git a/backend/Regalloc.ml b/backend/Regalloc.ml index b91bad27..200d0237 100644 --- a/backend/Regalloc.ml +++ b/backend/Regalloc.ml @@ -102,50 +102,61 @@ let parmove_regs2locs tyenv srcs dsts k = assert (List.length srcs = List.length dsts); let rec expand srcs' dsts' rl ll = match rl, ll with - | [], [] -> (srcs', dsts') + | [], [] -> + begin match srcs', dsts' with + | [], [] -> k + | [src], [dst] -> move src dst k + | _, _ -> Xparmove(srcs', dsts', new_temp Tint, new_temp Tfloat) :: k + end | r :: rl, One l :: ll -> let ty = tyenv r in expand (V(r, ty) :: srcs') (L l :: dsts') rl ll | r :: rl, Twolong(l1, l2) :: ll -> assert (tyenv r = Tlong); - expand (V(r, Tint) :: V(twin_reg r, Tint) :: srcs') - (L l1 :: L l2 :: dsts') - rl ll + if Archi.splitlong then + expand (V(r, Tint) :: V(twin_reg r, Tint) :: srcs') + (L l1 :: L l2 :: dsts') + rl ll + else + Xop(Ohighlong, [V(r, Tlong)], L l1) :: + Xop(Olowlong, [V(r, Tlong)], L l2) :: + expand srcs' dsts' rl ll | _, _ -> assert false in - let (srcs', dsts') = expand [] [] srcs dsts in - match srcs', dsts' with - | [], [] -> k - | [src], [dst] -> move src dst k - | _, _ -> Xparmove(srcs', dsts', new_temp Tint, new_temp Tfloat) :: k + expand [] [] srcs dsts let parmove_locs2regs tyenv srcs dsts k = assert (List.length srcs = List.length dsts); let rec expand srcs' dsts' ll rl = match ll, rl with - | [], [] -> (srcs', dsts') + | [], [] -> + begin match srcs', dsts' with + | [], [] -> k + | [src], [dst] -> move src dst k + | _, _ -> Xparmove(srcs', dsts', new_temp Tint, new_temp Tfloat) :: k + end | One l :: ll, r :: rl -> let ty = tyenv r in expand (L l :: srcs') (V(r, ty) :: dsts') ll rl | Twolong(l1, l2) :: ll, r :: rl -> assert (tyenv r = Tlong); - expand (L l1 :: L l2 :: srcs') - (V(r, Tint) :: V(twin_reg r, Tint) :: dsts') - ll rl + if Archi.splitlong then + expand (L l1 :: L l2 :: srcs') + (V(r, Tint) :: V(twin_reg r, Tint) :: dsts') + ll rl + else + Xop(Omakelong, [L l1; L l2], V(r, Tlong)) :: + expand srcs' dsts' ll rl | _, _ -> assert false in - let (srcs', dsts') = expand [] [] srcs dsts in - match srcs', dsts' with - | [], [] -> k - | [src], [dst] -> move src dst k - | _, _ -> Xparmove(srcs', dsts', new_temp Tint, new_temp Tfloat) :: k + expand [] [] srcs dsts let rec convert_builtin_arg tyenv = function | BA r -> - begin match tyenv r with - | Tlong -> BA_splitlong(BA(V(r, Tint)), BA(V(twin_reg r, Tint))) - | ty -> BA(V(r, ty)) - end + let ty = tyenv r in + if Archi.splitlong && ty = Tlong + then BA_splitlong(BA(V(r, Tint)), BA(V(twin_reg r, Tint))) + else BA(V(r, ty)) | BA_int n -> BA_int n | BA_long n -> BA_long n | BA_float n -> BA_float n @@ -159,10 +170,10 @@ let rec convert_builtin_arg tyenv = function let convert_builtin_res tyenv = function | BR r -> - begin match tyenv r with - | Tlong -> BR_splitlong(BR(V(r, Tint)), BR(V(twin_reg r, Tint))) - | ty -> BR(V(r, ty)) - end + let ty = tyenv r in + if Archi.splitlong && ty = Tlong + then BR_splitlong(BR(V(r, Tint)), BR(V(twin_reg r, Tint))) + else BR(V(r, ty)) | BR_none -> BR_none | BR_splitlong _ -> assert false @@ -197,25 +208,26 @@ let rec constrain_builtin_res a cl = (* Return the XTL basic block corresponding to the given RTL instruction. Move and parallel move instructions are introduced to honor calling conventions and register constraints on some operations. - 64-bit integer variables are split in two 32-bit halves. *) + 64-bit integer variables are split in two 32-bit halves + if [Archi.splitlong] is true. *) let block_of_RTL_instr funsig tyenv = function | RTL.Inop s -> [Xbranch s] | RTL.Iop(Omove, [arg], res, s) -> - if tyenv arg = Tlong then + if Archi.splitlong && tyenv arg = Tlong then [Xmove(V(arg, Tint), V(res, Tint)); Xmove(V(twin_reg arg, Tint), V(twin_reg res, Tint)); Xbranch s] else [Xmove(vreg tyenv arg, vreg tyenv res); Xbranch s] - | RTL.Iop(Omakelong, [arg1; arg2], res, s) -> + | RTL.Iop(Omakelong, [arg1; arg2], res, s) when Archi.splitlong -> [Xmove(V(arg1, Tint), V(res, Tint)); Xmove(V(arg2, Tint), V(twin_reg res, Tint)); Xbranch s] - | RTL.Iop(Olowlong, [arg], res, s) -> + | RTL.Iop(Olowlong, [arg], res, s) when Archi.splitlong -> [Xmove(V(twin_reg arg, Tint), V(res, Tint)); Xbranch s] - | RTL.Iop(Ohighlong, [arg], res, s) -> + | RTL.Iop(Ohighlong, [arg], res, s) when Archi.splitlong -> [Xmove(V(arg, Tint), V(res, Tint)); Xbranch s] | RTL.Iop(op, args, res, s) -> let (cargs, cres) = mregs_for_operation op in @@ -232,7 +244,7 @@ let block_of_RTL_instr funsig tyenv = function let t = new_temp (tyenv res) in (t :: args2', t) in movelist args1 args3 (Xop(op, args3, res3) :: move res3 res1 [Xbranch s]) | RTL.Iload(chunk, addr, args, dst, s) -> - if chunk = Mint64 then begin + if Archi.splitlong && chunk = Mint64 then begin match offset_addressing addr (coqint_of_camlint 4l) with | None -> assert false | Some addr' -> @@ -244,7 +256,7 @@ let block_of_RTL_instr funsig tyenv = function end else [Xload(chunk, addr, vregs tyenv args, vreg tyenv dst); Xbranch s] | RTL.Istore(chunk, addr, args, src, s) -> - if chunk = Mint64 then begin + if Archi.splitlong && chunk = Mint64 then begin match offset_addressing addr (coqint_of_camlint 4l) with | None -> assert false | Some addr' -> @@ -1024,10 +1036,8 @@ let make_parmove srcs dsts itmp ftmp k = let n = Array.length src in assert (Array.length dst = n); let status = Array.make n To_move in - let temp_for = - function (Tint|Tany32) -> itmp - | (Tfloat|Tsingle|Tany64) -> ftmp - | Tlong -> assert false in + let temp_for cls = + match cls with 0 -> itmp | 1 -> ftmp | _ -> assert false in let code = ref [] in let add_move s d = match s, d with @@ -1038,7 +1048,7 @@ let make_parmove srcs dsts itmp ftmp k = | Locations.S(sl, ofs, ty), R rd -> code := LTL.Lgetstack(sl, ofs, ty, rd) :: !code | Locations.S(sls, ofss, tys), Locations.S(sld, ofsd, tyd) -> - let tmp = temp_for tys in + let tmp = temp_for (class_of_type tys) in (* code will be reversed at the end *) code := LTL.Lsetstack(tmp, sld, ofsd, tyd) :: LTL.Lgetstack(sls, ofss, tys, tmp) :: !code @@ -1052,7 +1062,7 @@ let make_parmove srcs dsts itmp ftmp k = | To_move -> move_one j | Being_moved -> - let tmp = R (temp_for (Loc.coq_type src.(j))) in + let tmp = R (temp_for (class_of_loc src.(j))) in add_move src.(j) tmp; src.(j) <- tmp | Moved -> diff --git a/backend/SelectDiv.vp b/backend/SelectDiv.vp index a275a850..5cc66322 100644 --- a/backend/SelectDiv.vp +++ b/backend/SelectDiv.vp @@ -14,12 +14,8 @@ Require Import Coqlib. Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Op. -Require Import CminorSel. -Require Import SelectOp. +Require Import AST Integers Floats. +Require Import Op CminorSel SelectOp SplitLong SelectLong. Open Local Scope cminorsel_scope. @@ -36,7 +32,7 @@ Fixpoint find_div_mul_params (fuel: nat) (nc: Z) (d: Z) (p: Z) : option (Z * Z) | S fuel' => let twp := two_p p in if zlt (nc * (d - twp mod d)) twp - then Some(p - 32, (twp + d - twp mod d) / d) + then Some(p, (twp + d - twp mod d) / d) else find_div_mul_params fuel' nc d (p + 1) end. @@ -47,6 +43,7 @@ Definition divs_mul_params (d: Z) : option (Z * Z) := d 32 with | None => None | Some(p, m) => + let p := p - 32 in if zlt 0 d && zlt (two_p (32 + p)) (m * d) && zle (m * d) (two_p (32 + p) + two_p (p + 1)) @@ -62,6 +59,7 @@ Definition divu_mul_params (d: Z) : option (Z * Z) := d 32 with | None => None | Some(p, m) => + let p := p - 32 in if zlt 0 d && zle (two_p (32 + p)) (m * d) && zle (m * d) (two_p (32 + p) + two_p p) @@ -70,6 +68,38 @@ Definition divu_mul_params (d: Z) : option (Z * Z) := then Some(p, m) else None end. +Definition divls_mul_params (d: Z) : option (Z * Z) := + match find_div_mul_params + Int64.wordsize + (Int64.half_modulus - Int64.half_modulus mod d - 1) + d 64 with + | None => None + | Some(p, m) => + let p := p - 64 in + if zlt 0 d + && zlt (two_p (64 + p)) (m * d) + && zle (m * d) (two_p (64 + p) + two_p (p + 1)) + && zle 0 m && zlt m Int64.modulus + && zle 0 p && zlt p 64 + then Some(p, m) else None + end. + +Definition divlu_mul_params (d: Z) : option (Z * Z) := + match find_div_mul_params + Int64.wordsize + (Int64.modulus - Int64.modulus mod d - 1) + d 64 with + | None => None + | Some(p, m) => + let p := p - 64 in + if zlt 0 d + && zle (two_p (64 + p)) (m * d) + && zle (m * d) (two_p (64 + p) + two_p p) + && zle 0 m && zlt m Int64.modulus + && zle 0 p && zlt p 64 + then Some(p, m) else None + end. + Definition divu_mul (p: Z) (m: Z) := shruimm (Eop Omulhu (Eletvar O ::: Eop (Ointconst (Int.repr m)) Enil ::: Enil)) (Int.repr p). @@ -167,6 +197,100 @@ Nondetfunction mods (e1: expr) (e2: expr) := | _ => mods_base e1 e2 end. +(** 64-bit integer divisions *) + +Section SELECT. + +Context {hf: helper_functions}. + +Definition modl_from_divl (equo: expr) (n: int64) := + subl (Eletvar O) (mullimm n equo). + +Definition divlu_mull (p: Z) (m: Z) := + shrluimm (mullhu (Eletvar O) (Int64.repr m)) (Int.repr p). + +Definition divlu (e1 e2: expr) := + match is_longconst e2, is_longconst e1 with + | Some n2, Some n1 => longconst (Int64.divu n1 n2) + | Some n2, _ => + match Int64.is_power2' n2 with + | Some l => shrluimm e1 l + | None => if optim_for_size tt then + divlu_base e1 e2 + else + match divlu_mul_params (Int64.unsigned n2) with + | None => divlu_base e1 e2 + | Some(p, m) => Elet e1 (divlu_mull p m) + end + end + | _, _ => divlu_base e1 e2 + end. + +Definition modlu (e1 e2: expr) := + match is_longconst e2, is_longconst e1 with + | Some n2, Some n1 => longconst (Int64.modu n1 n2) + | Some n2, _ => + match Int64.is_power2 n2 with + | Some l => andl e1 (longconst (Int64.sub n2 Int64.one)) + | None => if optim_for_size tt then + modlu_base e1 e2 + else + match divlu_mul_params (Int64.unsigned n2) with + | None => modlu_base e1 e2 + | Some(p, m) => Elet e1 (modl_from_divl (divlu_mull p m) n2) + end + end + | _, _ => modlu_base e1 e2 + end. + +Definition divls_mull (p: Z) (m: Z) := + let e2 := + mullhs (Eletvar O) (Int64.repr m) in + let e3 := + if zlt m Int64.half_modulus then e2 else addl e2 (Eletvar O) in + addl (shrlimm e3 (Int.repr p)) + (shrluimm (Eletvar O) (Int.repr (Int64.zwordsize - 1))). + +Definition divls (e1 e2: expr) := + match is_longconst e2, is_longconst e1 with + | Some n2, Some n1 => longconst (Int64.divs n1 n2) + | Some n2, _ => + match Int64.is_power2' n2 with + | Some l => if Int.ltu l (Int.repr 63) + then shrxlimm e1 l + else divls_base e1 e2 + | None => if optim_for_size tt then + divls_base e1 e2 + else + match divls_mul_params (Int64.signed n2) with + | None => divls_base e1 e2 + | Some(p, m) => Elet e1 (divls_mull p m) + end + end + | _, _ => divls_base e1 e2 + end. + +Definition modls (e1 e2: expr) := + match is_longconst e2, is_longconst e1 with + | Some n2, Some n1 => longconst (Int64.mods n1 n2) + | Some n2, _ => + match Int64.is_power2' n2 with + | Some l => if Int.ltu l (Int.repr 63) + then Elet e1 (modl_from_divl (shrxlimm (Eletvar O) l) n2) + else modls_base e1 e2 + | None => if optim_for_size tt then + modls_base e1 e2 + else + match divls_mul_params (Int64.signed n2) with + | None => modls_base e1 e2 + | Some(p, m) => Elet e1 (modl_from_divl (divls_mull p m) n2) + end + end + | _, _ => modls_base e1 e2 + end. + +End SELECT. + (** Floating-point division by a constant can also be turned into a FP multiplication by the inverse constant, but only for powers of 2. *) diff --git a/backend/SelectDivproof.v b/backend/SelectDivproof.v index ffe607e4..3180a55d 100644 --- a/backend/SelectDivproof.v +++ b/backend/SelectDivproof.v @@ -12,21 +12,10 @@ (** Correctness of instruction selection for integer division *) -Require Import Coqlib. -Require Import Zquot. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Cminor. -Require Import Op. -Require Import CminorSel. -Require Import SelectOp. -Require Import SelectOpproof. -Require Import SelectDiv. +Require Import Zquot Coqlib. +Require Import AST Integers Floats Values Memory Globalenvs Events. +Require Import Cminor Op CminorSel. +Require Import SelectOp SelectOpproof SplitLong SplitLongproof SelectLong SelectLongproof SelectDiv. Open Local Scope cminorsel_scope. @@ -191,18 +180,19 @@ Lemma divs_mul_params_sound: Int.min_signed <= n <= Int.max_signed -> Z.quot n d = Zdiv (m * n) (two_p (32 + p)) + (if zlt n 0 then 1 else 0). Proof with (try discriminate). - unfold divs_mul_params; intros d m' p' EQ. + unfold divs_mul_params; intros d m' p'. destruct (find_div_mul_params Int.wordsize (Int.half_modulus - Int.half_modulus mod d - 1) d 32) as [[p m] | ]... + generalize (p - 32). intro p1. destruct (zlt 0 d)... - destruct (zlt (two_p (32 + p)) (m * d))... - destruct (zle (m * d) (two_p (32 + p) + two_p (p + 1)))... + destruct (zlt (two_p (32 + p1)) (m * d))... + destruct (zle (m * d) (two_p (32 + p1) + two_p (p1 + 1)))... destruct (zle 0 m)... destruct (zlt m Int.modulus)... - destruct (zle 0 p)... - destruct (zlt p 32)... - simpl in EQ. inv EQ. + destruct (zle 0 p1)... + destruct (zlt p1 32)... + intros EQ; inv EQ. split. auto. split. auto. intros. replace (32 + p') with (31 + (p' + 1)) by omega. apply Zquot_mul; try omega. @@ -219,18 +209,19 @@ Lemma divu_mul_params_sound: 0 <= n < Int.modulus -> Zdiv n d = Zdiv (m * n) (two_p (32 + p)). Proof with (try discriminate). - unfold divu_mul_params; intros d m' p' EQ. + unfold divu_mul_params; intros d m' p'. destruct (find_div_mul_params Int.wordsize (Int.modulus - Int.modulus mod d - 1) d 32) as [[p m] | ]... + generalize (p - 32); intro p1. destruct (zlt 0 d)... - destruct (zle (two_p (32 + p)) (m * d))... - destruct (zle (m * d) (two_p (32 + p) + two_p p))... + destruct (zle (two_p (32 + p1)) (m * d))... + destruct (zle (m * d) (two_p (32 + p1) + two_p p1))... destruct (zle 0 m)... destruct (zlt m Int.modulus)... - destruct (zle 0 p)... - destruct (zlt p 32)... - simpl in EQ. inv EQ. + destruct (zle 0 p1)... + destruct (zlt p1 32)... + intros EQ; inv EQ. split. auto. split. auto. intros. apply Zdiv_mul_pos; try omega. assumption. Qed. @@ -326,11 +317,173 @@ Proof. assert (32 < Int.max_unsigned) by (compute; auto). omega. Qed. +(** Same, for 64-bit integers *) + +Lemma divls_mul_params_sound: + forall d m p, + divls_mul_params d = Some(p, m) -> + 0 <= m < Int64.modulus /\ 0 <= p < 64 /\ + forall n, + Int64.min_signed <= n <= Int64.max_signed -> + Z.quot n d = Zdiv (m * n) (two_p (64 + p)) + (if zlt n 0 then 1 else 0). +Proof with (try discriminate). + unfold divls_mul_params; intros d m' p'. + destruct (find_div_mul_params Int64.wordsize + (Int64.half_modulus - Int64.half_modulus mod d - 1) d 64) + as [[p m] | ]... + generalize (p - 64). intro p1. + destruct (zlt 0 d)... + destruct (zlt (two_p (64 + p1)) (m * d))... + destruct (zle (m * d) (two_p (64 + p1) + two_p (p1 + 1)))... + destruct (zle 0 m)... + destruct (zlt m Int64.modulus)... + destruct (zle 0 p1)... + destruct (zlt p1 64)... + intros EQ; inv EQ. + split. auto. split. auto. intros. + replace (64 + p') with (63 + (p' + 1)) by omega. + apply Zquot_mul; try omega. + replace (63 + (p' + 1)) with (64 + p') by omega. omega. + change (Int64.min_signed <= n < Int64.half_modulus). + unfold Int64.max_signed in H. omega. +Qed. + +Lemma divlu_mul_params_sound: + forall d m p, + divlu_mul_params d = Some(p, m) -> + 0 <= m < Int64.modulus /\ 0 <= p < 64 /\ + forall n, + 0 <= n < Int64.modulus -> + Zdiv n d = Zdiv (m * n) (two_p (64 + p)). +Proof with (try discriminate). + unfold divlu_mul_params; intros d m' p'. + destruct (find_div_mul_params Int64.wordsize + (Int64.modulus - Int64.modulus mod d - 1) d 64) + as [[p m] | ]... + generalize (p - 64); intro p1. + destruct (zlt 0 d)... + destruct (zle (two_p (64 + p1)) (m * d))... + destruct (zle (m * d) (two_p (64 + p1) + two_p p1))... + destruct (zle 0 m)... + destruct (zlt m Int64.modulus)... + destruct (zle 0 p1)... + destruct (zlt p1 64)... + intros EQ; inv EQ. + split. auto. split. auto. intros. + apply Zdiv_mul_pos; try omega. assumption. +Qed. + +Remark int64_shr'_div_two_p: + forall x y, Int64.shr' x y = Int64.repr (Int64.signed x / two_p (Int.unsigned y)). +Proof. + intros; unfold Int64.shr'. rewrite Int64.Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega. +Qed. + +Lemma divls_mul_shift_gen: + forall x y m p, + divls_mul_params (Int64.signed y) = Some(p, m) -> + 0 <= m < Int64.modulus /\ 0 <= p < 64 /\ + Int64.divs x y = Int64.add (Int64.shr' (Int64.repr ((Int64.signed x * m) / Int64.modulus)) (Int.repr p)) + (Int64.shru x (Int64.repr 63)). +Proof. + intros. set (n := Int64.signed x). set (d := Int64.signed y) in *. + exploit divls_mul_params_sound; eauto. intros (A & B & C). + split. auto. split. auto. + unfold Int64.divs. fold n; fold d. rewrite C by (apply Int64.signed_range). + rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv. + rewrite Int64.shru_lt_zero. unfold Int64.add. apply Int64.eqm_samerepr. apply Int64.eqm_add. + rewrite int64_shr'_div_two_p. apply Int64.eqm_unsigned_repr_r. apply Int64.eqm_refl2. + rewrite Int.unsigned_repr. f_equal. + rewrite Int64.signed_repr. rewrite Int64.modulus_power. f_equal. ring. + cut (Int64.min_signed <= n * m / Int64.modulus < Int64.half_modulus). + unfold Int64.max_signed; omega. + apply Zdiv_interval_1. generalize Int64.min_signed_neg; omega. apply Int64.half_modulus_pos. + apply Int64.modulus_pos. + split. apply Zle_trans with (Int64.min_signed * m). apply Zmult_le_compat_l_neg. omega. generalize Int64.min_signed_neg; omega. + apply Zmult_le_compat_r. unfold n; generalize (Int64.signed_range x); tauto. tauto. + apply Zle_lt_trans with (Int64.half_modulus * m). + apply Zmult_le_compat_r. generalize (Int64.signed_range x); unfold n, Int64.max_signed; omega. tauto. + apply Zmult_lt_compat_l. generalize Int64.half_modulus_pos; omega. tauto. + assert (64 < Int.max_unsigned) by (compute; auto). omega. + unfold Int64.lt; fold n. rewrite Int64.signed_zero. destruct (zlt n 0); apply Int64.eqm_unsigned_repr. + apply two_p_gt_ZERO. omega. + apply two_p_gt_ZERO. omega. +Qed. + +Theorem divls_mul_shift_1: + forall x y m p, + divls_mul_params (Int64.signed y) = Some(p, m) -> + m < Int64.half_modulus -> + 0 <= p < 64 /\ + Int64.divs x y = Int64.add (Int64.shr' (Int64.mulhs x (Int64.repr m)) (Int.repr p)) + (Int64.shru' x (Int.repr 63)). +Proof. + intros. exploit divls_mul_shift_gen; eauto. instantiate (1 := x). + intros (A & B & C). split. auto. rewrite C. + unfold Int64.mulhs. rewrite Int64.signed_repr. auto. + generalize Int64.min_signed_neg; unfold Int64.max_signed; omega. +Qed. + +Theorem divls_mul_shift_2: + forall x y m p, + divls_mul_params (Int64.signed y) = Some(p, m) -> + m >= Int64.half_modulus -> + 0 <= p < 64 /\ + Int64.divs x y = Int64.add (Int64.shr' (Int64.add (Int64.mulhs x (Int64.repr m)) x) (Int.repr p)) + (Int64.shru' x (Int.repr 63)). +Proof. + intros. exploit divls_mul_shift_gen; eauto. instantiate (1 := x). + intros (A & B & C). split. auto. rewrite C. f_equal. f_equal. + rewrite Int64.add_signed. unfold Int64.mulhs. set (n := Int64.signed x). + transitivity (Int64.repr (n * (m - Int64.modulus) / Int64.modulus + n)). + f_equal. + replace (n * (m - Int64.modulus)) with (n * m + (-n) * Int64.modulus) by ring. + rewrite Z_div_plus. ring. apply Int64.modulus_pos. + apply Int64.eqm_samerepr. apply Int64.eqm_add; auto with ints. + apply Int64.eqm_sym. eapply Int64.eqm_trans. apply Int64.eqm_signed_unsigned. + apply Int64.eqm_unsigned_repr_l. apply Int64.eqm_refl2. f_equal. f_equal. + rewrite Int64.signed_repr_eq. rewrite Zmod_small by assumption. + apply zlt_false. omega. +Qed. + +Remark int64_shru'_div_two_p: + forall x y, Int64.shru' x y = Int64.repr (Int64.unsigned x / two_p (Int.unsigned y)). +Proof. + intros; unfold Int64.shru'. rewrite Int64.Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega. +Qed. + +Theorem divlu_mul_shift: + forall x y m p, + divlu_mul_params (Int64.unsigned y) = Some(p, m) -> + 0 <= p < 64 /\ + Int64.divu x y = Int64.shru' (Int64.mulhu x (Int64.repr m)) (Int.repr p). +Proof. + intros. exploit divlu_mul_params_sound; eauto. intros (A & B & C). + split. auto. + rewrite int64_shru'_div_two_p. rewrite Int.unsigned_repr. + unfold Int64.divu, Int64.mulhu. f_equal. rewrite C by apply Int64.unsigned_range. + rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv by (apply two_p_gt_ZERO; omega). + f_equal. rewrite (Int64.unsigned_repr m). + rewrite Int64.unsigned_repr. f_equal. ring. + cut (0 <= Int64.unsigned x * m / Int64.modulus < Int64.modulus). + unfold Int64.max_unsigned; omega. + apply Zdiv_interval_1. omega. compute; auto. compute; auto. + split. simpl. apply Z.mul_nonneg_nonneg. generalize (Int64.unsigned_range x); omega. omega. + apply Zle_lt_trans with (Int64.modulus * m). + apply Zmult_le_compat_r. generalize (Int64.unsigned_range x); omega. omega. + apply Zmult_lt_compat_l. compute; auto. omega. + unfold Int64.max_unsigned; omega. + assert (64 < Int.max_unsigned) by (compute; auto). omega. +Qed. + (** * Correctness of the smart constructors for division and modulus *) Section CMCONSTRS. -Variable ge: genv. +Variable prog: program. +Variable hf: helper_functions. +Hypothesis HELPERS: helper_functions_declared prog hf. +Let ge := Genv.globalenv prog. Variable sp: val. Variable e: env. Variable m: mem. @@ -552,6 +705,202 @@ Proof. - eapply eval_mods_base; eauto. Qed. +Lemma eval_modl_from_divl: + forall le a n x y, + eval_expr ge sp e m le a (Vlong y) -> + nth_error le O = Some (Vlong x) -> + eval_expr ge sp e m le (modl_from_divl a n) (Vlong (Int64.sub x (Int64.mul y n))). +Proof. + unfold modl_from_divl; intros. + exploit eval_mullimm; eauto. instantiate (1 := n). intros (v1 & A1 & B1). + assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)) by (constructor; auto). + exploit eval_subl; auto. eexact A0. eexact A1. + intros (v2 & A2 & B2). + simpl in B1; inv B1. simpl in B2; inv B2. exact A2. +Qed. + +Lemma eval_divlu_mull: + forall le x y p M, + divlu_mul_params (Int64.unsigned y) = Some(p, M) -> + nth_error le O = Some (Vlong x) -> + eval_expr ge sp e m le (divlu_mull p M) (Vlong (Int64.divu x y)). +Proof. + intros. unfold divlu_mull. exploit (divlu_mul_shift x); eauto. intros [A B]. + assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)) by (constructor; auto). + exploit eval_mullhu. eauto. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1). + exploit eval_shrluimm. eauto. eexact A1. instantiate (1 := Int.repr p). intros (v2 & A2 & B2). + simpl in B1; inv B1. simpl in B2. replace (Int.ltu (Int.repr p) Int64.iwordsize') with true in B2. inv B2. + rewrite B. assumption. + unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true; auto. tauto. + assert (64 < Int.max_unsigned) by (compute; auto). omega. +Qed. + +Theorem eval_divlu: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divlu x y = Some z -> + exists v, eval_expr ge sp e m le (divlu a b) v /\ Val.lessdef z v. +Proof. + unfold divlu; intros. + destruct (is_longconst b) as [n2|] eqn:N2. +- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y. + destruct (is_longconst a) as [n1|] eqn:N1. ++ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x. + simpl in H1. destruct (Int64.eq n2 Int64.zero); inv H1. + econstructor; split. apply eval_longconst. constructor. ++ destruct (Int64.is_power2' n2) as [l|] eqn:POW. +* exploit Val.divlu_pow2; eauto. intros EQ; subst z. apply eval_shrluimm; auto. +* destruct (Compopts.optim_for_size tt). eapply eval_divlu_base; eauto. + destruct (divlu_mul_params (Int64.unsigned n2)) as [[p M]|] eqn:PARAMS. +** destruct x; simpl in H1; try discriminate. + destruct (Int64.eq n2 Int64.zero); inv H1. + econstructor; split; eauto. econstructor. eauto. eapply eval_divlu_mull; eauto. +** eapply eval_divlu_base; eauto. +- eapply eval_divlu_base; eauto. +Qed. + +Theorem eval_modlu: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.modlu x y = Some z -> + exists v, eval_expr ge sp e m le (modlu a b) v /\ Val.lessdef z v. +Proof. + unfold modlu; intros. + destruct (is_longconst b) as [n2|] eqn:N2. +- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y. + destruct (is_longconst a) as [n1|] eqn:N1. ++ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x. + simpl in H1. destruct (Int64.eq n2 Int64.zero); inv H1. + econstructor; split. apply eval_longconst. constructor. ++ destruct (Int64.is_power2 n2) as [l|] eqn:POW. +* exploit Val.modlu_pow2; eauto. intros EQ; subst z. eapply eval_andl; eauto. apply eval_longconst. +* destruct (Compopts.optim_for_size tt). eapply eval_modlu_base; eauto. + destruct (divlu_mul_params (Int64.unsigned n2)) as [[p M]|] eqn:PARAMS. +** destruct x; simpl in H1; try discriminate. + destruct (Int64.eq n2 Int64.zero) eqn:Z; inv H1. + rewrite Int64.modu_divu. + econstructor; split; eauto. econstructor. eauto. + eapply eval_modl_from_divl; eauto. + eapply eval_divlu_mull; eauto. + red; intros; subst n2; discriminate Z. +** eapply eval_modlu_base; eauto. +- eapply eval_modlu_base; eauto. +Qed. + +Lemma eval_divls_mull: + forall le x y p M, + divls_mul_params (Int64.signed y) = Some(p, M) -> + nth_error le O = Some (Vlong x) -> + eval_expr ge sp e m le (divls_mull p M) (Vlong (Int64.divs x y)). +Proof. + intros. unfold divls_mull. + assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)). + { constructor; auto. } + exploit eval_mullhs. eauto. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1). + exploit eval_addl; auto. eexact A1. eexact A0. intros (v2 & A2 & B2). + exploit eval_shrluimm. eauto. eexact A0. instantiate (1 := Int.repr 63). intros (v3 & A3 & B3). + set (a4 := if zlt M Int64.half_modulus + then mullhs (Eletvar 0) (Int64.repr M) + else addl (mullhs (Eletvar 0) (Int64.repr M)) (Eletvar 0)). + set (v4 := if zlt M Int64.half_modulus then v1 else v2). + assert (A4: eval_expr ge sp e m le a4 v4). + { unfold a4, v4; destruct (zlt M Int64.half_modulus); auto. } + exploit eval_shrlimm. eauto. eexact A4. instantiate (1 := Int.repr p). intros (v5 & A5 & B5). + exploit eval_addl; auto. eexact A5. eexact A3. intros (v6 & A6 & B6). + assert (RANGE: forall x, 0 <= x < 64 -> Int.ltu (Int.repr x) Int64.iwordsize' = true). + { intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto. + assert (64 < Int.max_unsigned) by (compute; auto). omega. } + simpl in B1; inv B1. + simpl in B2; inv B2. + simpl in B3; rewrite RANGE in B3 by omega; inv B3. + destruct (zlt M Int64.half_modulus). +- exploit (divls_mul_shift_1 x); eauto. intros [A B]. + simpl in B5; rewrite RANGE in B5 by auto; inv B5. + simpl in B6; inv B6. + rewrite B; exact A6. +- exploit (divls_mul_shift_2 x); eauto. intros [A B]. + simpl in B5; rewrite RANGE in B5 by auto; inv B5. + simpl in B6; inv B6. + rewrite B; exact A6. +Qed. + +Theorem eval_divls: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divls x y = Some z -> + exists v, eval_expr ge sp e m le (divls a b) v /\ Val.lessdef z v. +Proof. + unfold divls; intros. + destruct (is_longconst b) as [n2|] eqn:N2. +- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y. + destruct (is_longconst a) as [n1|] eqn:N1. ++ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x. + simpl in H1. + destruct (Int64.eq n2 Int64.zero + || Int64.eq n1 (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1. + econstructor; split. apply eval_longconst. constructor. ++ destruct (Int64.is_power2' n2) as [l|] eqn:POW. +* destruct (Int.ltu l (Int.repr 63)) eqn:LT. +** exploit Val.divls_pow2; eauto. intros EQ. eapply eval_shrxlimm; eauto. +** eapply eval_divls_base; eauto. +* destruct (Compopts.optim_for_size tt). eapply eval_divls_base; eauto. + destruct (divls_mul_params (Int64.signed n2)) as [[p M]|] eqn:PARAMS. +** destruct x; simpl in H1; try discriminate. + destruct (Int64.eq n2 Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1. + econstructor; split; eauto. econstructor. eauto. + eapply eval_divls_mull; eauto. +** eapply eval_divls_base; eauto. +- eapply eval_divls_base; eauto. +Qed. + +Theorem eval_modls: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.modls x y = Some z -> + exists v, eval_expr ge sp e m le (modls a b) v /\ Val.lessdef z v. +Proof. + unfold modls; intros. + destruct (is_longconst b) as [n2|] eqn:N2. +- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y. + destruct (is_longconst a) as [n1|] eqn:N1. ++ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x. + simpl in H1. + destruct (Int64.eq n2 Int64.zero + || Int64.eq n1 (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1. + econstructor; split. apply eval_longconst. constructor. ++ destruct (Int64.is_power2' n2) as [l|] eqn:POW. +* destruct (Int.ltu l (Int.repr 63)) eqn:LT. +**destruct x; simpl in H1; try discriminate. + destruct (Int64.eq n2 Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone) eqn:D; inv H1. + assert (Val.divls (Vlong i) (Vlong n2) = Some (Vlong (Int64.divs i n2))). + { simpl; rewrite D; auto. } + exploit Val.divls_pow2; eauto. intros EQ. + set (le' := Vlong i :: le). + assert (A: eval_expr ge sp e m le' (Eletvar O) (Vlong i)) by (constructor; auto). + exploit eval_shrxlimm; eauto. intros (v1 & A1 & B1). inv B1. + econstructor; split. + econstructor. eauto. eapply eval_modl_from_divl. eexact A1. reflexivity. + rewrite Int64.mods_divs. auto. +**eapply eval_modls_base; eauto. +* destruct (Compopts.optim_for_size tt). eapply eval_modls_base; eauto. + destruct (divls_mul_params (Int64.signed n2)) as [[p M]|] eqn:PARAMS. +** destruct x; simpl in H1; try discriminate. + destruct (Int64.eq n2 Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1. + econstructor; split; eauto. econstructor. eauto. + rewrite Int64.mods_divs. + eapply eval_modl_from_divl; auto. + eapply eval_divls_mull; eauto. +** eapply eval_modls_base; eauto. +- eapply eval_modls_base; eauto. +Qed. + (** * Floating-point division *) Theorem eval_divf: diff --git a/backend/Selection.v b/backend/Selection.v index 02b37c48..abda1d95 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -23,19 +23,11 @@ The source language is Cminor and the target language is CminorSel. *) Require String. -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Errors. -Require Import Integers. -Require Import Globalenvs. -Require Import Switch. +Require Import Coqlib Maps. +Require Import AST Errors Integers Globalenvs Switch. Require Cminor. -Require Import Op. -Require Import CminorSel. -Require Import SelectOp. -Require Import SelectDiv. -Require Import SelectLong. +Require Import Op CminorSel. +Require Import SelectOp SplitLong SelectLong SelectDiv. Require Machregs. Local Open Scope cminorsel_scope. @@ -71,7 +63,7 @@ Section SELECTION. Definition globdef := AST.globdef Cminor.fundef unit. Variable defmap: PTree.t globdef. -Variable hf: helper_functions. +Context {hf: helper_functions}. Definition sel_constant (cst: Cminor.constant) : expr := match cst with @@ -110,14 +102,14 @@ Definition sel_unop (op: Cminor.unary_operation) (arg: expr) : expr := | Cminor.Ointoflong => intoflong arg | Cminor.Olongofint => longofint arg | Cminor.Olongofintu => longofintu arg - | Cminor.Olongoffloat => longoffloat hf arg - | Cminor.Olonguoffloat => longuoffloat hf arg - | Cminor.Ofloatoflong => floatoflong hf arg - | Cminor.Ofloatoflongu => floatoflongu hf arg - | Cminor.Olongofsingle => longofsingle hf arg - | Cminor.Olonguofsingle => longuofsingle hf arg - | Cminor.Osingleoflong => singleoflong hf arg - | Cminor.Osingleoflongu => singleoflongu hf arg + | Cminor.Olongoffloat => longoffloat arg + | Cminor.Olonguoffloat => longuoffloat arg + | Cminor.Ofloatoflong => floatoflong arg + | Cminor.Ofloatoflongu => floatoflongu arg + | Cminor.Olongofsingle => longofsingle arg + | Cminor.Olonguofsingle => longuofsingle arg + | Cminor.Osingleoflong => singleoflong arg + | Cminor.Osingleoflongu => singleoflongu arg end. Definition sel_binop (op: Cminor.binary_operation) (arg1 arg2: expr) : expr := @@ -145,17 +137,17 @@ Definition sel_binop (op: Cminor.binary_operation) (arg1 arg2: expr) : expr := | Cminor.Odivfs => divfs arg1 arg2 | Cminor.Oaddl => addl arg1 arg2 | Cminor.Osubl => subl arg1 arg2 - | Cminor.Omull => mull hf arg1 arg2 - | Cminor.Odivl => divl hf arg1 arg2 - | Cminor.Odivlu => divlu hf arg1 arg2 - | Cminor.Omodl => modl hf arg1 arg2 - | Cminor.Omodlu => modlu hf arg1 arg2 + | Cminor.Omull => mull arg1 arg2 + | Cminor.Odivl => divls arg1 arg2 + | Cminor.Odivlu => divlu arg1 arg2 + | Cminor.Omodl => modls arg1 arg2 + | Cminor.Omodlu => modlu arg1 arg2 | Cminor.Oandl => andl arg1 arg2 | Cminor.Oorl => orl arg1 arg2 | Cminor.Oxorl => xorl arg1 arg2 - | Cminor.Oshll => shll hf arg1 arg2 - | Cminor.Oshrl => shrl hf arg1 arg2 - | Cminor.Oshrlu => shrlu hf arg1 arg2 + | Cminor.Oshll => shll arg1 arg2 + | Cminor.Oshrl => shrl arg1 arg2 + | Cminor.Oshrlu => shrlu arg1 arg2 | Cminor.Ocmp c => comp c arg1 arg2 | Cminor.Ocmpu c => compu c arg1 arg2 | Cminor.Ocmpf c => compf c arg1 arg2 @@ -192,7 +184,7 @@ Inductive call_kind : Type := Definition expr_is_addrof_ident (e: Cminor.expr) : option ident := match e with | Cminor.Econst (Cminor.Oaddrsymbol id ofs) => - if Int.eq ofs Int.zero then Some id else None + if Ptrofs.eq ofs Ptrofs.zero then Some id else None | _ => None end. @@ -326,10 +318,12 @@ Fixpoint sel_stmt (s: Cminor.stmt) : res stmt := | Cminor.Sgoto lbl => OK (Sgoto lbl) end. +End SELECTION. + (** Conversion of functions. *) -Definition sel_function (f: Cminor.function) : res function := - do body' <- sel_stmt f.(Cminor.fn_body); +Definition sel_function (dm: PTree.t globdef) (hf: helper_functions) (f: Cminor.function) : res function := + do body' <- sel_stmt dm f.(Cminor.fn_body); OK (mkfunction f.(Cminor.fn_sig) f.(Cminor.fn_params) @@ -337,10 +331,8 @@ Definition sel_function (f: Cminor.function) : res function := f.(Cminor.fn_stackspace) body'). -Definition sel_fundef (f: Cminor.fundef) : res fundef := - transf_partial_fundef sel_function f. - -End SELECTION. +Definition sel_fundef (dm: PTree.t globdef) (hf: helper_functions) (f: Cminor.fundef) : res fundef := + transf_partial_fundef (sel_function dm hf) f. (** Setting up the helper functions. *) @@ -397,10 +389,13 @@ Definition get_helpers (defmap: PTree.t globdef) : res helper_functions := do i64_shl <- lookup_helper globs "__i64_shl" sig_li_l ; do i64_shr <- lookup_helper globs "__i64_shr" sig_li_l ; do i64_sar <- lookup_helper globs "__i64_sar" sig_li_l ; + do i64_umulh <- lookup_helper globs "__i64_umulh" sig_ll_l ; + do i64_smulh <- lookup_helper globs "__i64_smulh" sig_ll_l ; OK (mk_helper_functions i64_dtos i64_dtou i64_stod i64_utod i64_stof i64_utof i64_sdiv i64_udiv i64_smod i64_umod - i64_shl i64_shr i64_sar). + i64_shl i64_shr i64_sar + i64_umulh i64_smulh). (** Conversion of programs. *) diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index a57e5ea6..90e50338 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -12,28 +12,11 @@ (** Correctness of instruction selection *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Linking. -Require Import Errors. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Switch. -Require Import Cminor. -Require Import Op. -Require Import CminorSel. -Require Import SelectOp. -Require Import SelectDiv. -Require Import SelectLong. -Require Import Selection. -Require Import SelectOpproof. -Require Import SelectDivproof. -Require Import SelectLongproof. +Require Import Coqlib Maps. +Require Import AST Linking Errors Integers Values Memory Events Globalenvs Smallstep. +Require Import Switch Cminor Op CminorSel. +Require Import SelectOp SelectDiv SplitLong SelectLong Selection. +Require Import SelectOpproof SelectDivproof SplitLongproof SelectLongproof. Local Open Scope cminorsel_scope. Local Open Scope error_monad_scope. @@ -252,8 +235,7 @@ Lemma eval_sel_unop: forall le op a1 v1 v, eval_expr tge sp e m le a1 v1 -> eval_unop op v1 = Some v -> - - exists v', eval_expr tge sp e m le (sel_unop hf op a1) v' /\ Val.lessdef v v'. + exists v', eval_expr tge sp e m le (sel_unop op a1) v' /\ Val.lessdef v v'. Proof. destruct op; simpl; intros; FuncInv; try subst v. apply eval_cast8unsigned; auto. @@ -296,7 +278,7 @@ Lemma eval_sel_binop: eval_expr tge sp e m le a1 v1 -> eval_expr tge sp e m le a2 v2 -> eval_binop op v1 v2 m = Some v -> - exists v', eval_expr tge sp e m le (sel_binop hf op a1 a2) v' /\ Val.lessdef v v'. + exists v', eval_expr tge sp e m le (sel_binop op a1 a2) v' /\ Val.lessdef v v'. Proof. destruct op; simpl; intros; FuncInv; try subst v. apply eval_add; auto. @@ -323,9 +305,9 @@ Proof. eapply eval_addl; eauto. eapply eval_subl; eauto. eapply eval_mull; eauto. - eapply eval_divl; eauto. + eapply eval_divls; eauto. eapply eval_divlu; eauto. - eapply eval_modl; eauto. + eapply eval_modls; eauto. eapply eval_modlu; eauto. eapply eval_andl; eauto. eapply eval_orl; eauto. @@ -348,12 +330,12 @@ End CMCONSTR. Lemma expr_is_addrof_ident_correct: forall e id, expr_is_addrof_ident e = Some id -> - e = Cminor.Econst (Cminor.Oaddrsymbol id Int.zero). + e = Cminor.Econst (Cminor.Oaddrsymbol id Ptrofs.zero). Proof. intros e id. unfold expr_is_addrof_ident. destruct e; try congruence. destruct c; try congruence. - predSpec Int.eq Int.eq_spec i0 Int.zero; congruence. + predSpec Ptrofs.eq Ptrofs.eq_spec i0 Ptrofs.zero; congruence. Qed. Lemma classify_call_correct: @@ -363,17 +345,17 @@ Lemma classify_call_correct: Genv.find_funct ge v = Some fd -> match classify_call (prog_defmap unit) a with | Call_default => True - | Call_imm id => exists b, Genv.find_symbol ge id = Some b /\ v = Vptr b Int.zero + | Call_imm id => exists b, Genv.find_symbol ge id = Some b /\ v = Vptr b Ptrofs.zero | Call_builtin ef => fd = External ef end. Proof. unfold classify_call; intros. destruct (expr_is_addrof_ident a) as [id|] eqn:EA; auto. exploit expr_is_addrof_ident_correct; eauto. intros EQ; subst a. - inv H0. inv H3. + inv H0. inv H3. unfold Genv.symbol_address in *. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; try discriminate. rewrite Genv.find_funct_find_funct_ptr in H1. - assert (DFL: exists b1, Genv.find_symbol ge id = Some b1 /\ Vptr b Int.zero = Vptr b1 Int.zero) by (exists b; auto). + assert (DFL: exists b1, Genv.find_symbol ge id = Some b1 /\ Vptr b Ptrofs.zero = Vptr b1 Ptrofs.zero) by (exists b; auto). unfold globdef; destruct (prog_defmap unit)!id as [[[f|ef] |gv] |] eqn:G; auto. destruct (ef_inline ef) eqn:INLINE; auto. destruct (prog_defmap_linkorder _ _ _ _ H G) as (gd & P & Q). @@ -530,12 +512,12 @@ Proof. rewrite Int64.unsigned_repr. destruct (zeq (Int64.unsigned n0) n); auto. unfold Int64.max_unsigned; omega. - intros until n; intros EVAL R RANGE. - eapply eval_cmplu. eexact EVAL. apply eval_longconst with (n := Int64.repr n). + eapply eval_cmplu; auto. eexact EVAL. apply eval_longconst with (n := Int64.repr n). inv R. unfold Val.cmplu. simpl. f_equal; f_equal. unfold Int64.ltu. rewrite Int64.unsigned_repr. destruct (zlt (Int64.unsigned n0) n); auto. unfold Int64.max_unsigned; omega. - intros until n; intros EVAL R RANGE. - exploit eval_subl. eexact EVAL. apply eval_longconst with (n := Int64.repr n). + exploit eval_subl; auto. eexact EVAL. apply eval_longconst with (n := Int64.repr n). intros (vb & A & B). inv R. simpl in B. inv B. econstructor; split; eauto. replace ((Int64.unsigned n0 - n) mod Int64.modulus) @@ -579,13 +561,25 @@ Lemma eval_binop_lessdef: Proof. intros until m'; intros EV LD1 LD2 ME. assert (exists v', eval_binop op v1' v2' m = Some v' /\ Val.lessdef v v'). - inv LD1. inv LD2. exists v; auto. - destruct op; destruct v1'; simpl in *; inv EV; TrivialExists. - destruct op; simpl in *; inv EV; TrivialExists. - destruct op; try (exact H). - simpl in *. TrivialExists. inv EV. apply Val.of_optbool_lessdef. - intros. apply Val.cmpu_bool_lessdef with (Mem.valid_pointer m) v1 v2; auto. - intros; eapply Mem.valid_pointer_extends; eauto. + { inv LD1. inv LD2. exists v; auto. + destruct op; destruct v1'; simpl in *; inv EV; TrivialExists. + destruct op; simpl in *; inv EV; TrivialExists. } + assert (CMPU: forall c, + eval_binop (Ocmpu c) v1 v2 m = Some v -> + exists v' : val, eval_binop (Ocmpu c) v1' v2' m' = Some v' /\ Val.lessdef v v'). + { intros c A. simpl in *. inv A. econstructor; split. eauto. + apply Val.of_optbool_lessdef. + intros. apply Val.cmpu_bool_lessdef with (Mem.valid_pointer m) v1 v2; auto. + intros; eapply Mem.valid_pointer_extends; eauto. } + assert (CMPLU: forall c, + eval_binop (Ocmplu c) v1 v2 m = Some v -> + exists v' : val, eval_binop (Ocmplu c) v1' v2' m' = Some v' /\ Val.lessdef v v'). + { intros c A. simpl in *. unfold Val.cmplu in *. + destruct (Val.cmplu_bool (Mem.valid_pointer m) c v1 v2) as [b|] eqn:C; simpl in A; inv A. + eapply Val.cmplu_bool_lessdef with (valid_ptr' := (Mem.valid_pointer m')) in C; + eauto using Mem.valid_pointer_extends. + rewrite C. exists (Val.of_bool b); auto. } + destruct op; auto. Qed. (** * Semantic preservation for instruction selection. *) @@ -644,7 +638,7 @@ Lemma sel_expr_correct: Cminor.eval_expr ge sp e m a v -> forall e' le m', env_lessdef e e' -> Mem.extends m m' -> - exists v', eval_expr tge sp e' m' le (sel_expr hf a) v' /\ Val.lessdef v v'. + exists v', eval_expr tge sp e' m' le (sel_expr a) v' /\ Val.lessdef v v'. Proof. induction 1; intros; simpl. (* Evar *) @@ -654,10 +648,8 @@ Proof. exists (Vint i); split; auto. econstructor. constructor. auto. exists (Vfloat f); split; auto. econstructor. constructor. auto. exists (Vsingle f); split; auto. econstructor. constructor. auto. - exists (Val.longofwords (Vint (Int64.hiword i)) (Vint (Int64.loword i))); split. - eapply eval_Eop. constructor. EvalOp. simpl; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. - simpl. rewrite Int64.ofwords_recompose. auto. - rewrite <- symbols_preserved. fold (Genv.symbol_address tge i i0). apply eval_addrsymbol. + exists (Vlong i); split; auto. apply eval_longconst. + unfold Genv.symbol_address; rewrite <- symbols_preserved; fold (Genv.symbol_address tge i i0). apply eval_addrsymbol. apply eval_addrstack. (* Eunop *) exploit IHeval_expr; eauto. intros [v1' [A B]]. @@ -668,7 +660,9 @@ Proof. exploit IHeval_expr1; eauto. intros [v1' [A B]]. exploit IHeval_expr2; eauto. intros [v2' [C D]]. exploit eval_binop_lessdef; eauto. intros [v' [E F]]. - exploit eval_sel_binop. eexact LINK. eexact HF. eexact A. eexact C. eauto. intros [v'' [P Q]]. + assert (G: exists v'', eval_expr tge sp e' m' le (sel_binop op (sel_expr a1) (sel_expr a2)) v'' /\ Val.lessdef v' v'') + by (eapply eval_sel_binop; eauto). + destruct G as [v'' [P Q]]. exists v''; split; eauto. eapply Val.lessdef_trans; eauto. (* Eload *) exploit IHeval_expr; eauto. intros [vaddr' [A B]]. @@ -681,7 +675,7 @@ Lemma sel_exprlist_correct: Cminor.eval_exprlist ge sp e m a v -> forall e' le m', env_lessdef e e' -> Mem.extends m m' -> - exists v', eval_exprlist tge sp e' m' le (sel_exprlist hf a) v' /\ Val.lessdef_list v v'. + exists v', eval_exprlist tge sp e' m' le (sel_exprlist a) v' /\ Val.lessdef_list v v'. Proof. induction 1; intros; simpl. exists (@nil val); split; auto. constructor. @@ -695,13 +689,13 @@ Lemma sel_builtin_arg_correct: env_lessdef e e' -> Mem.extends m m' -> Cminor.eval_expr ge sp e m a v -> exists v', - CminorSel.eval_builtin_arg tge sp e' m' (sel_builtin_arg hf a c) v' + CminorSel.eval_builtin_arg tge sp e' m' (sel_builtin_arg a c) v' /\ Val.lessdef v v'. Proof. intros. unfold sel_builtin_arg. exploit sel_expr_correct; eauto. intros (v1 & A & B). exists v1; split; auto. - destruct (builtin_arg_ok (builtin_arg (sel_expr hf a)) c). + destruct (builtin_arg_ok (builtin_arg (sel_expr a)) c). apply eval_builtin_arg; eauto. constructor; auto. Qed. @@ -714,7 +708,7 @@ Lemma sel_builtin_args_correct: forall cl, exists vl', list_forall2 (CminorSel.eval_builtin_arg tge sp e' m') - (sel_builtin_args hf al cl) + (sel_builtin_args al cl) vl' /\ Val.lessdef_list vl vl'. Proof. @@ -737,37 +731,11 @@ End EXPRESSIONS. (** Semantic preservation for functions and statements. *) -(* -Inductive match_call_cont: Cminor.cont -> CminorSel.cont -> Prop := - | match_call_cont_stop: - match_call_cont Cminor.Kstop Kstop - | match_call_cont_call: forall cunit hf id f sp e k f' e' k', - linkorder cunit prog -> - helper_functions_declared cunit hf -> - sel_function (prog_defmap cunit) hf f = OK f' -> - match_cont cunit hf k k' -> env_lessdef e e' -> - match_call_cont (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k') - -with match_cont: Cminor.program -> helper_functions -> Cminor.cont -> CminorSel.cont -> Prop := - | match_cont_stop: forall cunit hf, - match_cont cunit hf Cminor.Kstop Kstop - | match_cont_seq: forall cunit hf s s' k k', - sel_stmt (prog_defmap cunit) hf s = OK s' -> - match_cont cunit hf k k' -> - match_cont cunit hf (Cminor.Kseq s k) (Kseq s' k') - | match_cont_block: forall cunit hf k k', - match_cont cunit hf k k' -> - match_cont cunit hf (Cminor.Kblock k) (Kblock k') - | match_cont_call: forall cunit hf id f sp e k f' e' k', - match_call_cont (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k') -> - match_cont cunit hf (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k'). -*) - Inductive match_cont: Cminor.program -> helper_functions -> Cminor.cont -> CminorSel.cont -> Prop := | match_cont_stop: forall cunit hf, match_cont cunit hf Cminor.Kstop Kstop | match_cont_seq: forall cunit hf s s' k k', - sel_stmt (prog_defmap cunit) hf s = OK s' -> + sel_stmt (prog_defmap cunit) s = OK s' -> match_cont cunit hf k k' -> match_cont cunit hf (Cminor.Kseq s k) (Kseq s' k') | match_cont_block: forall cunit hf k k', @@ -788,7 +756,7 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := (LINK: linkorder cunit prog) (HF: helper_functions_declared cunit hf) (TF: sel_function (prog_defmap cunit) hf f = OK f') - (TS: sel_stmt (prog_defmap cunit) hf s = OK s') + (TS: sel_stmt (prog_defmap cunit) s = OK s') (MC: match_cont cunit hf k k') (LD: env_lessdef e e') (ME: Mem.extends m m'), @@ -835,31 +803,20 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := (Cminor.Returnstate v (Cminor.Kcall optid f sp e k) m) (State f' Sskip k' sp (set_builtin_res (sel_builtin_res optid) v' e') m'). -(* -Remark call_cont_commut_1: - forall cunit hf k k', match_cont cunit hf k k' -> - forall cunit' hf', match_cont cunit' hf' (Cminor.call_cont k) (call_cont k'). -Proof. - induction 1; simpl; auto; intros; econstructor; eauto. -Qed. - -Remark call_cont_commut_2: - forall cunit hf k k', match_cont cunit hf k k' -> match_cont cunit hf (Cminor.call_cont k) (call_cont k'). -Proof. - intros. eapply call_cont_commut_1; eauto. -Qed. -*) - Remark call_cont_commut: forall cunit hf k k', match_cont cunit hf k k' -> match_call_cont (Cminor.call_cont k) (call_cont k'). Proof. - induction 1; simpl; auto; red; intros; econstructor; eauto. + induction 1; simpl; auto; red; intros. +- constructor. +- eapply match_cont_call with (hf := hf); eauto. Qed. Remark match_is_call_cont: forall cunit hf k k', match_cont cunit hf k k' -> Cminor.is_call_cont k -> match_call_cont k k'. Proof. - destruct 1; intros; try contradiction; red; intros; econstructor; eauto. + destruct 1; intros; try contradiction; red; intros. +- constructor. +- eapply match_cont_call with (hf := hf); eauto. Qed. Remark match_call_cont_cont: @@ -875,16 +832,16 @@ Qed. Remark find_label_commut: forall cunit hf lbl s k s' k', match_cont cunit hf k k' -> - sel_stmt (prog_defmap cunit) hf s = OK s' -> + sel_stmt (prog_defmap cunit) s = OK s' -> match Cminor.find_label lbl s k, find_label lbl s' k' with | None, None => True - | Some(s1, k1), Some(s1', k1') => sel_stmt (prog_defmap cunit) hf s1 = OK s1' /\ match_cont cunit hf k1 k1' + | Some(s1, k1), Some(s1', k1') => sel_stmt (prog_defmap cunit) s1 = OK s1' /\ match_cont cunit hf k1 k1' | _, _ => False end. Proof. induction s; intros until k'; simpl; intros MC SE; try (monadInv SE); simpl; auto. (* store *) - unfold store. destruct (addressing m (sel_expr hf e)); simpl; auto. + unfold store. destruct (addressing m (sel_expr e)); simpl; auto. (* call *) destruct (classify_call (prog_defmap cunit) e); simpl; auto. (* tailcall *) @@ -963,7 +920,7 @@ Proof. econstructor; eauto. econstructor; eauto. eapply sig_function_translated; eauto. eapply match_callstate with (cunit := cunit'); eauto. - red; intros. eapply match_cont_call with (cunit := cunit); eauto. + red; intros. eapply match_cont_call with (cunit := cunit) (hf := hf); eauto. + (* direct *) intros [b [U V]]. exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. @@ -973,7 +930,7 @@ Proof. subst vf. econstructor; eauto. rewrite symbols_preserved; eauto. eapply sig_function_translated; eauto. eapply match_callstate with (cunit := cunit'); eauto. - red; intros; eapply match_cont_call with (cunit := cunit); eauto. + red; intros; eapply match_cont_call with (cunit := cunit) (hf := hf); eauto. + (* turned into Sbuiltin *) intros EQ. subst fd. exploit sel_builtin_args_correct; eauto. intros [vargs' [C D]]. @@ -1052,7 +1009,7 @@ Proof. - (* Slabel *) left; econstructor; split. constructor. econstructor; eauto. - (* Sgoto *) - assert (sel_stmt (prog_defmap cunit) hf (Cminor.fn_body f) = OK (fn_body f')). + assert (sel_stmt (prog_defmap cunit) (Cminor.fn_body f) = OK (fn_body f')). { monadInv TF; simpl; auto. } exploit (find_label_commut cunit hf lbl (Cminor.fn_body f) (Cminor.call_cont k)). eapply call_cont_commut; eauto. eauto. diff --git a/backend/SelectLong.vp b/backend/SplitLong.vp index 105b284c..cbf7fa30 100644 --- a/backend/SelectLong.vp +++ b/backend/SplitLong.vp @@ -14,21 +14,18 @@ Require String. Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Op. -Require Import CminorSel. +Require Import AST Integers Floats. +Require Import Op CminorSel. Require Import SelectOp. Local Open Scope cminorsel_scope. Local Open Scope string_scope. (** Some operations on 64-bit integers are transformed into calls to - runtime library functions. The following record type collects + runtime library functions. The following type class collects the names of these functions. *) -Record helper_functions : Type := mk_helper_functions { +Class helper_functions := mk_helper_functions { i64_dtos: ident; (**r float64 -> signed long *) i64_dtou: ident; (**r float64 -> unsigned long *) i64_stod: ident; (**r signed long -> float64 *) @@ -41,7 +38,9 @@ Record helper_functions : Type := mk_helper_functions { i64_umod: ident; (**r unsigned remainder *) i64_shl: ident; (**r shift left *) i64_shr: ident; (**r shift right unsigned *) - i64_sar: ident (**r shift right signed *) + i64_sar: ident; (**r shift right signed *) + i64_umulh: ident; (**r unsigned multiply high *) + i64_smulh: ident; (**r signed multiply high *) }. Definition sig_l_l := mksignature (Tlong :: nil) (Some Tlong) cc_default. @@ -54,7 +53,7 @@ Definition sig_ii_l := mksignature (Tint :: Tint :: nil) (Some Tlong) cc_default Section SELECT. -Variable hf: helper_functions. +Context {hf: helper_functions}. Definition makelong (h l: expr): expr := Eop Omakelong (h ::: l ::: Enil). @@ -113,8 +112,11 @@ Definition is_longconst_zero (e: expr) := Definition intoflong (e: expr) := lowlong e. -Definition longofint (e: expr) := - Elet e (makelong (shrimm (Eletvar O) (Int.repr 31)) (Eletvar O)). +Nondetfunction longofint (e: expr) := + match e with + | Eop (Ointconst n) Enil => longconst (Int64.repr (Int.signed n)) + | _ => Elet e (makelong (shrimm (Eletvar O) (Int.repr 31)) (Eletvar O)) + end. Definition longofintu (e: expr) := makelong (Eop (Ointconst Int.zero) Enil) e. @@ -129,21 +131,21 @@ Definition notl (e: expr) := splitlong e (fun h l => makelong (notint h) (notint l)). Definition longoffloat (arg: expr) := - Eexternal hf.(i64_dtos) sig_f_l (arg ::: Enil). + Eexternal i64_dtos sig_f_l (arg ::: Enil). Definition longuoffloat (arg: expr) := - Eexternal hf.(i64_dtou) sig_f_l (arg ::: Enil). + Eexternal i64_dtou sig_f_l (arg ::: Enil). Definition floatoflong (arg: expr) := - Eexternal hf.(i64_stod) sig_l_f (arg ::: Enil). + Eexternal i64_stod sig_l_f (arg ::: Enil). Definition floatoflongu (arg: expr) := - Eexternal hf.(i64_utod) sig_l_f (arg ::: Enil). + Eexternal i64_utod sig_l_f (arg ::: Enil). Definition longofsingle (arg: expr) := longoffloat (floatofsingle arg). Definition longuofsingle (arg: expr) := longuoffloat (floatofsingle arg). Definition singleoflong (arg: expr) := - Eexternal hf.(i64_stof) sig_l_s (arg ::: Enil). + Eexternal i64_stof sig_l_s (arg ::: Enil). Definition singleoflongu (arg: expr) := - Eexternal hf.(i64_utof) sig_l_s (arg ::: Enil). + Eexternal i64_utof sig_l_s (arg ::: Enil). Definition andl (e1 e2: expr) := splitlong2 e1 e2 (fun h1 l1 h2 l2 => makelong (and h1 h2) (and l1 l2)). @@ -164,7 +166,7 @@ Definition shllimm (e1: expr) (n: int) := makelong (shlimm (lowlong e1) (Int.sub n Int.iwordsize)) (Eop (Ointconst Int.zero) Enil) else - Eexternal hf.(i64_shl) sig_li_l (e1 ::: Eop (Ointconst n) Enil ::: Enil). + Eexternal i64_shl sig_li_l (e1 ::: Eop (Ointconst n) Enil ::: Enil). Definition shrluimm (e1: expr) (n: int) := if Int.eq n Int.zero then e1 else @@ -176,7 +178,7 @@ Definition shrluimm (e1: expr) (n: int) := makelong (Eop (Ointconst Int.zero) Enil) (shruimm (highlong e1) (Int.sub n Int.iwordsize)) else - Eexternal hf.(i64_shr) sig_li_l (e1 ::: Eop (Ointconst n) Enil ::: Enil). + Eexternal i64_shr sig_li_l (e1 ::: Eop (Ointconst n) Enil ::: Enil). Definition shrlimm (e1: expr) (n: int) := if Int.eq n Int.zero then e1 else @@ -189,7 +191,7 @@ Definition shrlimm (e1: expr) (n: int) := (makelong (shrimm (Eletvar 0) (Int.repr 31)) (shrimm (Eletvar 0) (Int.sub n Int.iwordsize))) else - Eexternal hf.(i64_sar) sig_li_l (e1 ::: Eop (Ointconst n) Enil ::: Enil). + Eexternal i64_sar sig_li_l (e1 ::: Eop (Ointconst n) Enil ::: Enil). Definition is_intconst (e: expr) := match e with @@ -200,19 +202,19 @@ Definition is_intconst (e: expr) := Definition shll (e1 e2: expr) := match is_intconst e2 with | Some n => shllimm e1 n - | None => Eexternal hf.(i64_shl) sig_li_l (e1 ::: e2 ::: Enil) + | None => Eexternal i64_shl sig_li_l (e1 ::: e2 ::: Enil) end. Definition shrlu (e1 e2: expr) := match is_intconst e2 with | Some n => shrluimm e1 n - | None => Eexternal hf.(i64_shr) sig_li_l (e1 ::: e2 ::: Enil) + | None => Eexternal i64_shr sig_li_l (e1 ::: e2 ::: Enil) end. Definition shrl (e1 e2: expr) := match is_intconst e2 with | Some n => shrlimm e1 n - | None => Eexternal hf.(i64_sar) sig_li_l (e1 ::: e2 ::: Enil) + | None => Eexternal i64_sar sig_li_l (e1 ::: e2 ::: Enil) end. Definition addl (e1 e2: expr) := @@ -242,54 +244,38 @@ Definition mull_base (e1 e2: expr) := (mul (lift h1) (lift l2))) (Eop Olowlong (Eletvar O ::: Enil)))). -Definition mullimm (e: expr) (n: int64) := +Definition mullimm (n: int64) (e: expr) := if Int64.eq n Int64.zero then longconst Int64.zero else if Int64.eq n Int64.one then e else - match Int64.is_power2 n with - | Some l => shllimm e (Int.repr (Int64.unsigned l)) + match Int64.is_power2' n with + | Some l => shllimm e l | None => mull_base e (longconst n) end. Definition mull (e1 e2: expr) := match is_longconst e1, is_longconst e2 with | Some n1, Some n2 => longconst (Int64.mul n1 n2) - | Some n1, _ => mullimm e2 n1 - | _, Some n2 => mullimm e1 n2 + | Some n1, _ => mullimm n1 e2 + | _, Some n2 => mullimm n2 e1 | _, _ => mull_base e1 e2 end. -Definition binop_long (id: ident) (sem: int64 -> int64 -> int64) (e1 e2: expr) := - match is_longconst e1, is_longconst e2 with - | Some n1, Some n2 => longconst (sem n1 n2) - | _, _ => Eexternal id sig_ll_l (e1 ::: e2 ::: Enil) - end. +Definition mullhu (e1: expr) (n2: int64) := + Eexternal i64_umulh sig_ll_l (e1 ::: longconst n2 ::: Enil). +Definition mullhs (e1: expr) (n2: int64) := + Eexternal i64_smulh sig_ll_l (e1 ::: longconst n2 ::: Enil). -Definition divl e1 e2 := binop_long hf.(i64_sdiv) Int64.divs e1 e2. -Definition modl e1 e2 := binop_long hf.(i64_smod) Int64.mods e1 e2. +Definition shrxlimm (e: expr) (n: int) := + if Int.eq n Int.zero then e else + Elet e (shrlimm (addl (Eletvar O) + (shrluimm (shrlimm (Eletvar O) (Int.repr 63)) + (Int.sub (Int.repr 64) n))) + n). -Definition divlu (e1 e2: expr) := - let default := Eexternal hf.(i64_udiv) sig_ll_l (e1 ::: e2 ::: Enil) in - match is_longconst e1, is_longconst e2 with - | Some n1, Some n2 => longconst (Int64.divu n1 n2) - | _, Some n2 => - match Int64.is_power2 n2 with - | Some l => shrluimm e1 (Int.repr (Int64.unsigned l)) - | None => default - end - | _, _ => default - end. - -Definition modlu (e1 e2: expr) := - let default := Eexternal hf.(i64_umod) sig_ll_l (e1 ::: e2 ::: Enil) in - match is_longconst e1, is_longconst e2 with - | Some n1, Some n2 => longconst (Int64.modu n1 n2) - | _, Some n2 => - match Int64.is_power2 n2 with - | Some l => andl e1 (longconst (Int64.sub n2 Int64.one)) - | None => default - end - | _, _ => default - end. +Definition divlu_base (e1 e2: expr) := Eexternal i64_udiv sig_ll_l (e1 ::: e2 ::: Enil). +Definition modlu_base (e1 e2: expr) := Eexternal i64_umod sig_ll_l (e1 ::: e2 ::: Enil). +Definition divls_base (e1 e2: expr) := Eexternal i64_sdiv sig_ll_l (e1 ::: e2 ::: Enil). +Definition modls_base (e1 e2: expr) := Eexternal i64_smod sig_ll_l (e1 ::: e2 ::: Enil). Definition cmpl_eq_zero (e: expr) := splitlong e (fun h l => comp Ceq (or h l) (Eop (Ointconst Int.zero) Enil)). @@ -307,15 +293,8 @@ Definition cmplu (c: comparison) (e1 e2: expr) := match c with | Ceq => cmpl_eq_zero (xorl e1 e2) -(* - (if is_longconst_zero e2 then e1 - else if is_longconst_zero e1 then e2 - else xorl e1 e2) *) | Cne => cmpl_ne_zero (xorl e1 e2) -(* (if is_longconst_zero e2 then e1 - else if is_longconst_zero e1 then e2 - else xorl e1 e2) *) | Clt => cmplu_gen Clt Clt e1 e2 | Cle => diff --git a/backend/SelectLongproof.v b/backend/SplitLongproof.v index f15015e8..8c8dea2f 100644 --- a/backend/SelectLongproof.v +++ b/backend/SplitLongproof.v @@ -13,22 +13,10 @@ (** Correctness of instruction selection for integer division *) Require Import String. -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Cminor. -Require Import Op. -Require Import CminorSel. -Require Import SelectOp. -Require Import SelectOpproof. -Require Import SelectLong. +Require Import Coqlib Maps. +Require Import AST Errors Integers Floats. +Require Import Values Memory Globalenvs Events Cminor Op CminorSel. +Require Import SelectOp SelectOpproof SplitLong. Open Local Scope cminorsel_scope. Open Local Scope string_scope. @@ -60,25 +48,29 @@ Axiom i64_helpers_correct : /\ (forall x y z, Val.modlu x y = Some z -> external_implements "__i64_umod" sig_ll_l (x::y::nil) z) /\ (forall x y, external_implements "__i64_shl" sig_li_l (x::y::nil) (Val.shll x y)) /\ (forall x y, external_implements "__i64_shr" sig_li_l (x::y::nil) (Val.shrlu x y)) - /\ (forall x y, external_implements "__i64_sar" sig_li_l (x::y::nil) (Val.shrl x y)). + /\ (forall x y, external_implements "__i64_sar" sig_li_l (x::y::nil) (Val.shrl x y)) + /\ (forall x y, external_implements "__i64_umulh" sig_ll_l (x::y::nil) (Val.mullhu x y)) + /\ (forall x y, external_implements "__i64_smulh" sig_ll_l (x::y::nil) (Val.mullhs x y)). Definition helper_declared {F V: Type} (p: AST.program (AST.fundef F) V) (id: ident) (name: string) (sg: signature) : Prop := (prog_defmap p)!id = Some (Gfun (External (EF_runtime name sg))). Definition helper_functions_declared {F V: Type} (p: AST.program (AST.fundef F) V) (hf: helper_functions) : Prop := - helper_declared p hf.(i64_dtos) "__i64_dtos" sig_f_l - /\ helper_declared p hf.(i64_dtou) "__i64_dtou" sig_f_l - /\ helper_declared p hf.(i64_stod) "__i64_stod" sig_l_f - /\ helper_declared p hf.(i64_utod) "__i64_utod" sig_l_f - /\ helper_declared p hf.(i64_stof) "__i64_stof" sig_l_s - /\ helper_declared p hf.(i64_utof) "__i64_utof" sig_l_s - /\ helper_declared p hf.(i64_sdiv) "__i64_sdiv" sig_ll_l - /\ helper_declared p hf.(i64_udiv) "__i64_udiv" sig_ll_l - /\ helper_declared p hf.(i64_smod) "__i64_smod" sig_ll_l - /\ helper_declared p hf.(i64_umod) "__i64_umod" sig_ll_l - /\ helper_declared p hf.(i64_shl) "__i64_shl" sig_li_l - /\ helper_declared p hf.(i64_shr) "__i64_shr" sig_li_l - /\ helper_declared p hf.(i64_sar) "__i64_sar" sig_li_l. + helper_declared p i64_dtos "__i64_dtos" sig_f_l + /\ helper_declared p i64_dtou "__i64_dtou" sig_f_l + /\ helper_declared p i64_stod "__i64_stod" sig_l_f + /\ helper_declared p i64_utod "__i64_utod" sig_l_f + /\ helper_declared p i64_stof "__i64_stof" sig_l_s + /\ helper_declared p i64_utof "__i64_utof" sig_l_s + /\ helper_declared p i64_sdiv "__i64_sdiv" sig_ll_l + /\ helper_declared p i64_udiv "__i64_udiv" sig_ll_l + /\ helper_declared p i64_smod "__i64_smod" sig_ll_l + /\ helper_declared p i64_umod "__i64_umod" sig_ll_l + /\ helper_declared p i64_shl "__i64_shl" sig_li_l + /\ helper_declared p i64_shr "__i64_shr" sig_li_l + /\ helper_declared p i64_sar "__i64_sar" sig_li_l + /\ helper_declared p i64_umulh "__i64_umulh" sig_ll_l + /\ helper_declared p i64_smulh "__i64_smulh" sig_ll_l. (** * Correctness of the instruction selection functions for 64-bit operators *) @@ -184,7 +176,7 @@ Lemma eval_splitlong: Proof. intros until sem; intros EXEC UNDEF. unfold splitlong. case (splitlong_match a); intros. -- InvEval. subst v. +- InvEval; subst. exploit EXEC. eexact H2. eexact H3. intros [v' [A B]]. exists v'; split. auto. destruct v1; simpl in *; try (rewrite UNDEF; auto). @@ -232,7 +224,7 @@ Lemma eval_splitlong2: Proof. intros until sem; intros EXEC UNDEF. unfold splitlong2. case (splitlong2_match a b); intros. -- InvEval. subst va vb. +- InvEval; subst. exploit (EXEC le h1 l1 h2 l2); eauto. intros [v [A B]]. exists v; split; auto. destruct v1; simpl in *; try (rewrite UNDEF; auto). @@ -240,7 +232,7 @@ Proof. destruct v2; simpl in *; try (rewrite UNDEF; auto). destruct v3; try (rewrite UNDEF; auto). erewrite B; eauto. -- InvEval. subst va. +- InvEval; subst. exploit (EXEC (vb :: le) (lift h1) (lift l1) (Eop Ohighlong (Eletvar 0 ::: Enil)) (Eop Olowlong (Eletvar 0 ::: Enil))). EvalOp. EvalOp. EvalOp. EvalOp. @@ -251,7 +243,7 @@ Proof. destruct v0; try (rewrite UNDEF; auto). destruct vb; try (rewrite UNDEF; auto). erewrite B; simpl; eauto. rewrite Int64.ofwords_recompose. auto. -- InvEval. subst vb. +- InvEval; subst. exploit (EXEC (va :: le) (Eop Ohighlong (Eletvar 0 ::: Enil)) (Eop Olowlong (Eletvar 0 ::: Enil)) (lift h2) (lift l2)). @@ -330,7 +322,7 @@ Qed. Lemma eval_lowlong: unary_constructor_sound lowlong Val.loword. Proof. unfold lowlong; red. intros until x. destruct (lowlong_match a); intros. - InvEval. subst x. exists v0; split; auto. + InvEval; subst. exists v0; split; auto. destruct v1; simpl; auto. destruct v0; simpl; auto. rewrite Int64.lo_ofwords. auto. exists (Val.loword x); split; auto. EvalOp. @@ -339,7 +331,7 @@ Qed. Lemma eval_highlong: unary_constructor_sound highlong Val.hiword. Proof. unfold highlong; red. intros until x. destruct (highlong_match a); intros. - InvEval. subst x. exists v1; split; auto. + InvEval; subst. exists v1; split; auto. destruct v1; simpl; auto. destruct v0; simpl; auto. rewrite Int64.hi_ofwords. auto. exists (Val.hiword x); split; auto. EvalOp. @@ -370,8 +362,9 @@ Qed. Theorem eval_longofint: unary_constructor_sound longofint Val.longofint. Proof. - red; intros. unfold longofint. - exploit (eval_shrimm ge sp e m (Int.repr 31) (x :: le) (Eletvar 0)). EvalOp. + red; intros. unfold longofint. destruct (longofint_match a). +- InvEval. econstructor; split. apply eval_longconst. auto. +- exploit (eval_shrimm ge sp e m (Int.repr 31) (x :: le) (Eletvar 0)). EvalOp. intros [v1 [A B]]. econstructor; split. EvalOp. destruct x; simpl; auto. @@ -414,7 +407,7 @@ Theorem eval_longoffloat: forall le a x y, eval_expr ge sp e m le a x -> Val.longoffloat x = Some y -> - exists v, eval_expr ge sp e m le (longoffloat hf a) v /\ Val.lessdef y v. + exists v, eval_expr ge sp e m le (longoffloat a) v /\ Val.lessdef y v. Proof. intros; unfold longoffloat. econstructor; split. eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto. @@ -424,7 +417,7 @@ Theorem eval_longuoffloat: forall le a x y, eval_expr ge sp e m le a x -> Val.longuoffloat x = Some y -> - exists v, eval_expr ge sp e m le (longuoffloat hf a) v /\ Val.lessdef y v. + exists v, eval_expr ge sp e m le (longuoffloat a) v /\ Val.lessdef y v. Proof. intros; unfold longuoffloat. econstructor; split. eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto. @@ -434,7 +427,7 @@ Theorem eval_floatoflong: forall le a x y, eval_expr ge sp e m le a x -> Val.floatoflong x = Some y -> - exists v, eval_expr ge sp e m le (floatoflong hf a) v /\ Val.lessdef y v. + exists v, eval_expr ge sp e m le (floatoflong a) v /\ Val.lessdef y v. Proof. intros; unfold floatoflong. econstructor; split. eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto. @@ -444,7 +437,7 @@ Theorem eval_floatoflongu: forall le a x y, eval_expr ge sp e m le a x -> Val.floatoflongu x = Some y -> - exists v, eval_expr ge sp e m le (floatoflongu hf a) v /\ Val.lessdef y v. + exists v, eval_expr ge sp e m le (floatoflongu a) v /\ Val.lessdef y v. Proof. intros; unfold floatoflongu. econstructor; split. eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto. @@ -454,7 +447,7 @@ Theorem eval_longofsingle: forall le a x y, eval_expr ge sp e m le a x -> Val.longofsingle x = Some y -> - exists v, eval_expr ge sp e m le (longofsingle hf a) v /\ Val.lessdef y v. + exists v, eval_expr ge sp e m le (longofsingle a) v /\ Val.lessdef y v. Proof. intros; unfold longofsingle. destruct x; simpl in H0; inv H0. destruct (Float32.to_long f) as [n|] eqn:EQ; simpl in H2; inv H2. @@ -468,7 +461,7 @@ Theorem eval_longuofsingle: forall le a x y, eval_expr ge sp e m le a x -> Val.longuofsingle x = Some y -> - exists v, eval_expr ge sp e m le (longuofsingle hf a) v /\ Val.lessdef y v. + exists v, eval_expr ge sp e m le (longuofsingle a) v /\ Val.lessdef y v. Proof. intros; unfold longuofsingle. destruct x; simpl in H0; inv H0. destruct (Float32.to_longu f) as [n|] eqn:EQ; simpl in H2; inv H2. @@ -482,7 +475,7 @@ Theorem eval_singleoflong: forall le a x y, eval_expr ge sp e m le a x -> Val.singleoflong x = Some y -> - exists v, eval_expr ge sp e m le (singleoflong hf a) v /\ Val.lessdef y v. + exists v, eval_expr ge sp e m le (singleoflong a) v /\ Val.lessdef y v. Proof. intros; unfold singleoflong. econstructor; split. eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto. @@ -492,7 +485,7 @@ Theorem eval_singleoflongu: forall le a x y, eval_expr ge sp e m le a x -> Val.singleoflongu x = Some y -> - exists v, eval_expr ge sp e m le (singleoflongu hf a) v /\ Val.lessdef y v. + exists v, eval_expr ge sp e m le (singleoflongu a) v /\ Val.lessdef y v. Proof. intros; unfold singleoflongu. econstructor; split. eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto. @@ -592,7 +585,7 @@ Qed. Lemma eval_shllimm: forall n, - unary_constructor_sound (fun e => shllimm hf e n) (fun v => Val.shll v (Vint n)). + unary_constructor_sound (fun e => shllimm e n) (fun v => Val.shll v (Vint n)). Proof. unfold shllimm; red; intros. apply eval_shift_imm; intros. @@ -625,7 +618,7 @@ Proof. econstructor; split. eapply eval_helper_2; eauto. EvalOp. DeclHelper. UseHelper. auto. Qed. -Theorem eval_shll: binary_constructor_sound (shll hf) Val.shll. +Theorem eval_shll: binary_constructor_sound shll Val.shll. Proof. unfold shll; red; intros. destruct (is_intconst b) as [n|] eqn:IC. @@ -638,7 +631,7 @@ Qed. Lemma eval_shrluimm: forall n, - unary_constructor_sound (fun e => shrluimm hf e n) (fun v => Val.shrlu v (Vint n)). + unary_constructor_sound (fun e => shrluimm e n) (fun v => Val.shrlu v (Vint n)). Proof. unfold shrluimm; red; intros. apply eval_shift_imm; intros. + (* n = 0 *) @@ -670,7 +663,7 @@ Proof. econstructor; split. eapply eval_helper_2; eauto. EvalOp. DeclHelper. UseHelper. auto. Qed. -Theorem eval_shrlu: binary_constructor_sound (shrlu hf) Val.shrlu. +Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu. Proof. unfold shrlu; red; intros. destruct (is_intconst b) as [n|] eqn:IC. @@ -683,7 +676,7 @@ Qed. Lemma eval_shrlimm: forall n, - unary_constructor_sound (fun e => shrlimm hf e n) (fun v => Val.shrl v (Vint n)). + unary_constructor_sound (fun e => shrlimm e n) (fun v => Val.shrl v (Vint n)). Proof. unfold shrlimm; red; intros. apply eval_shift_imm; intros. + (* n = 0 *) @@ -719,7 +712,7 @@ Proof. econstructor; split. eapply eval_helper_2; eauto. EvalOp. DeclHelper. UseHelper. auto. Qed. -Theorem eval_shrl: binary_constructor_sound (shrl hf) Val.shrl. +Theorem eval_shrl: binary_constructor_sound shrl Val.shrl. Proof. unfold shrl; red; intros. destruct (is_intconst b) as [n|] eqn:IC. @@ -730,9 +723,9 @@ Proof. econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. Qed. -Theorem eval_addl: binary_constructor_sound addl Val.addl. +Theorem eval_addl: Archi.ptr64 = false -> binary_constructor_sound addl Val.addl. Proof. - unfold addl; red; intros. + unfold addl; red; intros. set (default := Ebuiltin (EF_builtin "__builtin_addl" sig_ll_l) (a ::: b ::: Enil)). assert (DEFAULT: exists v, eval_expr ge sp e m le default v /\ Val.lessdef (Val.addl x y) v). @@ -746,14 +739,14 @@ Proof. econstructor; split. apply eval_longconst. simpl; auto. - predSpec Int64.eq Int64.eq_spec p Int64.zero; auto. subst p. exploit (is_longconst_sound le a); eauto. intros EQ; subst x. - exists y; split; auto. simpl. destruct y; auto. rewrite Int64.add_zero_l; auto. + exists y; split; auto. unfold Val.addl; rewrite H; destruct y; auto. rewrite Int64.add_zero_l; auto. - predSpec Int64.eq Int64.eq_spec q Int64.zero; auto. subst q. exploit (is_longconst_sound le b); eauto. intros EQ; subst y. - exists x; split; auto. destruct x; simpl; auto. rewrite Int64.add_zero; auto. + exists x; split; auto. unfold Val.addl; rewrite H; destruct x; simpl; auto. rewrite Int64.add_zero; auto. - auto. Qed. -Theorem eval_subl: binary_constructor_sound subl Val.subl. +Theorem eval_subl: Archi.ptr64 = false -> binary_constructor_sound subl Val.subl. Proof. unfold subl; red; intros. set (default := Ebuiltin (EF_builtin "__builtin_subl" sig_ll_l) (a ::: b ::: Enil)). @@ -773,7 +766,7 @@ Proof. destruct y; simpl; auto. - predSpec Int64.eq Int64.eq_spec q Int64.zero; auto. subst q. exploit (is_longconst_sound le b); eauto. intros EQ; subst y. - exists x; split; auto. destruct x; simpl; auto. rewrite Int64.sub_zero_l; auto. + exists x; split; auto. unfold Val.subl; rewrite H; destruct x; simpl; auto. rewrite Int64.sub_zero_l; auto. - auto. Qed. @@ -799,7 +792,7 @@ Proof. Qed. Lemma eval_mullimm: - forall n, unary_constructor_sound (fun a => mullimm hf a n) (fun v => Val.mull v (Vlong n)). + forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)). Proof. unfold mullimm; red; intros. predSpec Int64.eq Int64.eq_spec n Int64.zero. @@ -808,28 +801,17 @@ Proof. predSpec Int64.eq Int64.eq_spec n Int64.one. subst n. exists x; split; auto. destruct x; simpl; auto. rewrite Int64.mul_one. auto. - destruct (Int64.is_power2 n) as [l|] eqn:P2. - exploit eval_shllimm. eauto. instantiate (1 := Int.repr (Int64.unsigned l)). - intros [v [A B]]. + destruct (Int64.is_power2' n) as [l|] eqn:P2. + exploit eval_shllimm. eauto. instantiate (1 := l). intros [v [A B]]. exists v; split; auto. destruct x; simpl; auto. - erewrite Int64.mul_pow2 by eauto. - assert (EQ: Int.unsigned (Int.repr (Int64.unsigned l)) = Int64.unsigned l). - { apply Int.unsigned_repr. - exploit Int64.is_power2_rng; eauto. - assert (Int64.zwordsize < Int.max_unsigned) by (compute; auto). - omega. - } - simpl in B. - replace (Int.ltu (Int.repr (Int64.unsigned l)) Int64.iwordsize') - with (Int64.ltu l Int64.iwordsize) in B. - erewrite Int64.is_power2_range in B by eauto. - unfold Int64.shl' in B. rewrite EQ in B. auto. - unfold Int64.ltu, Int.ltu. rewrite EQ. auto. + erewrite Int64.mul_pow2' by eauto. + simpl in B. erewrite Int64.is_power2'_range in B by eauto. + exact B. apply eval_mull_base; auto. apply eval_longconst. Qed. -Theorem eval_mull: binary_constructor_sound (mull hf) Val.mull. +Theorem eval_mull: binary_constructor_sound mull Val.mull. Proof. unfold mull; red; intros. destruct (is_longconst a) as [p|] eqn:LC1; @@ -846,128 +828,93 @@ Proof. - apply eval_mull_base; auto. Qed. -Lemma eval_binop_long: - forall id name sem le a b x y z, - (forall p q, x = Vlong p -> y = Vlong q -> z = Vlong (sem p q)) -> - helper_declared prog id name sig_ll_l -> - external_implements name sig_ll_l (x::y::nil) z -> +Theorem eval_mullhu: + forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)). +Proof. + unfold mullhu; intros; red; intros. econstructor; split; eauto. + eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper; eauto. UseHelper. +Qed. + +Theorem eval_mullhs: + forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)). +Proof. + unfold mullhs; intros; red; intros. econstructor; split; eauto. + eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper; eauto. UseHelper. +Qed. + +Theorem eval_shrxlimm: + forall le a n x z, + Archi.ptr64 = false -> eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - exists v, eval_expr ge sp e m le (binop_long id sem a b) v /\ Val.lessdef z v. + Val.shrxl x (Vint n) = Some z -> + exists v, eval_expr ge sp e m le (shrxlimm a n) v /\ Val.lessdef z v. Proof. - intros. unfold binop_long. - destruct (is_longconst a) as [p|] eqn:LC1. - destruct (is_longconst b) as [q|] eqn:LC2. - exploit is_longconst_sound. eexact LC1. eauto. intros EQ; subst x. - exploit is_longconst_sound. eexact LC2. eauto. intros EQ; subst y. - econstructor; split. EvalOp. erewrite H by eauto. rewrite Int64.ofwords_recompose. auto. - econstructor; split. eapply eval_helper_2; eauto. auto. - econstructor; split. eapply eval_helper_2; eauto. auto. + intros. + apply Val.shrxl_shrl_2 in H1. unfold shrxlimm. + destruct (Int.eq n Int.zero). +- subst z; exists x; auto. +- set (le' := x :: le). + edestruct (eval_shrlimm (Int.repr 63) le' (Eletvar O)) as (v1 & A1 & B1). + constructor. reflexivity. + edestruct (eval_shrluimm (Int.sub (Int.repr 64) n) le') as (v2 & A2 & B2). + eexact A1. + edestruct (eval_addl H le' (Eletvar 0)) as (v3 & A3 & B3). + constructor. reflexivity. eexact A2. + edestruct (eval_shrlimm n le') as (v4 & A4 & B4). eexact A3. + exists v4; split. + econstructor; eauto. + assert (X: forall v1 v2 n, Val.lessdef v1 v2 -> Val.lessdef (Val.shrl v1 (Vint n)) (Val.shrl v2 (Vint n))). + { intros. inv H2; auto. } + assert (Y: forall v1 v2 n, Val.lessdef v1 v2 -> Val.lessdef (Val.shrlu v1 (Vint n)) (Val.shrlu v2 (Vint n))). + { intros. inv H2; auto. } + subst z. eapply Val.lessdef_trans; [|eexact B4]. apply X. + eapply Val.lessdef_trans; [|eexact B3]. apply Val.addl_lessdef; auto. + eapply Val.lessdef_trans; [|eexact B2]. apply Y. + auto. Qed. -Theorem eval_divl: +Theorem eval_divlu_base: forall le a b x y z, eval_expr ge sp e m le a x -> eval_expr ge sp e m le b y -> - Val.divls x y = Some z -> - exists v, eval_expr ge sp e m le (divl hf a b) v /\ Val.lessdef z v. + Val.divlu x y = Some z -> + exists v, eval_expr ge sp e m le (divlu_base a b) v /\ Val.lessdef z v. Proof. - intros. eapply eval_binop_long; eauto. - intros; subst; simpl in H1. - destruct (Int64.eq q Int64.zero - || Int64.eq p (Int64.repr Int64.min_signed) && Int64.eq q Int64.mone); inv H1. - auto. - DeclHelper. UseHelper. + intros; unfold divlu_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. Qed. -Theorem eval_modl: +Theorem eval_modlu_base: forall le a b x y z, eval_expr ge sp e m le a x -> eval_expr ge sp e m le b y -> - Val.modls x y = Some z -> - exists v, eval_expr ge sp e m le (modl hf a b) v /\ Val.lessdef z v. + Val.modlu x y = Some z -> + exists v, eval_expr ge sp e m le (modlu_base a b) v /\ Val.lessdef z v. Proof. - intros. eapply eval_binop_long; eauto. - intros; subst; simpl in H1. - destruct (Int64.eq q Int64.zero - || Int64.eq p (Int64.repr Int64.min_signed) && Int64.eq q Int64.mone); inv H1. - auto. - DeclHelper. UseHelper. + intros; unfold modlu_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. Qed. -Theorem eval_divlu: +Theorem eval_divls_base: forall le a b x y z, eval_expr ge sp e m le a x -> eval_expr ge sp e m le b y -> - Val.divlu x y = Some z -> - exists v, eval_expr ge sp e m le (divlu hf a b) v /\ Val.lessdef z v. + Val.divls x y = Some z -> + exists v, eval_expr ge sp e m le (divls_base a b) v /\ Val.lessdef z v. Proof. - intros. unfold divlu. - set (default := Eexternal hf.(i64_udiv) sig_ll_l (a ::: b ::: Enil)). - assert (DEFAULT: - exists v, eval_expr ge sp e m le default v /\ Val.lessdef z v). - { - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. - } - destruct (is_longconst a) as [p|] eqn:LC1; - destruct (is_longconst b) as [q|] eqn:LC2. -- exploit (is_longconst_sound le a); eauto. intros EQ; subst x. - exploit (is_longconst_sound le b); eauto. intros EQ; subst y. - econstructor; split. apply eval_longconst. - simpl in H1. destruct (Int64.eq q Int64.zero); inv H1. auto. -- auto. -- destruct (Int64.is_power2 q) as [l|] eqn:P2; auto. - exploit (is_longconst_sound le b); eauto. intros EQ; subst y. - replace z with (Val.shrlu x (Vint (Int.repr (Int64.unsigned l)))). - apply eval_shrluimm. auto. - destruct x; simpl in H1; try discriminate. - destruct (Int64.eq q Int64.zero); inv H1. - simpl. - assert (EQ: Int.unsigned (Int.repr (Int64.unsigned l)) = Int64.unsigned l). - { apply Int.unsigned_repr. - exploit Int64.is_power2_rng; eauto. - assert (Int64.zwordsize < Int.max_unsigned) by (compute; auto). - omega. - } - replace (Int.ltu (Int.repr (Int64.unsigned l)) Int64.iwordsize') - with (Int64.ltu l Int64.iwordsize). - erewrite Int64.is_power2_range by eauto. - erewrite Int64.divu_pow2 by eauto. - unfold Int64.shru', Int64.shru. rewrite EQ. auto. - unfold Int64.ltu, Int.ltu. rewrite EQ. auto. -- auto. + intros; unfold divls_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. Qed. -Theorem eval_modlu: +Theorem eval_modls_base: forall le a b x y z, eval_expr ge sp e m le a x -> eval_expr ge sp e m le b y -> - Val.modlu x y = Some z -> - exists v, eval_expr ge sp e m le (modlu hf a b) v /\ Val.lessdef z v. + Val.modls x y = Some z -> + exists v, eval_expr ge sp e m le (modls_base a b) v /\ Val.lessdef z v. Proof. - intros. unfold modlu. - set (default := Eexternal hf.(i64_umod) sig_ll_l (a ::: b ::: Enil)). - assert (DEFAULT: - exists v, eval_expr ge sp e m le default v /\ Val.lessdef z v). - { - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. - } - destruct (is_longconst a) as [p|] eqn:LC1; - destruct (is_longconst b) as [q|] eqn:LC2. -- exploit (is_longconst_sound le a); eauto. intros EQ; subst x. - exploit (is_longconst_sound le b); eauto. intros EQ; subst y. - econstructor; split. apply eval_longconst. - simpl in H1. destruct (Int64.eq q Int64.zero); inv H1. auto. -- auto. -- destruct (Int64.is_power2 q) as [l|] eqn:P2; auto. - exploit (is_longconst_sound le b); eauto. intros EQ; subst y. - replace z with (Val.andl x (Vlong (Int64.sub q Int64.one))). - apply eval_andl. auto. apply eval_longconst. - destruct x; simpl in H1; try discriminate. - destruct (Int64.eq q Int64.zero); inv H1. - simpl. - erewrite Int64.modu_and by eauto. auto. -- auto. + intros; unfold modls_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. Qed. Remark decompose_cmpl_eq_zero: @@ -1058,11 +1005,12 @@ Theorem eval_cmplu: forall c le a x b y v, eval_expr ge sp e m le a x -> eval_expr ge sp e m le b y -> - Val.cmplu c x y = Some v -> + Val.cmplu (Mem.valid_pointer m) c x y = Some v -> + Archi.ptr64 = false -> eval_expr ge sp e m le (cmplu c a b) v. Proof. - intros. unfold Val.cmplu in H1. - destruct x; simpl in H1; try discriminate. destruct y; inv H1. + intros. unfold Val.cmplu, Val.cmplu_bool in H1. rewrite H2 in H1. simpl in H1. + destruct x; simpl in H1; try discriminate H1; destruct y; inv H1. rename i into x. rename i0 into y. destruct c; simpl. - (* Ceq *) diff --git a/backend/Stacking.v b/backend/Stacking.v index d1c17029..700025c2 100644 --- a/backend/Stacking.v +++ b/backend/Stacking.v @@ -39,7 +39,7 @@ Fixpoint save_callee_save_rec (rl: list mreg) (ofs: Z) (k: Mach.code) := let ty := mreg_type r in let sz := AST.typesize ty in let ofs1 := align ofs sz in - Msetstack r (Int.repr ofs1) ty :: save_callee_save_rec rl (ofs1 + sz) k + Msetstack r (Ptrofs.repr ofs1) ty :: save_callee_save_rec rl (ofs1 + sz) k end. Definition save_callee_save (fe: frame_env) (k: Mach.code) := @@ -56,7 +56,7 @@ Fixpoint restore_callee_save_rec (rl: list mreg) (ofs: Z) (k: Mach.code) := let ty := mreg_type r in let sz := AST.typesize ty in let ofs1 := align ofs sz in - Mgetstack (Int.repr ofs1) ty r :: restore_callee_save_rec rl (ofs1 + sz) k + Mgetstack (Ptrofs.repr ofs1) ty r :: restore_callee_save_rec rl (ofs1 + sz) k end. Definition restore_callee_save (fe: frame_env) (k: Mach.code) := @@ -72,10 +72,10 @@ Definition restore_callee_save (fe: frame_env) (k: Mach.code) := behaviour. *) Definition transl_op (fe: frame_env) (op: operation) := - shift_stack_operation (Int.repr fe.(fe_stack_data)) op. + shift_stack_operation fe.(fe_stack_data) op. Definition transl_addr (fe: frame_env) (addr: addressing) := - shift_stack_addressing (Int.repr fe.(fe_stack_data)) addr. + shift_stack_addressing fe.(fe_stack_data) addr. (** Translation of a builtin argument. *) @@ -83,16 +83,16 @@ Fixpoint transl_builtin_arg (fe: frame_env) (a: builtin_arg loc) : builtin_arg m match a with | BA (R r) => BA r | BA (S Local ofs ty) => - BA_loadstack (chunk_of_type ty) (Int.repr (offset_local fe ofs)) + BA_loadstack (chunk_of_type ty) (Ptrofs.repr (offset_local fe ofs)) | BA (S _ _ _) => BA_int Int.zero (**r never happens *) | BA_int n => BA_int n | BA_long n => BA_long n | BA_float n => BA_float n | BA_single n => BA_single n | BA_loadstack chunk ofs => - BA_loadstack chunk (Int.add ofs (Int.repr fe.(fe_stack_data))) + BA_loadstack chunk (Ptrofs.add ofs (Ptrofs.repr fe.(fe_stack_data))) | BA_addrstack ofs => - BA_addrstack (Int.add ofs (Int.repr fe.(fe_stack_data))) + BA_addrstack (Ptrofs.add ofs (Ptrofs.repr fe.(fe_stack_data))) | BA_loadglobal chunk id ofs => BA_loadglobal chunk id ofs | BA_addrglobal id ofs => BA_addrglobal id ofs | BA_splitlong hi lo => @@ -114,20 +114,20 @@ Definition transl_instr | Lgetstack sl ofs ty r => match sl with | Local => - Mgetstack (Int.repr (offset_local fe ofs)) ty r :: k + Mgetstack (Ptrofs.repr (offset_local fe ofs)) ty r :: k | Incoming => - Mgetparam (Int.repr (offset_arg ofs)) ty r :: k + Mgetparam (Ptrofs.repr (offset_arg ofs)) ty r :: k | Outgoing => - Mgetstack (Int.repr (offset_arg ofs)) ty r :: k + Mgetstack (Ptrofs.repr (offset_arg ofs)) ty r :: k end | Lsetstack r sl ofs ty => match sl with | Local => - Msetstack r (Int.repr (offset_local fe ofs)) ty :: k + Msetstack r (Ptrofs.repr (offset_local fe ofs)) ty :: k | Incoming => k (* should not happen *) | Outgoing => - Msetstack r (Int.repr (offset_arg ofs)) ty :: k + Msetstack r (Ptrofs.repr (offset_arg ofs)) ty :: k end | Lop op args res => Mop (transl_op fe op) args res :: k @@ -175,15 +175,15 @@ Definition transf_function (f: Linear.function) : res Mach.function := let fe := make_env (function_bounds f) in if negb (wt_function f) then Error (msg "Ill-formed Linear code") - else if zlt Int.max_unsigned fe.(fe_size) then + else if zlt Ptrofs.max_unsigned fe.(fe_size) then Error (msg "Too many spilled variables, stack size exceeded") else OK (Mach.mkfunction f.(Linear.fn_sig) (transl_body f fe) fe.(fe_size) - (Int.repr fe.(fe_ofs_link)) - (Int.repr fe.(fe_ofs_retaddr))). + (Ptrofs.repr fe.(fe_ofs_link)) + (Ptrofs.repr fe.(fe_ofs_retaddr))). Definition transf_fundef (f: Linear.fundef) : res Mach.fundef := AST.transf_partial_fundef transf_function f. diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index 0e9c58b3..d8d916de 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -67,12 +67,14 @@ Lemma load_result_inject: forall j ty v v', Val.inject j v v' -> Val.has_type v ty -> Val.inject j v (Val.load_result (chunk_of_type ty) v'). Proof. - destruct 1; intros; auto; destruct ty; simpl; try contradiction; econstructor; eauto. + intros until v'; unfold Val.has_type, Val.load_result; destruct Archi.ptr64; + destruct 1; intros; auto; destruct ty; simpl; + try contradiction; try discriminate; econstructor; eauto. Qed. Section PRESERVATION. -Variable return_address_offset: Mach.function -> Mach.code -> int -> Prop. +Variable return_address_offset: Mach.function -> Mach.code -> ptrofs -> Prop. Hypothesis return_address_offset_exists: forall f sg ros c, @@ -100,12 +102,12 @@ Lemma unfold_transf_function: f.(Linear.fn_sig) (transl_body f fe) fe.(fe_size) - (Int.repr fe.(fe_ofs_link)) - (Int.repr fe.(fe_ofs_retaddr)). + (Ptrofs.repr fe.(fe_ofs_link)) + (Ptrofs.repr fe.(fe_ofs_retaddr)). Proof. generalize TRANSF_F. unfold transf_function. destruct (wt_function f); simpl negb. - destruct (zlt Int.max_unsigned (fe_size (make_env (function_bounds f)))). + destruct (zlt Ptrofs.max_unsigned (fe_size (make_env (function_bounds f)))). intros; discriminate. intros. unfold fe. unfold b. congruence. intros; discriminate. @@ -118,11 +120,11 @@ Proof. destruct (wt_function f); simpl negb. auto. intros; discriminate. Qed. -Lemma size_no_overflow: fe.(fe_size) <= Int.max_unsigned. +Lemma size_no_overflow: fe.(fe_size) <= Ptrofs.max_unsigned. Proof. generalize TRANSF_F. unfold transf_function. destruct (wt_function f); simpl negb. - destruct (zlt Int.max_unsigned (fe_size (make_env (function_bounds f)))). + destruct (zlt Ptrofs.max_unsigned (fe_size (make_env (function_bounds f)))). intros; discriminate. intros. unfold fe. unfold b. omega. intros; discriminate. @@ -143,18 +145,18 @@ Local Opaque Z.add Z.mul Z.divide. Lemma contains_get_stack: forall spec m ty sp ofs, m |= contains (chunk_of_type ty) sp ofs spec -> - exists v, load_stack m (Vptr sp Int.zero) ty (Int.repr ofs) = Some v /\ spec v. + exists v, load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr ofs) = Some v /\ spec v. Proof. intros. unfold load_stack. - replace (Val.add (Vptr sp Int.zero) (Vint (Int.repr ofs))) with (Vptr sp (Int.repr ofs)). + replace (Val.offset_ptr (Vptr sp Ptrofs.zero) (Ptrofs.repr ofs)) with (Vptr sp (Ptrofs.repr ofs)). eapply loadv_rule; eauto. - simpl. rewrite Int.add_zero_l; auto. + simpl. rewrite Ptrofs.add_zero_l; auto. Qed. Lemma hasvalue_get_stack: forall ty m sp ofs v, m |= hasvalue (chunk_of_type ty) sp ofs v -> - load_stack m (Vptr sp Int.zero) ty (Int.repr ofs) = Some v. + load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr ofs) = Some v. Proof. intros. exploit contains_get_stack; eauto. intros (v' & A & B). congruence. Qed. @@ -164,13 +166,13 @@ Lemma contains_set_stack: m |= contains (chunk_of_type ty) sp ofs spec1 ** P -> spec (Val.load_result (chunk_of_type ty) v) -> exists m', - store_stack m (Vptr sp Int.zero) ty (Int.repr ofs) v = Some m' + store_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr ofs) v = Some m' /\ m' |= contains (chunk_of_type ty) sp ofs spec ** P. Proof. intros. unfold store_stack. - replace (Val.add (Vptr sp Int.zero) (Vint (Int.repr ofs))) with (Vptr sp (Int.repr ofs)). + replace (Val.offset_ptr (Vptr sp Ptrofs.zero) (Ptrofs.repr ofs)) with (Vptr sp (Ptrofs.repr ofs)). eapply storev_rule; eauto. - simpl. rewrite Int.add_zero_l; auto. + simpl. rewrite Ptrofs.add_zero_l; auto. Qed. (** [contains_locations j sp pos bound sl ls] is a separation logic assertion @@ -184,7 +186,7 @@ Qed. Program Definition contains_locations (j: meminj) (sp: block) (pos bound: Z) (sl: slot) (ls: locset) : massert := {| m_pred := fun m => - (8 | pos) /\ 0 <= pos /\ pos + 4 * bound <= Int.modulus /\ + (8 | pos) /\ 0 <= pos /\ pos + 4 * bound <= Ptrofs.modulus /\ Mem.range_perm m sp pos (pos + 4 * bound) Cur Freeable /\ forall ofs ty, 0 <= ofs -> ofs + typesize ty <= bound -> (typealign ty | ofs) -> exists v, Mem.load (chunk_of_type ty) m sp (pos + 4 * ofs) = Some v @@ -225,13 +227,13 @@ Lemma get_location: m |= contains_locations j sp pos bound sl ls -> 0 <= ofs -> ofs + typesize ty <= bound -> (typealign ty | ofs) -> exists v, - load_stack m (Vptr sp Int.zero) ty (Int.repr (pos + 4 * ofs)) = Some v + load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (pos + 4 * ofs)) = Some v /\ Val.inject j (ls (S sl ofs ty)) v. Proof. intros. destruct H as (D & E & F & G & H). exploit H; eauto. intros (v & U & V). exists v; split; auto. - unfold load_stack; simpl. rewrite Int.add_zero_l, Int.unsigned_repr; auto. - unfold Int.max_unsigned. generalize (typesize_pos ty). omega. + unfold load_stack; simpl. rewrite Ptrofs.add_zero_l, Ptrofs.unsigned_repr; auto. + unfold Ptrofs.max_unsigned. generalize (typesize_pos ty). omega. Qed. Lemma set_location: @@ -240,7 +242,7 @@ Lemma set_location: 0 <= ofs -> ofs + typesize ty <= bound -> (typealign ty | ofs) -> Val.inject j v v' -> exists m', - store_stack m (Vptr sp Int.zero) ty (Int.repr (pos + 4 * ofs)) v' = Some m' + store_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (pos + 4 * ofs)) v' = Some m' /\ m' |= contains_locations j sp pos bound sl (Locmap.set (S sl ofs ty) v ls) ** P. Proof. intros. destruct H as (A & B & C). destruct A as (D & E & F & G & H). @@ -249,8 +251,8 @@ Proof. assert (PERM: Mem.range_perm m' sp pos (pos + 4 * bound) Cur Freeable). { red; intros; eauto with mem. } exists m'; split. -- unfold store_stack; simpl. rewrite Int.add_zero_l, Int.unsigned_repr; eauto. - unfold Int.max_unsigned. generalize (typesize_pos ty). omega. +- unfold store_stack; simpl. rewrite Ptrofs.add_zero_l, Ptrofs.unsigned_repr; eauto. + unfold Ptrofs.max_unsigned. generalize (typesize_pos ty). omega. - simpl. intuition auto. + unfold Locmap.set. destruct (Loc.eq (S sl ofs ty) (S sl ofs0 ty0)); [|destruct (Loc.diff_dec (S sl ofs ty) (S sl ofs0 ty0))]. @@ -258,7 +260,7 @@ Proof. inv e. rename ofs0 into ofs. rename ty0 into ty. exists (Val.load_result (chunk_of_type ty) v'); split. eapply Mem.load_store_similar_2; eauto. omega. - inv H3; destruct (chunk_of_type ty); simpl; econstructor; eauto. + apply Val.load_result_inject; auto. * (* different locations *) exploit H; eauto. intros (v0 & X & Y). exists v0; split; auto. rewrite <- X; eapply Mem.load_store_other; eauto. @@ -366,8 +368,8 @@ represents the Linear stack data. *) Definition frame_contents_1 (j: meminj) (sp: block) (ls ls0: locset) (parent retaddr: val) := contains_locations j sp fe.(fe_ofs_local) b.(bound_local) Local ls ** contains_locations j sp fe_ofs_arg b.(bound_outgoing) Outgoing ls - ** hasvalue Mint32 sp fe.(fe_ofs_link) parent - ** hasvalue Mint32 sp fe.(fe_ofs_retaddr) retaddr + ** hasvalue Mptr sp fe.(fe_ofs_link) parent + ** hasvalue Mptr sp fe.(fe_ofs_retaddr) retaddr ** contains_callee_saves j sp fe.(fe_ofs_callee_save) b.(used_callee_save) ls0. Definition frame_contents (j: meminj) (sp: block) (ls ls0: locset) (parent retaddr: val) := @@ -382,7 +384,7 @@ Lemma frame_get_local: m |= frame_contents j sp ls ls0 parent retaddr ** P -> slot_within_bounds b Local ofs ty -> slot_valid f Local ofs ty = true -> exists v, - load_stack m (Vptr sp Int.zero) ty (Int.repr (offset_local fe ofs)) = Some v + load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (offset_local fe ofs)) = Some v /\ Val.inject j (ls (S Local ofs ty)) v. Proof. unfold frame_contents, frame_contents_1; intros. unfold slot_valid in H1; InvBooleans. @@ -395,7 +397,7 @@ Lemma frame_get_outgoing: m |= frame_contents j sp ls ls0 parent retaddr ** P -> slot_within_bounds b Outgoing ofs ty -> slot_valid f Outgoing ofs ty = true -> exists v, - load_stack m (Vptr sp Int.zero) ty (Int.repr (offset_arg ofs)) = Some v + load_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (offset_arg ofs)) = Some v /\ Val.inject j (ls (S Outgoing ofs ty)) v. Proof. unfold frame_contents, frame_contents_1; intros. unfold slot_valid in H1; InvBooleans. @@ -406,20 +408,20 @@ Qed. Lemma frame_get_parent: forall j sp ls ls0 parent retaddr m P, m |= frame_contents j sp ls ls0 parent retaddr ** P -> - load_stack m (Vptr sp Int.zero) Tint (Int.repr fe.(fe_ofs_link)) = Some parent. + load_stack m (Vptr sp Ptrofs.zero) Tptr (Ptrofs.repr fe.(fe_ofs_link)) = Some parent. Proof. unfold frame_contents, frame_contents_1; intros. - apply mconj_proj1 in H. apply sep_proj1 in H. apply sep_pick3 in H. + apply mconj_proj1 in H. apply sep_proj1 in H. apply sep_pick3 in H. rewrite <- chunk_of_Tptr in H. eapply hasvalue_get_stack; eauto. Qed. Lemma frame_get_retaddr: forall j sp ls ls0 parent retaddr m P, m |= frame_contents j sp ls ls0 parent retaddr ** P -> - load_stack m (Vptr sp Int.zero) Tint (Int.repr fe.(fe_ofs_retaddr)) = Some retaddr. + load_stack m (Vptr sp Ptrofs.zero) Tptr (Ptrofs.repr fe.(fe_ofs_retaddr)) = Some retaddr. Proof. unfold frame_contents, frame_contents_1; intros. - apply mconj_proj1 in H. apply sep_proj1 in H. apply sep_pick4 in H. + apply mconj_proj1 in H. apply sep_proj1 in H. apply sep_pick4 in H. rewrite <- chunk_of_Tptr in H. eapply hasvalue_get_stack; eauto. Qed. @@ -431,7 +433,7 @@ Lemma frame_set_local: slot_within_bounds b Local ofs ty -> slot_valid f Local ofs ty = true -> Val.inject j v v' -> exists m', - store_stack m (Vptr sp Int.zero) ty (Int.repr (offset_local fe ofs)) v' = Some m' + store_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (offset_local fe ofs)) v' = Some m' /\ m' |= frame_contents j sp (Locmap.set (S Local ofs ty) v ls) ls0 parent retaddr ** P. Proof. intros. unfold frame_contents in H. @@ -456,7 +458,7 @@ Lemma frame_set_outgoing: slot_within_bounds b Outgoing ofs ty -> slot_valid f Outgoing ofs ty = true -> Val.inject j v v' -> exists m', - store_stack m (Vptr sp Int.zero) ty (Int.repr (offset_arg ofs)) v' = Some m' + store_stack m (Vptr sp Ptrofs.zero) ty (Ptrofs.repr (offset_arg ofs)) v' = Some m' /\ m' |= frame_contents j sp (Locmap.set (S Outgoing ofs ty) v ls) ls0 parent retaddr ** P. Proof. intros. unfold frame_contents in H. @@ -855,7 +857,8 @@ Qed. Remark destroyed_by_store_caller_save: forall chunk addr, no_callee_saves (destroyed_by_store chunk addr). Proof. - unfold no_callee_saves; destruct chunk; reflexivity. +Local Transparent destroyed_by_store. + unfold no_callee_saves, destroyed_by_store; intros; destruct chunk; try reflexivity; destruct Archi.ptr64; reflexivity. Qed. Remark destroyed_by_cond_caller_save: @@ -939,12 +942,13 @@ Lemma save_callee_save_rec_correct: agree_regs j ls rs -> exists rs', exists m', star step tge - (State cs fb (Vptr sp Int.zero) (save_callee_save_rec l pos k) rs m) - E0 (State cs fb (Vptr sp Int.zero) k rs' m') + (State cs fb (Vptr sp Ptrofs.zero) (save_callee_save_rec l pos k) rs m) + E0 (State cs fb (Vptr sp Ptrofs.zero) k rs' m') /\ m' |= contains_callee_saves j sp pos l ls ** P /\ (forall ofs k p, Mem.perm m sp ofs k p -> Mem.perm m' sp ofs k p) /\ agree_regs j ls rs'. Proof. +Local Opaque mreg_type. induction l as [ | r l]; simpl; intros until P; intros CS SEP AG. - exists rs, m. split. apply star_refl. @@ -1029,8 +1033,8 @@ Lemma save_callee_save_correct: let rs1 := undef_regs destroyed_at_function_entry rs in exists rs', exists m', star step tge - (State cs fb (Vptr sp Int.zero) (save_callee_save fe k) rs1 m) - E0 (State cs fb (Vptr sp Int.zero) k rs' m') + (State cs fb (Vptr sp Ptrofs.zero) (save_callee_save fe k) rs1 m) + E0 (State cs fb (Vptr sp Ptrofs.zero) k rs' m') /\ m' |= contains_callee_saves j sp fe.(fe_ofs_callee_save) b.(used_callee_save) ls0 ** P /\ (forall ofs k p, Mem.perm m sp ofs k p -> Mem.perm m' sp ofs k p) /\ agree_regs j ls1 rs'. @@ -1071,15 +1075,15 @@ Lemma function_prologue_correct: ls1 = LTL.undef_regs destroyed_at_function_entry (LTL.call_regs ls) -> rs1 = undef_regs destroyed_at_function_entry rs -> Mem.alloc m1 0 f.(Linear.fn_stacksize) = (m2, sp) -> - Val.has_type parent Tint -> Val.has_type ra Tint -> + Val.has_type parent Tptr -> Val.has_type ra Tptr -> m1' |= minjection j m1 ** globalenv_inject ge j ** P -> exists j', exists rs', exists m2', exists sp', exists m3', exists m4', exists m5', Mem.alloc m1' 0 tf.(fn_stacksize) = (m2', sp') - /\ store_stack m2' (Vptr sp' Int.zero) Tint tf.(fn_link_ofs) parent = Some m3' - /\ store_stack m3' (Vptr sp' Int.zero) Tint tf.(fn_retaddr_ofs) ra = Some m4' + /\ store_stack m2' (Vptr sp' Ptrofs.zero) Tptr tf.(fn_link_ofs) parent = Some m3' + /\ store_stack m3' (Vptr sp' Ptrofs.zero) Tptr tf.(fn_retaddr_ofs) ra = Some m4' /\ star step tge - (State cs fb (Vptr sp' Int.zero) (save_callee_save fe k) rs1 m4') - E0 (State cs fb (Vptr sp' Int.zero) k rs' m5') + (State cs fb (Vptr sp' Ptrofs.zero) (save_callee_save fe k) rs1 m4') + E0 (State cs fb (Vptr sp' Ptrofs.zero) k rs' m5') /\ agree_regs j' ls1 rs' /\ agree_locs ls1 ls0 /\ m5' |= frame_contents j' sp' ls1 ls0 parent ra ** minjection j' m2 ** globalenv_inject ge j' ** P @@ -1113,17 +1117,17 @@ Local Opaque b fe. (* Dividing up the frame *) apply (frame_env_separated b) in SEP. replace (make_env b) with fe in SEP by auto. (* Store of parent *) - rewrite sep_swap3 in SEP. - apply (range_contains Mint32) in SEP; [|tauto]. - exploit (contains_set_stack (fun v' => v' = parent) parent (fun _ => True) m2' Tint). - eexact SEP. apply Val.load_result_same; auto. + rewrite sep_swap3 in SEP. + apply (range_contains Mptr) in SEP; [|tauto]. + exploit (contains_set_stack (fun v' => v' = parent) parent (fun _ => True) m2' Tptr). + rewrite chunk_of_Tptr; eexact SEP. apply Val.load_result_same; auto. clear SEP; intros (m3' & STORE_PARENT & SEP). rewrite sep_swap3 in SEP. (* Store of return address *) rewrite sep_swap4 in SEP. - apply (range_contains Mint32) in SEP; [|tauto]. - exploit (contains_set_stack (fun v' => v' = ra) ra (fun _ => True) m3' Tint). - eexact SEP. apply Val.load_result_same; auto. + apply (range_contains Mptr) in SEP; [|tauto]. + exploit (contains_set_stack (fun v' => v' = ra) ra (fun _ => True) m3' Tptr). + rewrite chunk_of_Tptr; eexact SEP. apply Val.load_result_same; auto. clear SEP; intros (m4' & STORE_RETADDR & SEP). rewrite sep_swap4 in SEP. (* Saving callee-save registers *) @@ -1147,7 +1151,8 @@ Local Opaque b fe. rewrite sep_swap in SEP. (* Now we frame this *) assert (SEPFINAL: m5' |= frame_contents j' sp' ls1 ls0 parent ra ** minjection j' m2 ** globalenv_inject ge j' ** P). - { eapply frame_mconj. eexact SEPCONJ. + { eapply frame_mconj. eexact SEPCONJ. + rewrite chunk_of_Tptr in SEP. unfold frame_contents_1; rewrite ! sep_assoc. exact SEP. assert (forall ofs k p, Mem.perm m2' sp' ofs k p -> Mem.perm m5' sp' ofs k p). { intros. apply PERMS. @@ -1198,12 +1203,13 @@ Lemma restore_callee_save_rec_correct: (forall r, In r l -> mreg_within_bounds b r) -> exists rs', star step tge - (State cs fb (Vptr sp Int.zero) (restore_callee_save_rec l ofs k) rs m) - E0 (State cs fb (Vptr sp Int.zero) k rs' m) + (State cs fb (Vptr sp Ptrofs.zero) (restore_callee_save_rec l ofs k) rs m) + E0 (State cs fb (Vptr sp Ptrofs.zero) k rs' m) /\ (forall r, In r l -> Val.inject j (ls0 (R r)) (rs' r)) /\ (forall r, ~(In r l) -> rs' r = rs r) /\ agree_unused ls0 rs'. Proof. +Local Opaque mreg_type. induction l as [ | r l]; simpl; intros. - (* base case *) exists rs. intuition auto. apply star_refl. @@ -1242,8 +1248,8 @@ Lemma restore_callee_save_correct: agree_unused j ls0 rs -> exists rs', star step tge - (State cs fb (Vptr sp Int.zero) (restore_callee_save fe k) rs m) - E0 (State cs fb (Vptr sp Int.zero) k rs' m) + (State cs fb (Vptr sp Ptrofs.zero) (restore_callee_save fe k) rs m) + E0 (State cs fb (Vptr sp Ptrofs.zero) k rs' m) /\ (forall r, is_callee_save r = true -> Val.inject j (ls0 (R r)) (rs' r)) /\ (forall r, @@ -1277,12 +1283,12 @@ Lemma function_epilogue_correct: j sp = Some(sp', fe.(fe_stack_data)) -> Mem.free m sp 0 f.(Linear.fn_stacksize) = Some m1 -> exists rs1, exists m1', - load_stack m' (Vptr sp' Int.zero) Tint tf.(fn_link_ofs) = Some pa - /\ load_stack m' (Vptr sp' Int.zero) Tint tf.(fn_retaddr_ofs) = Some ra + load_stack m' (Vptr sp' Ptrofs.zero) Tptr tf.(fn_link_ofs) = Some pa + /\ load_stack m' (Vptr sp' Ptrofs.zero) Tptr tf.(fn_retaddr_ofs) = Some ra /\ Mem.free m' sp' 0 tf.(fn_stacksize) = Some m1' /\ star step tge - (State cs fb (Vptr sp' Int.zero) (restore_callee_save fe k) rs m') - E0 (State cs fb (Vptr sp' Int.zero) k rs1 m') + (State cs fb (Vptr sp' Ptrofs.zero) (restore_callee_save fe k) rs m') + E0 (State cs fb (Vptr sp' Ptrofs.zero) k rs1 m') /\ agree_regs j (return_regs ls0 ls) rs1 /\ agree_callee_save (return_regs ls0 ls) ls0 /\ m1' |= minjection j m1 ** P. @@ -1304,8 +1310,8 @@ Proof. (* Reloading the back link and return address *) unfold frame_contents in SEP; apply mconj_proj1 in SEP. unfold frame_contents_1 in SEP; rewrite ! sep_assoc in SEP. - exploit (hasvalue_get_stack Tint). eapply sep_pick3; eexact SEP. intros LOAD_LINK. - exploit (hasvalue_get_stack Tint). eapply sep_pick4; eexact SEP. intros LOAD_RETADDR. + exploit (hasvalue_get_stack Tptr). rewrite chunk_of_Tptr. eapply sep_pick3; eexact SEP. intros LOAD_LINK. + exploit (hasvalue_get_stack Tptr). rewrite chunk_of_Tptr. eapply sep_pick4; eexact SEP. intros LOAD_RETADDR. clear SEP. (* Conclusions *) rewrite unfold_transf_function; simpl. @@ -1353,15 +1359,15 @@ Inductive match_stacks (j: meminj): (TRF: transf_function f = OK trf) (TRC: transl_code (make_env (function_bounds f)) c = c') (INJ: j sp = Some(sp', (fe_stack_data (make_env (function_bounds f))))) - (TY_RA: Val.has_type ra Tint) + (TY_RA: Val.has_type ra Tptr) (AGL: agree_locs f ls (parent_locset cs)) (ARGS: forall ofs ty, In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments sg)) -> slot_within_bounds (function_bounds f) Outgoing ofs ty) (STK: match_stacks j cs cs' (Linear.fn_sig f)), match_stacks j - (Linear.Stackframe f (Vptr sp Int.zero) ls c :: cs) - (Stackframe fb (Vptr sp' Int.zero) ra c' :: cs') + (Linear.Stackframe f (Vptr sp Ptrofs.zero) ls c :: cs) + (Stackframe fb (Vptr sp' Ptrofs.zero) ra c' :: cs') sg. (** Invariance with respect to change of memory injection. *) @@ -1409,17 +1415,17 @@ Qed. Lemma match_stacks_type_sp: forall j cs cs' sg, match_stacks j cs cs' sg -> - Val.has_type (parent_sp cs') Tint. + Val.has_type (parent_sp cs') Tptr. Proof. - induction 1; simpl; auto. -Qed. + induction 1; unfold parent_sp. apply Val.Vnullptr_has_type. apply Val.Vptr_has_type. +Qed. Lemma match_stacks_type_retaddr: forall j cs cs' sg, match_stacks j cs cs' sg -> - Val.has_type (parent_ra cs') Tint. + Val.has_type (parent_ra cs') Tptr. Proof. - induction 1; simpl; auto. + induction 1; unfold parent_ra. apply Val.Vnullptr_has_type. auto. Qed. (** * Syntactic properties of the translation *) @@ -1700,11 +1706,11 @@ Hypothesis SEP: m' |= frame_contents f j sp' ls ls0 parent retaddr ** minjection Lemma transl_builtin_arg_correct: forall a v, - eval_builtin_arg ge ls (Vptr sp Int.zero) m a v -> + eval_builtin_arg ge ls (Vptr sp Ptrofs.zero) m a v -> (forall l, In l (params_of_builtin_arg a) -> loc_valid f l = true) -> (forall sl ofs ty, In (S sl ofs ty) (params_of_builtin_arg a) -> slot_within_bounds b sl ofs ty) -> exists v', - eval_builtin_arg ge rs (Vptr sp' Int.zero) m' (transl_builtin_arg fe a) v' + eval_builtin_arg ge rs (Vptr sp' Ptrofs.zero) m' (transl_builtin_arg fe a) v' /\ Val.inject j v v'. Proof. assert (SYMB: forall id ofs, Val.inject j (Senv.symbol_address ge id ofs) (Senv.symbol_address ge id ofs)). @@ -1712,7 +1718,7 @@ Proof. { eapply globalenv_inject_preserves_globals. eapply sep_proj2. eapply sep_proj2. eexact SEP. } intros; unfold Senv.symbol_address; simpl; unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) eqn:FS; auto. - destruct G. econstructor. eauto. rewrite Int.add_zero; auto. } + destruct G. econstructor. eauto. rewrite Ptrofs.add_zero; auto. } Local Opaque fe. induction 1; simpl; intros VALID BOUNDS. - assert (loc_valid f x = true) by auto. @@ -1724,13 +1730,13 @@ Local Opaque fe. - econstructor; eauto with barg. - econstructor; eauto with barg. - econstructor; eauto with barg. -- set (ofs' := Int.add ofs (Int.repr (fe_stack_data fe))). +- set (ofs' := Ptrofs.add ofs (Ptrofs.repr (fe_stack_data fe))). apply sep_proj2 in SEP. apply sep_proj1 in SEP. exploit loadv_parallel_rule; eauto. - instantiate (1 := Val.add (Vptr sp' Int.zero) (Vint ofs')). - simpl. rewrite ! Int.add_zero_l. econstructor; eauto. + instantiate (1 := Val.offset_ptr (Vptr sp' Ptrofs.zero) ofs'). + simpl. rewrite ! Ptrofs.add_zero_l. econstructor; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. - econstructor; split; eauto with barg. - unfold Val.add. rewrite ! Int.add_zero_l. econstructor; eauto. + unfold Val.offset_ptr. rewrite ! Ptrofs.add_zero_l. econstructor; eauto. - apply sep_proj2 in SEP. apply sep_proj1 in SEP. exploit loadv_parallel_rule; eauto. intros (v' & A & B). exists v'; auto with barg. - econstructor; split; eauto with barg. @@ -1742,11 +1748,11 @@ Qed. Lemma transl_builtin_args_correct: forall al vl, - eval_builtin_args ge ls (Vptr sp Int.zero) m al vl -> + eval_builtin_args ge ls (Vptr sp Ptrofs.zero) m al vl -> (forall l, In l (params_of_builtin_args al) -> loc_valid f l = true) -> (forall sl ofs ty, In (S sl ofs ty) (params_of_builtin_args al) -> slot_within_bounds b sl ofs ty) -> exists vl', - eval_builtin_args ge rs (Vptr sp' Int.zero) m' (List.map (transl_builtin_arg fe) al) vl' + eval_builtin_args ge rs (Vptr sp' Ptrofs.zero) m' (List.map (transl_builtin_arg fe) al) vl' /\ Val.inject_list j vl vl'. Proof. induction 1; simpl; intros VALID BOUNDS. @@ -1798,8 +1804,8 @@ Inductive match_states: Linear.state -> Mach.state -> Prop := ** stack_contents j cs cs' ** minjection j m ** globalenv_inject ge j), - match_states (Linear.State cs f (Vptr sp Int.zero) c ls m) - (Mach.State cs' fb (Vptr sp' Int.zero) (transl_code (make_env (function_bounds f)) c) rs m') + match_states (Linear.State cs f (Vptr sp Ptrofs.zero) c ls m) + (Mach.State cs' fb (Vptr sp' Ptrofs.zero) (transl_code (make_env (function_bounds f)) c) rs m') | match_states_call: forall cs f ls m cs' fb rs m' j tf (STACKS: match_stacks j cs cs' (Linear.funsig f)) @@ -1882,7 +1888,7 @@ Proof. end). eapply frame_undef_regs with (rl := destroyed_by_setstack ty) in SEP. assert (A: exists m'', - store_stack m' (Vptr sp' Int.zero) ty (Int.repr ofs') (rs0 src) = Some m'' + store_stack m' (Vptr sp' Ptrofs.zero) ty (Ptrofs.repr ofs') (rs0 src) = Some m'' /\ m'' |= frame_contents f j sp' (Locmap.set (S sl ofs ty) (rs (R src)) (LTL.undef_regs (destroyed_by_setstack ty) rs)) (parent_locset s) (parent_sp cs') (parent_ra cs') @@ -1902,7 +1908,7 @@ Proof. - (* Lop *) assert (exists v', - eval_operation ge (Vptr sp' Int.zero) (transl_op (make_env (function_bounds f)) op) rs0##args m' = Some v' + eval_operation ge (Vptr sp' Ptrofs.zero) (transl_op (make_env (function_bounds f)) op) rs0##args m' = Some v' /\ Val.inject j v v'). eapply eval_operation_inject; eauto. eapply globalenv_inject_preserves_globals. eapply sep_proj2. eapply sep_proj2. eapply sep_proj2. eexact SEP. @@ -1921,7 +1927,7 @@ Proof. - (* Lload *) assert (exists a', - eval_addressing ge (Vptr sp' Int.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a' + eval_addressing ge (Vptr sp' Ptrofs.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a' /\ Val.inject j a a'). eapply eval_addressing_inject; eauto. eapply globalenv_inject_preserves_globals. eapply sep_proj2. eapply sep_proj2. eapply sep_proj2. eexact SEP. @@ -1941,7 +1947,7 @@ Proof. - (* Lstore *) assert (exists a', - eval_addressing ge (Vptr sp' Int.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a' + eval_addressing ge (Vptr sp' Ptrofs.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a' /\ Val.inject j a a'). eapply eval_addressing_inject; eauto. eapply globalenv_inject_preserves_globals. eapply sep_proj2. eapply sep_proj2. eapply sep_proj2. eexact SEP. @@ -1972,7 +1978,7 @@ Proof. apply plus_one. econstructor; eauto. econstructor; eauto. econstructor; eauto with coqlib. - simpl; auto. + apply Val.Vptr_has_type. intros; red. apply Zle_trans with (size_arguments (Linear.funsig f')); auto. apply loc_arguments_bounded; auto. @@ -2150,7 +2156,11 @@ Lemma transf_final_states: match_states st1 st2 -> Linear.final_state st1 r -> Mach.final_state st2 r. Proof. intros. inv H0. inv H. inv STACKS. - assert (R: exists r, loc_result signature_main = One r) by (econstructor; reflexivity). + assert (R: exists r, loc_result signature_main = One r). + { destruct (loc_result signature_main) as [r1 | r1 r2] eqn:LR. + - exists r1; auto. + - generalize (loc_result_type signature_main). rewrite LR. discriminate. + } destruct R as [rres EQ]. rewrite EQ in H1. simpl in H1. generalize (AGREGS rres). rewrite H1. intros A; inv A. econstructor; eauto. diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index 793dc861..1dcdfb64 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -310,14 +310,14 @@ Inductive match_stackframes: list stackframe -> list stackframe -> Prop := match_stackframes stk stk' -> regs_lessdef rs rs' -> match_stackframes - (Stackframe res f (Vptr sp Int.zero) pc rs :: stk) - (Stackframe res (transf_function f) (Vptr sp Int.zero) pc rs' :: stk') + (Stackframe res f (Vptr sp Ptrofs.zero) pc rs :: stk) + (Stackframe res (transf_function f) (Vptr sp Ptrofs.zero) pc rs' :: stk') | match_stackframes_tail: forall stk stk' res sp pc rs f, match_stackframes stk stk' -> is_return_spec f pc res -> f.(fn_stacksize) = 0 -> match_stackframes - (Stackframe res f (Vptr sp Int.zero) pc rs :: stk) + (Stackframe res f (Vptr sp Ptrofs.zero) pc rs :: stk) stk'. (** Here is the invariant relating two states. The first three @@ -331,8 +331,8 @@ Inductive match_states: state -> state -> Prop := (STACKS: match_stackframes s s') (RLD: regs_lessdef rs rs') (MLD: Mem.extends m m'), - match_states (State s f (Vptr sp Int.zero) pc rs m) - (State s' (transf_function f) (Vptr sp Int.zero) pc rs' m') + match_states (State s f (Vptr sp Ptrofs.zero) pc rs m) + (State s' (transf_function f) (Vptr sp Ptrofs.zero) pc rs' m') | match_states_call: forall s f args m s' args' m', match_stackframes s s' -> @@ -354,7 +354,7 @@ Inductive match_states: state -> state -> Prop := is_return_spec f pc r -> f.(fn_stacksize) = 0 -> Val.lessdef (rs#r) v' -> - match_states (State s f (Vptr sp Int.zero) pc rs m) + match_states (State s f (Vptr sp Ptrofs.zero) pc rs m) (Returnstate s' v' m'). (** The last case of [match_states] corresponds to the execution @@ -417,7 +417,7 @@ Proof. assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto. exploit eval_operation_lessdef; eauto. intros [v' [EVAL' VLD]]. - left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' (rs'#res <- v') m'); split. + left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (rs'#res <- v') m'); split. eapply exec_Iop; eauto. rewrite <- EVAL'. apply eval_operation_preserved. exact symbols_preserved. econstructor; eauto. apply set_reg_lessdef; auto. @@ -433,7 +433,7 @@ Proof. intros [a' [ADDR' ALD]]. exploit Mem.loadv_extends; eauto. intros [v' [LOAD' VLD]]. - left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' (rs'#dst <- v') m'); split. + left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (rs'#dst <- v') m'); split. eapply exec_Iload with (a := a'). eauto. rewrite <- ADDR'. apply eval_addressing_preserved. exact symbols_preserved. eauto. econstructor; eauto. apply set_reg_lessdef; auto. @@ -445,7 +445,7 @@ Proof. intros [a' [ADDR' ALD]]. exploit Mem.storev_extends. 2: eexact H1. eauto. eauto. apply RLD. intros [m'1 [STORE' MLD']]. - left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' rs' m'1); split. + left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' rs' m'1); split. eapply exec_Istore with (a := a'). eauto. rewrite <- ADDR'. apply eval_addressing_preserved. exact symbols_preserved. eauto. destruct a; simpl in H1; try discriminate. @@ -465,7 +465,7 @@ Proof. eapply Mem.free_right_extends; eauto. rewrite stacksize_preserved. rewrite H7. intros. omegaContradiction. + (* call that remains a call *) - left. exists (Callstate (Stackframe res (transf_function f) (Vptr sp0 Int.zero) pc' rs' :: s') + left. exists (Callstate (Stackframe res (transf_function f) (Vptr sp0 Ptrofs.zero) pc' rs' :: s') (transf_fundef fd) (rs'##args) m'); split. eapply exec_Icall; eauto. apply sig_preserved. constructor. constructor; auto. apply regs_lessdef_regs; auto. auto. @@ -485,7 +485,7 @@ Proof. intros (vargs' & P & Q). exploit external_call_mem_extends; eauto. intros [v' [m'1 [A [B [C D]]]]]. - left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' (regmap_setres res v' rs') m'1); split. + left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (regmap_setres res v' rs') m'1); split. eapply exec_Ibuiltin; eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved; eauto. apply senv_preserved. @@ -493,14 +493,14 @@ Proof. - (* cond *) TransfInstr. - left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) (if b then ifso else ifnot) rs' m'); split. + left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) (if b then ifso else ifnot) rs' m'); split. eapply exec_Icond; eauto. apply eval_condition_lessdef with (rs##args) m; auto. apply regs_lessdef_regs; auto. constructor; auto. - (* jumptable *) TransfInstr. - left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' rs' m'); split. + left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' rs' m'); split. eapply exec_Ijumptable; eauto. generalize (RLD arg). rewrite H0. intro. inv H2. auto. constructor; auto. diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index 44cf1e8a..7e9c3ca0 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -627,7 +627,7 @@ Lemma symbol_address_inject: Proof. intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. exploit symbols_inject_2; eauto. intros (b' & TFS & INJ). rewrite TFS. - econstructor; eauto. rewrite Int.add_zero; auto. + econstructor; eauto. rewrite Ptrofs.add_zero; auto. Qed. (** Semantic preservation *) @@ -691,8 +691,8 @@ Inductive match_stacks (j: meminj): (REGINJ: regset_inject j rs trs) (BELOW: Plt sp bound) (TBELOW: Plt tsp tbound), - match_stacks j (Stackframe res f (Vptr sp Int.zero) pc rs :: s) - (Stackframe res f (Vptr tsp Int.zero) pc trs :: ts) + match_stacks j (Stackframe res f (Vptr sp Ptrofs.zero) pc rs :: s) + (Stackframe res f (Vptr tsp Ptrofs.zero) pc trs :: ts) bound tbound. Lemma match_stacks_preserves_globals: @@ -759,8 +759,8 @@ Inductive match_states: state -> state -> Prop := (SPINJ: j sp = Some(tsp, 0)) (REGINJ: regset_inject j rs trs) (MEMINJ: Mem.inject j m tm), - match_states (State s f (Vptr sp Int.zero) pc rs m) - (State ts f (Vptr tsp Int.zero) pc trs tm) + match_states (State s f (Vptr sp Ptrofs.zero) pc rs m) + (State ts f (Vptr tsp Ptrofs.zero) pc trs tm) | match_states_call: forall s fd args m ts targs tm j (STACKS: match_stacks j s ts (Mem.nextblock m) (Mem.nextblock tm)) (KEPT: forall id, ref_fundef fd id -> kept id) @@ -819,14 +819,14 @@ Qed. Lemma eval_builtin_arg_inject: forall rs sp m j rs' sp' m' a v, - eval_builtin_arg ge (fun r => rs#r) (Vptr sp Int.zero) m a v -> + eval_builtin_arg ge (fun r => rs#r) (Vptr sp Ptrofs.zero) m a v -> j sp = Some(sp', 0) -> meminj_preserves_globals j -> regset_inject j rs rs' -> Mem.inject j m m' -> (forall id, In id (globals_of_builtin_arg a) -> kept id) -> exists v', - eval_builtin_arg tge (fun r => rs'#r) (Vptr sp' Int.zero) m' a v' + eval_builtin_arg tge (fun r => rs'#r) (Vptr sp' Ptrofs.zero) m' a v' /\ Val.inject j v v'. Proof. induction 1; intros SP GL RS MI K; simpl in K. @@ -837,18 +837,18 @@ Proof. - econstructor; eauto with barg. - simpl in H. exploit Mem.load_inject; eauto. rewrite Zplus_0_r. intros (v' & A & B). exists v'; auto with barg. -- econstructor; split; eauto with barg. simpl. econstructor; eauto. rewrite Int.add_zero; auto. +- econstructor; split; eauto with barg. simpl. econstructor; eauto. rewrite Ptrofs.add_zero; auto. - assert (Val.inject j (Senv.symbol_address ge id ofs) (Senv.symbol_address tge id ofs)). { unfold Senv.symbol_address; simpl; unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. exploit symbols_inject_2; eauto. intros (b' & A & B). rewrite A. - econstructor; eauto. rewrite Int.add_zero; auto. } + econstructor; eauto. rewrite Ptrofs.add_zero; auto. } exploit Mem.loadv_inject; eauto. intros (v' & A & B). exists v'; auto with barg. - econstructor; split; eauto with barg. unfold Senv.symbol_address; simpl; unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. exploit symbols_inject_2; eauto. intros (b' & A & B). rewrite A. - econstructor; eauto. rewrite Int.add_zero; auto. + econstructor; eauto. rewrite Ptrofs.add_zero; auto. - destruct IHeval_builtin_arg1 as (v1' & A1 & B1); eauto using in_or_app. destruct IHeval_builtin_arg2 as (v2' & A2 & B2); eauto using in_or_app. exists (Val.longofwords v1' v2'); split; auto with barg. @@ -857,14 +857,14 @@ Qed. Lemma eval_builtin_args_inject: forall rs sp m j rs' sp' m' al vl, - eval_builtin_args ge (fun r => rs#r) (Vptr sp Int.zero) m al vl -> + eval_builtin_args ge (fun r => rs#r) (Vptr sp Ptrofs.zero) m al vl -> j sp = Some(sp', 0) -> meminj_preserves_globals j -> regset_inject j rs rs' -> Mem.inject j m m' -> (forall id, In id (globals_of_builtin_args al) -> kept id) -> exists vl', - eval_builtin_args tge (fun r => rs'#r) (Vptr sp' Int.zero) m' al vl' + eval_builtin_args tge (fun r => rs'#r) (Vptr sp' Ptrofs.zero) m' al vl' /\ Val.inject_list j vl vl'. Proof. induction 1; intros. @@ -889,9 +889,9 @@ Proof. - (* op *) assert (A: exists tv, - eval_operation tge (Vptr tsp Int.zero) op trs##args tm = Some tv + eval_operation tge (Vptr tsp Ptrofs.zero) op trs##args tm = Some tv /\ Val.inject j v tv). - { apply eval_operation_inj with (ge1 := ge) (m1 := m) (sp1 := Vptr sp0 Int.zero) (vl1 := rs##args). + { apply eval_operation_inj with (ge1 := ge) (m1 := m) (sp1 := Vptr sp0 Ptrofs.zero) (vl1 := rs##args). intros; eapply Mem.valid_pointer_inject_val; eauto. intros; eapply Mem.weak_valid_pointer_inject_val; eauto. intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. @@ -907,9 +907,9 @@ Proof. - (* load *) assert (A: exists ta, - eval_addressing tge (Vptr tsp Int.zero) addr trs##args = Some ta + eval_addressing tge (Vptr tsp Ptrofs.zero) addr trs##args = Some ta /\ Val.inject j a ta). - { apply eval_addressing_inj with (ge1 := ge) (sp1 := Vptr sp0 Int.zero) (vl1 := rs##args). + { apply eval_addressing_inj with (ge1 := ge) (sp1 := Vptr sp0 Ptrofs.zero) (vl1 := rs##args). intros. apply symbol_address_inject. eapply match_stacks_preserves_globals; eauto. apply KEPT. red. exists pc, (Iload chunk addr args dst pc'); auto. econstructor; eauto. @@ -922,9 +922,9 @@ Proof. - (* store *) assert (A: exists ta, - eval_addressing tge (Vptr tsp Int.zero) addr trs##args = Some ta + eval_addressing tge (Vptr tsp Ptrofs.zero) addr trs##args = Some ta /\ Val.inject j a ta). - { apply eval_addressing_inj with (ge1 := ge) (sp1 := Vptr sp0 Int.zero) (vl1 := rs##args). + { apply eval_addressing_inj with (ge1 := ge) (sp1 := Vptr sp0 Ptrofs.zero) (vl1 := rs##args). intros. apply symbol_address_inject. eapply match_stacks_preserves_globals; eauto. apply KEPT. red. exists pc, (Istore chunk addr args src pc'); auto. econstructor; eauto. @@ -1104,11 +1104,11 @@ Proof. assert (kept i). { apply H. red. exists i0; auto with coqlib. } exploit symbols_inject_2. apply init_meminj_preserves_globals. eauto. eauto. intros (b' & A & B). rewrite A. apply inj_value_inject. - econstructor; eauto. symmetry; apply Int.add_zero. + econstructor; eauto. symmetry; apply Ptrofs.add_zero. destruct (Genv.find_symbol tge i) as [b'|] eqn:FS'. exploit symbols_inject_3. apply init_meminj_preserves_globals. eauto. intros (b & A & B). congruence. - apply repeat_Undef_inject_self with (n := 4%nat). + apply repeat_Undef_inject_self. + apply IHil. intros id [ofs IN]. apply H. exists ofs; auto with coqlib. Qed. @@ -1177,7 +1177,7 @@ Proof. exploit init_meminj_invert. eexact H1. intros (A2 & id2 & B2 & C2). destruct (ident_eq id1 id2). congruence. left; eapply Genv.global_addresses_distinct; eauto. - exploit init_meminj_invert; eauto. intros (A & id & B & C). subst delta. - split. omega. generalize (Int.unsigned_range_2 ofs). omega. + split. omega. generalize (Ptrofs.unsigned_range_2 ofs). omega. - exploit init_meminj_invert_strong; eauto. intros (A & id & gd & B & C & D & E & F). exploit (Genv.init_mem_characterization_gen p); eauto. exploit (Genv.init_mem_characterization_gen tp); eauto. diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index a4d34279..c89f8435 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -187,7 +187,7 @@ Definition store_init_data (ab: ablock) (p: Z) (id: init_data) : ablock := (if propagate_float_constants tt then FS n else ntop) | Init_float64 n => ablock_store Mfloat64 ab p (if propagate_float_constants tt then F n else ntop) - | Init_addrof symb ofs => ablock_store Mint32 ab p (Ptr (Gl symb ofs)) + | Init_addrof symb ofs => ablock_store Mptr ab p (Ptr (Gl symb ofs)) | Init_space n => ab end. @@ -329,13 +329,13 @@ Lemma abuiltin_arg_sound: genv_match bc ge -> bc sp = BCstack -> forall a v, - eval_builtin_arg ge (fun r => rs#r) (Vptr sp Int.zero) m a v -> + eval_builtin_arg ge (fun r => rs#r) (Vptr sp Ptrofs.zero) m a v -> vmatch bc v (abuiltin_arg ae am rm a). Proof. intros until am; intros EM RM MM GM SP. induction 1; simpl; eauto with va. -- eapply loadv_sound; eauto. simpl. rewrite Int.add_zero_l. auto with va. -- simpl. rewrite Int.add_zero_l. auto with va. +- eapply loadv_sound; eauto. simpl. rewrite Ptrofs.add_zero_l. auto with va. +- simpl. rewrite Ptrofs.add_zero_l. auto with va. - eapply loadv_sound; eauto. apply symbol_address_sound; auto. - apply symbol_address_sound; auto. Qed. @@ -348,7 +348,7 @@ Lemma abuiltin_args_sound: genv_match bc ge -> bc sp = BCstack -> forall al vl, - eval_builtin_args ge (fun r => rs#r) (Vptr sp Int.zero) m al vl -> + eval_builtin_args ge (fun r => rs#r) (Vptr sp Ptrofs.zero) m al vl -> list_forall2 (vmatch bc) vl (map (abuiltin_arg ae am rm) al). Proof. intros until am; intros EM RM MM GM SP. @@ -1050,7 +1050,7 @@ Inductive sound_stack: block_classification -> list stackframe -> mem -> block - (GE: genv_match bc' ge) (AN: VA.ge (analyze rm f)!!pc (VA.State (AE.set res Vtop ae) mafter_public_call)) (EM: ematch bc' e ae), - sound_stack bc (Stackframe res f (Vptr sp Int.zero) pc e :: stk) m bound + sound_stack bc (Stackframe res f (Vptr sp Ptrofs.zero) pc e :: stk) m bound | sound_stack_private_call: forall (bc: block_classification) res f sp pc e stk m bound bc' bound' ae am (STK: sound_stack bc' stk m sp) @@ -1063,7 +1063,7 @@ Inductive sound_stack: block_classification -> list stackframe -> mem -> block - (AN: VA.ge (analyze rm f)!!pc (VA.State (AE.set res (Ifptr Nonstack) ae) (mafter_private_call am))) (EM: ematch bc' e ae) (CONTENTS: bmatch bc' m sp am.(am_stack)), - sound_stack bc (Stackframe res f (Vptr sp Int.zero) pc e :: stk) m bound. + sound_stack bc (Stackframe res f (Vptr sp Ptrofs.zero) pc e :: stk) m bound. Inductive sound_state_base: state -> Prop := | sound_regular_state: @@ -1075,7 +1075,7 @@ Inductive sound_state_base: state -> Prop := (MM: mmatch bc m am) (GE: genv_match bc ge) (SP: bc sp = BCstack), - sound_state_base (State s f (Vptr sp Int.zero) pc e m) + sound_state_base (State s f (Vptr sp Ptrofs.zero) pc e m) | sound_call_state: forall s fd args m bc (STK: sound_stack bc s m (Mem.nextblock m)) @@ -1143,7 +1143,7 @@ Qed. Lemma sound_stack_storebytes: forall m b ofs bytes m' bc aaddr stk bound, - Mem.storebytes m b (Int.unsigned ofs) bytes = Some m' -> + Mem.storebytes m b (Ptrofs.unsigned ofs) bytes = Some m' -> vmatch bc (Vptr b ofs) aaddr -> sound_stack bc stk m bound -> sound_stack bc stk m' bound. @@ -1209,7 +1209,7 @@ Lemma sound_succ_state: genv_match bc ge -> bc sp = BCstack -> sound_stack bc s m' sp -> - sound_state_base (State s f (Vptr sp Int.zero) pc' e' m'). + sound_state_base (State s f (Vptr sp Ptrofs.zero) pc' e' m'). Proof. intros. exploit analyze_succ; eauto. intros (ae'' & am'' & AN & EM & MM). econstructor; eauto. @@ -1296,7 +1296,7 @@ Proof. assert (DEFAULT: transfer f rm pc ae am = transfer_builtin_default ae am rm args res -> sound_state_base - (State s f (Vptr sp0 Int.zero) pc' (regmap_setres res vres rs) m')). + (State s f (Vptr sp0 Ptrofs.zero) pc' (regmap_setres res vres rs) m')). { unfold transfer_builtin_default, analyze_call; intros TR'. set (aargs := map (abuiltin_arg ae am rm) args) in *. assert (ARGS: list_forall2 (vmatch bc) vargs aargs) by (eapply abuiltin_args_sound; eauto). @@ -1603,9 +1603,13 @@ Lemma store_init_data_sound: bmatch bc m' b (store_init_data ab p id). Proof. intros. destruct id; try (eapply ablock_store_sound; eauto; constructor). +- (* float32 *) simpl. destruct (propagate_float_constants tt); eapply ablock_store_sound; eauto; constructor. +- (* float64 *) simpl. destruct (propagate_float_constants tt); eapply ablock_store_sound; eauto; constructor. +- (* space *) simpl in H. inv H. auto. +- (* addrof *) simpl in H. destruct (Genv.find_symbol ge i) as [b'|] eqn:FS; try discriminate. eapply ablock_store_sound; eauto. constructor. constructor. apply GMATCH; auto. Qed. @@ -1882,7 +1886,7 @@ Definition avalue (a: VA.t) (r: reg) : aval := Lemma avalue_sound: forall cunit prog s f sp pc e m r, - sound_state prog (State s f (Vptr sp Int.zero) pc e m) -> + sound_state prog (State s f (Vptr sp Ptrofs.zero) pc e m) -> linkorder cunit prog -> exists bc, vmatch bc e#r (avalue (analyze (romem_for cunit) f)!!pc r) @@ -1900,7 +1904,7 @@ Definition aaddr (a: VA.t) (r: reg) : aptr := Lemma aaddr_sound: forall cunit prog s f sp pc e m r b ofs, - sound_state prog (State s f (Vptr sp Int.zero) pc e m) -> + sound_state prog (State s f (Vptr sp Ptrofs.zero) pc e m) -> linkorder cunit prog -> e#r = Vptr b ofs -> exists bc, @@ -1920,9 +1924,9 @@ Definition aaddressing (a: VA.t) (addr: addressing) (args: list reg) : aptr := Lemma aaddressing_sound: forall cunit prog s f sp pc e m addr args b ofs, - sound_state prog (State s f (Vptr sp Int.zero) pc e m) -> + sound_state prog (State s f (Vptr sp Ptrofs.zero) pc e m) -> linkorder cunit prog -> - eval_addressing (Genv.globalenv prog) (Vptr sp Int.zero) addr e##args = Some (Vptr b ofs) -> + eval_addressing (Genv.globalenv prog) (Vptr sp Ptrofs.zero) addr e##args = Some (Vptr b ofs) -> exists bc, pmatch bc b ofs (aaddressing (analyze (romem_for cunit) f)!!pc addr args) /\ genv_match bc (Genv.globalenv prog) @@ -1955,7 +1959,7 @@ Lemma aaddr_arg_sound_1: mmatch bc m am -> genv_match bc ge -> bc sp = BCstack -> - eval_builtin_arg ge (fun r : positive => rs # r) (Vptr sp Int.zero) m a (Vptr b ofs) -> + eval_builtin_arg ge (fun r : positive => rs # r) (Vptr sp Ptrofs.zero) m a (Vptr b ofs) -> pmatch bc b ofs (aaddr_arg (VA.State ae am) a). Proof. intros. @@ -1966,9 +1970,9 @@ Qed. Lemma aaddr_arg_sound: forall cunit prog s f sp pc e m a b ofs, - sound_state prog (State s f (Vptr sp Int.zero) pc e m) -> + sound_state prog (State s f (Vptr sp Ptrofs.zero) pc e m) -> linkorder cunit prog -> - eval_builtin_arg (Genv.globalenv prog) (fun r => e#r) (Vptr sp Int.zero) m a (Vptr b ofs) -> + eval_builtin_arg (Genv.globalenv prog) (fun r => e#r) (Vptr sp Ptrofs.zero) m a (Vptr b ofs) -> exists bc, pmatch bc b ofs (aaddr_arg (analyze (romem_for cunit) f)!!pc a) /\ genv_match bc (Genv.globalenv prog) diff --git a/backend/ValueDomain.v b/backend/ValueDomain.v index bc09c3dc..be8bcccc 100644 --- a/backend/ValueDomain.v +++ b/backend/ValueDomain.v @@ -116,21 +116,21 @@ Qed. (** * Abstracting pointers *) Inductive aptr : Type := - | Pbot (**r bottom (empty set of pointers) *) - | Gl (id: ident) (ofs: int) (**r pointer into the block for global variable [id] at offset [ofs] *) - | Glo (id: ident) (**r pointer anywhere into the block for global [id] *) - | Glob (**r pointer into any global variable *) - | Stk (ofs: int) (**r pointer into the current stack frame at offset [ofs] *) - | Stack (**r pointer anywhere into the current stack frame *) - | Nonstack (**r pointer anywhere but into the current stack frame *) - | Ptop. (**r any valid pointer *) + | Pbot (**r bottom (empty set of pointers) *) + | Gl (id: ident) (ofs: ptrofs) (**r pointer into the block for global variable [id] at offset [ofs] *) + | Glo (id: ident) (**r pointer anywhere into the block for global [id] *) + | Glob (**r pointer into any global variable *) + | Stk (ofs: ptrofs) (**r pointer into the current stack frame at offset [ofs] *) + | Stack (**r pointer anywhere into the current stack frame *) + | Nonstack (**r pointer anywhere but into the current stack frame *) + | Ptop. (**r any valid pointer *) Definition eq_aptr: forall (p1 p2: aptr), {p1=p2} + {p1<>p2}. Proof. - intros. generalize ident_eq, Int.eq_dec; intros. decide equality. + intros. generalize ident_eq, Ptrofs.eq_dec; intros. decide equality. Defined. -Inductive pmatch (b: block) (ofs: int): aptr -> Prop := +Inductive pmatch (b: block) (ofs: ptrofs): aptr -> Prop := | pmatch_gl: forall id, bc b = BCglob id -> pmatch b ofs (Gl id ofs) @@ -191,7 +191,7 @@ Definition plub (p q: aptr) : aptr := | Pbot, _ => q | _, Pbot => p | Gl id1 ofs1, Gl id2 ofs2 => - if ident_eq id1 id2 then if Int.eq_dec ofs1 ofs2 then p else Glo id1 else Glob + if ident_eq id1 id2 then if Ptrofs.eq_dec ofs1 ofs2 then p else Glo id1 else Glob | Gl id1 ofs1, Glo id2 => if ident_eq id1 id2 then q else Glob | Glo id1, Gl id2 ofs2 => @@ -205,7 +205,7 @@ Definition plub (p q: aptr) : aptr := | Nonstack, (Gl _ _ | Glo _ | Glob) => Nonstack | Stk ofs1, Stk ofs2 => - if Int.eq_dec ofs1 ofs2 then p else Stack + if Ptrofs.eq_dec ofs1 ofs2 then p else Stack | (Stk _ | Stack), Stack => Stack | Stack, Stk _ => @@ -219,7 +219,7 @@ Proof. intros; unfold plub; destruct p; destruct q; auto. destruct (ident_eq id id0). subst id0. rewrite dec_eq_true. - destruct (Int.eq_dec ofs ofs0). subst ofs0. rewrite dec_eq_true. auto. + destruct (Ptrofs.eq_dec ofs ofs0). subst ofs0. rewrite dec_eq_true. auto. rewrite dec_eq_false by auto. auto. rewrite dec_eq_false by auto. auto. destruct (ident_eq id id0). subst id0. @@ -231,7 +231,7 @@ Proof. destruct (ident_eq id id0). subst id0. rewrite dec_eq_true; auto. rewrite dec_eq_false; auto. - destruct (Int.eq_dec ofs ofs0). subst ofs0. rewrite dec_eq_true; auto. + destruct (Ptrofs.eq_dec ofs ofs0). subst ofs0. rewrite dec_eq_true; auto. rewrite dec_eq_false; auto. Qed. @@ -240,12 +240,12 @@ Lemma pge_lub_l: Proof. unfold plub; destruct p, q; auto with va. - destruct (ident_eq id id0). - destruct (Int.eq_dec ofs ofs0); subst; constructor. + destruct (Ptrofs.eq_dec ofs ofs0); subst; constructor. constructor. - destruct (ident_eq id id0); subst; constructor. - destruct (ident_eq id id0); subst; constructor. - destruct (ident_eq id id0); subst; constructor. -- destruct (Int.eq_dec ofs ofs0); subst; constructor. +- destruct (Ptrofs.eq_dec ofs ofs0); subst; constructor. Qed. Lemma pge_lub_r: @@ -274,27 +274,27 @@ Proof. - unfold plub; destruct q; repeat rewrite dec_eq_true; constructor. - rewrite dec_eq_true; constructor. - rewrite dec_eq_true; constructor. -- rewrite dec_eq_true. destruct (Int.eq_dec ofs ofs0); constructor. -- destruct (ident_eq id id0). destruct (Int.eq_dec ofs ofs0); constructor. constructor. +- rewrite dec_eq_true. destruct (Ptrofs.eq_dec ofs ofs0); constructor. +- destruct (ident_eq id id0). destruct (Ptrofs.eq_dec ofs ofs0); constructor. constructor. - destruct (ident_eq id id0); constructor. - destruct (ident_eq id id0); constructor. - destruct (ident_eq id id0); constructor. -- destruct (ident_eq id id0). destruct (Int.eq_dec ofs ofs0); constructor. constructor. +- destruct (ident_eq id id0). destruct (Ptrofs.eq_dec ofs ofs0); constructor. constructor. - destruct (ident_eq id id0); constructor. - destruct (ident_eq id id0); constructor. - destruct (ident_eq id id0); constructor. -- destruct (Int.eq_dec ofs ofs0); constructor. +- destruct (Ptrofs.eq_dec ofs ofs0); constructor. Qed. Definition pincl (p q: aptr) : bool := match p, q with | Pbot, _ => true - | Gl id1 ofs1, Gl id2 ofs2 => peq id1 id2 && Int.eq_dec ofs1 ofs2 + | Gl id1 ofs1, Gl id2 ofs2 => peq id1 id2 && Ptrofs.eq_dec ofs1 ofs2 | Gl id1 ofs1, Glo id2 => peq id1 id2 | Glo id1, Glo id2 => peq id1 id2 | (Gl _ _ | Glo _ | Glob), Glob => true | (Gl _ _ | Glo _ | Glob | Nonstack), Nonstack => true - | Stk ofs1, Stk ofs2 => Int.eq_dec ofs1 ofs2 + | Stk ofs1, Stk ofs2 => Ptrofs.eq_dec ofs1 ofs2 | Stk ofs1, Stack => true | Stack, Stack => true | _, Ptop => true @@ -322,32 +322,32 @@ Proof. intros. eapply pmatch_ge; eauto. apply pincl_ge; auto. Qed. -Definition padd (p: aptr) (n: int) : aptr := +Definition padd (p: aptr) (n: ptrofs) : aptr := match p with - | Gl id ofs => Gl id (Int.add ofs n) - | Stk ofs => Stk (Int.add ofs n) + | Gl id ofs => Gl id (Ptrofs.add ofs n) + | Stk ofs => Stk (Ptrofs.add ofs n) | _ => p end. Lemma padd_sound: forall b ofs p delta, pmatch b ofs p -> - pmatch b (Int.add ofs delta) (padd p delta). + pmatch b (Ptrofs.add ofs delta) (padd p delta). Proof. intros. inv H; simpl padd; eauto with va. Qed. -Definition psub (p: aptr) (n: int) : aptr := +Definition psub (p: aptr) (n: ptrofs) : aptr := match p with - | Gl id ofs => Gl id (Int.sub ofs n) - | Stk ofs => Stk (Int.sub ofs n) + | Gl id ofs => Gl id (Ptrofs.sub ofs n) + | Stk ofs => Stk (Ptrofs.sub ofs n) | _ => p end. Lemma psub_sound: forall b ofs p delta, pmatch b ofs p -> - pmatch b (Int.sub ofs delta) (psub p delta). + pmatch b (Ptrofs.sub ofs delta) (psub p delta). Proof. intros. inv H; simpl psub; eauto with va. Qed. @@ -367,29 +367,6 @@ Proof. intros. inv H; simpl poffset; eauto with va. Qed. -Definition psub2 (p q: aptr) : option int := - match p, q with - | Gl id1 ofs1, Gl id2 ofs2 => - if peq id1 id2 then Some (Int.sub ofs1 ofs2) else None - | Stk ofs1, Stk ofs2 => - Some (Int.sub ofs1 ofs2) - | _, _ => - None - end. - -Lemma psub2_sound: - forall b1 ofs1 p1 b2 ofs2 p2 delta, - psub2 p1 p2 = Some delta -> - pmatch b1 ofs1 p1 -> - pmatch b2 ofs2 p2 -> - b1 = b2 /\ delta = Int.sub ofs1 ofs2. -Proof. - intros. destruct p1; try discriminate; destruct p2; try discriminate; simpl in H. -- destruct (peq id id0); inv H. inv H0; inv H1. - split. eapply bc_glob; eauto. reflexivity. -- inv H; inv H0; inv H1. split. eapply bc_stack; eauto. reflexivity. -Qed. - Definition cmp_different_blocks (c: comparison) : abool := match c with | Ceq => Maybe false @@ -413,7 +390,7 @@ Definition pcmp (c: comparison) (p1 p2: aptr) : abool := match p1, p2 with | Pbot, _ | _, Pbot => Bnone | Gl id1 ofs1, Gl id2 ofs2 => - if peq id1 id2 then Maybe (Int.cmpu c ofs1 ofs2) + if peq id1 id2 then Maybe (Ptrofs.cmpu c ofs1 ofs2) else cmp_different_blocks c | Gl id1 ofs1, Glo id2 => if peq id1 id2 then Btop else cmp_different_blocks c @@ -421,7 +398,7 @@ Definition pcmp (c: comparison) (p1 p2: aptr) : abool := if peq id1 id2 then Btop else cmp_different_blocks c | Glo id1, Glo id2 => if peq id1 id2 then Btop else cmp_different_blocks c - | Stk ofs1, Stk ofs2 => Maybe (Int.cmpu c ofs1 ofs2) + | Stk ofs1, Stk ofs2 => Maybe (Ptrofs.cmpu c ofs1 ofs2) | (Gl _ _ | Glo _ | Glob | Nonstack), (Stk _ | Stack) => cmp_different_blocks c | (Stk _ | Stack), (Gl _ _ | Glo _ | Glob | Nonstack) => cmp_different_blocks c | _, _ => Btop @@ -438,17 +415,59 @@ Proof. (cmp_different_blocks c)). { intros. simpl. rewrite dec_eq_false by assumption. - destruct (valid b1 (Int.unsigned ofs1) && valid b2 (Int.unsigned ofs2)); simpl. + destruct Archi.ptr64. + apply cmp_different_blocks_none. + destruct (valid b1 (Ptrofs.unsigned ofs1) && valid b2 (Ptrofs.unsigned ofs2)); simpl. apply cmp_different_blocks_sound. apply cmp_different_blocks_none. } assert (SAME: b1 = b2 -> cmatch (Val.cmpu_bool valid c (Vptr b1 ofs1) (Vptr b2 ofs2)) - (Maybe (Int.cmpu c ofs1 ofs2))). + (Maybe (Ptrofs.cmpu c ofs1 ofs2))). { - intros. subst b2. simpl. rewrite dec_eq_true. - destruct ((valid b1 (Int.unsigned ofs1) || valid b1 (Int.unsigned ofs1 - 1)) && - (valid b1 (Int.unsigned ofs2) || valid b1 (Int.unsigned ofs2 - 1))); simpl. + intros. subst b2. simpl. destruct Archi.ptr64. + constructor. + rewrite dec_eq_true. + destruct ((valid b1 (Ptrofs.unsigned ofs1) || valid b1 (Ptrofs.unsigned ofs1 - 1)) && + (valid b1 (Ptrofs.unsigned ofs2) || valid b1 (Ptrofs.unsigned ofs2 - 1))); simpl. + constructor. + constructor. + } + unfold pcmp; inv H; inv H0; (apply cmatch_top || (apply DIFF; congruence) || idtac). + - destruct (peq id id0). subst id0. apply SAME. eapply bc_glob; eauto. + auto with va. + - destruct (peq id id0); auto with va. + - destruct (peq id id0); auto with va. + - destruct (peq id id0); auto with va. + - apply SAME. eapply bc_stack; eauto. +Qed. + +Lemma pcmp_sound_64: + forall valid c b1 ofs1 p1 b2 ofs2 p2, + pmatch b1 ofs1 p1 -> pmatch b2 ofs2 p2 -> + cmatch (Val.cmplu_bool valid c (Vptr b1 ofs1) (Vptr b2 ofs2)) (pcmp c p1 p2). +Proof. + intros. + assert (DIFF: b1 <> b2 -> + cmatch (Val.cmplu_bool valid c (Vptr b1 ofs1) (Vptr b2 ofs2)) + (cmp_different_blocks c)). + { + intros. simpl. rewrite dec_eq_false by assumption. + destruct Archi.ptr64; simpl. + destruct (valid b1 (Ptrofs.unsigned ofs1) && valid b2 (Ptrofs.unsigned ofs2)); simpl. + apply cmp_different_blocks_sound. + apply cmp_different_blocks_none. + apply cmp_different_blocks_none. + } + assert (SAME: b1 = b2 -> + cmatch (Val.cmplu_bool valid c (Vptr b1 ofs1) (Vptr b2 ofs2)) + (Maybe (Ptrofs.cmpu c ofs1 ofs2))). + { + intros. subst b2. simpl. destruct Archi.ptr64. + rewrite dec_eq_true. + destruct ((valid b1 (Ptrofs.unsigned ofs1) || valid b1 (Ptrofs.unsigned ofs1 - 1)) && + (valid b1 (Ptrofs.unsigned ofs2) || valid b1 (Ptrofs.unsigned ofs2 - 1))); simpl. + constructor. constructor. constructor. } @@ -475,15 +494,15 @@ Definition pdisjoint (p1: aptr) (sz1: Z) (p2: aptr) (sz2: Z) : bool := | _, Pbot => true | Gl id1 ofs1, Gl id2 ofs2 => if peq id1 id2 - then zle (Int.unsigned ofs1 + sz1) (Int.unsigned ofs2) - || zle (Int.unsigned ofs2 + sz2) (Int.unsigned ofs1) + then zle (Ptrofs.unsigned ofs1 + sz1) (Ptrofs.unsigned ofs2) + || zle (Ptrofs.unsigned ofs2 + sz2) (Ptrofs.unsigned ofs1) else true | Gl id1 ofs1, Glo id2 => negb(peq id1 id2) | Glo id1, Gl id2 ofs2 => negb(peq id1 id2) | Glo id1, Glo id2 => negb(peq id1 id2) | Stk ofs1, Stk ofs2 => - zle (Int.unsigned ofs1 + sz1) (Int.unsigned ofs2) - || zle (Int.unsigned ofs2 + sz2) (Int.unsigned ofs1) + zle (Ptrofs.unsigned ofs1 + sz1) (Ptrofs.unsigned ofs2) + || zle (Ptrofs.unsigned ofs2 + sz2) (Ptrofs.unsigned ofs1) | (Gl _ _ | Glo _ | Glob | Nonstack), (Stk _ | Stack) => true | (Stk _ | Stack), (Gl _ _ | Glo _ | Glob | Nonstack) => true | _, _ => false @@ -493,7 +512,7 @@ Lemma pdisjoint_sound: forall sz1 b1 ofs1 p1 sz2 b2 ofs2 p2, pdisjoint p1 sz1 p2 sz2 = true -> pmatch b1 ofs1 p1 -> pmatch b2 ofs2 p2 -> - b1 <> b2 \/ Int.unsigned ofs1 + sz1 <= Int.unsigned ofs2 \/ Int.unsigned ofs2 + sz2 <= Int.unsigned ofs1. + b1 <> b2 \/ Ptrofs.unsigned ofs1 + sz1 <= Ptrofs.unsigned ofs2 \/ Ptrofs.unsigned ofs2 + sz2 <= Ptrofs.unsigned ofs1. Proof. intros. inv H0; inv H1; simpl in H; try discriminate; try (left; congruence). - destruct (peq id id0). subst id0. destruct (orb_true_elim _ _ H); InvBooleans; auto. @@ -1154,6 +1173,28 @@ Proof. intros. unfold binop_int; inv H; auto with va; inv H0; auto with va. Qed. +Definition unop_long (sem: int64 -> int64) (x: aval) := + match x with L n => L (sem n) | _ => ntop1 x end. + +Lemma unop_long_sound: + forall sem v x, + vmatch v x -> + vmatch (match v with Vlong i => Vlong(sem i) | _ => Vundef end) (unop_long sem x). +Proof. + intros. unfold unop_long; inv H; auto with va. +Qed. + +Definition binop_long (sem: int64 -> int64 -> int64) (x y: aval) := + match x, y with L n, L m => L (sem n m) | _, _ => ntop2 x y end. + +Lemma binop_long_sound: + forall sem v x w y, + vmatch v x -> vmatch w y -> + vmatch (match v, w with Vlong i, Vlong j => Vlong(sem i j) | _, _ => Vundef end) (binop_long sem x y). +Proof. + intros. unfold binop_long; inv H; auto with va; inv H0; auto with va. +Qed. + Definition unop_float (sem: float -> float) (x: aval) := match x with F n => F (sem n) | _ => ntop1 x end. @@ -1502,9 +1543,9 @@ Proof (unop_int_sound Int.neg). Definition add (x y: aval) := match x, y with | I i, I j => I (Int.add i j) - | Ptr p, I i | I i, Ptr p => Ptr (padd p i) + | Ptr p, I i | I i, Ptr p => Ptr (if Archi.ptr64 then poffset p else padd p (Ptrofs.of_int i)) | Ptr p, _ | _, Ptr p => Ptr (poffset p) - | Ifptr p, I i | I i, Ifptr p => Ifptr (padd p i) + | Ifptr p, I i | I i, Ifptr p => Ifptr (if Archi.ptr64 then poffset p else padd p (Ptrofs.of_int i)) | Ifptr p, Ifptr q => Ifptr (plub (poffset p) (poffset q)) | Ifptr p, _ | _, Ifptr p => Ifptr (poffset p) | _, _ => ntop2 x y @@ -1513,7 +1554,9 @@ Definition add (x y: aval) := Lemma add_sound: forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.add v w) (add x y). Proof. - intros. unfold Val.add, add; inv H; inv H0; constructor; + intros. unfold Val.add, add. destruct Archi.ptr64. +- inv H; inv H0; constructor. +- inv H; inv H0; constructor; ((apply padd_sound; assumption) || (eapply poffset_sound; eassumption) || idtac). apply pmatch_lub_r. eapply poffset_sound; eauto. apply pmatch_lub_l. eapply poffset_sound; eauto. @@ -1522,13 +1565,9 @@ Qed. Definition sub (v w: aval) := match v, w with | I i1, I i2 => I (Int.sub i1 i2) - | Ptr p, I i => Ptr (psub p i) -(* problem with undefs *) -(* - | Ptr p1, Ptr p2 => match psub2 p1 p2 with Some n => I n | _ => itop end -*) + | Ptr p, I i => if Archi.ptr64 then Ifptr (poffset p) else Ptr (psub p (Ptrofs.of_int i)) | Ptr p, _ => Ifptr (poffset p) - | Ifptr p, I i => Ifptr (psub p i) + | Ifptr p, I i => if Archi.ptr64 then Ifptr (plub (poffset p) (provenance w)) else Ifptr (psub p (Ptrofs.of_int i)) | Ifptr p, _ => Ifptr (plub (poffset p) (provenance w)) | _, _ => ntop2 v w end. @@ -1536,9 +1575,9 @@ Definition sub (v w: aval) := Lemma sub_sound: forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.sub v w) (sub x y). Proof. - intros. inv H; subst; inv H0; subst; simpl; - try (destruct (eq_block b b0)); - eauto using psub_sound, poffset_sound, pmatch_lub_l with va. + intros. unfold Val.sub, sub. destruct Archi.ptr64. +- inv H; inv H0; eauto with va. +- inv H; inv H0; try (destruct (eq_block b b0)); eauto using psub_sound, poffset_sound, pmatch_lub_l with va. Qed. Definition mul := binop_int Int.mul. @@ -1659,6 +1698,274 @@ Proof. rewrite LTU; auto with va. Qed. +(** 64-bit integer operations *) + +Definition shift_long (sem: int64 -> int -> int64) (v w: aval) := + match w with + | I amount => + if Int.ltu amount Int64.iwordsize' then + match v with + | L i => L (sem i amount) + | _ => ntop1 v + end + else ntop1 v + | _ => ntop1 v + end. + +Lemma shift_long_sound: + forall sem v w x y, + vmatch v x -> vmatch w y -> + vmatch (match v, w with + | Vlong i, Vint j => if Int.ltu j Int64.iwordsize' + then Vlong (sem i j) else Vundef + | _, _ => Vundef end) + (shift_long sem x y). +Proof. + intros. + assert (DEFAULT: + vmatch (match v, w with + | Vlong i, Vint j => if Int.ltu j Int64.iwordsize' + then Vlong (sem i j) else Vundef + | _, _ => Vundef end) + (ntop1 x)). + { destruct v; try constructor; destruct w; try constructor. + destruct (Int.ltu i0 Int64.iwordsize'); constructor. } + unfold shift_long. destruct y; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT; auto. + destruct x; auto. + inv H; inv H0. rewrite LT. constructor. +Qed. + +Definition shll := shift_long Int64.shl'. + +Lemma shll_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.shll v w) (shll x y). +Proof (shift_long_sound Int64.shl'). + +Definition shrl := shift_long Int64.shr'. + +Lemma shrl_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.shrl v w) (shrl x y). +Proof (shift_long_sound Int64.shr'). + +Definition shrlu := shift_long Int64.shru'. + +Lemma shrlu_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.shrlu v w) (shrlu x y). +Proof (shift_long_sound Int64.shru'). + +Definition andl := binop_long Int64.and. + +Lemma andl_sound: + forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.andl v w) (andl x y). +Proof (binop_long_sound Int64.and). + +Definition orl := binop_long Int64.or. + +Lemma orl_sound: + forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.orl v w) (orl x y). +Proof (binop_long_sound Int64.or). + +Definition xorl := binop_long Int64.xor. + +Lemma xorl_sound: + forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.xorl v w) (xorl x y). +Proof (binop_long_sound Int64.xor). + +Definition notl := unop_long Int64.not. + +Lemma notl_sound: + forall v x, vmatch v x -> vmatch (Val.notl v) (notl x). +Proof (unop_long_sound Int64.not). + +Definition rotate_long (sem: int64 -> int64 -> int64) (v w: aval) := + match v, w with + | L i, I amount => L (sem i (Int64.repr (Int.unsigned amount))) + | _, _ => ntop1 v + end. + +Lemma rotate_long_sound: + forall sem v w x y, + vmatch v x -> vmatch w y -> + vmatch (match v, w with + | Vlong i, Vint j => Vlong (sem i (Int64.repr (Int.unsigned j))) + | _, _ => Vundef end) + (rotate_long sem x y). +Proof. + intros. + assert (DEFAULT: + vmatch (match v, w with + | Vlong i, Vint j => Vlong (sem i (Int64.repr (Int.unsigned j))) + | _, _ => Vundef end) + (ntop1 x)). + { destruct v; try constructor. destruct w; constructor. } + unfold rotate_long. destruct x; auto. destruct y; auto. inv H; inv H0. constructor. +Qed. + +Definition roll := rotate_long Int64.rol. + +Lemma roll_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.roll v w) (roll x y). +Proof (rotate_long_sound Int64.rol). + +Definition rorl := rotate_long Int64.ror. + +Lemma rorl_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.rorl v w) (rorl x y). +Proof (rotate_long_sound Int64.ror). + +Definition negl := unop_long Int64.neg. + +Lemma negl_sound: + forall v x, vmatch v x -> vmatch (Val.negl v) (negl x). +Proof (unop_long_sound Int64.neg). + +Definition addl (x y: aval) := + match x, y with + | L i, L j => L (Int64.add i j) + | Ptr p, L i | L i, Ptr p => Ptr (if Archi.ptr64 then padd p (Ptrofs.of_int64 i) else poffset p) + | Ptr p, _ | _, Ptr p => Ptr (poffset p) + | Ifptr p, L i | L i, Ifptr p => Ifptr (if Archi.ptr64 then padd p (Ptrofs.of_int64 i) else poffset p) + | Ifptr p, Ifptr q => Ifptr (plub (poffset p) (poffset q)) + | Ifptr p, _ | _, Ifptr p => Ifptr (poffset p) + | _, _ => ntop2 x y + end. + +Lemma addl_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.addl v w) (addl x y). +Proof. + intros. unfold Val.addl, addl. destruct Archi.ptr64. +- inv H; inv H0; constructor; + ((apply padd_sound; assumption) || (eapply poffset_sound; eassumption) || idtac). + apply pmatch_lub_r. eapply poffset_sound; eauto. + apply pmatch_lub_l. eapply poffset_sound; eauto. +- inv H; inv H0; constructor. +Qed. + +Definition subl (v w: aval) := + match v, w with + | L i1, L i2 => L (Int64.sub i1 i2) + | Ptr p, L i => if Archi.ptr64 then Ptr (psub p (Ptrofs.of_int64 i)) else Ifptr (poffset p) + | Ptr p, _ => Ifptr (poffset p) + | Ifptr p, L i => if Archi.ptr64 then Ifptr (psub p (Ptrofs.of_int64 i)) else Ifptr (plub (poffset p) (provenance w)) + | Ifptr p, _ => Ifptr (plub (poffset p) (provenance w)) + | _, _ => ntop2 v w + end. + +Lemma subl_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.subl v w) (subl x y). +Proof. + intros. unfold Val.subl, subl. destruct Archi.ptr64. +- inv H; inv H0; try (destruct (eq_block b b0)); eauto using psub_sound, poffset_sound, pmatch_lub_l with va. +- inv H; inv H0; eauto with va. +Qed. + +Definition mull := binop_long Int64.mul. + +Lemma mull_sound: + forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.mull v w) (mull x y). +Proof (binop_long_sound Int64.mul). + +Definition mullhs := binop_long Int64.mulhs. + +Lemma mullhs_sound: + forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.mullhs v w) (mullhs x y). +Proof (binop_long_sound Int64.mulhs). + +Definition mullhu := binop_long Int64.mulhu. + +Lemma mullhu_sound: + forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.mullhu v w) (mullhu x y). +Proof (binop_long_sound Int64.mulhu). + +Definition divls (v w: aval) := + match w, v with + | L i2, L i1 => + if Int64.eq i2 Int64.zero + || Int64.eq i1 (Int64.repr Int64.min_signed) && Int64.eq i2 Int64.mone + then if va_strict tt then Vbot else ntop + else L (Int64.divs i1 i2) + | _, _ => ntop2 v w + end. + +Lemma divls_sound: + forall v w u x y, vmatch v x -> vmatch w y -> Val.divls v w = Some u -> vmatch u (divls x y). +Proof. + intros. destruct v; destruct w; try discriminate; simpl in H1. + destruct (Int64.eq i0 Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone) eqn:E; inv H1. + inv H; inv H0; auto with va. simpl. rewrite E. constructor. +Qed. + +Definition divlu (v w: aval) := + match w, v with + | L i2, L i1 => + if Int64.eq i2 Int64.zero + then if va_strict tt then Vbot else ntop + else L (Int64.divu i1 i2) + | _, _ => ntop2 v w + end. + +Lemma divlu_sound: + forall v w u x y, vmatch v x -> vmatch w y -> Val.divlu v w = Some u -> vmatch u (divlu x y). +Proof. + intros. destruct v; destruct w; try discriminate; simpl in H1. + destruct (Int64.eq i0 Int64.zero) eqn:E; inv H1. + inv H; inv H0; auto with va. simpl. rewrite E. constructor. +Qed. + +Definition modls (v w: aval) := + match w, v with + | L i2, L i1 => + if Int64.eq i2 Int64.zero + || Int64.eq i1 (Int64.repr Int64.min_signed) && Int64.eq i2 Int64.mone + then if va_strict tt then Vbot else ntop + else L (Int64.mods i1 i2) + | _, _ => ntop2 v w + end. + +Lemma modls_sound: + forall v w u x y, vmatch v x -> vmatch w y -> Val.modls v w = Some u -> vmatch u (modls x y). +Proof. + intros. destruct v; destruct w; try discriminate; simpl in H1. + destruct (Int64.eq i0 Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone) eqn:E; inv H1. + inv H; inv H0; auto with va. simpl. rewrite E. constructor. +Qed. + +Definition modlu (v w: aval) := + match w, v with + | L i2, L i1 => + if Int64.eq i2 Int64.zero + then if va_strict tt then Vbot else ntop + else L (Int64.modu i1 i2) + | _, _ => ntop2 v w + end. + +Lemma modlu_sound: + forall v w u x y, vmatch v x -> vmatch w y -> Val.modlu v w = Some u -> vmatch u (modlu x y). +Proof. + intros. destruct v; destruct w; try discriminate; simpl in H1. + destruct (Int64.eq i0 Int64.zero) eqn:E; inv H1. + inv H; inv H0; auto with va. simpl. rewrite E. constructor. +Qed. + +Definition shrxl (v w: aval) := + match v, w with + | L i, I j => if Int.ltu j (Int.repr 63) then L(Int64.shrx' i j) else ntop + | _, _ => ntop1 v + end. + +Lemma shrxl_sound: + forall v w u x y, vmatch v x -> vmatch w y -> Val.shrxl v w = Some u -> vmatch u (shrxl x y). +Proof. + intros. + destruct v; destruct w; try discriminate; simpl in H1. + destruct (Int.ltu i0 (Int.repr 63)) eqn:LTU; inv H1. + unfold shrxl; inv H; auto with va; inv H0; auto with va. + rewrite LTU; auto with va. +Qed. + (** Floating-point arithmetic operations *) Definition negf := unop_float Float.neg. @@ -1778,6 +2085,30 @@ Proof. apply Z.min_case; auto with va. Qed. +Definition longofint (v: aval) := + match v with + | I i => L (Int64.repr (Int.signed i)) + | _ => ntop1 v + end. + +Lemma longofint_sound: + forall v x, vmatch v x -> vmatch (Val.longofint v) (longofint x). +Proof. + unfold Val.longofint, longofint; intros; inv H; auto with va. +Qed. + +Definition longofintu (v: aval) := + match v with + | I i => L (Int64.repr (Int.unsigned i)) + | _ => ntop1 v + end. + +Lemma longofintu_sound: + forall v x, vmatch v x -> vmatch (Val.longofintu v) (longofintu x). +Proof. + unfold Val.longofintu, longofintu; intros; inv H; auto with va. +Qed. + Definition singleoffloat (v: aval) := match v with | F f => FS (Float.to_single f) @@ -1932,6 +2263,130 @@ Proof. inv H; simpl; auto with va. Qed. +Definition longoffloat (x: aval) := + match x with + | F f => + match Float.to_long f with + | Some i => L i + | None => if va_strict tt then Vbot else ntop + end + | _ => ntop1 x + end. + +Lemma longoffloat_sound: + forall v x w, vmatch v x -> Val.longoffloat v = Some w -> vmatch w (longoffloat x). +Proof. + unfold Val.longoffloat; intros. destruct v; try discriminate. + destruct (Float.to_long f) as [i|] eqn:E; simpl in H0; inv H0. + inv H; simpl; auto with va. rewrite E; constructor. +Qed. + +Definition longuoffloat (x: aval) := + match x with + | F f => + match Float.to_longu f with + | Some i => L i + | None => if va_strict tt then Vbot else ntop + end + | _ => ntop1 x + end. + +Lemma longuoffloat_sound: + forall v x w, vmatch v x -> Val.longuoffloat v = Some w -> vmatch w (longuoffloat x). +Proof. + unfold Val.longuoffloat; intros. destruct v; try discriminate. + destruct (Float.to_longu f) as [i|] eqn:E; simpl in H0; inv H0. + inv H; simpl; auto with va. rewrite E; constructor. +Qed. + +Definition floatoflong (x: aval) := + match x with + | L i => F(Float.of_long i) + | _ => ntop1 x + end. + +Lemma floatoflong_sound: + forall v x w, vmatch v x -> Val.floatoflong v = Some w -> vmatch w (floatoflong x). +Proof. + unfold Val.floatoflong; intros. destruct v; inv H0. + inv H; simpl; auto with va. +Qed. + +Definition floatoflongu (x: aval) := + match x with + | L i => F(Float.of_longu i) + | _ => ntop1 x + end. + +Lemma floatoflongu_sound: + forall v x w, vmatch v x -> Val.floatoflongu v = Some w -> vmatch w (floatoflongu x). +Proof. + unfold Val.floatoflongu; intros. destruct v; inv H0. + inv H; simpl; auto with va. +Qed. + +Definition longofsingle (x: aval) := + match x with + | FS f => + match Float32.to_long f with + | Some i => L i + | None => if va_strict tt then Vbot else ntop + end + | _ => ntop1 x + end. + +Lemma longofsingle_sound: + forall v x w, vmatch v x -> Val.longofsingle v = Some w -> vmatch w (longofsingle x). +Proof. + unfold Val.longofsingle; intros. destruct v; try discriminate. + destruct (Float32.to_long f) as [i|] eqn:E; simpl in H0; inv H0. + inv H; simpl; auto with va. rewrite E; constructor. +Qed. + +Definition longuofsingle (x: aval) := + match x with + | FS f => + match Float32.to_longu f with + | Some i => L i + | None => if va_strict tt then Vbot else ntop + end + | _ => ntop1 x + end. + +Lemma longuofsingle_sound: + forall v x w, vmatch v x -> Val.longuofsingle v = Some w -> vmatch w (longuofsingle x). +Proof. + unfold Val.longuofsingle; intros. destruct v; try discriminate. + destruct (Float32.to_longu f) as [i|] eqn:E; simpl in H0; inv H0. + inv H; simpl; auto with va. rewrite E; constructor. +Qed. + +Definition singleoflong (x: aval) := + match x with + | L i => FS(Float32.of_long i) + | _ => ntop1 x + end. + +Lemma singleoflong_sound: + forall v x w, vmatch v x -> Val.singleoflong v = Some w -> vmatch w (singleoflong x). +Proof. + unfold Val.singleoflong; intros. destruct v; inv H0. + inv H; simpl; auto with va. +Qed. + +Definition singleoflongu (x: aval) := + match x with + | L i => FS(Float32.of_longu i) + | _ => ntop1 x + end. + +Lemma singleoflongu_sound: + forall v x w, vmatch v x -> Val.singleoflongu v = Some w -> vmatch w (singleoflongu x). +Proof. + unfold Val.singleoflongu; intros. destruct v; inv H0. + inv H; simpl; auto with va. +Qed. + Definition floatofwords (x y: aval) := match x, y with | I i, I j => F(Float.from_words i j) @@ -2166,13 +2621,17 @@ Proof. assert (IP: forall i b ofs, cmatch (Val.cmpu_bool valid c (Vint i) (Vptr b ofs)) (cmp_different_blocks c)). { - intros. simpl. destruct (Int.eq i Int.zero && (valid b (Int.unsigned ofs) || valid b (Int.unsigned ofs - 1))). + intros. simpl. destruct Archi.ptr64. + apply cmp_different_blocks_none. + destruct (Int.eq i Int.zero && (valid b (Ptrofs.unsigned ofs) || valid b (Ptrofs.unsigned ofs - 1))). apply cmp_different_blocks_sound. apply cmp_different_blocks_none. } assert (PI: forall i b ofs, cmatch (Val.cmpu_bool valid c (Vptr b ofs) (Vint i)) (cmp_different_blocks c)). { - intros. simpl. destruct (Int.eq i Int.zero && (valid b (Int.unsigned ofs) || valid b (Int.unsigned ofs - 1))). + intros. simpl. destruct Archi.ptr64. + apply cmp_different_blocks_none. + destruct (Int.eq i Int.zero && (valid b (Ptrofs.unsigned ofs) || valid b (Ptrofs.unsigned ofs - 1))). apply cmp_different_blocks_sound. apply cmp_different_blocks_none. } unfold cmpu_bool; inversion H; subst; inversion H0; subst; @@ -2199,6 +2658,58 @@ Proof. - constructor. Qed. +Definition cmplu_bool (c: comparison) (v w: aval) : abool := + match v, w with + | L i1, L i2 => Just (Int64.cmpu c i1 i2) + | Ptr _, L _ => cmp_different_blocks c + | L _, Ptr _ => cmp_different_blocks c + | Ptr p1, Ptr p2 => pcmp c p1 p2 + | Ptr p1, Ifptr p2 => club (pcmp c p1 p2) (cmp_different_blocks c) + | Ifptr p1, Ptr p2 => club (pcmp c p1 p2) (cmp_different_blocks c) + | _, _ => Btop + end. + +Lemma cmplu_bool_sound: + forall valid c v w x y, vmatch v x -> vmatch w y -> cmatch (Val.cmplu_bool valid c v w) (cmplu_bool c x y). +Proof. + intros. + assert (IP: forall i b ofs, + cmatch (Val.cmplu_bool valid c (Vlong i) (Vptr b ofs)) (cmp_different_blocks c)). + { + intros. simpl. destruct Archi.ptr64; simpl. + destruct (Int64.eq i Int64.zero && (valid b (Ptrofs.unsigned ofs) || valid b (Ptrofs.unsigned ofs - 1))). + apply cmp_different_blocks_sound. apply cmp_different_blocks_none. + apply cmp_different_blocks_none. + } + assert (PI: forall i b ofs, + cmatch (Val.cmplu_bool valid c (Vptr b ofs) (Vlong i)) (cmp_different_blocks c)). + { + intros. simpl. destruct Archi.ptr64; simpl. + destruct (Int64.eq i Int64.zero && (valid b (Ptrofs.unsigned ofs) || valid b (Ptrofs.unsigned ofs - 1))). + apply cmp_different_blocks_sound. apply cmp_different_blocks_none. + apply cmp_different_blocks_none. + } + unfold cmplu_bool; inversion H; subst; inversion H0; subst; + auto using cmatch_top, cmp_different_blocks_none, pcmp_none, + cmatch_lub_l, cmatch_lub_r, pcmp_sound_64. +- constructor. +Qed. + +Definition cmpl_bool (c: comparison) (v w: aval) : abool := + match v, w with + | L i1, L i2 => Just (Int64.cmp c i1 i2) + | _, _ => Btop + end. + +Lemma cmpl_bool_sound: + forall c v w x y, vmatch v x -> vmatch w y -> cmatch (Val.cmpl_bool c v w) (cmpl_bool c x y). +Proof. + intros. + unfold cmpl_bool; inversion H; subst; inversion H0; subst; + auto using cmatch_top. +- constructor. +Qed. + Definition cmpf_bool (c: comparison) (v w: aval) : abool := match v, w with | F f1, F f2 => Just (Float.cmp c f1 f2) @@ -2298,12 +2809,15 @@ Definition vnormalize (chunk: memory_chunk) (v: aval) := | Mint16unsigned, I i => I (Int.zero_ext 16 i) | Mint16unsigned, Uns p n => Uns (provenance v) (Z.min n 16) | Mint16unsigned, _ => Uns (provenance v) 16 - | Mint32, (I _ | Uns _ _ | Sgn _ _ | Ptr _ | Ifptr _) => v - | Mint64, L _ => v - | Mint64, (Ptr p | Ifptr p | Uns p _ | Sgn p _) => Ifptr (if va_strict tt then Pbot else p) + | Mint32, (I _ | Uns _ _ | Sgn _ _ | Ifptr _) => v + | Mint32, Ptr p => if Archi.ptr64 then Ifptr p else v + | Mint64, (L _ | Ifptr _) => v + | Mint64, (Uns p _ | Sgn p _) => Ifptr p + | Mint64, Ptr p => if Archi.ptr64 then v else Ifptr p | Mfloat32, FS f => v | Mfloat64, F f => v - | Many32, (I _ | Uns _ _ | Sgn _ _ | Ptr _ | Ifptr _ | FS _) => v + | Many32, (I _ | Uns _ _ | Sgn _ _ | FS _ | Ifptr _) => v + | Many32, Ptr p => if Archi.ptr64 then Ifptr p else v | Many64, _ => v | _, _ => Ifptr (provenance v) end. @@ -2311,7 +2825,8 @@ Definition vnormalize (chunk: memory_chunk) (v: aval) := Lemma vnormalize_sound: forall chunk v x, vmatch v x -> vmatch (Val.load_result chunk v) (vnormalize chunk x). Proof. - unfold Val.load_result, vnormalize; induction 1; destruct chunk; auto with va. + unfold Val.load_result, vnormalize; generalize Archi.ptr64; intros ptr64; + induction 1; destruct chunk; auto with va. - destruct (zlt n 8); constructor; auto with va. apply is_sign_ext_uns; auto. apply is_sign_ext_sgn; auto with va. @@ -2326,10 +2841,19 @@ Proof. - constructor. omega. apply is_zero_ext_uns; auto with va. - constructor. xomega. apply is_sign_ext_sgn; auto with va. apply Z.min_case; auto with va. - constructor. omega. apply is_zero_ext_uns; auto with va. +- destruct ptr64; auto with va. +- destruct ptr64; auto with va. +- destruct ptr64; auto with va. +- destruct ptr64; auto with va. +- destruct ptr64; auto with va. +- destruct ptr64; auto with va. - constructor. omega. apply is_sign_ext_sgn; auto with va. - constructor. omega. apply is_zero_ext_uns; auto with va. - constructor. omega. apply is_sign_ext_sgn; auto with va. - constructor. omega. apply is_zero_ext_uns; auto with va. +- destruct ptr64; auto with va. +- destruct ptr64; auto with va. +- destruct ptr64; auto with va. Qed. Lemma vnormalize_cast: @@ -2351,13 +2875,13 @@ Proof. - (* int32 *) auto. - (* int64 *) - destruct v; try contradiction; constructor. + auto. - (* float32 *) destruct v; try contradiction; constructor. - (* float64 *) destruct v; try contradiction; constructor. - (* any32 *) - auto. + destruct Archi.ptr64; auto. - (* any64 *) auto. Qed. @@ -2379,7 +2903,7 @@ Lemma vnormalize_monotone: forall chunk x y, vge x y -> vge (vnormalize chunk x) (vnormalize chunk y). Proof with (auto using provenance_monotone with va). - intros chunk x y V; inversion V; subst; destruct chunk; simpl... + intros chunk x y V; unfold vnormalize; generalize Archi.ptr64; intro ptr64; inversion V; subst; destruct chunk eqn:C; simpl... - destruct (zlt n 8); constructor... apply is_sign_ext_uns... apply is_sign_ext_sgn... @@ -2393,19 +2917,19 @@ Proof with (auto using provenance_monotone with va). destruct (zlt n2 8)... - destruct (zlt n1 16). rewrite zlt_true by omega... destruct (zlt n2 16)... -- destruct (va_strict tt)... - constructor... apply is_sign_ext_sgn... apply Z.min_case... - constructor... apply is_zero_ext_uns... - constructor... apply is_sign_ext_sgn... apply Z.min_case... - constructor... apply is_zero_ext_uns... - unfold provenance; destruct (va_strict tt)... -- destruct (va_strict tt)... - destruct (zlt n2 8); constructor... - destruct (zlt n2 16); constructor... -- destruct (va_strict tt)... -- destruct (va_strict tt)... -- destruct (va_strict tt)... -- destruct (va_strict tt)... +- destruct ptr64... +- destruct ptr64... +- destruct ptr64... +- destruct ptr64... +- destruct ptr64... +- destruct ptr64... - constructor... apply is_sign_ext_sgn... - constructor... apply is_zero_ext_uns... - constructor... apply is_sign_ext_sgn... @@ -2420,8 +2944,6 @@ Proof with (auto using provenance_monotone with va). - unfold provenance; destruct (va_strict tt)... - destruct (zlt n 8)... - destruct (zlt n 16)... -- destruct (va_strict tt)... -- destruct (va_strict tt)... Qed. (** Abstracting memory blocks *) @@ -2648,7 +3170,7 @@ Lemma store_provenance: forall chunk m b ofs v m' b' ofs' b'' ofs'' q i, Mem.store chunk m b ofs v = Some m' -> Mem.loadbytes m' b' ofs' 1 = Some (Fragment (Vptr b'' ofs'') q i :: nil) -> - v = Vptr b'' ofs'' /\ (chunk = Mint32 \/ chunk = Many32 \/ chunk = Many64) + v = Vptr b'' ofs'' /\ (chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) \/ Mem.loadbytes m b' ofs' 1 = Some (Fragment (Vptr b'' ofs'') q i :: nil). Proof. intros. exploit storebytes_provenance; eauto. eapply Mem.store_storebytes; eauto. @@ -2704,7 +3226,8 @@ Proof. generalize (decode_val_shape chunk byte1' bytes'). rewrite <- Q. intros DEC; inv DEC; try contradiction. assert (v = Vptr bx ofsx). - { destruct H5 as [E|[E|E]]; rewrite E in H4; destruct v; simpl in H4; congruence. } + { destruct H5 as [E|[E|[E|E]]]; rewrite E in H4; destruct v; simpl in H4; + try congruence; destruct Archi.ptr64; congruence. } exploit In_loadbytes; eauto. eauto with coqlib. intros (ofs' & X & Y). subst v. exploit storebytes_provenance; eauto. intros [Z | Z]. @@ -3177,10 +3700,10 @@ Definition load (chunk: memory_chunk) (rm: romem) (m: amem) (p: aptr) : aval := | Pbot => if va_strict tt then Vbot else Vtop | Gl id ofs => match rm!id with - | Some ab => ablock_load chunk ab (Int.unsigned ofs) + | Some ab => ablock_load chunk ab (Ptrofs.unsigned ofs) | None => match m.(am_glob)!id with - | Some ab => ablock_load chunk ab (Int.unsigned ofs) + | Some ab => ablock_load chunk ab (Ptrofs.unsigned ofs) | None => vnormalize chunk (Ifptr m.(am_nonstack)) end end @@ -3193,7 +3716,7 @@ Definition load (chunk: memory_chunk) (rm: romem) (m: amem) (p: aptr) : aval := | None => vnormalize chunk (Ifptr m.(am_nonstack)) end end - | Stk ofs => ablock_load chunk m.(am_stack) (Int.unsigned ofs) + | Stk ofs => ablock_load chunk m.(am_stack) (Ptrofs.unsigned ofs) | Stack => ablock_load_anywhere chunk m.(am_stack) | Glob | Nonstack => vnormalize chunk (Ifptr m.(am_nonstack)) | Ptop => vnormalize chunk (Ifptr m.(am_top)) @@ -3205,7 +3728,7 @@ Definition loadv (chunk: memory_chunk) (rm: romem) (m: amem) (addr: aval) : aval Definition store (chunk: memory_chunk) (m: amem) (p: aptr) (av: aval) : amem := {| am_stack := match p with - | Stk ofs => ablock_store chunk m.(am_stack) (Int.unsigned ofs) av + | Stk ofs => ablock_store chunk m.(am_stack) (Ptrofs.unsigned ofs) av | Stack | Ptop => ablock_store_anywhere chunk m.(am_stack) av | _ => m.(am_stack) end; @@ -3213,7 +3736,7 @@ Definition store (chunk: memory_chunk) (m: amem) (p: aptr) (av: aval) : amem := match p with | Gl id ofs => let ab := match m.(am_glob)!id with Some ab => ab | None => ablock_init m.(am_nonstack) end in - PTree.set id (ablock_store chunk ab (Int.unsigned ofs) av) m.(am_glob) + PTree.set id (ablock_store chunk ab (Ptrofs.unsigned ofs) av) m.(am_glob) | Glo id => let ab := match m.(am_glob)!id with Some ab => ab | None => ablock_init m.(am_nonstack) end in PTree.set id (ablock_store_anywhere chunk ab av) m.(am_glob) @@ -3251,7 +3774,7 @@ Definition loadbytes (m: amem) (rm: romem) (p: aptr) : aptr := Definition storebytes (m: amem) (dst: aptr) (sz: Z) (p: aptr) : amem := {| am_stack := match dst with - | Stk ofs => ablock_storebytes m.(am_stack) p (Int.unsigned ofs) sz + | Stk ofs => ablock_storebytes m.(am_stack) p (Ptrofs.unsigned ofs) sz | Stack | Ptop => ablock_storebytes_anywhere m.(am_stack) p | _ => m.(am_stack) end; @@ -3259,7 +3782,7 @@ Definition storebytes (m: amem) (dst: aptr) (sz: Z) (p: aptr) : amem := match dst with | Gl id ofs => let ab := match m.(am_glob)!id with Some ab => ab | None => ablock_init m.(am_nonstack) end in - PTree.set id (ablock_storebytes ab p (Int.unsigned ofs) sz) m.(am_glob) + PTree.set id (ablock_storebytes ab p (Ptrofs.unsigned ofs) sz) m.(am_glob) | Glo id => let ab := match m.(am_glob)!id with Some ab => ab | None => ablock_init m.(am_nonstack) end in PTree.set id (ablock_storebytes_anywhere ab p) m.(am_glob) @@ -3276,7 +3799,7 @@ Definition storebytes (m: amem) (dst: aptr) (sz: Z) (p: aptr) : amem := Theorem load_sound: forall chunk m b ofs v rm am p, - Mem.load chunk m b (Int.unsigned ofs) = Some v -> + Mem.load chunk m b (Ptrofs.unsigned ofs) = Some v -> romatch m rm -> mmatch m am -> pmatch b ofs p -> @@ -3321,7 +3844,7 @@ Qed. Theorem store_sound: forall chunk m b ofs v m' am p av, - Mem.store chunk m b (Int.unsigned ofs) v = Some m' -> + Mem.store chunk m b (Ptrofs.unsigned ofs) v = Some m' -> mmatch m am -> pmatch b ofs p -> vmatch v av -> @@ -3399,7 +3922,7 @@ Qed. Theorem loadbytes_sound: forall m b ofs sz bytes am rm p, - Mem.loadbytes m b (Int.unsigned ofs) sz = Some bytes -> + Mem.loadbytes m b (Ptrofs.unsigned ofs) sz = Some bytes -> romatch m rm -> mmatch m am -> pmatch b ofs p -> @@ -3432,7 +3955,7 @@ Qed. Theorem storebytes_sound: forall m b ofs bytes m' am p sz q, - Mem.storebytes m b (Int.unsigned ofs) bytes = Some m' -> + Mem.storebytes m b (Ptrofs.unsigned ofs) bytes = Some m' -> mmatch m am -> pmatch b ofs p -> length bytes = nat_of_Z sz -> @@ -3716,8 +4239,8 @@ Lemma vmatch_inj: forall bc v x, vmatch bc v x -> Val.inject (inj_of_bc bc) v v. Proof. induction 1; econstructor. - eapply pmatch_inj; eauto. rewrite Int.add_zero; auto. - eapply pmatch_inj; eauto. rewrite Int.add_zero; auto. + eapply pmatch_inj; eauto. rewrite Ptrofs.add_zero; auto. + eapply pmatch_inj; eauto. rewrite Ptrofs.add_zero; auto. Qed. Lemma vmatch_list_inj: @@ -3752,7 +4275,7 @@ Proof. { exploit mmatch_top; eauto. intros [P Q]. eapply pmatch_top'. eapply Q; eauto. } inv PM; auto. - rewrite Int.add_zero; auto. + rewrite Ptrofs.add_zero; auto. - (* free blocks *) intros. unfold inj_of_bc. erewrite bc_below_invalid; eauto. - (* mapped blocks *) @@ -3765,7 +4288,7 @@ Proof. auto. - (* overflow *) intros. exploit inj_of_bc_inv; eauto. intros (A & B & C); subst. - rewrite Zplus_0_r. split. omega. apply Int.unsigned_range_2. + rewrite Zplus_0_r. split. omega. apply Ptrofs.unsigned_range_2. - (* perm inv *) intros. exploit inj_of_bc_inv; eauto. intros (A & B & C); subst. rewrite Zplus_0_r in H2. auto. @@ -4046,13 +4569,22 @@ Hint Resolve cnot_sound symbol_address_sound neg_sound add_sound sub_sound mul_sound mulhs_sound mulhu_sound divs_sound divu_sound mods_sound modu_sound shrx_sound + shll_sound shrl_sound shrlu_sound + andl_sound orl_sound xorl_sound notl_sound roll_sound rorl_sound + negl_sound addl_sound subl_sound + mull_sound mullhs_sound mullhu_sound + divls_sound divlu_sound modls_sound modlu_sound shrxl_sound negf_sound absf_sound addf_sound subf_sound mulf_sound divf_sound negfs_sound absfs_sound addfs_sound subfs_sound mulfs_sound divfs_sound - zero_ext_sound sign_ext_sound singleoffloat_sound floatofsingle_sound + zero_ext_sound sign_ext_sound longofint_sound longofintu_sound + singleoffloat_sound floatofsingle_sound intoffloat_sound intuoffloat_sound floatofint_sound floatofintu_sound intofsingle_sound intuofsingle_sound singleofint_sound singleofintu_sound + longoffloat_sound longuoffloat_sound floatoflong_sound floatoflongu_sound + longofsingle_sound longuofsingle_sound singleoflong_sound singleoflongu_sound longofwords_sound loword_sound hiword_sound - cmpu_bool_sound cmp_bool_sound cmpf_bool_sound cmpfs_bool_sound + cmpu_bool_sound cmp_bool_sound cmplu_bool_sound cmpl_bool_sound + cmpf_bool_sound cmpfs_bool_sound maskzero_sound : va. diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 5d75aa6a..a1ca48d1 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -197,7 +197,7 @@ let builtins_generic = { false); "__compcert_va_composite", (TPtr(TVoid [], []), - [TPtr(TVoid [], []); TInt(IUInt, [])], + [TPtr(TVoid [], []); TInt(IULong, [])], false); (* Helper functions for int64 arithmetic *) "__i64_dtos", @@ -251,6 +251,14 @@ let builtins_generic = { "__i64_sar", (TInt(ILongLong, []), [TInt(ILongLong, []); TInt(IInt, [])], + false); + "__i64_smulh", + (TInt(ILongLong, []), + [TInt(ILongLong, []); TInt(ILongLong, [])], + false); + "__i64_umulh", + (TInt(IULongLong, []), + [TInt(IULongLong, []); TInt(IULongLong, [])], false) ] } @@ -393,14 +401,13 @@ let make_builtin_va_arg_by_val helper ty ty_ret arg = let make_builtin_va_arg_by_ref helper ty arg = let ty_fun = - Tfunction(Tcons(Tpointer(Tvoid, noattr), Tnil), + Tfunction(Tcons(Tpointer(Tvoid, noattr), Tcons(Ctyping.size_t, Tnil)), Tpointer(Tvoid, noattr), cc_default) in let ty_ptr = Tpointer(ty, noattr) in let call = Ecall(Evalof(Evar(intern_string helper, ty_fun), ty_fun), - Econs(va_list_ptr arg, - Econs(Esizeof(ty, Tint(I32, Unsigned, noattr)), Enil)), + Econs(va_list_ptr arg, Econs(Esizeof(ty, Ctyping.size_t), Enil)), Tpointer(Tvoid, noattr)) in Evalof(Ederef(Ecast(call, ty_ptr), ty), ty) @@ -445,27 +452,31 @@ let convertCallconv va unproto attr = (** Types *) -let convertIkind = function - | C.IBool -> (Unsigned, Ctypes.IBool) - | C.IChar -> ((if (!Machine.config).Machine.char_signed - then Signed else Unsigned), I8) - | C.ISChar -> (Signed, I8) - | C.IUChar -> (Unsigned, I8) - | C.IInt -> (Signed, I32) - | C.IUInt -> (Unsigned, I32) - | C.IShort -> (Signed, I16) - | C.IUShort -> (Unsigned, I16) - | C.ILong -> (Signed, I32) - | C.IULong -> (Unsigned, I32) - (* Special-cased in convertTyp below *) - | C.ILongLong | C.IULongLong -> assert false - -let convertFkind = function - | C.FFloat -> F32 - | C.FDouble -> F64 +let convertIkind k a : coq_type = + match k with + | C.IBool -> Tint (IBool, Unsigned, a) + | C.IChar -> Tint (I8, (if Machine.((!config).char_signed) + then Signed else Unsigned), a) + | C.ISChar -> Tint (I8, Signed, a) + | C.IUChar -> Tint (I8, Unsigned, a) + | C.IInt -> Tint (I32, Signed, a) + | C.IUInt -> Tint (I32, Unsigned, a) + | C.IShort -> Tint (I16, Signed, a) + | C.IUShort -> Tint (I16, Unsigned, a) + | C.ILong -> if Machine.((!config).sizeof_long) = 8 + then Tlong (Signed, a) else Tint (I32, Signed, a) + | C.IULong -> if Machine.((!config).sizeof_long) = 8 + then Tlong (Unsigned, a) else Tint (I32, Unsigned, a) + | C.ILongLong -> Tlong (Signed, a) + | C.IULongLong -> Tlong (Unsigned, a) + +let convertFkind k a : coq_type = + match k with + | C.FFloat -> Tfloat (F32, a) + | C.FDouble -> Tfloat (F64, a) | C.FLongDouble -> if not !Clflags.option_flongdouble then unsupported "'long double' type"; - F64 + Tfloat (F64, a) let checkFunctionType env tres targs = if not !Clflags.option_fstruct_passing then begin @@ -485,14 +496,10 @@ let checkFunctionType env tres targs = let rec convertTyp env t = match t with | C.TVoid a -> Tvoid - | C.TInt(C.ILongLong, a) -> - Tlong(Signed, convertAttr a) - | C.TInt(C.IULongLong, a) -> - Tlong(Unsigned, convertAttr a) | C.TInt(ik, a) -> - let (sg, sz) = convertIkind ik in Tint(sz, sg, convertAttr a) + convertIkind ik (convertAttr a) | C.TFloat(fk, a) -> - Tfloat(convertFkind fk, convertAttr a) + convertFkind fk (convertAttr a) | C.TPtr(ty, a) -> Tpointer(convertTyp env ty, convertAttr a) | C.TArray(ty, None, a) -> @@ -517,8 +524,7 @@ let rec convertTyp env t = | C.TUnion(id, a) -> Tunion(intern_string id.name, convertAttr a) | C.TEnum(id, a) -> - let (sg, sz) = convertIkind Cutil.enum_ikind in - Tint(sz, sg, convertAttr a) + convertIkind Cutil.enum_ikind (convertAttr a) and convertParams env = function | [] -> Tnil @@ -653,7 +659,7 @@ let rec convertExpr env e = | C.EConst(C.CInt(i, k, _)) -> let sg = if Cutil.is_signed_ikind k then Signed else Unsigned in - if k = ILongLong || k = IULongLong + if Cutil.sizeof_ikind k = 8 then Ctyping.econst_long (coqint_of_camlint64 i) sg else Ctyping.econst_int (convertInt i) sg | C.EConst(C.CFloat(f, k)) -> diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index a2bfa6e1..4dcf2a47 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -12,25 +12,11 @@ (** Animating the CompCert C semantics *) -Require Import String. -Require Import Axioms. -Require Import Classical. -Require Import Decidableplus. -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import AST. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Determinism. -Require Import Ctypes. -Require Import Cop. -Require Import Csyntax. -Require Import Csem. +Require Import Axioms Classical. +Require Import String Coqlib Decidableplus. +Require Import Errors Maps Integers Floats. +Require Import AST Values Memory Events Globalenvs Determinism. +Require Import Ctypes Cop Csyntax Csem. Require Cstrategy. Local Open Scope string_scope. @@ -74,7 +60,7 @@ Proof. intros until ty. destruct a; simpl; congruence. Qed. -Definition is_loc (a: expr) : option (block * int * type) := +Definition is_loc (a: expr) : option (block * ptrofs * type) := match a with | Eloc b ofs ty => Some(b, ofs, ty) | _ => None @@ -106,16 +92,17 @@ Section EXEC. Variable ge: genv. Definition eventval_of_val (v: val) (t: typ) : option eventval := - match v, t with - | Vint i, AST.Tint => Some (EVint i) - | Vfloat f, AST.Tfloat => Some (EVfloat f) - | Vsingle f, AST.Tsingle => Some (EVsingle f) - | Vlong n, AST.Tlong => Some (EVlong n) - | Vptr b ofs, AST.Tint => + match v with + | Vint i => check (typ_eq t AST.Tint); Some (EVint i) + | Vfloat f => check (typ_eq t AST.Tfloat); Some (EVfloat f) + | Vsingle f => check (typ_eq t AST.Tsingle); Some (EVsingle f) + | Vlong n => check (typ_eq t AST.Tlong); Some (EVlong n) + | Vptr b ofs => do id <- Genv.invert_symbol ge b; check (Genv.public_symbol ge id); + check (typ_eq t AST.Tptr); Some (EVptr_global id ofs) - | _, _ => None + | _ => None end. Fixpoint list_eventval_of_val (vl: list val) (tl: list typ) : option (list eventval) := @@ -129,32 +116,45 @@ Fixpoint list_eventval_of_val (vl: list val) (tl: list typ) : option (list event end. Definition val_of_eventval (ev: eventval) (t: typ) : option val := - match ev, t with - | EVint i, AST.Tint => Some (Vint i) - | EVfloat f, AST.Tfloat => Some (Vfloat f) - | EVsingle f, AST.Tsingle => Some (Vsingle f) - | EVlong n, AST.Tlong => Some (Vlong n) - | EVptr_global id ofs, AST.Tint => + match ev with + | EVint i => check (typ_eq t AST.Tint); Some (Vint i) + | EVfloat f => check (typ_eq t AST.Tfloat); Some (Vfloat f) + | EVsingle f => check (typ_eq t AST.Tsingle); Some (Vsingle f) + | EVlong n => check (typ_eq t AST.Tlong); Some (Vlong n) + | EVptr_global id ofs => check (Genv.public_symbol ge id); + check (typ_eq t AST.Tptr); do b <- Genv.find_symbol ge id; Some (Vptr b ofs) - | _, _ => None + end. + +Ltac mydestr := + match goal with + | [ |- None = Some _ -> _ ] => intro X; discriminate + | [ |- Some _ = Some _ -> _ ] => intro X; inv X + | [ |- match ?x with Some _ => _ | None => _ end = Some _ -> _ ] => destruct x eqn:?; mydestr + | [ |- match ?x with true => _ | false => _ end = Some _ -> _ ] => destruct x eqn:?; mydestr + | [ |- match ?x with left _ => _ | right _ => _ end = Some _ -> _ ] => destruct x; mydestr + | _ => idtac end. Lemma eventval_of_val_sound: forall v t ev, eventval_of_val v t = Some ev -> eventval_match ge ev t v. Proof. - intros. destruct v; destruct t; simpl in H; inv H; try constructor. - destruct (Genv.invert_symbol ge b) as [id|] eqn:?; try discriminate. - destruct (Genv.public_symbol ge id) eqn:?; inv H1. - constructor. auto. apply Genv.invert_find_symbol; auto. + intros until ev. destruct v; simpl; mydestr; constructor. + auto. apply Genv.invert_find_symbol; auto. Qed. Lemma eventval_of_val_complete: forall ev t v, eventval_match ge ev t v -> eventval_of_val v t = Some ev. Proof. - induction 1; simpl; auto. - rewrite (Genv.find_invert_symbol _ _ H0). simpl in H; rewrite H. auto. + induction 1; simpl. +- auto. +- auto. +- auto. +- auto. +- rewrite (Genv.find_invert_symbol _ _ H0). simpl in H; rewrite H. + rewrite dec_eq_true. auto. Qed. Lemma list_eventval_of_val_sound: @@ -177,21 +177,23 @@ Qed. Lemma val_of_eventval_sound: forall ev t v, val_of_eventval ev t = Some v -> eventval_match ge ev t v. Proof. - intros. destruct ev; destruct t; simpl in H; inv H; try constructor. - destruct (Genv.public_symbol ge i) eqn:?; try discriminate. - destruct (Genv.find_symbol ge i) as [b|] eqn:?; inv H1. - constructor; auto. + intros until v. destruct ev; simpl; mydestr; constructor; auto. Qed. Lemma val_of_eventval_complete: forall ev t v, eventval_match ge ev t v -> val_of_eventval ev t = Some v. Proof. - induction 1; simpl; auto. simpl in *. rewrite H, H0; auto. + induction 1; simpl. +- auto. +- auto. +- auto. +- auto. +- simpl in *. rewrite H, H0. rewrite dec_eq_true. auto. Qed. (** Volatile memory accesses. *) -Definition do_volatile_load (w: world) (chunk: memory_chunk) (m: mem) (b: block) (ofs: int) +Definition do_volatile_load (w: world) (chunk: memory_chunk) (m: mem) (b: block) (ofs: ptrofs) : option (world * trace * val) := if Genv.block_is_volatile ge b then do id <- Genv.invert_symbol ge b; @@ -202,10 +204,10 @@ Definition do_volatile_load (w: world) (chunk: memory_chunk) (m: mem) (b: block) Some(w', Event_vload chunk id ofs res :: nil, Val.load_result chunk vres) end else - do v <- Mem.load chunk m b (Int.unsigned ofs); + do v <- Mem.load chunk m b (Ptrofs.unsigned ofs); Some(w, E0, v). -Definition do_volatile_store (w: world) (chunk: memory_chunk) (m: mem) (b: block) (ofs: int) (v: val) +Definition do_volatile_store (w: world) (chunk: memory_chunk) (m: mem) (b: block) (ofs: ptrofs) (v: val) : option (world * trace * mem) := if Genv.block_is_volatile ge b then do id <- Genv.invert_symbol ge b; @@ -213,19 +215,9 @@ Definition do_volatile_store (w: world) (chunk: memory_chunk) (m: mem) (b: block do w' <- nextworld_vstore w chunk id ofs ev; Some(w', Event_vstore chunk id ofs ev :: nil, m) else - do m' <- Mem.store chunk m b (Int.unsigned ofs) v; + do m' <- Mem.store chunk m b (Ptrofs.unsigned ofs) v; Some(w, E0, m'). -Ltac mydestr := - match goal with - | [ |- None = Some _ -> _ ] => let X := fresh "X" in intro X; discriminate - | [ |- Some _ = Some _ -> _ ] => let X := fresh "X" in intro X; inv X - | [ |- match ?x with Some _ => _ | None => _ end = Some _ -> _ ] => destruct x eqn:?; mydestr - | [ |- match ?x with true => _ | false => _ end = Some _ -> _ ] => destruct x eqn:?; mydestr - | [ |- match ?x with left _ => _ | right _ => _ end = Some _ -> _ ] => destruct x; mydestr - | _ => idtac - end. - Lemma do_volatile_load_sound: forall w chunk m b ofs w' t v, do_volatile_load w chunk m b ofs = Some(w', t, v) -> @@ -276,7 +268,7 @@ Qed. (** Accessing locations *) -Definition do_deref_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: int) : option (world * trace * val) := +Definition do_deref_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) : option (world * trace * val) := match access_mode ty with | By_value chunk => match type_is_volatile ty with @@ -288,37 +280,37 @@ Definition do_deref_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: int) : o | _ => None end. -Definition assign_copy_ok (ty: type) (b: block) (ofs: int) (b': block) (ofs': int) : Prop := - (alignof_blockcopy ge ty | Int.unsigned ofs') /\ (alignof_blockcopy ge ty | Int.unsigned ofs) /\ - (b' <> b \/ Int.unsigned ofs' = Int.unsigned ofs - \/ Int.unsigned ofs' + sizeof ge ty <= Int.unsigned ofs - \/ Int.unsigned ofs + sizeof ge ty <= Int.unsigned ofs'). +Definition assign_copy_ok (ty: type) (b: block) (ofs: ptrofs) (b': block) (ofs': ptrofs) : Prop := + (alignof_blockcopy ge ty | Ptrofs.unsigned ofs') /\ (alignof_blockcopy ge ty | Ptrofs.unsigned ofs) /\ + (b' <> b \/ Ptrofs.unsigned ofs' = Ptrofs.unsigned ofs + \/ Ptrofs.unsigned ofs' + sizeof ge ty <= Ptrofs.unsigned ofs + \/ Ptrofs.unsigned ofs + sizeof ge ty <= Ptrofs.unsigned ofs'). Remark check_assign_copy: - forall (ty: type) (b: block) (ofs: int) (b': block) (ofs': int), + forall (ty: type) (b: block) (ofs: ptrofs) (b': block) (ofs': ptrofs), { assign_copy_ok ty b ofs b' ofs' } + {~ assign_copy_ok ty b ofs b' ofs' }. Proof with try (right; intuition omega). intros. unfold assign_copy_ok. assert (alignof_blockcopy ge ty > 0) by apply alignof_blockcopy_pos. - destruct (Zdivide_dec (alignof_blockcopy ge ty) (Int.unsigned ofs')); auto... - destruct (Zdivide_dec (alignof_blockcopy ge ty) (Int.unsigned ofs)); auto... + destruct (Zdivide_dec (alignof_blockcopy ge ty) (Ptrofs.unsigned ofs')); auto... + destruct (Zdivide_dec (alignof_blockcopy ge ty) (Ptrofs.unsigned ofs)); auto... assert (Y: {b' <> b \/ - Int.unsigned ofs' = Int.unsigned ofs \/ - Int.unsigned ofs' + sizeof ge ty <= Int.unsigned ofs \/ - Int.unsigned ofs + sizeof ge ty <= Int.unsigned ofs'} + + Ptrofs.unsigned ofs' = Ptrofs.unsigned ofs \/ + Ptrofs.unsigned ofs' + sizeof ge ty <= Ptrofs.unsigned ofs \/ + Ptrofs.unsigned ofs + sizeof ge ty <= Ptrofs.unsigned ofs'} + {~(b' <> b \/ - Int.unsigned ofs' = Int.unsigned ofs \/ - Int.unsigned ofs' + sizeof ge ty <= Int.unsigned ofs \/ - Int.unsigned ofs + sizeof ge ty <= Int.unsigned ofs')}). + Ptrofs.unsigned ofs' = Ptrofs.unsigned ofs \/ + Ptrofs.unsigned ofs' + sizeof ge ty <= Ptrofs.unsigned ofs \/ + Ptrofs.unsigned ofs + sizeof ge ty <= Ptrofs.unsigned ofs')}). destruct (eq_block b' b); auto. - destruct (zeq (Int.unsigned ofs') (Int.unsigned ofs)); auto. - destruct (zle (Int.unsigned ofs' + sizeof ge ty) (Int.unsigned ofs)); auto. - destruct (zle (Int.unsigned ofs + sizeof ge ty) (Int.unsigned ofs')); auto. + destruct (zeq (Ptrofs.unsigned ofs') (Ptrofs.unsigned ofs)); auto. + destruct (zle (Ptrofs.unsigned ofs' + sizeof ge ty) (Ptrofs.unsigned ofs)); auto. + destruct (zle (Ptrofs.unsigned ofs + sizeof ge ty) (Ptrofs.unsigned ofs')); auto. right; intuition omega. destruct Y... left; intuition omega. Defined. -Definition do_assign_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: int) (v: val): option (world * trace * mem) := +Definition do_assign_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) (v: val): option (world * trace * mem) := match access_mode ty with | By_value chunk => match type_is_volatile ty with @@ -329,8 +321,8 @@ Definition do_assign_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: int) (v match v with | Vptr b' ofs' => if check_assign_copy ty b ofs b' ofs' then - do bytes <- Mem.loadbytes m b' (Int.unsigned ofs') (sizeof ge ty); - do m' <- Mem.storebytes m b (Int.unsigned ofs) bytes; + do bytes <- Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ge ty); + do m' <- Mem.storebytes m b (Ptrofs.unsigned ofs) bytes; Some(w, E0, m') else None | _ => None @@ -433,21 +425,29 @@ Definition do_ef_volatile_store (chunk: memory_chunk) | _ => None end. -Definition do_ef_volatile_load_global (chunk: memory_chunk) (id: ident) (ofs: int) +Definition do_ef_volatile_load_global (chunk: memory_chunk) (id: ident) (ofs: ptrofs) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := do b <- Genv.find_symbol ge id; do_ef_volatile_load chunk w (Vptr b ofs :: vargs) m. -Definition do_ef_volatile_store_global (chunk: memory_chunk) (id: ident) (ofs: int) +Definition do_ef_volatile_store_global (chunk: memory_chunk) (id: ident) (ofs: ptrofs) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := do b <- Genv.find_symbol ge id; do_ef_volatile_store chunk w (Vptr b ofs :: vargs) m. +Definition do_alloc_size (v: val) : option ptrofs := + match v with + | Vint n => if Archi.ptr64 then None else Some (Ptrofs.of_int n) + | Vlong n => if Archi.ptr64 then Some (Ptrofs.of_int64 n) else None + | _ => None + end. + Definition do_ef_malloc (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := match vargs with - | Vint n :: nil => - let (m', b) := Mem.alloc m (-4) (Int.unsigned n) in - do m'' <- Mem.store Mint32 m' b (-4) (Vint n); - Some(w, E0, Vptr b Int.zero, m'') + | v :: nil => + do sz <- do_alloc_size v; + let (m', b) := Mem.alloc m (- size_chunk Mptr) (Ptrofs.unsigned sz) in + do m'' <- Mem.store Mptr m' b (- size_chunk Mptr) v; + Some(w, E0, Vptr b Ptrofs.zero, m'') | _ => None end. @@ -455,14 +455,11 @@ Definition do_ef_free (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := match vargs with | Vptr b lo :: nil => - do vsz <- Mem.load Mint32 m b (Int.unsigned lo - 4); - match vsz with - | Vint sz => - check (zlt 0 (Int.unsigned sz)); - do m' <- Mem.free m b (Int.unsigned lo - 4) (Int.unsigned lo + Int.unsigned sz); - Some(w, E0, Vundef, m') - | _ => None - end + do vsz <- Mem.load Mptr m b (Ptrofs.unsigned lo - size_chunk Mptr); + do sz <- do_alloc_size vsz; + check (zlt 0 (Ptrofs.unsigned sz)); + do m' <- Mem.free m b (Ptrofs.unsigned lo - size_chunk Mptr) (Ptrofs.unsigned lo + Ptrofs.unsigned sz); + Some(w, E0, Vundef, m') | _ => None end. @@ -478,9 +475,9 @@ Definition do_ef_memcpy (sz al: Z) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := match vargs with | Vptr bdst odst :: Vptr bsrc osrc :: nil => - if decide (memcpy_args_ok sz al bdst (Int.unsigned odst) bsrc (Int.unsigned osrc)) then - do bytes <- Mem.loadbytes m bsrc (Int.unsigned osrc) sz; - do m' <- Mem.storebytes m bdst (Int.unsigned odst) bytes; + if decide (memcpy_args_ok sz al bdst (Ptrofs.unsigned odst) bsrc (Ptrofs.unsigned osrc)) then + do bytes <- Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz; + do m' <- Mem.storebytes m bdst (Ptrofs.unsigned odst) bytes; Some(w, E0, Vundef, m') else None | _ => None @@ -526,6 +523,9 @@ Lemma do_ef_external_sound: do_external ef w vargs m = Some(w', t, vres, m') -> external_call ef ge vargs m t vres m' /\ possible_trace w t w'. Proof with try congruence. + assert (SIZE: forall v sz, do_alloc_size v = Some sz -> v = Vptrofs sz). + { intros until sz; unfold Vptrofs; destruct v; simpl; destruct Archi.ptr64 eqn:SF; + intros EQ; inv EQ; f_equal; symmetry; eauto with ptrofs. } intros until m'. destruct ef; simpl. (* EF_external *) @@ -545,16 +545,16 @@ Proof with try congruence. exploit do_volatile_store_sound; eauto. intuition. econstructor; eauto. auto. (* EF_malloc *) - unfold do_ef_malloc. destruct vargs... destruct v... destruct vargs... - destruct (Mem.alloc m (-4) (Int.unsigned i)) as [m1 b] eqn:?. mydestr. - split. econstructor; eauto. constructor. + unfold do_ef_malloc. destruct vargs... destruct vargs... mydestr. + destruct (Mem.alloc m (- size_chunk Mptr) (Ptrofs.unsigned i)) as [m1 b] eqn:?. mydestr. + split. apply SIZE in Heqo. subst v. econstructor; eauto. constructor. (* EF_free *) unfold do_ef_free. destruct vargs... destruct v... destruct vargs... - mydestr. destruct v... mydestr. - split. econstructor; eauto. omega. constructor. + mydestr. split. apply SIZE in Heqo0. econstructor; eauto. congruence. omega. constructor. (* EF_memcpy *) unfold do_ef_memcpy. destruct vargs... destruct v... destruct vargs... - destruct v... destruct vargs... mydestr. apply Decidable_sound in Heqb1. red in Heqb1. + destruct v... destruct vargs... mydestr. + apply Decidable_sound in Heqb1. red in Heqb1. split. econstructor; eauto; tauto. constructor. (* EF_annot *) unfold do_ef_annot. mydestr. @@ -575,6 +575,10 @@ Lemma do_ef_external_complete: external_call ef ge vargs m t vres m' -> possible_trace w t w' -> do_external ef w vargs m = Some(w', t, vres, m'). Proof. + assert (SIZE: forall n, do_alloc_size (Vptrofs n) = Some n). + { unfold Vptrofs, do_alloc_size; intros; destruct Archi.ptr64 eqn:SF. + rewrite Ptrofs.of_int64_to_int64; auto. + rewrite Ptrofs.of_int_to_int; auto. } intros. destruct ef; simpl in *. (* EF_external *) eapply do_external_function_complete; eauto. @@ -590,13 +594,13 @@ Proof. exploit do_volatile_store_complete; eauto. intros EQ; rewrite EQ; auto. (* EF_malloc *) inv H; unfold do_ef_malloc. - inv H0. rewrite H1. rewrite H2. auto. + inv H0. erewrite SIZE by eauto. rewrite H1, H2. auto. (* EF_free *) inv H; unfold do_ef_free. - inv H0. rewrite H1. rewrite zlt_true. rewrite H3. auto. omega. + inv H0. rewrite H1. erewrite SIZE by eauto. rewrite zlt_true. rewrite H3. auto. omega. (* EF_memcpy *) inv H; unfold do_ef_memcpy. - inv H0. rewrite Decidable_complete, H7, H8. auto. + inv H0. rewrite Decidable_complete. rewrite H7; rewrite H8; auto. red. tauto. (* EF_annot *) inv H; unfold do_ef_annot. inv H0. inv H6. inv H4. @@ -680,10 +684,10 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := match e!x with | Some(b, ty') => check type_eq ty ty'; - topred (Lred "red_var_local" (Eloc b Int.zero ty) m) + topred (Lred "red_var_local" (Eloc b Ptrofs.zero ty) m) | None => do b <- Genv.find_symbol ge x; - topred (Lred "red_var_global" (Eloc b Int.zero ty) m) + topred (Lred "red_var_global" (Eloc b Ptrofs.zero ty) m) end | LV, Ederef r ty => match is_val r with @@ -702,7 +706,7 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := do co <- ge.(genv_cenv)!id; match field_offset ge f (co_members co) with | Error _ => stuck - | OK delta => topred (Lred "red_field_struct" (Eloc b (Int.add ofs (Int.repr delta)) ty) m) + | OK delta => topred (Lred "red_field_struct" (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) ty) m) end | Tunion id _ => do co <- ge.(genv_cenv)!id; @@ -782,9 +786,9 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := incontext (fun x => Econdition x r2 r3 ty) (step_expr RV r1 m) end | RV, Esizeof ty' ty => - topred (Rred "red_sizeof" (Eval (Vint (Int.repr (sizeof ge ty'))) ty) m E0) + topred (Rred "red_sizeof" (Eval (Vptrofs (Ptrofs.repr (sizeof ge ty'))) ty) m E0) | RV, Ealignof ty' ty => - topred (Rred "red_alignof" (Eval (Vint (Int.repr (alignof ge ty'))) ty) m E0) + topred (Rred "red_alignof" (Eval (Vptrofs (Ptrofs.repr (alignof ge ty'))) ty) m E0) | RV, Eassign l1 r2 ty => match is_loc l1, is_val r2 with | Some(b, ofs, ty1), Some(v2, ty2) => @@ -1870,7 +1874,7 @@ Function sem_bind_parameters (w: world) (e: env) (m: mem) (l: list (ident * type match PTree.get id e with | Some (b, ty') => check (type_eq ty ty'); - do w', t, m1 <- do_assign_loc w ty m b Int.zero v1; + do w', t, m1 <- do_assign_loc w ty m b Ptrofs.zero v1; match t with nil => sem_bind_parameters w e m1 params lv | _ => None end | None => None end @@ -2034,15 +2038,12 @@ Definition do_step (w: world) (s: state) : list transition := Ltac myinv := match goal with - | [ |- In _ nil -> _ ] => let X := fresh "X" in intro X; elim X + | [ |- In _ nil -> _ ] => intro X; elim X | [ |- In _ (ret _ _) -> _ ] => - let X := fresh "X" in intro X; elim X; clear X; - [let EQ := fresh "EQ" in intro EQ; unfold ret in EQ; inv EQ; myinv | myinv] + [intro EQ; unfold ret in EQ; inv EQ; myinv | myinv] | [ |- In _ (_ :: nil) -> _ ] => - let X := fresh "X" in - intro X; elim X; clear X; - [let EQ := fresh "EQ" in intro EQ; inv EQ; myinv | myinv] + intro X; elim X; clear X; [intro EQ; inv EQ; myinv | myinv] | [ |- In _ (match ?x with Some _ => _ | None => _ end) -> _ ] => destruct x eqn:?; myinv | [ |- In _ (match ?x with false => _ | true => _ end) -> _ ] => destruct x eqn:?; myinv | [ |- In _ (match ?x with left _ => _ | right _ => _ end) -> _ ] => destruct x; myinv diff --git a/cfrontend/Clight.v b/cfrontend/Clight.v index e6426fb8..7a4c49a2 100644 --- a/cfrontend/Clight.v +++ b/cfrontend/Clight.v @@ -202,7 +202,7 @@ Definition temp_env := PTree.t val. memory load is performed. If the type [ty] indicates an access by reference or by copy, the pointer [Vptr b ofs] is returned. *) -Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: int) : val -> Prop := +Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs) : val -> Prop := | deref_loc_value: forall chunk v, access_mode ty = By_value chunk -> Mem.loadv chunk m (Vptr b ofs) = Some v -> @@ -220,7 +220,7 @@ Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: int) : val -> Prop := This is allowed only if [ty] indicates an access by value or by copy. [m'] is the updated memory state. *) -Inductive assign_loc (ce: composite_env) (ty: type) (m: mem) (b: block) (ofs: int): +Inductive assign_loc (ce: composite_env) (ty: type) (m: mem) (b: block) (ofs: ptrofs): val -> mem -> Prop := | assign_loc_value: forall v chunk m', access_mode ty = By_value chunk -> @@ -228,13 +228,13 @@ Inductive assign_loc (ce: composite_env) (ty: type) (m: mem) (b: block) (ofs: in assign_loc ce ty m b ofs v m' | assign_loc_copy: forall b' ofs' bytes m', access_mode ty = By_copy -> - (sizeof ce ty > 0 -> (alignof_blockcopy ce ty | Int.unsigned ofs')) -> - (sizeof ce ty > 0 -> (alignof_blockcopy ce ty | Int.unsigned ofs)) -> - b' <> b \/ Int.unsigned ofs' = Int.unsigned ofs - \/ Int.unsigned ofs' + sizeof ce ty <= Int.unsigned ofs - \/ Int.unsigned ofs + sizeof ce ty <= Int.unsigned ofs' -> - Mem.loadbytes m b' (Int.unsigned ofs') (sizeof ce ty) = Some bytes -> - Mem.storebytes m b (Int.unsigned ofs) bytes = Some m' -> + (sizeof ce ty > 0 -> (alignof_blockcopy ce ty | Ptrofs.unsigned ofs')) -> + (sizeof ce ty > 0 -> (alignof_blockcopy ce ty | Ptrofs.unsigned ofs)) -> + b' <> b \/ Ptrofs.unsigned ofs' = Ptrofs.unsigned ofs + \/ Ptrofs.unsigned ofs' + sizeof ce ty <= Ptrofs.unsigned ofs + \/ Ptrofs.unsigned ofs + sizeof ce ty <= Ptrofs.unsigned ofs' -> + Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ce ty) = Some bytes -> + Mem.storebytes m b (Ptrofs.unsigned ofs) bytes = Some m' -> assign_loc ce ty m b ofs (Vptr b' ofs') m'. Section SEMANTICS. @@ -274,7 +274,7 @@ Inductive bind_parameters (e: env): | bind_parameters_cons: forall m id ty params v1 vl b m1 m2, PTree.get id e = Some(b, ty) -> - assign_loc ge ty m b Int.zero v1 m1 -> + assign_loc ge ty m b Ptrofs.zero v1 m1 -> bind_parameters e m1 params vl m2 -> bind_parameters e m ((id, ty) :: params) (v1 :: vl) m2. @@ -384,9 +384,9 @@ Inductive eval_expr: expr -> val -> Prop := sem_cast v1 (typeof a) ty m = Some v -> eval_expr (Ecast a ty) v | eval_Esizeof: forall ty1 ty, - eval_expr (Esizeof ty1 ty) (Vint (Int.repr (sizeof ge ty1))) + eval_expr (Esizeof ty1 ty) (Vptrofs (Ptrofs.repr (sizeof ge ty1))) | eval_Ealignof: forall ty1 ty, - eval_expr (Ealignof ty1 ty) (Vint (Int.repr (alignof ge ty1))) + eval_expr (Ealignof ty1 ty) (Vptrofs (Ptrofs.repr (alignof ge ty1))) | eval_Elvalue: forall a loc ofs v, eval_lvalue a loc ofs -> deref_loc (typeof a) m loc ofs v -> @@ -396,14 +396,14 @@ Inductive eval_expr: expr -> val -> Prop := in l-value position. The result is the memory location [b, ofs] that contains the value of the expression [a]. *) -with eval_lvalue: expr -> block -> int -> Prop := +with eval_lvalue: expr -> block -> ptrofs -> Prop := | eval_Evar_local: forall id l ty, e!id = Some(l, ty) -> - eval_lvalue (Evar id ty) l Int.zero + eval_lvalue (Evar id ty) l Ptrofs.zero | eval_Evar_global: forall id l ty, e!id = None -> Genv.find_symbol ge id = Some l -> - eval_lvalue (Evar id ty) l Int.zero + eval_lvalue (Evar id ty) l Ptrofs.zero | eval_Ederef: forall a ty l ofs, eval_expr a (Vptr l ofs) -> eval_lvalue (Ederef a ty) l ofs @@ -412,7 +412,7 @@ with eval_lvalue: expr -> block -> int -> Prop := typeof a = Tstruct id att -> ge.(genv_cenv)!id = Some co -> field_offset ge i (co_members co) = OK delta -> - eval_lvalue (Efield a i ty) l (Int.add ofs (Int.repr delta)) + eval_lvalue (Efield a i ty) l (Ptrofs.add ofs (Ptrofs.repr delta)) | eval_Efield_union: forall a i ty l ofs id co att, eval_expr a (Vptr l ofs) -> typeof a = Tunion id att -> diff --git a/cfrontend/Cminorgen.v b/cfrontend/Cminorgen.v index b9a28ee1..5017fc8e 100644 --- a/cfrontend/Cminorgen.v +++ b/cfrontend/Cminorgen.v @@ -47,8 +47,8 @@ Definition compilenv := PTree.t Z. Definition var_addr (cenv: compilenv) (id: ident): expr := match PTree.get id cenv with - | Some ofs => Econst (Oaddrstack (Int.repr ofs)) - | None => Econst (Oaddrsymbol id Int.zero) + | Some ofs => Econst (Oaddrstack (Ptrofs.repr ofs)) + | None => Econst (Oaddrsymbol id Ptrofs.zero) end. (** * Translation of expressions and statements. *) @@ -269,7 +269,7 @@ Definition transl_funbody Definition transl_function (f: Csharpminor.function): res function := let (cenv, stacksize) := build_compilenv f in - if zle stacksize Int.max_unsigned + if zle stacksize Ptrofs.max_unsigned then transl_funbody cenv stacksize f else Error(msg "Cminorgen: too many local variables, stack size exceeded"). diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index 2f551d68..ea1bc89c 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -76,7 +76,7 @@ Lemma sig_preserved: Proof. intros until tf; destruct f; simpl. unfold transl_function. destruct (build_compilenv f). - case (zle z Int.max_unsigned); simpl bind; try congruence. + case (zle z Ptrofs.max_unsigned); simpl bind; try congruence. intros. monadInv H. simpl. eapply sig_preserved_body; eauto. intro. inv H. reflexivity. Qed. @@ -190,7 +190,7 @@ Qed. Inductive match_var (f: meminj) (sp: block): option (block * Z) -> option Z -> Prop := | match_var_local: forall b sz ofs, - Val.inject f (Vptr b Int.zero) (Vptr sp (Int.repr ofs)) -> + Val.inject f (Vptr b Ptrofs.zero) (Vptr sp (Ptrofs.repr ofs)) -> match_var f sp (Some(b, sz)) (Some ofs) | match_var_global: match_var f sp None None. @@ -311,7 +311,7 @@ Proof. intros. rewrite PTree.gsspec. destruct (peq id0 id). (* the new var *) subst id0. rewrite CENV. constructor. econstructor. eauto. - rewrite Int.add_commut; rewrite Int.add_zero; auto. + rewrite Ptrofs.add_commut; rewrite Ptrofs.add_zero; auto. (* old vars *) generalize (me_vars0 id0). rewrite PTree.gro; auto. intros M; inv M. constructor; eauto. @@ -794,7 +794,7 @@ Definition cenv_mem_separated (cenv: compilenv) (vars: list (ident * Z)) (f: mem Lemma match_callstack_alloc_variables_rec: forall tm sp tf cenv le te lo cs, Mem.valid_block tm sp -> - fn_stackspace tf <= Int.max_unsigned -> + fn_stackspace tf <= Ptrofs.max_unsigned -> (forall ofs k p, Mem.perm tm sp ofs k p -> 0 <= ofs < fn_stackspace tf) -> (forall ofs k p, 0 <= ofs < fn_stackspace tf -> Mem.perm tm sp ofs k p) -> forall e1 m1 vars e2 m2, @@ -854,7 +854,7 @@ Qed. Lemma match_callstack_alloc_variables: forall tm1 sp tm2 m1 vars e m2 cenv f1 cs fn le te, Mem.alloc tm1 0 (fn_stackspace fn) = (tm2, sp) -> - fn_stackspace fn <= Int.max_unsigned -> + fn_stackspace fn <= Ptrofs.max_unsigned -> alloc_variables empty_env m1 vars e m2 -> list_norepet (map fst vars) -> cenv_compat cenv vars (fn_stackspace fn) -> @@ -1225,7 +1225,7 @@ Qed. Theorem match_callstack_function_entry: forall fn cenv tf m e m' tm tm' sp f cs args targs le, build_compilenv fn = (cenv, tf.(fn_stackspace)) -> - tf.(fn_stackspace) <= Int.max_unsigned -> + tf.(fn_stackspace) <= Ptrofs.max_unsigned -> list_norepet (map fst (Csharpminor.fn_vars fn)) -> list_norepet (Csharpminor.fn_params fn) -> list_disjoint (Csharpminor.fn_params fn) (Csharpminor.fn_temps fn) -> @@ -1334,82 +1334,91 @@ Lemma eval_binop_compat: eval_binop op tv1 tv2 tm = Some tv /\ Val.inject f v tv. Proof. - destruct op; simpl; intros. - inv H; inv H0; inv H1; TrivialExists. - repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - inv H; inv H0; inv H1; TrivialExists. - apply Int.sub_add_l. - simpl. destruct (eq_block b1 b0); auto. - subst b1. rewrite H in H0; inv H0. - rewrite dec_eq_true. rewrite Int.sub_shifted. auto. - inv H; inv H0; inv H1; TrivialExists. - inv H0; try discriminate; inv H1; try discriminate. simpl in *. + destruct op; simpl; intros; inv H. +- TrivialExists. apply Val.add_inject; auto. +- TrivialExists. apply Val.sub_inject; auto. +- TrivialExists. inv H0; inv H1; constructor. +- inv H0; try discriminate; inv H1; try discriminate. simpl in *. destruct (Int.eq i0 Int.zero - || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H; TrivialExists. - inv H0; try discriminate; inv H1; try discriminate. simpl in *. - destruct (Int.eq i0 Int.zero); inv H. TrivialExists. - inv H0; try discriminate; inv H1; try discriminate. simpl in *. + || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H4; TrivialExists. +- inv H0; try discriminate; inv H1; try discriminate. simpl in *. + destruct (Int.eq i0 Int.zero); inv H4. TrivialExists. +- inv H0; try discriminate; inv H1; try discriminate. simpl in *. destruct (Int.eq i0 Int.zero - || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H; TrivialExists. - inv H0; try discriminate; inv H1; try discriminate. simpl in *. - destruct (Int.eq i0 Int.zero); inv H. TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. simpl. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H; inv H0; inv H1; TrivialExists. simpl. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H; inv H0; inv H1; TrivialExists. simpl. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H0; try discriminate; inv H1; try discriminate. simpl in *. + || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H4; TrivialExists. +- inv H0; try discriminate; inv H1; try discriminate. simpl in *. + destruct (Int.eq i0 Int.zero); inv H4. TrivialExists. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; simpl; auto. + destruct (Int.ltu i0 Int.iwordsize); constructor. +- TrivialExists; inv H0; inv H1; simpl; auto. + destruct (Int.ltu i0 Int.iwordsize); constructor. +- TrivialExists; inv H0; inv H1; simpl; auto. + destruct (Int.ltu i0 Int.iwordsize); constructor. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists. apply Val.addl_inject; auto. +- TrivialExists. apply Val.subl_inject; auto. +- TrivialExists. inv H0; inv H1; constructor. +- inv H0; try discriminate; inv H1; try discriminate. simpl in *. destruct (Int64.eq i0 Int64.zero - || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H; TrivialExists. - inv H0; try discriminate; inv H1; try discriminate. simpl in *. - destruct (Int64.eq i0 Int64.zero); inv H. TrivialExists. - inv H0; try discriminate; inv H1; try discriminate. simpl in *. + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H4; TrivialExists. +- inv H0; try discriminate; inv H1; try discriminate. simpl in *. + destruct (Int64.eq i0 Int64.zero); inv H4. TrivialExists. +- inv H0; try discriminate; inv H1; try discriminate. simpl in *. destruct (Int64.eq i0 Int64.zero - || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H; TrivialExists. - inv H0; try discriminate; inv H1; try discriminate. simpl in *. - destruct (Int64.eq i0 Int64.zero); inv H. TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. - inv H; inv H0; inv H1; TrivialExists. simpl. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H; inv H0; inv H1; TrivialExists. simpl. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H; inv H0; inv H1; TrivialExists. simpl. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H; inv H0; inv H1; TrivialExists. apply val_inject_val_of_optbool. -(* cmpu *) - inv H. econstructor; split; eauto. - unfold Val.cmpu. + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H4; TrivialExists. +- inv H0; try discriminate; inv H1; try discriminate. simpl in *. + destruct (Int64.eq i0 Int64.zero); inv H4. TrivialExists. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; constructor. +- TrivialExists; inv H0; inv H1; simpl; auto. + destruct (Int.ltu i0 Int64.iwordsize'); constructor. +- TrivialExists; inv H0; inv H1; simpl; auto. + destruct (Int.ltu i0 Int64.iwordsize'); constructor. +- TrivialExists; inv H0; inv H1; simpl; auto. + destruct (Int.ltu i0 Int64.iwordsize'); constructor. +- (* cmp *) + TrivialExists. inv H0; inv H1; auto. apply val_inject_val_of_optbool. +- (* cmpu *) + TrivialExists. unfold Val.cmpu. destruct (Val.cmpu_bool (Mem.valid_pointer m) c v1 v2) as [b|] eqn:E. replace (Val.cmpu_bool (Mem.valid_pointer tm) c tv1 tv2) with (Some b). - destruct b; simpl; constructor. + apply val_inject_val_of_optbool. symmetry. eapply Val.cmpu_bool_inject; eauto. intros; eapply Mem.valid_pointer_inject_val; eauto. intros; eapply Mem.weak_valid_pointer_inject_val; eauto. intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. intros; eapply Mem.different_pointers_inject; eauto. simpl; auto. -(* cmpf *) - inv H; inv H0; inv H1; TrivialExists. apply val_inject_val_of_optbool. -(* cmpfs *) - inv H; inv H0; inv H1; TrivialExists. apply val_inject_val_of_optbool. -(* cmpl *) - unfold Val.cmpl in *. inv H0; inv H1; simpl in H; inv H. +- (* cmpf *) + TrivialExists. inv H0; inv H1; auto. apply val_inject_val_of_optbool. +- (* cmpfs *) + TrivialExists. inv H0; inv H1; auto. apply val_inject_val_of_optbool. +- (* cmpl *) + unfold Val.cmpl in *. inv H0; inv H1; simpl in H4; inv H4. econstructor; split. simpl; eauto. apply val_inject_val_of_bool. -(* cmplu *) - unfold Val.cmplu in *. inv H0; inv H1; simpl in H; inv H. +- (* cmplu *) + unfold Val.cmplu in *. + destruct (Val.cmplu_bool (Mem.valid_pointer m) c v1 v2) as [b|] eqn:E. + simpl in H4; inv H4. + replace (Val.cmplu_bool (Mem.valid_pointer tm) c tv1 tv2) with (Some b). econstructor; split. simpl; eauto. apply val_inject_val_of_bool. + symmetry. eapply Val.cmplu_bool_inject; eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. + discriminate. Qed. (** * Correctness of Cminor construction functions *) @@ -1421,21 +1430,22 @@ Lemma var_addr_correct: match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> eval_var_addr ge e id b -> exists tv, - eval_expr tge (Vptr sp Int.zero) te tm (var_addr cenv id) tv - /\ Val.inject f (Vptr b Int.zero) tv. + eval_expr tge (Vptr sp Ptrofs.zero) te tm (var_addr cenv id) tv + /\ Val.inject f (Vptr b Ptrofs.zero) tv. Proof. unfold var_addr; intros. assert (match_var f sp e!id cenv!id). inv H. inv MENV. auto. inv H1; inv H0; try congruence. (* local *) - exists (Vptr sp (Int.repr ofs)); split. - constructor. simpl. rewrite Int.add_zero_l; auto. + exists (Vptr sp (Ptrofs.repr ofs)); split. + constructor. simpl. rewrite Ptrofs.add_zero_l; auto. congruence. (* global *) exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. inv MG. - exists (Vptr b Int.zero); split. - constructor. simpl. rewrite symbols_preserved. rewrite H2. auto. + exists (Vptr b Ptrofs.zero); split. + constructor. simpl. unfold Genv.symbol_address. + rewrite symbols_preserved. rewrite H2. auto. econstructor; eauto. Qed. @@ -1497,7 +1507,7 @@ Lemma transl_expr_correct: forall ta (TR: transl_expr cenv a = OK ta), exists tv, - eval_expr tge (Vptr sp Int.zero) te tm ta tv + eval_expr tge (Vptr sp Ptrofs.zero) te tm ta tv /\ Val.inject f v tv. Proof. induction 3; intros; simpl in TR; try (monadInv TR). @@ -1535,7 +1545,7 @@ Lemma transl_exprlist_correct: forall ta (TR: transl_exprlist cenv a = OK ta), exists tv, - eval_exprlist tge (Vptr sp Int.zero) te tm ta tv + eval_exprlist tge (Vptr sp Ptrofs.zero) te tm ta tv /\ Val.inject_list f v tv. Proof. induction 3; intros; monadInv TR. @@ -1569,7 +1579,7 @@ Inductive match_cont: Csharpminor.cont -> Cminor.cont -> compilenv -> exit_env - transl_funbody cenv sz fn = OK tfn -> match_cont k tk cenv xenv cs -> match_cont (Csharpminor.Kcall optid fn e le k) - (Kcall optid tfn (Vptr sp Int.zero) te tk) + (Kcall optid tfn (Vptr sp Ptrofs.zero) te tk) cenv' nil (Frame cenv tfn e le te sp lo hi :: cs). @@ -1584,7 +1594,7 @@ Inductive match_states: Csharpminor.state -> Cminor.state -> Prop := (Mem.nextblock m) (Mem.nextblock tm)) (MK: match_cont k tk cenv xenv cs), match_states (Csharpminor.State fn s k e le m) - (State tfn ts tk (Vptr sp Int.zero) te tm) + (State tfn ts tk (Vptr sp Ptrofs.zero) te tm) | match_state_seq: forall fn s1 s2 k e le m tfn ts1 tk sp te tm cenv xenv f lo hi cs sz (TRF: transl_funbody cenv sz fn = OK tfn) @@ -1595,7 +1605,7 @@ Inductive match_states: Csharpminor.state -> Cminor.state -> Prop := (Mem.nextblock m) (Mem.nextblock tm)) (MK: match_cont (Csharpminor.Kseq s2 k) tk cenv xenv cs), match_states (Csharpminor.State fn (Csharpminor.Sseq s1 s2) k e le m) - (State tfn ts1 tk (Vptr sp Int.zero) te tm) + (State tfn ts1 tk (Vptr sp Ptrofs.zero) te tm) | match_callstate: forall fd args k m tfd targs tk tm f cs cenv (TR: transl_fundef fd = OK tfd) @@ -1789,7 +1799,7 @@ Lemma switch_match_states: (MK: match_cont k tk cenv xenv cs) (TK: transl_lblstmt_cont cenv xenv ls tk tk'), exists S, - plus step tge (State tfn (Sexit O) tk' (Vptr sp Int.zero) te tm) E0 S + plus step tge (State tfn (Sexit O) tk' (Vptr sp Ptrofs.zero) te tm) E0 S /\ match_states (Csharpminor.State fn (seq_of_lbl_stmt ls) k e le m) S. Proof. intros. inv TK. @@ -2050,7 +2060,7 @@ Opaque PTree.set. (* ifthenelse *) monadInv TR. exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]]. - left; exists (State tfn (if b then x0 else x1) tk (Vptr sp Int.zero) te tm); split. + left; exists (State tfn (if b then x0 else x1) tk (Vptr sp Ptrofs.zero) te tm); split. apply plus_one. eapply step_ifthenelse; eauto. eapply bool_of_val_inject; eauto. econstructor; eauto. destruct b; auto. @@ -2152,7 +2162,7 @@ Opaque PTree.set. (* internal call *) monadInv TR. generalize EQ; clear EQ; unfold transl_function. caseEq (build_compilenv f). intros ce sz BC. - destruct (zle sz Int.max_unsigned); try congruence. + destruct (zle sz Ptrofs.max_unsigned); try congruence. intro TRBODY. generalize TRBODY; intro TMP. monadInv TMP. set (tf := mkfunction (Csharpminor.fn_sig f) diff --git a/cfrontend/Cop.v b/cfrontend/Cop.v index 4ac56b04..c395a2cb 100644 --- a/cfrontend/Cop.v +++ b/cfrontend/Cop.v @@ -22,6 +22,7 @@ Require Import Floats. Require Import Values. Require Import Memory. Require Import Ctypes. +Require Archi. (** * Syntax of operators. *) @@ -72,7 +73,7 @@ Inductive incr_or_decr : Type := Incr | Decr. (** ** Casts and truth values *) Inductive classify_cast_cases : Type := - | cast_case_neutral (**r int|pointer -> int32|pointer *) + | cast_case_pointer (**r between pointer types or intptr_t types *) | cast_case_i2i (sz2:intsize) (si2:signedness) (**r int -> int *) | cast_case_f2f (**r double -> double *) | cast_case_s2s (**r single -> single *) @@ -89,10 +90,10 @@ Inductive classify_cast_cases : Type := | cast_case_l2s (si1: signedness) (**r long -> single *) | cast_case_f2l (si2:signedness) (**r double -> long *) | cast_case_s2l (si2:signedness) (**r single -> long *) + | cast_case_i2bool (**r int -> bool *) + | cast_case_l2bool (**r long -> bool *) | cast_case_f2bool (**r double -> bool *) | cast_case_s2bool (**r single -> bool *) - | cast_case_l2bool (**r long -> bool *) - | cast_case_p2bool (**r pointer -> bool *) | cast_case_struct (id1 id2: ident) (**r struct -> struct *) | cast_case_union (id1 id2: ident) (**r union -> union *) | cast_case_void (**r any -> void *) @@ -100,33 +101,54 @@ Inductive classify_cast_cases : Type := Definition classify_cast (tfrom tto: type) : classify_cast_cases := match tto, tfrom with - | Tint I32 si2 _, (Tint _ _ _ | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) => cast_case_neutral + (* To [void] *) + | Tvoid, _ => cast_case_void + (* To [_Bool] *) + | Tint IBool _ _, Tint _ _ _ => cast_case_i2bool + | Tint IBool _ _, Tlong _ _ => cast_case_l2bool | Tint IBool _ _, Tfloat F64 _ => cast_case_f2bool | Tint IBool _ _, Tfloat F32 _ => cast_case_s2bool - | Tint IBool _ _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) => cast_case_p2bool - | Tint sz2 si2 _, Tint sz1 si1 _ => cast_case_i2i sz2 si2 + | Tint IBool _ _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) => + if Archi.ptr64 then cast_case_l2bool else cast_case_i2bool + (* To [int] other than [_Bool] *) + | Tint sz2 si2 _, Tint _ _ _ => + if Archi.ptr64 then cast_case_i2i sz2 si2 + else if intsize_eq sz2 I32 then cast_case_pointer + else cast_case_i2i sz2 si2 + | Tint sz2 si2 _, Tlong _ _ => cast_case_l2i sz2 si2 | Tint sz2 si2 _, Tfloat F64 _ => cast_case_f2i sz2 si2 | Tint sz2 si2 _, Tfloat F32 _ => cast_case_s2i sz2 si2 - | Tfloat F64 _, Tfloat F64 _ => cast_case_f2f - | Tfloat F32 _, Tfloat F32 _ => cast_case_s2s - | Tfloat F64 _, Tfloat F32 _ => cast_case_s2f - | Tfloat F32 _, Tfloat F64 _ => cast_case_f2s - | Tfloat F64 _, Tint sz1 si1 _ => cast_case_i2f si1 - | Tfloat F32 _, Tint sz1 si1 _ => cast_case_i2s si1 - | Tpointer _ _, (Tint _ _ _ | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) => cast_case_neutral - | Tlong _ _, Tlong _ _ => cast_case_l2l + | Tint sz2 si2 _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) => + if Archi.ptr64 then cast_case_l2i sz2 si2 + else if intsize_eq sz2 I32 then cast_case_pointer + else cast_case_i2i sz2 si2 + (* To [long] *) + | Tlong _ _, Tlong _ _ => + if Archi.ptr64 then cast_case_pointer else cast_case_l2l | Tlong _ _, Tint sz1 si1 _ => cast_case_i2l si1 - | Tint IBool _ _, Tlong _ _ => cast_case_l2bool - | Tint sz2 si2 _, Tlong _ _ => cast_case_l2i sz2 si2 | Tlong si2 _, Tfloat F64 _ => cast_case_f2l si2 | Tlong si2 _, Tfloat F32 _ => cast_case_s2l si2 + | Tlong si2 _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) => + if Archi.ptr64 then cast_case_pointer else cast_case_i2l si2 + (* To [float] *) + | Tfloat F64 _, Tint sz1 si1 _ => cast_case_i2f si1 + | Tfloat F32 _, Tint sz1 si1 _ => cast_case_i2s si1 | Tfloat F64 _, Tlong si1 _ => cast_case_l2f si1 | Tfloat F32 _, Tlong si1 _ => cast_case_l2s si1 - | Tpointer _ _, Tlong _ _ => cast_case_l2i I32 Unsigned - | Tlong si2 _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) => cast_case_i2l si2 + | Tfloat F64 _, Tfloat F64 _ => cast_case_f2f + | Tfloat F32 _, Tfloat F32 _ => cast_case_s2s + | Tfloat F64 _, Tfloat F32 _ => cast_case_s2f + | Tfloat F32 _, Tfloat F64 _ => cast_case_f2s + (* To pointer types *) + | Tpointer _ _, Tint _ _ _ => + if Archi.ptr64 then cast_case_i2l Unsigned else cast_case_pointer + | Tpointer _ _, Tlong _ _ => + if Archi.ptr64 then cast_case_pointer else cast_case_l2i I32 Unsigned + | Tpointer _ _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) => cast_case_pointer + (* To struct or union types *) | Tstruct id2 _, Tstruct id1 _ => cast_case_struct id1 id2 | Tunion id2 _, Tunion id1 _ => cast_case_union id1 id2 - | Tvoid, _ => cast_case_void + (* Catch-all *) | _, _ => cast_case_default end. @@ -200,9 +222,11 @@ Definition cast_single_long (si : signedness) (f: float32) : option int64 := Definition sem_cast (v: val) (t1 t2: type) (m: mem): option val := match classify_cast t1 t2 with - | cast_case_neutral => + | cast_case_pointer => match v with - | Vint _ | Vptr _ _ => Some v + | Vptr _ _ => Some v + | Vint _ => if Archi.ptr64 then None else Some v + | Vlong _ => if Archi.ptr64 then Some v else None | _ => None end | cast_case_i2i sz2 si2 => @@ -258,6 +282,25 @@ Definition sem_cast (v: val) (t1 t2: type) (m: mem): option val := end | _ => None end + | cast_case_i2bool => + match v with + | Vint n => + Some(Vint(if Int.eq n Int.zero then Int.zero else Int.one)) + | Vptr b ofs => + if Archi.ptr64 then None else + if Mem.weak_valid_pointer m b (Ptrofs.unsigned ofs) then Some Vone else None + | _ => None + end + | cast_case_l2bool => + match v with + | Vlong n => + Some(Vint(if Int64.eq n Int64.zero then Int.zero else Int.one)) + | Vptr b ofs => + if negb Archi.ptr64 then None else + if Mem.weak_valid_pointer m b (Ptrofs.unsigned ofs) then Some Vone else None + + | _ => None + end | cast_case_f2bool => match v with | Vfloat f => @@ -270,12 +313,6 @@ Definition sem_cast (v: val) (t1 t2: type) (m: mem): option val := Some(Vint(if Float32.cmp Ceq f Float32.zero then Int.zero else Int.one)) | _ => None end - | cast_case_p2bool => - match v with - | Vint i => Some (Vint (cast_int_int IBool Signed i)) - | Vptr b ofs => if Mem.weak_valid_pointer m b (Int.unsigned ofs) then Some Vone else None - | _ => None - end | cast_case_l2l => match v with | Vlong n => Some (Vlong n) @@ -291,12 +328,6 @@ Definition sem_cast (v: val) (t1 t2: type) (m: mem): option val := | Vlong n => Some(Vint (cast_int_int sz si (Int.repr (Int64.unsigned n)))) | _ => None end - | cast_case_l2bool => - match v with - | Vlong n => - Some(Vint(if Int64.eq n Int64.zero then Int.zero else Int.one)) - | _ => None - end | cast_case_l2f si1 => match v with | Vlong i => Some (Vfloat (cast_long_float si1 i)) @@ -350,16 +381,15 @@ Definition sem_cast (v: val) (t1 t2: type) (m: mem): option val := Inductive classify_bool_cases : Type := | bool_case_i (**r integer *) + | bool_case_l (**r long *) | bool_case_f (**r double float *) | bool_case_s (**r single float *) - | bool_case_p (**r pointer *) - | bool_case_l (**r long *) | bool_default. Definition classify_bool (ty: type) : classify_bool_cases := match typeconv ty with | Tint _ _ _ => bool_case_i - | Tpointer _ _ => bool_case_p + | Tpointer _ _ => if Archi.ptr64 then bool_case_l else bool_case_i | Tfloat F64 _ => bool_case_f | Tfloat F32 _ => bool_case_s | Tlong _ _ => bool_case_l @@ -376,6 +406,17 @@ Definition bool_val (v: val) (t: type) (m: mem) : option bool := | bool_case_i => match v with | Vint n => Some (negb (Int.eq n Int.zero)) + | Vptr b ofs => + if Archi.ptr64 then None else + if Mem.weak_valid_pointer m b (Ptrofs.unsigned ofs) then Some true else None + | _ => None + end + | bool_case_l => + match v with + | Vlong n => Some (negb (Int64.eq n Int64.zero)) + | Vptr b ofs => + if negb Archi.ptr64 then None else + if Mem.weak_valid_pointer m b (Ptrofs.unsigned ofs) then Some true else None | _ => None end | bool_case_f => @@ -388,17 +429,6 @@ Definition bool_val (v: val) (t: type) (m: mem) : option bool := | Vsingle f => Some (negb (Float32.cmp Ceq f Float32.zero)) | _ => None end - | bool_case_p => - match v with - | Vint n => Some (negb (Int.eq n Int.zero)) - | Vptr b ofs => if Mem.weak_valid_pointer m b (Int.unsigned ofs) then Some true else None - | _ => None - end - | bool_case_l => - match v with - | Vlong n => Some (negb (Int64.eq n Int64.zero)) - | _ => None - end | bool_default => None end. @@ -407,35 +437,7 @@ Definition bool_val (v: val) (t: type) (m: mem) : option bool := (** *** Boolean negation *) Definition sem_notbool (v: val) (ty: type) (m: mem): option val := - match classify_bool ty with - | bool_case_i => - match v with - | Vint n => Some (Val.of_bool (Int.eq n Int.zero)) - | _ => None - end - | bool_case_f => - match v with - | Vfloat f => Some (Val.of_bool (Float.cmp Ceq f Float.zero)) - | _ => None - end - | bool_case_s => - match v with - | Vsingle f => Some (Val.of_bool (Float32.cmp Ceq f Float32.zero)) - | _ => None - end - | bool_case_p => - match v with - | Vint n => Some (Val.of_bool (Int.eq n Int.zero)) - | Vptr b ofs => if Mem.weak_valid_pointer m b (Int.unsigned ofs) then Some Vfalse else None - | _ => None - end - | bool_case_l => - match v with - | Vlong n => Some (Val.of_bool (Int64.eq n Int64.zero)) - | _ => None - end - | bool_default => None - end. + option_map (fun b => Val.of_bool (negb b)) (bool_val v ty m). (** *** Opposite and absolute value *) @@ -623,59 +625,63 @@ Definition sem_binarith (** *** Addition *) Inductive classify_add_cases : Type := - | add_case_pi(ty: type) (**r pointer, int *) - | add_case_ip(ty: type) (**r int, pointer *) - | add_case_pl(ty: type) (**r pointer, long *) - | add_case_lp(ty: type) (**r long, pointer *) - | add_default. (**r numerical type, numerical type *) + | add_case_pi (ty: type) (si: signedness) (**r pointer, int *) + | add_case_pl (ty: type) (**r pointer, long *) + | add_case_ip (si: signedness) (ty: type) (**r int, pointer *) + | add_case_lp (ty: type) (**r long, pointer *) + | add_default. (**r numerical type, numerical type *) Definition classify_add (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tpointer ty _, Tint _ _ _ => add_case_pi ty - | Tint _ _ _, Tpointer ty _ => add_case_ip ty + | Tpointer ty _, Tint _ si _ => add_case_pi ty si | Tpointer ty _, Tlong _ _ => add_case_pl ty + | Tint _ si _, Tpointer ty _ => add_case_ip si ty | Tlong _ _, Tpointer ty _ => add_case_lp ty | _, _ => add_default end. +Definition ptrofs_of_int (si: signedness) (n: int) : ptrofs := + match si with + | Signed => Ptrofs.of_ints n + | Unsigned => Ptrofs.of_intu n + end. + +Definition sem_add_ptr_int (cenv: composite_env) (ty: type) (si: signedness) (v1 v2: val): option val := + match v1, v2 with + | Vptr b1 ofs1, Vint n2 => + let n2 := ptrofs_of_int si n2 in + Some (Vptr b1 (Ptrofs.add ofs1 (Ptrofs.mul (Ptrofs.repr (sizeof cenv ty)) n2))) + | Vint n1, Vint n2 => + if Archi.ptr64 then None else Some (Vint (Int.add n1 (Int.mul (Int.repr (sizeof cenv ty)) n2))) + | Vlong n1, Vint n2 => + let n2 := cast_int_long si n2 in + if Archi.ptr64 then Some (Vlong (Int64.add n1 (Int64.mul (Int64.repr (sizeof cenv ty)) n2))) else None + | _, _ => None + end. + +Definition sem_add_ptr_long (cenv: composite_env) (ty: type) (v1 v2: val): option val := + match v1, v2 with + | Vptr b1 ofs1, Vlong n2 => + let n2 := Ptrofs.of_int64 n2 in + Some (Vptr b1 (Ptrofs.add ofs1 (Ptrofs.mul (Ptrofs.repr (sizeof cenv ty)) n2))) + | Vint n1, Vlong n2 => + let n2 := Int.repr (Int64.unsigned n2) in + if Archi.ptr64 then None else Some (Vint (Int.add n1 (Int.mul (Int.repr (sizeof cenv ty)) n2))) + | Vlong n1, Vlong n2 => + if Archi.ptr64 then Some (Vlong (Int64.add n1 (Int64.mul (Int64.repr (sizeof cenv ty)) n2))) else None + | _, _ => None + end. + Definition sem_add (cenv: composite_env) (v1:val) (t1:type) (v2: val) (t2:type) (m: mem): option val := match classify_add t1 t2 with - | add_case_pi ty => (**r pointer plus integer *) - match v1,v2 with - | Vptr b1 ofs1, Vint n2 => - Some (Vptr b1 (Int.add ofs1 (Int.mul (Int.repr (sizeof cenv ty)) n2))) - | Vint n1, Vint n2 => - Some (Vint (Int.add n1 (Int.mul (Int.repr (sizeof cenv ty)) n2))) - | _, _ => None - end - | add_case_ip ty => (**r integer plus pointer *) - match v1,v2 with - | Vint n1, Vptr b2 ofs2 => - Some (Vptr b2 (Int.add ofs2 (Int.mul (Int.repr (sizeof cenv ty)) n1))) - | Vint n1, Vint n2 => - Some (Vint (Int.add n2 (Int.mul (Int.repr (sizeof cenv ty)) n1))) - | _, _ => None - end - | add_case_pl ty => (**r pointer plus long *) - match v1,v2 with - | Vptr b1 ofs1, Vlong n2 => - let n2 := Int.repr (Int64.unsigned n2) in - Some (Vptr b1 (Int.add ofs1 (Int.mul (Int.repr (sizeof cenv ty)) n2))) - | Vint n1, Vlong n2 => - let n2 := Int.repr (Int64.unsigned n2) in - Some (Vint (Int.add n1 (Int.mul (Int.repr (sizeof cenv ty)) n2))) - | _, _ => None - end - | add_case_lp ty => (**r long plus pointer *) - match v1,v2 with - | Vlong n1, Vptr b2 ofs2 => - let n1 := Int.repr (Int64.unsigned n1) in - Some (Vptr b2 (Int.add ofs2 (Int.mul (Int.repr (sizeof cenv ty)) n1))) - | Vlong n1, Vint n2 => - let n1 := Int.repr (Int64.unsigned n1) in - Some (Vint (Int.add n2 (Int.mul (Int.repr (sizeof cenv ty)) n1))) - | _, _ => None - end + | add_case_pi ty si => (**r pointer plus integer *) + sem_add_ptr_int cenv ty si v1 v2 + | add_case_pl ty => (**r pointer plus long *) + sem_add_ptr_long cenv ty v1 v2 + | add_case_ip si ty => (**r integer plus pointer *) + sem_add_ptr_int cenv ty si v2 v1 + | add_case_lp ty => (**r long plus pointer *) + sem_add_ptr_long cenv ty v2 v1 | add_default => sem_binarith (fun sg n1 n2 => Some(Vint(Int.add n1 n2))) @@ -688,14 +694,14 @@ Definition sem_add (cenv: composite_env) (v1:val) (t1:type) (v2: val) (t2:type) (** *** Subtraction *) Inductive classify_sub_cases : Type := - | sub_case_pi(ty: type) (**r pointer, int *) - | sub_case_pp(ty: type) (**r pointer, pointer *) - | sub_case_pl(ty: type) (**r pointer, long *) - | sub_default. (**r numerical type, numerical type *) + | sub_case_pi (ty: type) (si: signedness) (**r pointer, int *) + | sub_case_pp (ty: type) (**r pointer, pointer *) + | sub_case_pl (ty: type) (**r pointer, long *) + | sub_default. (**r numerical type, numerical type *) Definition classify_sub (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tpointer ty _, Tint _ _ _ => sub_case_pi ty + | Tpointer ty _, Tint _ si _ => sub_case_pi ty si | Tpointer ty _ , Tpointer _ _ => sub_case_pp ty | Tpointer ty _, Tlong _ _ => sub_case_pl ty | _, _ => sub_default @@ -703,22 +709,28 @@ Definition classify_sub (ty1: type) (ty2: type) := Definition sem_sub (cenv: composite_env) (v1:val) (t1:type) (v2: val) (t2:type) (m:mem): option val := match classify_sub t1 t2 with - | sub_case_pi ty => (**r pointer minus integer *) - match v1,v2 with + | sub_case_pi ty si => (**r pointer minus integer *) + match v1, v2 with | Vptr b1 ofs1, Vint n2 => - Some (Vptr b1 (Int.sub ofs1 (Int.mul (Int.repr (sizeof cenv ty)) n2))) + let n2 := ptrofs_of_int si n2 in + Some (Vptr b1 (Ptrofs.sub ofs1 (Ptrofs.mul (Ptrofs.repr (sizeof cenv ty)) n2))) | Vint n1, Vint n2 => - Some (Vint (Int.sub n1 (Int.mul (Int.repr (sizeof cenv ty)) n2))) + if Archi.ptr64 then None else Some (Vint (Int.sub n1 (Int.mul (Int.repr (sizeof cenv ty)) n2))) + | Vlong n1, Vint n2 => + let n2 := cast_int_long si n2 in + if Archi.ptr64 then Some (Vlong (Int64.sub n1 (Int64.mul (Int64.repr (sizeof cenv ty)) n2))) else None | _, _ => None end | sub_case_pl ty => (**r pointer minus long *) - match v1,v2 with + match v1, v2 with | Vptr b1 ofs1, Vlong n2 => - let n2 := Int.repr (Int64.unsigned n2) in - Some (Vptr b1 (Int.sub ofs1 (Int.mul (Int.repr (sizeof cenv ty)) n2))) + let n2 := Ptrofs.of_int64 n2 in + Some (Vptr b1 (Ptrofs.sub ofs1 (Ptrofs.mul (Ptrofs.repr (sizeof cenv ty)) n2))) | Vint n1, Vlong n2 => let n2 := Int.repr (Int64.unsigned n2) in - Some (Vint (Int.sub n1 (Int.mul (Int.repr (sizeof cenv ty)) n2))) + if Archi.ptr64 then None else Some (Vint (Int.sub n1 (Int.mul (Int.repr (sizeof cenv ty)) n2))) + | Vlong n1, Vlong n2 => + if Archi.ptr64 then Some (Vlong (Int64.sub n1 (Int64.mul (Int64.repr (sizeof cenv ty)) n2))) else None | _, _ => None end | sub_case_pp ty => (**r pointer minus pointer *) @@ -726,8 +738,8 @@ Definition sem_sub (cenv: composite_env) (v1:val) (t1:type) (v2: val) (t2:type) | Vptr b1 ofs1, Vptr b2 ofs2 => if eq_block b1 b2 then let sz := sizeof cenv ty in - if zlt 0 sz && zle sz Int.max_signed - then Some (Vint (Int.divs (Int.sub ofs1 ofs2) (Int.repr sz))) + if zlt 0 sz && zle sz Ptrofs.max_signed + then Some (Vptrofs (Ptrofs.divs (Ptrofs.sub ofs1 ofs2) (Ptrofs.repr sz))) else None else None | _, _ => None @@ -903,6 +915,8 @@ Definition sem_shr (v1:val) (t1:type) (v2: val) (t2:type) : option val := Inductive classify_cmp_cases : Type := | cmp_case_pp (**r pointer, pointer *) + | cmp_case_pi (si: signedness) (**r pointer, int *) + | cmp_case_ip (si: signedness) (**r int, pointer *) | cmp_case_pl (**r pointer, long *) | cmp_case_lp (**r long, pointer *) | cmp_default. (**r numerical, numerical *) @@ -910,32 +924,64 @@ Inductive classify_cmp_cases : Type := Definition classify_cmp (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with | Tpointer _ _ , Tpointer _ _ => cmp_case_pp - | Tpointer _ _ , Tint _ _ _ => cmp_case_pp - | Tint _ _ _, Tpointer _ _ => cmp_case_pp + | Tpointer _ _ , Tint _ si _ => cmp_case_pi si + | Tint _ si _, Tpointer _ _ => cmp_case_ip si | Tpointer _ _ , Tlong _ _ => cmp_case_pl | Tlong _ _ , Tpointer _ _ => cmp_case_lp | _, _ => cmp_default end. +Definition cmp_ptr (m: mem) (c: comparison) (v1 v2: val): option val := + option_map Val.of_bool + (if Archi.ptr64 + then Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 + else Val.cmpu_bool (Mem.valid_pointer m) c v1 v2). + Definition sem_cmp (c:comparison) (v1: val) (t1: type) (v2: val) (t2: type) (m: mem): option val := match classify_cmp t1 t2 with | cmp_case_pp => - option_map Val.of_bool (Val.cmpu_bool (Mem.valid_pointer m) c v1 v2) + cmp_ptr m c v1 v2 + | cmp_case_pi si => + match v2 with + | Vint n2 => + let v2' := Vptrofs (ptrofs_of_int si n2) in + cmp_ptr m c v1 v2' + | Vptr b ofs => + if Archi.ptr64 then None else cmp_ptr m c v1 v2 + | _ => + None + end + | cmp_case_ip si => + match v1 with + | Vint n1 => + let v1' := Vptrofs (ptrofs_of_int si n1) in + cmp_ptr m c v1' v2 + | Vptr b ofs => + if Archi.ptr64 then None else cmp_ptr m c v1 v2 + | _ => + None + end | cmp_case_pl => match v2 with | Vlong n2 => - let n2 := Int.repr (Int64.unsigned n2) in - option_map Val.of_bool (Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n2)) - | _ => None + let v2' := Vptrofs (Ptrofs.of_int64 n2) in + cmp_ptr m c v1 v2' + | Vptr b ofs => + if Archi.ptr64 then cmp_ptr m c v1 v2 else None + | _ => + None end | cmp_case_lp => match v1 with | Vlong n1 => - let n1 := Int.repr (Int64.unsigned n1) in - option_map Val.of_bool (Val.cmpu_bool (Mem.valid_pointer m) c (Vint n1) v2) - | _ => None + let v1' := Vptrofs (Ptrofs.of_int64 n1) in + cmp_ptr m c v1' v2 + | Vptr b ofs => + if Archi.ptr64 then cmp_ptr m c v1 v2 else None + | _ => + None end | cmp_default => sem_binarith @@ -1047,30 +1093,30 @@ Variables m m': mem. Hypothesis valid_pointer_inj: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - Mem.valid_pointer m b1 (Int.unsigned ofs) = true -> - Mem.valid_pointer m' b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + Mem.valid_pointer m b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m' b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Hypothesis weak_valid_pointer_inj: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m b1 (Int.unsigned ofs) = true -> - Mem.weak_valid_pointer m' b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + Mem.weak_valid_pointer m b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m' b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Hypothesis weak_valid_pointer_no_overflow: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m b1 (Int.unsigned ofs) = true -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + Mem.weak_valid_pointer m b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. Hypothesis valid_different_pointers_inj: forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, b1 <> b2 -> - Mem.valid_pointer m b1 (Int.unsigned ofs1) = true -> - Mem.valid_pointer m b2 (Int.unsigned ofs2) = true -> + Mem.valid_pointer m b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m b2 (Ptrofs.unsigned ofs2) = true -> f b1 = Some (b1', delta1) -> f b2 = Some (b2', delta2) -> b1' <> b2' \/ - Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)). + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). Remark val_inject_vtrue: forall f, Val.inject f Vtrue Vtrue. Proof. unfold Vtrue; auto. Qed. @@ -1082,11 +1128,18 @@ Remark val_inject_of_bool: forall f b, Val.inject f (Val.of_bool b) (Val.of_bool Proof. intros. unfold Val.of_bool. destruct b; [apply val_inject_vtrue|apply val_inject_vfalse]. Qed. -Hint Resolve val_inject_vtrue val_inject_vfalse val_inject_of_bool. +Remark val_inject_vptrofs: forall n, Val.inject f (Vptrofs n) (Vptrofs n). +Proof. intros. unfold Vptrofs. destruct Archi.ptr64; auto. Qed. + +Hint Resolve val_inject_vtrue val_inject_vfalse val_inject_of_bool val_inject_vptrofs. Ltac TrivialInject := match goal with - | |- exists v', Some ?v = Some v' /\ _ => exists v; split; auto + | [ H: None = Some _ |- _ ] => discriminate + | [ H: Some _ = Some _ |- _ ] => inv H; TrivialInject + | [ H: match ?x with Some _ => _ | None => _ end = Some _ |- _ ] => destruct x; TrivialInject + | [ H: match ?x with true => _ | false => _ end = Some _ |- _ ] => destruct x eqn:?; TrivialInject + | [ |- exists v', Some ?v = Some v' /\ _ ] => exists v; split; auto | _ => idtac end. @@ -1096,20 +1149,31 @@ Lemma sem_cast_inj: Val.inject f v1 tv1 -> exists tv, sem_cast tv1 ty1 ty m'= Some tv /\ Val.inject f v tv. Proof. - unfold sem_cast; intros; destruct (classify_cast ty1 ty); - inv H0; inv H; TrivialInject. + unfold sem_cast; intros; destruct (classify_cast ty1 ty); inv H0; TrivialInject. - econstructor; eauto. -- destruct (cast_float_int si2 f0); inv H1; TrivialInject. -- destruct (cast_single_int si2 f0); inv H1; TrivialInject. -- destruct (cast_float_long si2 f0); inv H1; TrivialInject. -- destruct (cast_single_long si2 f0); inv H1; TrivialInject. -- destruct (Mem.weak_valid_pointer m b1 (Int.unsigned ofs1)) eqn:VALID; inv H2. - erewrite weak_valid_pointer_inj by eauto. TrivialInject. -- destruct (ident_eq id1 id2); inv H2; TrivialInject. econstructor; eauto. -- destruct (ident_eq id1 id2); inv H2; TrivialInject. econstructor; eauto. +- erewrite weak_valid_pointer_inj by eauto. TrivialInject. +- erewrite weak_valid_pointer_inj by eauto. TrivialInject. +- destruct (ident_eq id1 id2); TrivialInject. econstructor; eauto. +- destruct (ident_eq id1 id2); TrivialInject. econstructor; eauto. - econstructor; eauto. Qed. +Lemma bool_val_inj: + forall v ty b tv, + bool_val v ty m = Some b -> + Val.inject f v tv -> + bool_val tv ty m' = Some b. +Proof. + unfold bool_val; intros. + destruct (classify_bool ty); inv H0; try congruence. + destruct Archi.ptr64; try discriminate. + destruct (Mem.weak_valid_pointer m b1 (Ptrofs.unsigned ofs1)) eqn:VP; inv H. + erewrite weak_valid_pointer_inj by eauto. auto. + destruct Archi.ptr64; try discriminate. + destruct (Mem.weak_valid_pointer m b1 (Ptrofs.unsigned ofs1)) eqn:VP; inv H. + erewrite weak_valid_pointer_inj by eauto. auto. +Qed. + Lemma sem_unary_operation_inj: forall op v1 ty v tv1, sem_unary_operation op v1 ty m = Some v -> @@ -1117,15 +1181,14 @@ Lemma sem_unary_operation_inj: exists tv, sem_unary_operation op tv1 ty m' = Some tv /\ Val.inject f v tv. Proof. unfold sem_unary_operation; intros. destruct op. - (* notbool *) - unfold sem_notbool in *; destruct (classify_bool ty); inv H0; inv H; TrivialInject. - destruct (Mem.weak_valid_pointer m b1 (Int.unsigned ofs1)) eqn:VP; inv H2. - erewrite weak_valid_pointer_inj by eauto. TrivialInject. - (* notint *) +- (* notbool *) + unfold sem_notbool in *. destruct (bool_val v1 ty m) as [b|] eqn:BV; simpl in H; inv H. + erewrite bool_val_inj by eauto. simpl. TrivialInject. +- (* notint *) unfold sem_notint in *; destruct (classify_notint ty); inv H0; inv H; TrivialInject. - (* neg *) +- (* neg *) unfold sem_neg in *; destruct (classify_neg ty); inv H0; inv H; TrivialInject. - (* absfloat *) +- (* absfloat *) unfold sem_absfloat in *; destruct (classify_neg ty); inv H0; inv H; TrivialInject. Qed. @@ -1175,6 +1238,24 @@ Proof. destruct (Int.ltu i0 Int64.iwordsize'); inv H; auto. Qed. +Remark sem_cmp_ptr_inj: + forall c v1 v2 v tv1 tv2, + cmp_ptr m c v1 v2 = Some v -> + Val.inject f v1 tv1 -> + Val.inject f v2 tv2 -> + exists tv, cmp_ptr m' c tv1 tv2 = Some tv /\ Val.inject f v tv. +Proof. + unfold cmp_ptr; intros. + remember (if Archi.ptr64 + then Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 + else Val.cmpu_bool (Mem.valid_pointer m) c v1 v2) as ob. + destruct ob as [b|]; simpl in H; inv H. + exists (Val.of_bool b); split; auto. + destruct Archi.ptr64. + erewrite Val.cmplu_bool_inject by eauto. auto. + erewrite Val.cmpu_bool_inject by eauto. auto. +Qed. + Remark sem_cmp_inj: forall cmp v1 tv1 ty1 v2 tv2 ty2 v, sem_cmp cmp v1 ty1 v2 ty2 m = Some v -> @@ -1185,24 +1266,15 @@ Proof. intros. unfold sem_cmp in *; destruct (classify_cmp ty1 ty2). - (* pointer - pointer *) - destruct (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) as [b|] eqn:E; simpl in H; inv H. - replace (Val.cmpu_bool (Mem.valid_pointer m') cmp tv1 tv2) with (Some b). - simpl. TrivialInject. - symmetry. eapply Val.cmpu_bool_inject; eauto. + eapply sem_cmp_ptr_inj; eauto. +- (* pointer - int *) + inversion H1; subst; TrivialInject; eapply sem_cmp_ptr_inj; eauto. +- (* int - pointer *) + inversion H0; subst; TrivialInject; eapply sem_cmp_ptr_inj; eauto. - (* pointer - long *) - destruct v2; try discriminate. inv H1. - set (v2 := Vint (Int.repr (Int64.unsigned i))) in *. - destruct (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) as [b|] eqn:E; simpl in H; inv H. - replace (Val.cmpu_bool (Mem.valid_pointer m') cmp tv1 v2) with (Some b). - simpl. TrivialInject. - symmetry. eapply Val.cmpu_bool_inject with (v2 := v2); eauto. constructor. + inversion H1; subst; TrivialInject; eapply sem_cmp_ptr_inj; eauto. - (* long - pointer *) - destruct v1; try discriminate. inv H0. - set (v1 := Vint (Int.repr (Int64.unsigned i))) in *. - destruct (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) as [b|] eqn:E; simpl in H; inv H. - replace (Val.cmpu_bool (Mem.valid_pointer m') cmp v1 tv2) with (Some b). - simpl. TrivialInject. - symmetry. eapply Val.cmpu_bool_inject with (v1 := v1); eauto. constructor. + inversion H0; subst; TrivialInject; eapply sem_cmp_ptr_inj; eauto. - (* numerical - numerical *) assert (SELF: forall b, optval_self_injects (Some (Val.of_bool b))). { @@ -1219,27 +1291,31 @@ Lemma sem_binary_operation_inj: Proof. unfold sem_binary_operation; intros; destruct op. - (* add *) - unfold sem_add in *; destruct (classify_add ty1 ty2). - + inv H0; inv H1; inv H. TrivialInject. TrivialInject. - econstructor. eauto. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - + inv H0; inv H1; inv H. TrivialInject. TrivialInject. - econstructor. eauto. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - + inv H0; inv H1; inv H. TrivialInject. TrivialInject. - econstructor. eauto. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - + inv H0; inv H1; inv H. TrivialInject. TrivialInject. - econstructor. eauto. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + assert (A: forall cenv ty si v1' v2' tv1' tv2', + Val.inject f v1' tv1' -> Val.inject f v2' tv2' -> + sem_add_ptr_int cenv ty si v1' v2' = Some v -> + exists tv, sem_add_ptr_int cenv ty si tv1' tv2' = Some tv /\ Val.inject f v tv). + { intros. unfold sem_add_ptr_int in *; inv H2; inv H3; TrivialInject. + econstructor. eauto. repeat rewrite Ptrofs.add_assoc. decEq. apply Ptrofs.add_commut. } + assert (B: forall cenv ty v1' v2' tv1' tv2', + Val.inject f v1' tv1' -> Val.inject f v2' tv2' -> + sem_add_ptr_long cenv ty v1' v2' = Some v -> + exists tv, sem_add_ptr_long cenv ty tv1' tv2' = Some tv /\ Val.inject f v tv). + { intros. unfold sem_add_ptr_long in *; inv H2; inv H3; TrivialInject. + econstructor. eauto. repeat rewrite Ptrofs.add_assoc. decEq. apply Ptrofs.add_commut. } + unfold sem_add in *; destruct (classify_add ty1 ty2); eauto. + eapply sem_binarith_inject; eauto; intros; exact I. - (* sub *) unfold sem_sub in *; destruct (classify_sub ty1 ty2). - + inv H0; inv H1; inv H. TrivialInject. TrivialInject. - econstructor. eauto. rewrite Int.sub_add_l. auto. - + inv H0; inv H1; inv H. TrivialInject. + + inv H0; inv H1; TrivialInject. + econstructor. eauto. rewrite Ptrofs.sub_add_l. auto. + + inv H0; inv H1; TrivialInject. destruct (eq_block b1 b0); try discriminate. subst b1. rewrite H0 in H2; inv H2. rewrite dec_eq_true. - destruct (zlt 0 (sizeof cenv ty) && zle (sizeof cenv ty) Int.max_signed); inv H3. - rewrite Int.sub_shifted. TrivialInject. - + inv H0; inv H1; inv H. TrivialInject. TrivialInject. - econstructor. eauto. rewrite Int.sub_add_l. auto. + destruct (zlt 0 (sizeof cenv ty) && zle (sizeof cenv ty) Ptrofs.max_signed); inv H. + rewrite Ptrofs.sub_shifted. TrivialInject. + + inv H0; inv H1; TrivialInject. + econstructor. eauto. rewrite Ptrofs.sub_add_l. auto. + eapply sem_binarith_inject; eauto; intros; exact I. - (* mul *) eapply sem_binarith_inject; eauto; intros; exact I. @@ -1286,18 +1362,6 @@ Proof. - eapply sem_cmp_inj; eauto. Qed. -Lemma bool_val_inj: - forall v ty b tv, - bool_val v ty m = Some b -> - Val.inject f v tv -> - bool_val tv ty m' = Some b. -Proof. - unfold bool_val; intros. - destruct (classify_bool ty); inv H0; try congruence. - destruct (Mem.weak_valid_pointer m b1 (Int.unsigned ofs1)) eqn:VP; inv H. - erewrite weak_valid_pointer_inj by eauto. auto. -Qed. - End GENERIC_INJECTION. Lemma sem_cast_inject: @@ -1364,7 +1428,7 @@ Lemma cast_bool_bool_val: assert (A: classify_bool t = match t with | Tint _ _ _ => bool_case_i - | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _ => bool_case_p + | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _ => if Archi.ptr64 then bool_case_l else bool_case_i | Tfloat F64 _ => bool_case_f | Tfloat F32 _ => bool_case_s | Tlong _ _ => bool_case_l @@ -1373,9 +1437,12 @@ Lemma cast_bool_bool_val: { unfold classify_bool; destruct t; simpl; auto. destruct i; auto. } - unfold bool_val. rewrite A. unfold sem_cast. destruct t; simpl; auto; destruct v; auto. + unfold bool_val. rewrite A. + unfold sem_cast, classify_cast; remember Archi.ptr64 as ptr64; destruct t; simpl; auto; destruct v; auto. destruct (Int.eq i0 Int.zero); auto. + destruct ptr64; auto. destruct (Mem.weak_valid_pointer m b (Ptrofs.unsigned i0)); auto. destruct (Int64.eq i Int64.zero); auto. + destruct (negb ptr64); auto. destruct (Mem.weak_valid_pointer m b (Ptrofs.unsigned i)); auto. destruct f; auto. destruct f; auto. destruct f; auto. @@ -1383,13 +1450,30 @@ Lemma cast_bool_bool_val: destruct (Float.cmp Ceq f0 Float.zero); auto. destruct f; auto. destruct (Float32.cmp Ceq f0 Float32.zero); auto. - destruct f; auto. - destruct (Int.eq i Int.zero); auto. - destruct (Mem.weak_valid_pointer m b (Int.unsigned i)); auto. - destruct (Int.eq i Int.zero); auto. - destruct (Mem.weak_valid_pointer m b (Int.unsigned i)); auto. + destruct f; auto. + destruct ptr64; auto. destruct (Int.eq i Int.zero); auto. - destruct (Mem.weak_valid_pointer m b (Int.unsigned i)); auto. + destruct ptr64; auto. + destruct ptr64; auto. + destruct ptr64; auto. destruct (Int64.eq i Int64.zero); auto. + destruct ptr64; auto. + destruct ptr64; auto. + destruct ptr64; auto. destruct (Mem.weak_valid_pointer m b (Ptrofs.unsigned i)); auto. + destruct (Mem.weak_valid_pointer m b (Ptrofs.unsigned i)); auto. + destruct ptr64; auto. + destruct ptr64; auto. destruct (Int.eq i Int.zero); auto. + destruct ptr64; auto. destruct (Int64.eq i Int64.zero); auto. + destruct ptr64; auto. + destruct ptr64; auto. + destruct ptr64; auto. destruct (Mem.weak_valid_pointer m b (Ptrofs.unsigned i)); auto. + destruct (Mem.weak_valid_pointer m b (Ptrofs.unsigned i)); auto. + destruct ptr64; auto. + destruct ptr64; auto. destruct (Int.eq i Int.zero); auto. + destruct ptr64; auto. destruct (Int64.eq i Int64.zero); auto. + destruct ptr64; auto. + destruct ptr64; auto. + destruct ptr64; auto. destruct (Mem.weak_valid_pointer m b (Ptrofs.unsigned i)); auto. + destruct (Mem.weak_valid_pointer m b (Ptrofs.unsigned i)); auto. Qed. (** Relation between Boolean value and Boolean negation. *) @@ -1399,13 +1483,13 @@ Lemma notbool_bool_val: sem_notbool v t m = match bool_val v t m with None => None | Some b => Some(Val.of_bool (negb b)) end. Proof. - intros. unfold sem_notbool, bool_val. - destruct (classify_bool t); auto; destruct v; auto; rewrite ? negb_involutive; auto. - destruct (Mem.weak_valid_pointer m b (Int.unsigned i)); auto. + intros. unfold sem_notbool. destruct (bool_val v t m) as [[] | ]; reflexivity. Qed. (** Properties of values obtained by casting to a given type. *) +Section VAL_CASTED. + Inductive val_casted: val -> type -> Prop := | val_casted_int: forall sz si attr n, cast_int_int sz si n = n -> @@ -1419,9 +1503,13 @@ Inductive val_casted: val -> type -> Prop := | val_casted_ptr_ptr: forall b ofs ty attr, val_casted (Vptr b ofs) (Tpointer ty attr) | val_casted_int_ptr: forall n ty attr, - val_casted (Vint n) (Tpointer ty attr) + Archi.ptr64 = false -> val_casted (Vint n) (Tpointer ty attr) | val_casted_ptr_int: forall b ofs si attr, - val_casted (Vptr b ofs) (Tint I32 si attr) + Archi.ptr64 = false -> val_casted (Vptr b ofs) (Tint I32 si attr) + | val_casted_long_ptr: forall n ty attr, + Archi.ptr64 = true -> val_casted (Vlong n) (Tpointer ty attr) + | val_casted_ptr_long: forall b ofs si attr, + Archi.ptr64 = true -> val_casted (Vptr b ofs) (Tlong si attr) | val_casted_struct: forall id attr b ofs, val_casted (Vptr b ofs) (Tstruct id attr) | val_casted_union: forall id attr b ofs, @@ -1429,6 +1517,8 @@ Inductive val_casted: val -> type -> Prop := | val_casted_void: forall v, val_casted v Tvoid. +Hint Constructors val_casted. + Remark cast_int_int_idem: forall sz sg i, cast_int_int sz sg (cast_int_int sz sg i) = cast_int_int sz sg i. Proof. @@ -1438,77 +1528,50 @@ Proof. destruct (Int.eq i Int.zero); auto. Qed. +Ltac DestructCases := + match goal with + | [H: match match ?x with _ => _ end with _ => _ end = Some _ |- _ ] => destruct x eqn:?; DestructCases + | [H: match ?x with _ => _ end = Some _ |- _ ] => destruct x eqn:?; DestructCases + | [H: Some _ = Some _ |- _ ] => inv H; DestructCases + | [H: None = Some _ |- _ ] => discriminate H + | [H: @eq intsize _ _ |- _ ] => discriminate H || (clear H; DestructCases) + | [ |- val_casted (Vint (if ?x then Int.zero else Int.one)) _ ] => + try (constructor; destruct x; reflexivity) + | [ |- val_casted (Vint _) (Tint ?sz ?sg _) ] => + try (constructor; apply (cast_int_int_idem sz sg)) + | _ => idtac + end. + Lemma cast_val_is_casted: forall v ty ty' v' m, sem_cast v ty ty' m = Some v' -> val_casted v' ty'. Proof. - unfold sem_cast; intros. destruct ty'; simpl in *. -- (* void *) - constructor. -- (* int *) - destruct i; destruct ty; simpl in H; try (destruct f); try discriminate; destruct v; inv H. - constructor. apply (cast_int_int_idem I8 s). - constructor. apply (cast_int_int_idem I8 s). - destruct (cast_single_int s f); inv H1. constructor. apply (cast_int_int_idem I8 s). - destruct (cast_float_int s f); inv H1. constructor. apply (cast_int_int_idem I8 s). - constructor. apply (cast_int_int_idem I16 s). - constructor. apply (cast_int_int_idem I16 s). - destruct (cast_single_int s f); inv H1. constructor. apply (cast_int_int_idem I16 s). - destruct (cast_float_int s f); inv H1. constructor. apply (cast_int_int_idem I16 s). - constructor. auto. - constructor. - constructor. auto. - destruct (cast_single_int s f); inv H1. constructor. auto. - destruct (cast_float_int s f); inv H1. constructor; auto. - constructor; auto. - constructor. - constructor; auto. - constructor. - constructor; auto. - constructor. - constructor. simpl. destruct (Int.eq i0 Int.zero); auto. - constructor. simpl. destruct (Int64.eq i Int64.zero); auto. - constructor. simpl. destruct (Float32.cmp Ceq f Float32.zero); auto. - constructor. simpl. destruct (Float.cmp Ceq f Float.zero); auto. - constructor. simpl. destruct (Int.eq i Int.zero); auto. - destruct (Mem.weak_valid_pointer m b (Int.unsigned i)); inv H1. constructor; auto. - constructor. simpl. destruct (Int.eq i Int.zero); auto. - destruct (Mem.weak_valid_pointer m b (Int.unsigned i)); inv H1. constructor; auto. - constructor. simpl. destruct (Int.eq i Int.zero); auto. - destruct (Mem.weak_valid_pointer m b (Int.unsigned i)); inv H1. constructor; auto. -- (* long *) - destruct ty; try (destruct f); try discriminate. - destruct v; inv H. constructor. - destruct v; inv H. constructor. - destruct v; try discriminate. destruct (cast_single_long s f); inv H. constructor. - destruct v; try discriminate. destruct (cast_float_long s f); inv H. constructor. - destruct v; inv H. constructor. - destruct v; inv H. constructor. - destruct v; inv H. constructor. -- (* float *) - destruct f; destruct ty; simpl in H; try (destruct f); try discriminate; destruct v; inv H; constructor. -- (* pointer *) - destruct ty; simpl in H; try discriminate; destruct v; inv H; try constructor. -- (* array (impossible case) *) - discriminate. -- (* function (impossible case) *) - discriminate. -- (* structs *) - destruct ty; try discriminate; destruct v; try discriminate. - destruct (ident_eq i0 i); inv H; constructor. -- (* unions *) - destruct ty; try discriminate; destruct v; try discriminate. - destruct (ident_eq i0 i); inv H; constructor. + unfold sem_cast; intros. + destruct ty, ty'; simpl in H; DestructCases; constructor; auto. Qed. +End VAL_CASTED. + (** As a consequence, casting twice is equivalent to casting once. *) Lemma cast_val_casted: forall v ty m, val_casted v ty -> sem_cast v ty ty m = Some v. Proof. - intros. inversion H; clear H; subst v ty; unfold sem_cast; simpl; auto. - destruct sz; congruence. - unfold proj_sumbool; repeat rewrite dec_eq_true; auto. - unfold proj_sumbool; repeat rewrite dec_eq_true; auto. + intros. unfold sem_cast; inversion H; clear H; subst v ty; simpl. +- destruct Archi.ptr64; [ | destruct (intsize_eq sz I32)]. ++ destruct sz; f_equal; f_equal; assumption. ++ subst sz; auto. ++ destruct sz; f_equal; f_equal; assumption. +- auto. +- auto. +- destruct Archi.ptr64; auto. +- auto. +- rewrite H0; auto. +- rewrite H0; auto. +- rewrite H0; auto. +- rewrite H0; auto. +- rewrite dec_eq_true; auto. +- rewrite dec_eq_true; auto. +- auto. Qed. Lemma cast_idempotent: diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index 30e6200d..0c3e00de 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -63,7 +63,7 @@ Variable ge: genv. returned, and [t] the trace of observables (nonempty if this is a volatile access). *) -Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: int) : trace -> val -> Prop := +Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs) : trace -> val -> Prop := | deref_loc_value: forall chunk v, access_mode ty = By_value chunk -> type_is_volatile ty = false -> @@ -87,7 +87,7 @@ Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: int) : trace -> val -> [m'] is the updated memory state and [t] the trace of observables (nonempty if this is a volatile store). *) -Inductive assign_loc (ty: type) (m: mem) (b: block) (ofs: int): +Inductive assign_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs): val -> trace -> mem -> Prop := | assign_loc_value: forall v chunk m', access_mode ty = By_value chunk -> @@ -100,13 +100,13 @@ Inductive assign_loc (ty: type) (m: mem) (b: block) (ofs: int): assign_loc ty m b ofs v t m' | assign_loc_copy: forall b' ofs' bytes m', access_mode ty = By_copy -> - (alignof_blockcopy ge ty | Int.unsigned ofs') -> - (alignof_blockcopy ge ty | Int.unsigned ofs) -> - b' <> b \/ Int.unsigned ofs' = Int.unsigned ofs - \/ Int.unsigned ofs' + sizeof ge ty <= Int.unsigned ofs - \/ Int.unsigned ofs + sizeof ge ty <= Int.unsigned ofs' -> - Mem.loadbytes m b' (Int.unsigned ofs') (sizeof ge ty) = Some bytes -> - Mem.storebytes m b (Int.unsigned ofs) bytes = Some m' -> + (alignof_blockcopy ge ty | Ptrofs.unsigned ofs') -> + (alignof_blockcopy ge ty | Ptrofs.unsigned ofs) -> + b' <> b \/ Ptrofs.unsigned ofs' = Ptrofs.unsigned ofs + \/ Ptrofs.unsigned ofs' + sizeof ge ty <= Ptrofs.unsigned ofs + \/ Ptrofs.unsigned ofs + sizeof ge ty <= Ptrofs.unsigned ofs' -> + Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ge ty) = Some bytes -> + Mem.storebytes m b (Ptrofs.unsigned ofs) bytes = Some m' -> assign_loc ty m b ofs (Vptr b' ofs') E0 m'. (** Allocation of function-local variables. @@ -142,7 +142,7 @@ Inductive bind_parameters (e: env): | bind_parameters_cons: forall m id ty params v1 vl b m1 m2, PTree.get id e = Some(b, ty) -> - assign_loc ty m b Int.zero v1 E0 m1 -> + assign_loc ty m b Ptrofs.zero v1 E0 m1 -> bind_parameters e m1 params vl m2 -> bind_parameters e m ((id, ty) :: params) (v1 :: vl) m2. @@ -211,12 +211,12 @@ Inductive lred: expr -> mem -> expr -> mem -> Prop := | red_var_local: forall x ty m b, e!x = Some(b, ty) -> lred (Evar x ty) m - (Eloc b Int.zero ty) m + (Eloc b Ptrofs.zero ty) m | red_var_global: forall x ty m b, e!x = None -> Genv.find_symbol ge x = Some b -> lred (Evar x ty) m - (Eloc b Int.zero ty) m + (Eloc b Ptrofs.zero ty) m | red_deref: forall b ofs ty1 ty m, lred (Ederef (Eval (Vptr b ofs) ty1) ty) m (Eloc b ofs ty) m @@ -224,7 +224,7 @@ Inductive lred: expr -> mem -> expr -> mem -> Prop := ge.(genv_cenv)!id = Some co -> field_offset ge f (co_members co) = OK delta -> lred (Efield (Eval (Vptr b ofs) (Tstruct id a)) f ty) m - (Eloc b (Int.add ofs (Int.repr delta)) ty) m + (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) ty) m | red_field_union: forall b ofs id co a f ty m, ge.(genv_cenv)!id = Some co -> lred (Efield (Eval (Vptr b ofs) (Tunion id a)) f ty) m @@ -274,10 +274,10 @@ Inductive rred: expr -> mem -> trace -> expr -> mem -> Prop := E0 (Eparen (if b then r1 else r2) ty ty) m | red_sizeof: forall ty1 ty m, rred (Esizeof ty1 ty) m - E0 (Eval (Vint (Int.repr (sizeof ge ty1))) ty) m + E0 (Eval (Vptrofs (Ptrofs.repr (sizeof ge ty1))) ty) m | red_alignof: forall ty1 ty m, rred (Ealignof ty1 ty) m - E0 (Eval (Vint (Int.repr (alignof ge ty1))) ty) m + E0 (Eval (Vptrofs (Ptrofs.repr (alignof ge ty1))) ty) m | red_assign: forall b ofs ty1 v2 ty2 m v t m', sem_cast v2 ty2 ty1 m = Some v -> assign_loc ty1 m b ofs v t m' -> diff --git a/cfrontend/Csharpminor.v b/cfrontend/Csharpminor.v index e42091af..4393640c 100644 --- a/cfrontend/Csharpminor.v +++ b/cfrontend/Csharpminor.v @@ -321,7 +321,7 @@ Inductive eval_expr: expr -> val -> Prop := eval_expr (Evar id) v | eval_Eaddrof: forall id b, eval_var_addr e id b -> - eval_expr (Eaddrof id) (Vptr b Int.zero) + eval_expr (Eaddrof id) (Vptr b Ptrofs.zero) | eval_Econst: forall cst v, eval_constant cst = Some v -> eval_expr (Econst cst) v diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index 40b51bd3..aeb31fe2 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -49,6 +49,9 @@ Definition make_floatconst (f: float) := Econst (Ofloatconst f). Definition make_singleconst (f: float32) := Econst (Osingleconst f). +Definition make_ptrofsconst (n: Z) := + if Archi.ptr64 then make_longconst (Int64.repr n) else make_intconst (Int.repr n). + Definition make_singleoffloat (e: expr) := Eunop Osingleoffloat e. Definition make_floatofsingle (e: expr) := Eunop Ofloatofsingle e. @@ -106,7 +109,7 @@ Definition make_longofsingle (e: expr) (sg: signedness) := | Unsigned => Eunop Olonguofsingle e end. -Definition make_cmp_ne_zero (e: expr) := +Definition make_cmpu_ne_zero (e: expr) := match e with | Ebinop (Ocmp c) e1 e2 => e | Ebinop (Ocmpu c) e1 e2 => e @@ -114,7 +117,7 @@ Definition make_cmp_ne_zero (e: expr) := | Ebinop (Ocmpfs c) e1 e2 => e | Ebinop (Ocmpl c) e1 e2 => e | Ebinop (Ocmplu c) e1 e2 => e - | _ => Ebinop (Ocmp Cne) e (make_intconst Int.zero) + | _ => Ebinop (Ocmpu Cne) e (make_intconst Int.zero) end. (** Variants of [sizeof] and [alignof] that check that the given type is complete. *) @@ -139,12 +142,12 @@ Definition make_cast_int (e: expr) (sz: intsize) (si: signedness) := | I16, Signed => Eunop Ocast16signed e | I16, Unsigned => Eunop Ocast16unsigned e | I32, _ => e - | IBool, _ => make_cmp_ne_zero e + | IBool, _ => make_cmpu_ne_zero e end. Definition make_cast (from to: type) (e: expr) := match classify_cast from to with - | cast_case_neutral => OK e + | cast_case_pointer => OK e | cast_case_i2i sz2 si2 => OK (make_cast_int e sz2 si2) | cast_case_f2f => OK e | cast_case_s2s => OK e @@ -161,10 +164,10 @@ Definition make_cast (from to: type) (e: expr) := | cast_case_l2s si1 => OK (make_singleoflong e si1) | cast_case_f2l si2 => OK (make_longoffloat e si2) | cast_case_s2l si2 => OK (make_longofsingle e si2) + | cast_case_i2bool => OK (make_cmpu_ne_zero e) | cast_case_f2bool => OK (Ebinop (Ocmpf Cne) e (make_floatconst Float.zero)) | cast_case_s2bool => OK (Ebinop (Ocmpfs Cne) e (make_singleconst Float32.zero)) - | cast_case_l2bool => OK (Ebinop (Ocmpl Cne) e (make_longconst Int64.zero)) - | cast_case_p2bool => OK (Ebinop (Ocmpu Cne) e (make_intconst Int.zero)) + | cast_case_l2bool => OK (Ebinop (Ocmplu Cne) e (make_longconst Int64.zero)) | cast_case_struct id1 id2 => OK e | cast_case_union id1 id2 => OK e | cast_case_void => OK e @@ -176,11 +179,10 @@ Definition make_cast (from to: type) (e: expr) := Definition make_boolean (e: expr) (ty: type) := match classify_bool ty with - | bool_case_i => make_cmp_ne_zero e + | bool_case_i => make_cmpu_ne_zero e | bool_case_f => Ebinop (Ocmpf Cne) e (make_floatconst Float.zero) | bool_case_s => Ebinop (Ocmpfs Cne) e (make_singleconst Float32.zero) - | bool_case_p => Ebinop (Ocmpu Cne) e (make_intconst Int.zero) - | bool_case_l => Ebinop (Ocmpl Cne) e (make_longconst Int64.zero) + | bool_case_l => Ebinop (Ocmplu Cne) e (make_longconst Int64.zero) | bool_default => e (**r should not happen *) end. @@ -188,12 +190,11 @@ Definition make_boolean (e: expr) (ty: type) := Definition make_notbool (e: expr) (ty: type) := match classify_bool ty with - | bool_case_i => OK (Ebinop (Ocmp Ceq) e (make_intconst Int.zero)) + | bool_case_i => OK (Ebinop (Ocmpu Ceq) e (make_intconst Int.zero)) | bool_case_f => OK (Ebinop (Ocmpf Ceq) e (make_floatconst Float.zero)) | bool_case_s => OK (Ebinop (Ocmpfs Ceq) e (make_singleconst Float32.zero)) - | bool_case_p => OK (Ebinop (Ocmpu Ceq) e (make_intconst Int.zero)) - | bool_case_l => OK (Ebinop (Ocmpl Ceq) e (make_longconst Int64.zero)) - | _ => Error (msg "Cshmgen.make_notbool") + | bool_case_l => OK (Ebinop (Ocmplu Ceq) e (make_longconst Int64.zero)) + | bool_default => Error (msg "Cshmgen.make_notbool") end. Definition make_neg (e: expr) (ty: type) := @@ -202,7 +203,7 @@ Definition make_neg (e: expr) (ty: type) := | neg_case_f => OK (Eunop Onegf e) | neg_case_s => OK (Eunop Onegfs e) | neg_case_l _ => OK (Eunop Onegl e) - | _ => Error (msg "Cshmgen.make_neg") + | neg_default => Error (msg "Cshmgen.make_neg") end. Definition make_absfloat (e: expr) (ty: type) := @@ -211,14 +212,14 @@ Definition make_absfloat (e: expr) (ty: type) := | neg_case_f => OK (Eunop Oabsf e) | neg_case_s => OK (Eunop Oabsf (make_floatofsingle e)) | neg_case_l sg => OK (Eunop Oabsf (make_floatoflong e sg)) - | _ => Error (msg "Cshmgen.make_absfloat") + | neg_default => Error (msg "Cshmgen.make_absfloat") end. Definition make_notint (e: expr) (ty: type) := match classify_notint ty with | notint_case_i _ => OK (Eunop Onotint e) | notint_case_l _ => OK (Eunop Onotl e) - | _ => Error (msg "Cshmgen.make_notint") + | notint_default => Error (msg "Cshmgen.make_notint") end. (** Binary operators *) @@ -239,42 +240,59 @@ Definition make_binarith (iop iopu fop sop lop lopu: binary_operation) | bin_default => Error (msg "Cshmgen.make_binarith") end. +Definition make_add_ptr_int (ce: composite_env) (ty: type) (si: signedness) (e1 e2: expr) := + do sz <- sizeof ce ty; + if Archi.ptr64 then + let n := make_longconst (Int64.repr sz) in + OK (Ebinop Oaddl e1 (Ebinop Omull n (make_longofint e2 si))) + else + let n := make_intconst (Int.repr sz) in + OK (Ebinop Oadd e1 (Ebinop Omul n e2)). + +Definition make_add_ptr_long (ce: composite_env) (ty: type) (e1 e2: expr) := + do sz <- sizeof ce ty; + if Archi.ptr64 then + let n := make_longconst (Int64.repr sz) in + OK (Ebinop Oaddl e1 (Ebinop Omull n e2)) + else + let n := make_intconst (Int.repr sz) in + OK (Ebinop Oadd e1 (Ebinop Omul n (Eunop Ointoflong e2))). + Definition make_add (ce: composite_env) (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_add ty1 ty2 with - | add_case_pi ty => - do sz <- sizeof ce ty; - let n := make_intconst (Int.repr sz) in - OK (Ebinop Oadd e1 (Ebinop Omul n e2)) - | add_case_ip ty => - do sz <- sizeof ce ty; - let n := make_intconst (Int.repr sz) in - OK (Ebinop Oadd e2 (Ebinop Omul n e1)) - | add_case_pl ty => - do sz <- sizeof ce ty; - let n := make_intconst (Int.repr sz) in - OK (Ebinop Oadd e1 (Ebinop Omul n (Eunop Ointoflong e2))) - | add_case_lp ty => - do sz <- sizeof ce ty; - let n := make_intconst (Int.repr sz) in - OK (Ebinop Oadd e2 (Ebinop Omul n (Eunop Ointoflong e1))) - | add_default => - make_binarith Oadd Oadd Oaddf Oaddfs Oaddl Oaddl e1 ty1 e2 ty2 + | add_case_pi ty si => make_add_ptr_int ce ty si e1 e2 + | add_case_pl ty => make_add_ptr_long ce ty e1 e2 + | add_case_ip si ty => make_add_ptr_int ce ty si e2 e1 + | add_case_lp ty => make_add_ptr_long ce ty e2 e1 + | add_default => make_binarith Oadd Oadd Oaddf Oaddfs Oaddl Oaddl e1 ty1 e2 ty2 end. Definition make_sub (ce: composite_env) (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_sub ty1 ty2 with - | sub_case_pi ty => + | sub_case_pi ty si => do sz <- sizeof ce ty; - let n := make_intconst (Int.repr sz) in - OK (Ebinop Osub e1 (Ebinop Omul n e2)) + if Archi.ptr64 then + let n := make_longconst (Int64.repr sz) in + OK (Ebinop Osubl e1 (Ebinop Omull n (make_longofint e2 si))) + else + let n := make_intconst (Int.repr sz) in + OK (Ebinop Osub e1 (Ebinop Omul n e2)) | sub_case_pp ty => do sz <- sizeof ce ty; - let n := make_intconst (Int.repr sz) in - OK (Ebinop Odiv (Ebinop Osub e1 e2) n) + if Archi.ptr64 then + let n := make_longconst (Int64.repr sz) in + OK (Ebinop Odivl (Ebinop Osubl e1 e2) n) + else + let n := make_intconst (Int.repr sz) in + OK (Ebinop Odiv (Ebinop Osub e1 e2) n) | sub_case_pl ty => do sz <- sizeof ce ty; - let n := make_intconst (Int.repr sz) in - OK (Ebinop Osub e1 (Ebinop Omul n (Eunop Ointoflong e2))) + if Archi.ptr64 then + let n := make_longconst (Int64.repr sz) in + OK (Ebinop Osubl e1 (Ebinop Omull n e2)) + else + let n := make_intconst (Int.repr sz) in + OK (Ebinop Osub e1 (Ebinop Omul n (Eunop Ointoflong e2))) | sub_default => make_binarith Osub Osub Osubf Osubfs Osubl Osubl e1 ty1 e2 ty2 end. @@ -333,11 +351,20 @@ Definition make_shr (e1: expr) (ty1: type) (e2: expr) (ty2: type) := | shift_default => Error (msg "Cshmgen.make_shr") end. +Definition make_cmp_ptr (c: comparison) (e1 e2: expr) := + Ebinop (if Archi.ptr64 then Ocmplu c else Ocmpu c) e1 e2. + Definition make_cmp (c: comparison) (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_cmp ty1 ty2 with - | cmp_case_pp => OK (Ebinop (Ocmpu c) e1 e2) - | cmp_case_pl => OK (Ebinop (Ocmpu c) e1 (Eunop Ointoflong e2)) - | cmp_case_lp => OK (Ebinop (Ocmpu c) (Eunop Ointoflong e1) e2) + | cmp_case_pp => OK (make_cmp_ptr c e1 e2) + | cmp_case_pi si => + OK (make_cmp_ptr c e1 (if Archi.ptr64 then make_longofint e2 si else e2)) + | cmp_case_ip si => + OK (make_cmp_ptr c (if Archi.ptr64 then make_longofint e1 si else e1) e2) + | cmp_case_pl => + OK (make_cmp_ptr c e1 (if Archi.ptr64 then e2 else Eunop Ointoflong e2)) + | cmp_case_lp => + OK (make_cmp_ptr c (if Archi.ptr64 then e1 else Eunop Ointoflong e1) e2) | cmp_default => make_binarith (Ocmp c) (Ocmpu c) (Ocmpf c) (Ocmpfs c) (Ocmpl c) (Ocmplu c) @@ -421,7 +448,9 @@ Definition make_field_access (ce: composite_env) (ty: type) (f: ident) (a: expr) Error (MSG "Undefined struct " :: CTX id :: nil) | Some co => do ofs <- field_offset ce f (co_members co); - OK (Ebinop Oadd a (make_intconst (Int.repr ofs))) + OK (if Archi.ptr64 + then Ebinop Oaddl a (make_longconst (Int64.repr ofs)) + else Ebinop Oadd a (make_intconst (Int.repr ofs))) end | Tunion id _ => OK a @@ -469,9 +498,9 @@ Fixpoint transl_expr (ce: composite_env) (a: Clight.expr) {struct a} : res expr do addr <- make_field_access ce (typeof b) i tb; make_load addr ty | Clight.Esizeof ty' ty => - do sz <- sizeof ce ty'; OK(make_intconst (Int.repr sz)) + do sz <- sizeof ce ty'; OK(make_ptrofsconst sz) | Clight.Ealignof ty' ty => - do al <- alignof ce ty'; OK(make_intconst (Int.repr al)) + do al <- alignof ce ty'; OK(make_ptrofsconst al) end (** [transl_lvalue a] returns the Csharpminor code that evaluates diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index 8bc97b99..09e31cb2 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -37,7 +37,7 @@ Lemma transf_program_match: forall p tp, transl_program p = OK tp -> match_prog p tp. Proof. unfold transl_program; intros. - eapply match_transform_partial_program2. + eapply match_transform_partial_program2. eexact H. - intros. destruct f; simpl in H0. + monadInv H0. constructor; auto. @@ -109,7 +109,7 @@ Lemma transl_alignof_blockcopy: Proof. intros. destruct H. unfold sizeof in H0. destruct (complete_type (prog_comp_env cunit) t) eqn:C; inv H0. - split. + split. - symmetry. apply Ctypes.sizeof_stable; auto. - revert C. induction t; simpl; auto; destruct (prog_comp_env cunit)!i as [co|] eqn:X; try discriminate; erewrite H1 by eauto; auto. @@ -119,10 +119,10 @@ Lemma field_offset_stable: forall (cunit prog: Clight.program) id co f, linkorder cunit prog -> cunit.(prog_comp_env)!id = Some co -> - prog.(prog_comp_env)!id = Some co /\ + prog.(prog_comp_env)!id = Some co /\ field_offset prog.(prog_comp_env) f (co_members co) = field_offset cunit.(prog_comp_env) f (co_members co). Proof. - intros. + intros. assert (C: composite_consistent cunit.(prog_comp_env) co). { apply build_composite_env_consistent with cunit.(prog_types) id; auto. apply prog_comp_env_eq. } @@ -134,7 +134,7 @@ Proof. rewrite ! (alignof_stable _ _ A) by auto. rewrite ! (sizeof_stable _ _ A) by auto. destruct (ident_eq f f1); eauto. -Qed. +Qed. (** * Properties of the translation functions *) @@ -245,6 +245,19 @@ Proof. intros. unfold make_floatconst. econstructor. reflexivity. Qed. +Lemma make_ptrofsconst_correct: + forall n e le m, + eval_expr ge e le m (make_ptrofsconst n) (Vptrofs (Ptrofs.repr n)). +Proof. + intros. unfold Vptrofs, make_ptrofsconst. destruct Archi.ptr64 eqn:SF. +- replace (Ptrofs.to_int64 (Ptrofs.repr n)) with (Int64.repr n). + apply make_longconst_correct. + symmetry; auto with ptrofs. +- replace (Ptrofs.to_int (Ptrofs.repr n)) with (Int.repr n). + apply make_intconst_correct. + symmetry; auto with ptrofs. +Qed. + Lemma make_singleoffloat_correct: forall a n e le m, eval_expr ge e le m a (Vfloat n) -> @@ -276,38 +289,62 @@ Hint Resolve make_intconst_correct make_floatconst_correct make_longconst_correc Hint Constructors eval_expr eval_exprlist: cshm. Hint Extern 2 (@eq trace _ _) => traceEq: cshm. -Lemma make_cmp_ne_zero_correct: +Lemma make_cmpu_ne_zero_correct: forall e le m a n, eval_expr ge e le m a (Vint n) -> - eval_expr ge e le m (make_cmp_ne_zero a) (Vint (if Int.eq n Int.zero then Int.zero else Int.one)). + eval_expr ge e le m (make_cmpu_ne_zero a) (Vint (if Int.eq n Int.zero then Int.zero else Int.one)). Proof. intros. - assert (DEFAULT: eval_expr ge e le m (Ebinop (Ocmp Cne) a (make_intconst Int.zero)) + assert (DEFAULT: eval_expr ge e le m (Ebinop (Ocmpu Cne) a (make_intconst Int.zero)) (Vint (if Int.eq n Int.zero then Int.zero else Int.one))). - econstructor; eauto with cshm. simpl. unfold Val.cmp, Val.cmp_bool. - unfold Int.cmp. destruct (Int.eq n Int.zero); auto. + { econstructor; eauto with cshm. simpl. unfold Val.cmpu, Val.cmpu_bool. + unfold Int.cmpu. destruct (Int.eq n Int.zero); auto. } assert (CMP: forall ob, Val.of_optbool ob = Vint n -> n = (if Int.eq n Int.zero then Int.zero else Int.one)). - intros. destruct ob; simpl in H0; inv H0. destruct b; inv H2. + { intros. destruct ob; simpl in H0; inv H0. destruct b; inv H2. rewrite Int.eq_false. auto. apply Int.one_not_zero. - rewrite Int.eq_true. auto. + rewrite Int.eq_true. auto. } destruct a; simpl; auto. destruct b; auto. - inv H. econstructor; eauto. rewrite H6. decEq. decEq. - simpl in H6. inv H6. unfold Val.cmp in H0. eauto. - inv H. econstructor; eauto. rewrite H6. decEq. decEq. - simpl in H6. inv H6. unfold Val.cmp in H0. eauto. - inv H. econstructor; eauto. rewrite H6. decEq. decEq. - simpl in H6. inv H6. unfold Val.cmp in H0. eauto. - inv H. econstructor; eauto. rewrite H6. decEq. decEq. - simpl in H6. unfold Val.cmpfs in H6. - destruct (Val.cmpfs_bool c v1 v2) as [[]|]; inv H6; reflexivity. - inv H. econstructor; eauto. rewrite H6. decEq. decEq. +- inv H. econstructor; eauto. rewrite H6. decEq. decEq. + simpl in H6. inv H6. eauto. +- inv H. econstructor; eauto. rewrite H6. decEq. decEq. + simpl in H6. inv H6. eauto. +- inv H. econstructor; eauto. rewrite H6. decEq. decEq. + simpl in H6. inv H6. eauto. +- inv H. econstructor; eauto. rewrite H6. decEq. decEq. + simpl in H6. inv H6. eauto. +- inv H. econstructor; eauto. rewrite H6. decEq. decEq. simpl in H6. unfold Val.cmpl in H6. destruct (Val.cmpl_bool c v1 v2) as [[]|]; inv H6; reflexivity. - inv H. econstructor; eauto. rewrite H6. decEq. decEq. +- inv H. econstructor; eauto. rewrite H6. decEq. decEq. simpl in H6. unfold Val.cmplu in H6. - destruct (Val.cmplu_bool c v1 v2) as [[]|]; inv H6; reflexivity. + destruct (Val.cmplu_bool (Mem.valid_pointer m) c v1 v2) as [[]|]; inv H6; reflexivity. +Qed. + +Lemma make_cmpu_ne_zero_correct_ptr: + forall e le m a b i, + eval_expr ge e le m a (Vptr b i) -> + Archi.ptr64 = false -> + Mem.weak_valid_pointer m b (Ptrofs.unsigned i) = true -> + eval_expr ge e le m (make_cmpu_ne_zero a) Vone. +Proof. + intros. + assert (DEFAULT: eval_expr ge e le m (Ebinop (Ocmpu Cne) a (make_intconst Int.zero)) Vone). + { econstructor; eauto with cshm. simpl. unfold Val.cmpu, Val.cmpu_bool. + unfold Mem.weak_valid_pointer in H1. rewrite H0, H1. + rewrite Int.eq_true; auto. } + assert (OF_OPTBOOL: forall ob, Some (Val.of_optbool ob) <> Some (Vptr b i)). + { intros. destruct ob as [[]|]; discriminate. } + assert (OF_BOOL: forall ob, option_map Val.of_bool ob <> Some (Vptr b i)). + { intros. destruct ob as [[]|]; discriminate. } + destruct a; simpl; auto. destruct b0; auto. +- inv H; eelim OF_OPTBOOL; eauto. +- inv H; eelim OF_OPTBOOL; eauto. +- inv H; eelim OF_OPTBOOL; eauto. +- inv H; eelim OF_OPTBOOL; eauto. +- inv H; eelim OF_BOOL; eauto. +- inv H; eelim OF_BOOL; eauto. Qed. Lemma make_cast_int_correct: @@ -320,10 +357,27 @@ Proof. destruct si; eauto with cshm. destruct si; eauto with cshm. auto. - apply make_cmp_ne_zero_correct; auto. + apply make_cmpu_ne_zero_correct; auto. Qed. -Hint Resolve make_cast_int_correct: cshm. +Lemma make_longofint_correct: + forall e le m a n si, + eval_expr ge e le m a (Vint n) -> + eval_expr ge e le m (make_longofint a si) (Vlong (cast_int_long si n)). +Proof. + intros. unfold make_longofint, cast_int_long. destruct si; eauto with cshm. +Qed. + +Hint Resolve make_cast_int_correct make_longofint_correct: cshm. + +Ltac InvEval := + match goal with + | [ H: None = Some _ |- _ ] => discriminate + | [ H: Some _ = Some _ |- _ ] => inv H; InvEval + | [ H: match ?x with Some _ => _ | None => _ end = Some _ |- _ ] => destruct x eqn:?; InvEval + | [ H: match ?x with true => _ | false => _ end = Some _ |- _ ] => destruct x eqn:?; InvEval + | _ => idtac + end. Lemma make_cast_correct: forall e le m a b v ty1 ty2 v', @@ -333,59 +387,51 @@ Lemma make_cast_correct: eval_expr ge e le m b v'. Proof. intros. unfold make_cast, sem_cast in *; - destruct (classify_cast ty1 ty2); inv H; destruct v; inv H1; eauto with cshm. - (* single -> int *) + destruct (classify_cast ty1 ty2); inv H; destruct v; InvEval; eauto with cshm. +- (* single -> int *) unfold make_singleofint, cast_int_float. destruct si1; eauto with cshm. - (* float -> int *) - destruct (cast_float_int si2 f) as [i|] eqn:E; inv H2. +- (* float -> int *) apply make_cast_int_correct. - unfold cast_float_int in E. unfold make_intoffloat. - destruct si2; econstructor; eauto; simpl; rewrite E; auto. - (* single -> int *) - destruct (cast_single_int si2 f) as [i|] eqn:E; inv H2. + unfold cast_float_int in Heqo. unfold make_intoffloat. + destruct si2; econstructor; eauto; simpl; rewrite Heqo; auto. +- (* single -> int *) apply make_cast_int_correct. - unfold cast_single_int in E. unfold make_intofsingle. - destruct si2; econstructor; eauto with cshm; simpl; rewrite E; auto. - (* long -> int *) - unfold make_longofint, cast_int_long. destruct si1; eauto with cshm. - (* long -> float *) + unfold cast_single_int in Heqo. unfold make_intofsingle. + destruct si2; econstructor; eauto with cshm; simpl; rewrite Heqo; auto. +- (* long -> float *) unfold make_floatoflong, cast_long_float. destruct si1; eauto with cshm. - (* long -> single *) +- (* long -> single *) unfold make_singleoflong, cast_long_single. destruct si1; eauto with cshm. - (* float -> long *) - destruct (cast_float_long si2 f) as [i|] eqn:E; inv H2. - unfold cast_float_long in E. unfold make_longoffloat. - destruct si2; econstructor; eauto; simpl; rewrite E; auto. - (* single -> long *) - destruct (cast_single_long si2 f) as [i|] eqn:E; inv H2. - unfold cast_single_long in E. unfold make_longofsingle. - destruct si2; econstructor; eauto with cshm; simpl; rewrite E; auto. - (* float -> bool *) +- (* float -> long *) + unfold cast_float_long in Heqo. unfold make_longoffloat. + destruct si2; econstructor; eauto; simpl; rewrite Heqo; auto. +- (* single -> long *) + unfold cast_single_long in Heqo. unfold make_longofsingle. + destruct si2; econstructor; eauto with cshm; simpl; rewrite Heqo; auto. +- (* int -> bool *) + apply make_cmpu_ne_zero_correct; auto. +- (* pointer (32 bits) -> bool *) + eapply make_cmpu_ne_zero_correct_ptr; eauto. +- (* long -> bool *) + econstructor; eauto with cshm. + simpl. unfold Val.cmplu, Val.cmplu_bool, Int64.cmpu. + destruct (Int64.eq i Int64.zero); auto. +- (* pointer (64 bits) -> bool *) + econstructor; eauto with cshm. + simpl. unfold Val.cmplu, Val.cmplu_bool. unfold Mem.weak_valid_pointer in Heqb1. + rewrite Heqb0, Heqb1. rewrite Int64.eq_true. reflexivity. +- (* float -> bool *) econstructor; eauto with cshm. simpl. unfold Val.cmpf, Val.cmpf_bool. rewrite Float.cmp_ne_eq. destruct (Float.cmp Ceq f Float.zero); auto. - (* single -> bool *) +- (* single -> bool *) econstructor; eauto with cshm. simpl. unfold Val.cmpfs, Val.cmpfs_bool. rewrite Float32.cmp_ne_eq. destruct (Float32.cmp Ceq f Float32.zero); auto. - (* long -> bool *) - econstructor; eauto with cshm. - simpl. unfold Val.cmpl, Val.cmpl_bool, Int64.cmp. - destruct (Int64.eq i Int64.zero); auto. - (* int -> bool *) - econstructor; eauto with cshm. - simpl. unfold Val.cmpu, Val.cmpu_bool, Int.cmpu. - destruct (Int.eq i Int.zero); auto. - (* pointer -> bool *) - destruct (Mem.weak_valid_pointer m b (Int.unsigned i)) eqn:VALID; inv H2. - econstructor; eauto with cshm. - simpl. unfold Val.cmpu. simpl. rewrite Int.eq_true. - unfold Mem.weak_valid_pointer in VALID; rewrite VALID. - auto. - (* struct *) - destruct (ident_eq id1 id2); inv H2; auto. - (* union *) - destruct (ident_eq id1 id2); inv H2; auto. +- (* struct *) + destruct (ident_eq id1 id2); inv H1; auto. +- (* union *) + destruct (ident_eq id1 id2); inv H1; auto. Qed. Lemma make_boolean_correct: @@ -397,29 +443,28 @@ Lemma make_boolean_correct: /\ Val.bool_of_val vb b. Proof. intros. unfold make_boolean. unfold bool_val in H0. - destruct (classify_bool ty); destruct v; inv H0. -(* int *) - econstructor; split. apply make_cmp_ne_zero_correct with (n := i); auto. + destruct (classify_bool ty); destruct v; InvEval. +- (* int *) + econstructor; split. apply make_cmpu_ne_zero_correct with (n := i); auto. destruct (Int.eq i Int.zero); simpl; constructor. -(* float *) +- (* ptr 32 bits *) + exists Vone; split. eapply make_cmpu_ne_zero_correct_ptr; eauto. constructor. +- (* long *) + econstructor; split. econstructor; eauto with cshm. simpl. unfold Val.cmplu. simpl. eauto. + destruct (Int64.eq i Int64.zero); simpl; constructor. +- (* ptr 64 bits *) + exists Vone; split. + econstructor; eauto with cshm. simpl. unfold Val.cmplu, Val.cmplu_bool. + unfold Mem.weak_valid_pointer in Heqb0. rewrite Heqb0, Heqb1, Int64.eq_true. reflexivity. + constructor. +- (* float *) econstructor; split. econstructor; eauto with cshm. simpl. eauto. unfold Val.cmpf, Val.cmpf_bool. simpl. rewrite <- Float.cmp_ne_eq. destruct (Float.cmp Cne f Float.zero); constructor. -(* single *) +- (* single *) econstructor; split. econstructor; eauto with cshm. simpl. eauto. unfold Val.cmpfs, Val.cmpfs_bool. simpl. rewrite <- Float32.cmp_ne_eq. destruct (Float32.cmp Cne f Float32.zero); constructor. -(* pointer *) - econstructor; split. econstructor; eauto with cshm. simpl. eauto. - unfold Val.cmpu, Val.cmpu_bool. simpl. - destruct (Int.eq i Int.zero); simpl; constructor. - econstructor; split. econstructor; eauto with cshm. simpl. eauto. - destruct (Mem.weak_valid_pointer m b0 (Int.unsigned i)) eqn:V; inv H2. - unfold Val.cmpu, Val.cmpu_bool. simpl. - unfold Mem.weak_valid_pointer in V; rewrite V. constructor. -(* long *) - econstructor; split. econstructor; eauto with cshm. simpl. unfold Val.cmpl. simpl. eauto. - destruct (Int64.eq i Int64.zero); simpl; constructor. Qed. Lemma make_neg_correct: @@ -454,11 +499,24 @@ Lemma make_notbool_correct: eval_expr ge e le m a va -> eval_expr ge e le m c v. Proof. - unfold sem_notbool, make_notbool; intros until m; intros SEM MAKE EV1; - destruct (classify_bool tya); inv MAKE; destruct va; inv SEM; eauto with cshm. - destruct (Mem.weak_valid_pointer m b (Int.unsigned i)) eqn:V; inv H0. + unfold sem_notbool, bool_val, make_notbool; intros until m; intros SEM MAKE EV1. + destruct (classify_bool tya); inv MAKE; destruct va; simpl in SEM; InvEval. +- econstructor; eauto with cshm. simpl. unfold Val.cmpu, Val.cmpu_bool, Int.cmpu. + destruct (Int.eq i Int.zero); auto. +- destruct Archi.ptr64 eqn:SF; inv SEM. + destruct (Mem.weak_valid_pointer m b (Ptrofs.unsigned i)) eqn:V; simpl in H0; inv H0. econstructor; eauto with cshm. simpl. unfold Val.cmpu, Val.cmpu_bool. - unfold Mem.weak_valid_pointer in V; rewrite V. auto. + unfold Mem.weak_valid_pointer in V. rewrite SF, V, Int.eq_true. auto. +- econstructor; eauto with cshm. simpl. unfold Val.cmplu, Val.cmplu_bool, Int64.cmpu. + destruct (Int64.eq i Int64.zero); auto. +- destruct Archi.ptr64 eqn:SF; inv SEM. + destruct (Mem.weak_valid_pointer m b (Ptrofs.unsigned i)) eqn:V; simpl in H0; inv H0. + econstructor; eauto with cshm. simpl. unfold Val.cmplu, Val.cmplu_bool. + unfold Mem.weak_valid_pointer in V. rewrite SF, V, Int64.eq_true. auto. +- econstructor; eauto with cshm. simpl. unfold Val.cmpf, Val.cmpf_bool. + destruct (Float.cmp Ceq f Float.zero); auto. +- econstructor; eauto with cshm. simpl. unfold Val.cmpfs, Val.cmpfs_bool. + destruct (Float32.cmp Ceq f Float32.zero); auto. Qed. Lemma make_notint_correct: @@ -563,17 +621,48 @@ Hint Extern 2 (@eq (option val) _ _) => (simpl; reflexivity) : cshm. Lemma make_add_correct: binary_constructor_correct (make_add cunit.(prog_comp_env)) (sem_add prog.(prog_comp_env)). Proof. + assert (A: forall ty si a b c e le m va vb v, + make_add_ptr_int cunit.(prog_comp_env) ty si a b = OK c -> + eval_expr ge e le m a va -> eval_expr ge e le m b vb -> + sem_add_ptr_int (prog_comp_env prog) ty si va vb = Some v -> + eval_expr ge e le m c v). + { unfold make_add_ptr_int, sem_add_ptr_int; intros until v; intros MAKE EV1 EV2 SEM; monadInv MAKE. + destruct Archi.ptr64 eqn:SF; inv EQ0; rewrite (transl_sizeof _ _ _ _ LINK EQ). + - destruct va; InvEval; destruct vb; inv SEM. + + eauto with cshm. + + econstructor; eauto with cshm. + simpl. rewrite SF. f_equal. f_equal. f_equal. + assert (Ptrofs.agree64 (ptrofs_of_int si i0) (cast_int_long si i0)). + { destruct si; simpl; apply Ptrofs.agree64_repr; auto. } + auto with ptrofs. + - destruct va; InvEval; destruct vb; inv SEM. + + eauto with cshm. + + econstructor; eauto with cshm. + simpl. rewrite SF. f_equal. f_equal. f_equal. + assert (Ptrofs.agree32 (ptrofs_of_int si i0) i0) by (destruct si; simpl; auto with ptrofs). + auto with ptrofs. + } + assert (B: forall ty a b c e le m va vb v, + make_add_ptr_long cunit.(prog_comp_env) ty a b = OK c -> + eval_expr ge e le m a va -> eval_expr ge e le m b vb -> + sem_add_ptr_long (prog_comp_env prog) ty va vb = Some v -> + eval_expr ge e le m c v). + { unfold make_add_ptr_long, sem_add_ptr_long; intros until v; intros MAKE EV1 EV2 SEM; monadInv MAKE. + destruct Archi.ptr64 eqn:SF; inv EQ0; rewrite (transl_sizeof _ _ _ _ LINK EQ). + - destruct va; InvEval; destruct vb; inv SEM. + + eauto with cshm. + + econstructor; eauto with cshm. + simpl. rewrite SF. f_equal. f_equal. f_equal. auto with ptrofs. + - destruct va; InvEval; destruct vb; inv SEM. + + eauto with cshm. + + econstructor; eauto with cshm. + simpl. rewrite SF. f_equal. f_equal. f_equal. + assert (Ptrofs.agree32 (Ptrofs.of_int64 i0) (Int64.loword i0)) by (apply Ptrofs.agree32_repr; auto). + auto with ptrofs. + } red; unfold make_add, sem_add; intros until m; intros SEM MAKE EV1 EV2; - destruct (classify_add tya tyb); try (monadInv MAKE). -- rewrite (transl_sizeof _ _ _ _ LINK EQ). - destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. -- rewrite (transl_sizeof _ _ _ _ LINK EQ). - destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. -- rewrite (transl_sizeof _ _ _ _ LINK EQ). - destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. -- rewrite (transl_sizeof _ _ _ _ LINK EQ). - destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. + destruct (classify_add tya tyb); eauto. - eapply make_binarith_correct; eauto; intros; auto. Qed. @@ -582,25 +671,61 @@ Proof. red; unfold make_sub, sem_sub; intros until m; intros SEM MAKE EV1 EV2; destruct (classify_sub tya tyb); try (monadInv MAKE). -- rewrite (transl_sizeof _ _ _ _ LINK EQ). - destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. -- rewrite (transl_sizeof _ _ _ _ LINK EQ). - destruct va; try discriminate; destruct vb; inv SEM. - destruct (eq_block b0 b1); try discriminate. +- destruct Archi.ptr64 eqn:SF; inv EQ0; rewrite (transl_sizeof _ _ _ _ LINK EQ). ++ destruct va; InvEval; destruct vb; inv SEM; eauto with cshm. + econstructor; eauto with cshm. + simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. + assert (Ptrofs.agree64 (ptrofs_of_int si i0) (cast_int_long si i0)). + { destruct si; simpl; apply Ptrofs.agree64_repr; auto. } + auto with ptrofs. ++ destruct va; InvEval; destruct vb; inv SEM; eauto with cshm. + econstructor; eauto with cshm. simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. + assert (Ptrofs.agree32 (ptrofs_of_int si i0) i0) by (destruct si; simpl; auto with ptrofs). + auto with ptrofs. +- rewrite (transl_sizeof _ _ _ _ LINK EQ) in EQ0. clear EQ. set (sz := Ctypes.sizeof (prog_comp_env prog) ty) in *. + destruct va; InvEval; destruct vb; InvEval. + destruct (eq_block b0 b1); try discriminate. destruct (zlt 0 sz); try discriminate. - destruct (zle sz Int.max_signed); simpl in H0; inv H0. + destruct (zle sz Ptrofs.max_signed); simpl in SEM; inv SEM. + assert (E1: Ptrofs.signed (Ptrofs.repr sz) = sz). + { apply Ptrofs.signed_repr. generalize Ptrofs.min_signed_neg; omega. } + destruct Archi.ptr64 eqn:SF; inversion EQ0; clear EQ0; subst c. ++ assert (E: Int64.signed (Int64.repr sz) = sz). + { apply Int64.signed_repr. + replace Int64.max_signed with Ptrofs.max_signed. + generalize Int64.min_signed_neg; omega. + unfold Ptrofs.max_signed, Ptrofs.half_modulus; rewrite Ptrofs.modulus_eq64 by auto. reflexivity. } econstructor; eauto with cshm. - rewrite dec_eq_true; simpl. - assert (E: Int.signed (Int.repr sz) = sz). - { apply Int.signed_repr. generalize Int.min_signed_neg; omega. } + rewrite SF, dec_eq_true. simpl. + predSpec Int64.eq Int64.eq_spec (Int64.repr sz) Int64.zero. + rewrite H in E; rewrite Int64.signed_zero in E; omegaContradiction. + predSpec Int64.eq Int64.eq_spec (Int64.repr sz) Int64.mone. + rewrite H0 in E; rewrite Int64.signed_mone in E; omegaContradiction. + rewrite andb_false_r; simpl. unfold Vptrofs; rewrite SF. apply f_equal. + apply f_equal. symmetry. auto with ptrofs. ++ assert (E: Int.signed (Int.repr sz) = sz). + { apply Int.signed_repr. + replace Int.max_signed with Ptrofs.max_signed. + generalize Int.min_signed_neg; omega. + unfold Ptrofs.max_signed, Ptrofs.half_modulus, Ptrofs.modulus, Ptrofs.wordsize, Wordsize_Ptrofs.wordsize. rewrite SF. reflexivity. + } + econstructor; eauto with cshm. rewrite SF, dec_eq_true. simpl. predSpec Int.eq Int.eq_spec (Int.repr sz) Int.zero. rewrite H in E; rewrite Int.signed_zero in E; omegaContradiction. predSpec Int.eq Int.eq_spec (Int.repr sz) Int.mone. rewrite H0 in E; rewrite Int.signed_mone in E; omegaContradiction. - rewrite andb_false_r; auto. -- rewrite (transl_sizeof _ _ _ _ LINK EQ). - destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. + rewrite andb_false_r; simpl. unfold Vptrofs; rewrite SF. apply f_equal. apply f_equal. + symmetry. auto with ptrofs. +- destruct Archi.ptr64 eqn:SF; inv EQ0; rewrite (transl_sizeof _ _ _ _ LINK EQ). ++ destruct va; InvEval; destruct vb; inv SEM; eauto with cshm. + econstructor; eauto with cshm. + simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. + auto with ptrofs. ++ destruct va; InvEval; destruct vb; inv SEM; eauto with cshm. + econstructor; eauto with cshm. simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. + assert (Ptrofs.agree32 (Ptrofs.of_int64 i0) (Int64.loword i0)) by (apply Ptrofs.agree32_repr; auto). + auto with ptrofs. - eapply make_binarith_correct; eauto; intros; auto. Qed. @@ -716,25 +841,61 @@ Proof. unfold Int64.shru', Int64.shru; rewrite small_shift_amount_3; auto. Qed. +Lemma make_cmp_ptr_correct: + forall cmp e le m a va b vb v, + cmp_ptr m cmp va vb = Some v -> + eval_expr ge e le m a va -> + eval_expr ge e le m b vb -> + eval_expr ge e le m (make_cmp_ptr cmp a b) v. +Proof. + unfold cmp_ptr, make_cmp_ptr; intros. + destruct Archi.ptr64. +- econstructor; eauto. +- econstructor; eauto. simpl. unfold Val.cmpu. + destruct (Val.cmpu_bool (Mem.valid_pointer m) cmp va vb) as [bo|]; inv H. auto. +Qed. + +Remark make_ptrofs_of_int_correct: + forall e le m a i si, + eval_expr ge e le m a (Vint i) -> + eval_expr ge e le m (if Archi.ptr64 then make_longofint a si else a) (Vptrofs (ptrofs_of_int si i)). +Proof. + intros. unfold Vptrofs, ptrofs_of_int. destruct Archi.ptr64 eqn:SF. +- unfold make_longofint. destruct si. ++ replace (Ptrofs.to_int64 (Ptrofs.of_ints i)) with (Int64.repr (Int.signed i)). + eauto with cshm. + apply Int64.eqm_samerepr. rewrite Ptrofs.eqm64 by auto. apply Ptrofs.eqm_unsigned_repr. ++ replace (Ptrofs.to_int64 (Ptrofs.of_intu i)) with (Int64.repr (Int.unsigned i)). + eauto with cshm. + apply Int64.eqm_samerepr. rewrite Ptrofs.eqm64 by auto. apply Ptrofs.eqm_unsigned_repr. +- destruct si. ++ replace (Ptrofs.to_int (Ptrofs.of_ints i)) with i. auto. + symmetry. auto with ptrofs. ++ replace (Ptrofs.to_int (Ptrofs.of_intu i)) with i. auto. + symmetry. auto with ptrofs. +Qed. + +Remark make_ptrofs_of_int64_correct: + forall e le m a i, + eval_expr ge e le m a (Vlong i) -> + eval_expr ge e le m (if Archi.ptr64 then a else Eunop Ointoflong a) (Vptrofs (Ptrofs.of_int64 i)). +Proof. + intros. unfold Vptrofs. destruct Archi.ptr64 eqn:SF. +- replace (Ptrofs.to_int64 (Ptrofs.of_int64 i)) with i. auto. + symmetry. auto with ptrofs. +- econstructor; eauto. simpl. apply f_equal. apply f_equal. + apply Int.eqm_samerepr. rewrite Ptrofs.eqm32 by auto. apply Ptrofs.eqm_unsigned_repr. +Qed. + Lemma make_cmp_correct: forall cmp, binary_constructor_correct (make_cmp cmp) (sem_cmp cmp). Proof. red; unfold sem_cmp, make_cmp; intros until m; intros SEM MAKE EV1 EV2; destruct (classify_cmp tya tyb). -- inv MAKE. destruct (Val.cmpu_bool (Mem.valid_pointer m) cmp va vb) as [bv|] eqn:E; - simpl in SEM; inv SEM. - econstructor; eauto. simpl. unfold Val.cmpu. rewrite E. auto. -- inv MAKE. destruct vb; try discriminate. - set (vb := Vint (Int.repr (Int64.unsigned i))) in *. - destruct (Val.cmpu_bool (Mem.valid_pointer m) cmp va vb) as [bv|] eqn:E; - simpl in SEM; inv SEM. - econstructor; eauto with cshm. simpl. change (Vint (Int64.loword i)) with vb. - unfold Val.cmpu. rewrite E. auto. -- inv MAKE. destruct va; try discriminate. - set (va := Vint (Int.repr (Int64.unsigned i))) in *. - destruct (Val.cmpu_bool (Mem.valid_pointer m) cmp va vb) as [bv|] eqn:E; - simpl in SEM; inv SEM. - econstructor; eauto with cshm. simpl. change (Vint (Int64.loword i)) with va. - unfold Val.cmpu. rewrite E. auto. +- inv MAKE. eapply make_cmp_ptr_correct; eauto. +- inv MAKE. destruct vb; InvEval; eauto using make_cmp_ptr_correct, make_ptrofs_of_int_correct. +- inv MAKE. destruct va; InvEval; eauto using make_cmp_ptr_correct, make_ptrofs_of_int_correct. +- inv MAKE. destruct vb; InvEval; eauto using make_cmp_ptr_correct, make_ptrofs_of_int64_correct. +- inv MAKE. destruct va; InvEval; eauto using make_cmp_ptr_correct, make_ptrofs_of_int64_correct. - eapply make_binarith_correct; eauto; intros; auto. Qed. @@ -806,7 +967,7 @@ Lemma make_memcpy_correct: step ge (State f s k e le m) E0 (State f Sskip k e le m'). Proof. intros. inv H1; try congruence. - monadInv H3. + monadInv H3. exploit transl_alignof_blockcopy. eexact LINK. eauto. intros [A B]. rewrite A, B. change le with (set_optvar None Vundef le) at 2. econstructor. @@ -954,8 +1115,8 @@ Lemma match_env_alloc_variables: Proof. induction 2; simpl; intros. - inv H0. exists te1; split. constructor. auto. -- monadInv H2. monadInv EQ. simpl in *. - exploit transl_sizeof. eexact H. eauto. intros SZ; rewrite SZ. +- monadInv H2. monadInv EQ. simpl in *. + exploit transl_sizeof. eexact H. eauto. intros SZ; rewrite SZ. exploit (IHalloc_variables x0 (PTree.set id (b1, Ctypes.sizeof ge ty) te1)). auto. constructor. @@ -1042,49 +1203,53 @@ Lemma transl_expr_lvalue_correct: Csharpminor.eval_expr tge te le m ta (Vptr b ofs)). Proof. apply eval_expr_lvalue_ind; intros; try (monadInv TR). -(* const int *) +- (* const int *) apply make_intconst_correct. -(* const float *) +- (* const float *) apply make_floatconst_correct. -(* const single *) +- (* const single *) apply make_singleconst_correct. -(* const long *) +- (* const long *) apply make_longconst_correct. -(* temp var *) +- (* temp var *) constructor; auto. -(* addrof *) +- (* addrof *) simpl in TR. auto. -(* unop *) +- (* unop *) eapply transl_unop_correct; eauto. -(* binop *) +- (* binop *) eapply transl_binop_correct; eauto. -(* cast *) +- (* cast *) eapply make_cast_correct; eauto. -(* sizeof *) - rewrite (transl_sizeof _ _ _ _ LINK EQ). apply make_intconst_correct. -(* alignof *) - rewrite (transl_alignof _ _ _ _ LINK EQ). apply make_intconst_correct. -(* rvalue out of lvalue *) +- (* sizeof *) + rewrite (transl_sizeof _ _ _ _ LINK EQ). apply make_ptrofsconst_correct. +- (* alignof *) + rewrite (transl_alignof _ _ _ _ LINK EQ). apply make_ptrofsconst_correct. +- (* rvalue out of lvalue *) exploit transl_expr_lvalue; eauto. intros [tb [TRLVAL MKLOAD]]. eapply make_load_correct; eauto. -(* var local *) +- (* var local *) exploit (me_local _ _ MENV); eauto. intros EQ. econstructor. eapply eval_var_addr_local. eauto. -(* var global *) +- (* var global *) econstructor. eapply eval_var_addr_global. eapply match_env_globals; eauto. rewrite symbols_preserved. auto. -(* deref *) +- (* deref *) simpl in TR. eauto. -(* field struct *) - unfold make_field_access in EQ0. rewrite H1 in EQ0. +- (* field struct *) + unfold make_field_access in EQ0. rewrite H1 in EQ0. destruct (prog_comp_env cunit)!id as [co'|] eqn:CO; monadInv EQ0. exploit field_offset_stable. eexact LINK. eauto. instantiate (1 := i). intros [A B]. - rewrite <- B in EQ1. - eapply eval_Ebinop; eauto. - apply make_intconst_correct. - simpl. unfold ge in *; simpl in *. congruence. -(* field union *) + rewrite <- B in EQ1. + assert (x0 = delta) by (unfold ge in *; simpl in *; congruence). + subst x0. + destruct Archi.ptr64 eqn:SF. ++ eapply eval_Ebinop; eauto using make_longconst_correct. + simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. auto with ptrofs. ++ eapply eval_Ebinop; eauto using make_intconst_correct. + simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. auto with ptrofs. +- (* field union *) unfold make_field_access in EQ0; rewrite H1 in EQ0; monadInv EQ0. auto. Qed. @@ -1389,7 +1554,7 @@ Proof. rewrite H in CF. simpl in CF. inv CF. econstructor; split. apply plus_one. econstructor; eauto. - eapply transl_expr_correct with (cunit := cu); eauto. + eapply transl_expr_correct with (cunit := cu); eauto. eapply transl_arglist_correct with (cunit := cu); eauto. erewrite typlist_of_arglist_eq by eauto. eapply transl_fundef_sig1; eauto. @@ -1558,7 +1723,7 @@ Proof. econstructor; eauto. constructor. - (* internal function *) - inv H. inv TR. monadInv H5. + inv H. inv TR. monadInv H5. exploit match_cont_is_call_cont; eauto. intros [A B]. exploit match_env_alloc_variables; eauto. apply match_env_empty. @@ -1568,7 +1733,7 @@ Proof. simpl. erewrite transl_vars_names by eauto. assumption. simpl. assumption. simpl. assumption. - simpl; eauto. + simpl; eauto. simpl. rewrite create_undef_temps_match. eapply bind_parameter_temps_match; eauto. simpl. econstructor; eauto. unfold transl_function. rewrite EQ; simpl. rewrite EQ1; simpl. auto. @@ -1628,7 +1793,7 @@ End CORRECTNESS. Instance TransfCshmgenLink : TransfLink match_prog. Proof. red; intros. destruct (link_linkorder _ _ _ H) as (LO1 & LO2). - generalize H. + generalize H. Local Transparent Ctypes.Linker_program. simpl; unfold link_program. destruct (link (program_of_program p1) (program_of_program p2)) as [pp|] eqn:LP; try discriminate. @@ -1638,15 +1803,15 @@ Local Transparent Ctypes.Linker_program. (prog_comp_env_eq p2) EQ) as (env & P & Q). intros E. eapply Linking.link_match_program; eauto. -- intros. +- intros. Local Transparent Linker_fundef Linking.Linker_fundef. - inv H3; inv H4; simpl in H2. + inv H3; inv H4; simpl in H2. + discriminate. + destruct ef; inv H2. econstructor; split. simpl; eauto. left; constructor; auto. + destruct ef; inv H2. econstructor; split. simpl; eauto. right; constructor; auto. + destruct (external_function_eq ef ef0 && typelist_eq args args0 && type_eq res res0 && calling_convention_eq cc cc0) eqn:E'; inv H2. - InvBooleans. subst ef0. econstructor; split. + InvBooleans. subst ef0. econstructor; split. simpl; rewrite dec_eq_true; eauto. left; constructor. congruence. - intros. exists tt. auto. diff --git a/cfrontend/Cstrategy.v b/cfrontend/Cstrategy.v index 6b2924e4..2f731068 100644 --- a/cfrontend/Cstrategy.v +++ b/cfrontend/Cstrategy.v @@ -84,16 +84,16 @@ Section SIMPLE_EXPRS. Variable e: env. Variable m: mem. -Inductive eval_simple_lvalue: expr -> block -> int -> Prop := +Inductive eval_simple_lvalue: expr -> block -> ptrofs -> Prop := | esl_loc: forall b ofs ty, eval_simple_lvalue (Eloc b ofs ty) b ofs | esl_var_local: forall x ty b, e!x = Some(b, ty) -> - eval_simple_lvalue (Evar x ty) b Int.zero + eval_simple_lvalue (Evar x ty) b Ptrofs.zero | esl_var_global: forall x ty b, e!x = None -> Genv.find_symbol ge x = Some b -> - eval_simple_lvalue (Evar x ty) b Int.zero + eval_simple_lvalue (Evar x ty) b Ptrofs.zero | esl_deref: forall r ty b ofs, eval_simple_rvalue r (Vptr b ofs) -> eval_simple_lvalue (Ederef r ty) b ofs @@ -102,7 +102,7 @@ Inductive eval_simple_lvalue: expr -> block -> int -> Prop := typeof r = Tstruct id a -> ge.(genv_cenv)!id = Some co -> field_offset ge f (co_members co) = OK delta -> - eval_simple_lvalue (Efield r f ty) b (Int.add ofs (Int.repr delta)) + eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) | esl_field_union: forall r f ty b ofs id co a, eval_simple_rvalue r (Vptr b ofs) -> typeof r = Tunion id a -> @@ -133,9 +133,9 @@ with eval_simple_rvalue: expr -> val -> Prop := sem_cast v1 (typeof r1) ty m = Some v -> eval_simple_rvalue (Ecast r1 ty) v | esr_sizeof: forall ty1 ty, - eval_simple_rvalue (Esizeof ty1 ty) (Vint (Int.repr (sizeof ge ty1))) + eval_simple_rvalue (Esizeof ty1 ty) (Vptrofs (Ptrofs.repr (sizeof ge ty1))) | esr_alignof: forall ty1 ty, - eval_simple_rvalue (Ealignof ty1 ty) (Vint (Int.repr (alignof ge ty1))). + eval_simple_rvalue (Ealignof ty1 ty) (Vptrofs (Ptrofs.repr (alignof ge ty1))). Inductive eval_simple_list: exprlist -> typelist -> list val -> Prop := | esrl_nil: @@ -813,13 +813,13 @@ Ltac StepR REC C' a := exists v; constructor. (* var *) exploit safe_inv; eauto; simpl. intros [b A]. - exists b; exists Int.zero. + exists b; exists Ptrofs.zero. intuition. apply esl_var_local; auto. apply esl_var_global; auto. (* field *) StepR IHa (fun x => C(Efield x f0 ty)) a. exploit safe_inv. eexact SAFE0. eauto. simpl. intros [b [ofs [EQ TY]]]. subst v. destruct (typeof a) eqn:?; try contradiction. - destruct TY as (co & delta & CE & OFS). exists b; exists (Int.add ofs (Int.repr delta)); econstructor; eauto. + destruct TY as (co & delta & CE & OFS). exists b; exists (Ptrofs.add ofs (Ptrofs.repr delta)); econstructor; eauto. destruct TY as (co & CE). exists b; exists ofs; econstructor; eauto. (* valof *) destruct (andb_prop _ _ S) as [S1 S2]. clear S. rewrite negb_true_iff in S2. diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index fd7a6b96..914328be 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -55,7 +55,7 @@ Inductive expr : Type := (**r function call [r1(rargs)] *) | Ebuiltin (ef: external_function) (tyargs: typelist) (rargs: exprlist) (ty: type) (**r builtin function call *) - | Eloc (b: block) (ofs: int) (ty: type) + | Eloc (b: block) (ofs: ptrofs) (ty: type) (**r memory location, result of evaluating a l-value *) | Eparen (r: expr) (tycast: type) (ty: type) (**r marked subexpression *) diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index 9faa6d40..0794743d 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -78,15 +78,19 @@ with typelist : Type := | Tnil: typelist | Tcons: type -> typelist -> typelist. +Lemma intsize_eq: forall (s1 s2: intsize), {s1=s2} + {s1<>s2}. +Proof. + decide equality. +Defined. + Lemma type_eq: forall (ty1 ty2: type), {ty1=ty2} + {ty1<>ty2} with typelist_eq: forall (tyl1 tyl2: typelist), {tyl1=tyl2} + {tyl1<>tyl2}. Proof. - assert (forall (x y: intsize), {x=y} + {x<>y}) by decide equality. assert (forall (x y: signedness), {x=y} + {x<>y}) by decide equality. assert (forall (x y: floatsize), {x=y} + {x<>y}) by decide equality. assert (forall (x y: attr), {x=y} + {x<>y}). { decide equality. decide equality. apply N.eq_dec. apply bool_dec. } - generalize ident_eq zeq bool_dec ident_eq; intros. + generalize ident_eq zeq bool_dec ident_eq intsize_eq; intros. decide equality. decide equality. decide equality. @@ -272,7 +276,7 @@ Fixpoint alignof (env: composite_env) (t: type) : Z := | Tlong _ _ => Archi.align_int64 | Tfloat F32 _ => 4 | Tfloat F64 _ => Archi.align_float64 - | Tpointer _ _ => 4 + | Tpointer _ _ => if Archi.ptr64 then 8 else 4 | Tarray t' _ _ => alignof env t' | Tfunction _ _ _ => 1 | Tstruct id _ | Tunion id _ => @@ -299,11 +303,11 @@ Proof. exists 1%nat; auto. exists 2%nat; auto. exists 0%nat; auto. - (exists 2%nat; reflexivity) || (exists 3%nat; reflexivity). + unfold Archi.align_int64. destruct Archi.ptr64; ((exists 2%nat; reflexivity) || (exists 3%nat; reflexivity)). destruct f. exists 2%nat; auto. - (exists 2%nat; reflexivity) || (exists 3%nat; reflexivity). - exists 2%nat; auto. + unfold Archi.align_float64. destruct Archi.ptr64; ((exists 2%nat; reflexivity) || (exists 3%nat; reflexivity)). + exists (if Archi.ptr64 then 3%nat else 2%nat); destruct Archi.ptr64; auto. apply IHt. exists 0%nat; auto. destruct (env!i). apply co_alignof_two_p. exists 0%nat; auto. @@ -335,7 +339,7 @@ Fixpoint sizeof (env: composite_env) (t: type) : Z := | Tlong _ _ => 8 | Tfloat F32 _ => 4 | Tfloat F64 _ => 8 - | Tpointer _ _ => 4 + | Tpointer _ _ => if Archi.ptr64 then 8 else 4 | Tarray t' n _ => sizeof env t' * Z.max 0 n | Tfunction _ _ _ => 1 | Tstruct id _ | Tunion id _ => @@ -348,6 +352,7 @@ Proof. induction t; simpl; try omega. destruct i; omega. destruct f; omega. + destruct Archi.ptr64; omega. change 0 with (0 * Z.max 0 z) at 2. apply Zmult_ge_compat_r. auto. xomega. destruct (env!i). apply co_sizeof_pos. omega. destruct (env!i). apply co_sizeof_pos. omega. @@ -370,8 +375,8 @@ Proof. induction t; intros [A B]; unfold alignof, align_attr; rewrite A; simpl. - apply Zdivide_refl. - destruct i; apply Zdivide_refl. -- exists (8 / Archi.align_int64); reflexivity. -- destruct f. apply Zdivide_refl. exists (8 / Archi.align_float64); reflexivity. +- exists (8 / Archi.align_int64). unfold Archi.align_int64; destruct Archi.ptr64; reflexivity. +- destruct f. apply Zdivide_refl. exists (8 / Archi.align_float64). unfold Archi.align_float64; destruct Archi.ptr64; reflexivity. - apply Zdivide_refl. - apply Z.divide_mul_l; auto. - apply Zdivide_refl. @@ -576,7 +581,7 @@ Definition access_mode (ty: type) : mode := | Tfloat F32 _ => By_value Mfloat32 | Tfloat F64 _ => By_value Mfloat64 | Tvoid => By_nothing - | Tpointer _ _ => By_value Mint32 + | Tpointer _ _ => By_value Mptr | Tarray _ _ _ => By_reference | Tfunction _ _ _ => By_reference | Tstruct _ _ => By_copy @@ -609,7 +614,7 @@ Fixpoint alignof_blockcopy (env: composite_env) (t: type) : Z := | Tlong _ _ => 8 | Tfloat F32 _ => 4 | Tfloat F64 _ => 8 - | Tpointer _ _ => 4 + | Tpointer _ _ => if Archi.ptr64 then 8 else 4 | Tarray t' _ _ => alignof_blockcopy env t' | Tfunction _ _ _ => 1 | Tstruct id _ | Tunion id _ => @@ -633,9 +638,14 @@ Proof. rewrite two_power_nat_two_p. rewrite ! inj_S. change 8 with (two_p 3). apply two_p_monotone. omega. } - induction ty; simpl; auto. + induction ty; simpl. + auto. destruct i; auto. + auto. destruct f; auto. + destruct Archi.ptr64; auto. + apply IHty. + auto. destruct (env!i); auto. destruct (env!i); auto. Qed. @@ -714,20 +724,16 @@ Fixpoint type_of_params (params: list (ident * type)) : typelist := Definition typ_of_type (t: type) : AST.typ := match t with - | Tfloat F32 _ => AST.Tsingle - | Tfloat _ _ => AST.Tfloat + | Tvoid => AST.Tint + | Tint _ _ _ => AST.Tint | Tlong _ _ => AST.Tlong - | _ => AST.Tint + | Tfloat F32 _ => AST.Tsingle + | Tfloat F64 _ => AST.Tfloat + | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _ | Tstruct _ _ | Tunion _ _ => AST.Tptr end. Definition opttyp_of_type (t: type) : option AST.typ := - match t with - | Tvoid => None - | Tfloat F32 _ => Some AST.Tsingle - | Tfloat _ _ => Some AST.Tfloat - | Tlong _ _ => Some AST.Tlong - | _ => Some AST.Tint - end. + if type_eq t Tvoid then None else Some (typ_of_type t). Fixpoint typlist_of_typelist (tl: typelist) : list AST.typ := match tl with diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v index 440e4e84..ba1d34fb 100644 --- a/cfrontend/Ctyping.v +++ b/cfrontend/Ctyping.v @@ -26,6 +26,12 @@ Local Open Scope error_monad_scope. Definition strict := false. Opaque strict. +Definition size_t : type := + if Archi.ptr64 then Tlong Unsigned noattr else Tint I32 Unsigned noattr. + +Definition ptrdiff_t : type := + if Archi.ptr64 then Tlong Signed noattr else Tint I32 Signed noattr. + (** * Operations over types *) (** The type of a member of a composite (struct or union). @@ -107,20 +113,14 @@ Definition type_binop (op: binary_operation) (ty1 ty2: type) : res type := match op with | Oadd => match classify_add ty1 ty2 with - | add_case_pi ty | add_case_ip ty - | add_case_pl ty | add_case_lp ty => OK (Tpointer ty noattr) + | add_case_pi ty _ | add_case_ip _ ty + | add_case_pl ty | add_case_lp ty => OK (Tpointer ty noattr) | add_default => binarith_type ty1 ty2 "operator +" end | Osub => match classify_sub ty1 ty2 with - | sub_case_pi ty | sub_case_pl ty => OK (Tpointer ty noattr) -(* - | sub_case_pp ty1 ty2 => - if type_eq (remove_attributes ty1) (remove_attributes ty2) - then OK (Tint I32 Signed noattr) - else Error (msg "operator - : incompatible pointer types") -*) - | sub_case_pp ty => OK (Tint I32 Signed noattr) + | sub_case_pi ty _ | sub_case_pl ty => OK (Tpointer ty noattr) + | sub_case_pp ty => OK ptrdiff_t | sub_default => binarith_type ty1 ty2 "operator infix -" end | Omul => binarith_type ty1 ty2 "operator infix *" @@ -281,9 +281,13 @@ Inductive wt_val : val -> type -> Prop := wt_int n sz sg -> wt_val (Vint n) (Tint sz sg a) | wt_val_ptr_int: forall b ofs sg a, + Archi.ptr64 = false -> wt_val (Vptr b ofs) (Tint I32 sg a) | wt_val_long: forall n sg a, wt_val (Vlong n) (Tlong sg a) + | wt_val_ptr_long: forall b ofs sg a, + Archi.ptr64 = true -> + wt_val (Vptr b ofs) (Tlong sg a) | wt_val_float: forall f a, wt_val (Vfloat f) (Tfloat F64 a) | wt_val_single: forall f a, @@ -291,7 +295,11 @@ Inductive wt_val : val -> type -> Prop := | wt_val_pointer: forall b ofs ty a, wt_val (Vptr b ofs) (Tpointer ty a) | wt_val_int_pointer: forall n ty a, + Archi.ptr64 = false -> wt_val (Vint n) (Tpointer ty a) + | wt_val_long_pointer: forall n ty a, + Archi.ptr64 = true -> + wt_val (Vlong n) (Tpointer ty a) | wt_val_array: forall b ofs ty sz a, wt_val (Vptr b ofs) (Tarray ty sz a) | wt_val_function: forall b ofs tyargs tyres cc, @@ -359,9 +367,9 @@ Inductive wt_rvalue : expr -> Prop := wt_cast (typeof r2) ty -> wt_cast (typeof r3) ty -> wt_rvalue (Econdition r1 r2 r3 ty) | wt_Esizeof: forall ty, - wt_rvalue (Esizeof ty (Tint I32 Unsigned noattr)) + wt_rvalue (Esizeof ty size_t) | wt_Ealignof: forall ty, - wt_rvalue (Ealignof ty (Tint I32 Unsigned noattr)) + wt_rvalue (Ealignof ty size_t) | wt_Eassign: forall l r, wt_lvalue l -> wt_rvalue r -> wt_cast (typeof r) (typeof l) -> wt_rvalue (Eassign l r (typeof l)) @@ -522,11 +530,10 @@ Hint Extern 1 (wt_int _ _ _) => reflexivity: ty. Ltac DestructCases := match goal with - | [H: match match ?x with _ => _ end with _ => _ end = Some _ |- _ ] => destruct x; DestructCases - | [H: match match ?x with _ => _ end with _ => _ end = OK _ |- _ ] => destruct x; DestructCases - | [H: match ?x with _ => _ end = OK _ |- _ ] => destruct x; DestructCases - | [H: match ?x with _ => _ end = Some _ |- _ ] => destruct x; DestructCases - | [H: match ?x with _ => _ end = OK _ |- _ ] => destruct x; DestructCases + | [H: match match ?x with _ => _ end with _ => _ end = Some _ |- _ ] => destruct x eqn:?; DestructCases + | [H: match match ?x with _ => _ end with _ => _ end = OK _ |- _ ] => destruct x eqn:?; DestructCases + | [H: match ?x with _ => _ end = OK _ |- _ ] => destruct x eqn:?; DestructCases + | [H: match ?x with _ => _ end = Some _ |- _ ] => destruct x eqn:?; DestructCases | [H: Some _ = Some _ |- _ ] => inv H; DestructCases | [H: None = Some _ |- _ ] => discriminate | [H: OK _ = OK _ |- _ ] => inv H; DestructCases @@ -628,11 +635,14 @@ Definition econst_int (n: int) (sg: signedness) : expr := (Eval (Vint n) (Tint I32 sg noattr)). Definition econst_ptr_int (n: int) (ty: type) : expr := - (Eval (Vint n) (Tpointer ty noattr)). + (Eval (if Archi.ptr64 then Vlong (Int64.repr (Int.unsigned n)) else Vint n) (Tpointer ty noattr)). Definition econst_long (n: int64) (sg: signedness) : expr := (Eval (Vlong n) (Tlong sg noattr)). +Definition econst_ptr_long (n: int64) (ty: type) : expr := + (Eval (if Archi.ptr64 then Vlong n else Vint (Int64.loword n)) (Tpointer ty noattr)). + Definition econst_float (n: float) : expr := (Eval (Vfloat n) (Tfloat F64 noattr)). @@ -684,10 +694,10 @@ Definition econdition' (r1 r2 r3: expr) (ty: type) : res expr := OK (Econdition r1 r2 r3 ty). Definition esizeof (ty: type) : expr := - Esizeof ty (Tint I32 Unsigned noattr). + Esizeof ty size_t. Definition ealignof (ty: type) : expr := - Ealignof ty (Tint I32 Unsigned noattr). + Ealignof ty size_t. Definition eassign (l r: expr) : res expr := do x1 <- check_lval l; do x2 <- check_rval r; @@ -954,7 +964,9 @@ Lemma binarith_type_cast: binarith_type t1 t2 m = OK t -> wt_cast t1 t /\ wt_cast t2 t. Proof. unfold wt_cast, binarith_type, classify_binarith; intros; DestructCases; - simpl; split; try congruence. destruct f; congruence. + simpl; split; try congruence; + try (destruct Archi.ptr64; congruence). + destruct f0; congruence. Qed. Lemma typeconv_cast: @@ -969,6 +981,16 @@ Proof. destruct i; auto. Qed. +Lemma wt_cast_int: + forall i1 s1 a1 i2 s2 a2, wt_cast (Tint i1 s1 a1) (Tint i2 s2 a2). +Proof. + intros; red; simpl. + destruct Archi.ptr64; [ | destruct (Ctypes.intsize_eq i2 I32)]. +- destruct i2; congruence. +- subst i2; congruence. +- destruct i2; congruence. +Qed. + Lemma type_combine_cast: forall t1 t2 t, type_combine t1 t2 = OK t -> @@ -980,9 +1002,9 @@ Proof. unfold wt_cast; destruct t1; try discriminate; destruct t2; simpl in H; inv H. - simpl; split; congruence. - destruct (intsize_eq i i0 && signedness_eq s s0); inv H3. - simpl; destruct i; split; congruence. + split; apply wt_cast_int. - destruct (signedness_eq s s0); inv H3. - simpl; split; congruence. + simpl; split; try congruence; destruct Archi.ptr64; congruence. - destruct (floatsize_eq f f0); inv H3. simpl; destruct f0; split; congruence. - monadInv H3. simpl; split; congruence. @@ -1006,11 +1028,14 @@ Proof. destruct (typeconv t1) eqn:T1; try discriminate; destruct (typeconv t2) eqn:T2; inv H; eauto using D, binarith_type_cast. - split; apply typeconv_cast; unfold wt_cast. - rewrite T1; simpl; congruence. rewrite T2; simpl; congruence. + rewrite T1; simpl; try congruence; destruct Archi.ptr64; congruence. + rewrite T2; simpl; try congruence; destruct Archi.ptr64; congruence. - split; apply typeconv_cast; unfold wt_cast. - rewrite T1; simpl; congruence. rewrite T2; simpl; congruence. + rewrite T1; simpl; try congruence; destruct Archi.ptr64; congruence. + rewrite T2; simpl; try congruence; destruct Archi.ptr64; congruence. - split; apply typeconv_cast; unfold wt_cast. - rewrite T1; simpl; congruence. rewrite T2; simpl; congruence. + rewrite T1; simpl; try congruence; destruct Archi.ptr64; congruence. + rewrite T2; simpl; try congruence; destruct Archi.ptr64; congruence. Qed. Section SOUNDNESS_CONSTRUCTORS. @@ -1063,7 +1088,7 @@ Qed. Lemma econst_ptr_int_sound: forall n ty, wt_expr ce e (econst_ptr_int n ty). Proof. - unfold econst_ptr_int; auto with ty. + unfold econst_ptr_int; intros. destruct Archi.ptr64 eqn:SF; auto with ty. Qed. Lemma econst_long_sound: @@ -1072,6 +1097,12 @@ Proof. unfold econst_long; auto with ty. Qed. +Lemma econst_ptr_long_sound: + forall n ty, wt_expr ce e (econst_ptr_long n ty). +Proof. + unfold econst_ptr_long; intros. destruct Archi.ptr64 eqn:SF; auto with ty. +Qed. + Lemma econst_float_sound: forall n, wt_expr ce e (econst_float n). Proof. @@ -1354,28 +1385,17 @@ Proof. - destruct (Int.eq n Int.zero); auto. Qed. -Hint Resolve pres_cast_int_int: ty. +Lemma wt_val_casted: + forall v ty, val_casted v ty -> wt_val v ty. +Proof. + induction 1; constructor; auto. +- rewrite <- H; apply pres_cast_int_int. +Qed. Lemma pres_sem_cast: forall m v2 ty2 v1 ty1, wt_val v1 ty1 -> sem_cast v1 ty1 ty2 m = Some v2 -> wt_val v2 ty2. Proof. - unfold sem_cast, classify_cast; induction 1; simpl; intros; DestructCases; auto with ty. -- constructor. apply (pres_cast_int_int I8 s). -- constructor. apply (pres_cast_int_int I16 s). -- destruct (Int.eq n Int.zero); auto with ty. -- constructor. apply (pres_cast_int_int I8 s). -- constructor. apply (pres_cast_int_int I16 s). -- destruct (Int64.eq n Int64.zero); auto with ty. -- constructor. apply (pres_cast_int_int I8 s). -- constructor. apply (pres_cast_int_int I16 s). -- destruct (Float.cmp Ceq f Float.zero); auto with ty. -- constructor. apply (pres_cast_int_int I8 s). -- constructor. apply (pres_cast_int_int I16 s). -- destruct (Float32.cmp Ceq f Float32.zero); auto with ty. -- constructor. reflexivity. -- destruct (Int.eq n Int.zero); auto with ty. -- constructor. reflexivity. -- constructor. reflexivity. + intros. apply wt_val_casted. eapply cast_val_is_casted; eauto. Qed. Lemma pres_sem_binarith: @@ -1459,6 +1479,8 @@ Proof with (try discriminate). - inv H; eauto. - DestructCases; eauto. - DestructCases; eauto. +- DestructCases; eauto. +- DestructCases; eauto. - unfold sem_binarith in H0. set (ty' := Cop.binarith_type (classify_binarith ty1 ty2)) in *. destruct (sem_cast v1 ty1 ty') as [v1'|]... @@ -1476,10 +1498,11 @@ Proof. intros until m; intros TY SEM WT1 WT2. destruct op; simpl in TY; simpl in SEM. - (* add *) - unfold sem_add in SEM; DestructCases; auto with ty. + unfold sem_add, sem_add_ptr_int, sem_add_ptr_long in SEM; DestructCases; auto with ty. eapply pres_sem_binarith; eauto; intros; exact I. - (* sub *) unfold sem_sub in SEM; DestructCases; auto with ty. + unfold ptrdiff_t, Vptrofs. destruct Archi.ptr64; auto with ty. eapply pres_sem_binarith; eauto; intros; exact I. - (* mul *) unfold sem_mul in SEM. eapply pres_sem_binarith; eauto; intros; exact I. @@ -1522,13 +1545,12 @@ Proof. intros until v; intros TY SEM WT1. destruct op; simpl in TY; simpl in SEM. - (* notbool *) - unfold sem_notbool in SEM; DestructCases. - destruct (Int.eq i Int.zero); constructor; auto with ty. - destruct (Float.cmp Ceq f Float.zero); constructor; auto with ty. - destruct (Float32.cmp Ceq f Float32.zero); constructor; auto with ty. - destruct (Int.eq i Int.zero); constructor; auto with ty. - constructor. constructor. - destruct (Int64.eq i Int64.zero); constructor; auto with ty. + unfold sem_notbool in SEM. + assert (A: ty = Tint I32 Signed noattr) by (destruct (classify_bool ty1); inv TY; auto). + assert (B: exists b, v = Val.of_bool b). + { destruct (bool_val v1 ty1 m); inv SEM. exists (negb b); auto. } + destruct B as [b B]. + rewrite A, B. destruct b; constructor; auto with ty. - (* notint *) unfold sem_notint in SEM; DestructCases; auto with ty. - (* neg *) @@ -1542,16 +1564,18 @@ Lemma wt_load_result: access_mode ty = By_value chunk -> wt_val (Val.load_result chunk v) ty. Proof. - intros until v; intros AC. destruct ty; simpl in AC; try discriminate. - destruct i; [destruct s|destruct s|idtac|idtac]; inv AC; simpl; destruct v; auto with ty. - constructor; red. apply Int.sign_ext_idem; omega. - constructor; red. apply Int.zero_ext_idem; omega. - constructor; red. apply Int.sign_ext_idem; omega. - constructor; red. apply Int.zero_ext_idem; omega. - constructor; red. apply Int.zero_ext_idem; omega. - inv AC; simpl; destruct v; auto with ty. - destruct f; inv AC; simpl; destruct v; auto with ty. - inv AC; simpl; destruct v; auto with ty. + unfold access_mode, Val.load_result. remember Archi.ptr64 as ptr64. + intros until v; intros AC. destruct ty; simpl in AC; try discriminate AC. +- destruct i; [destruct s|destruct s|idtac|idtac]; inv AC; simpl. + destruct v; auto with ty. constructor; red. apply Int.sign_ext_idem; omega. + destruct v; auto with ty. constructor; red. apply Int.zero_ext_idem; omega. + destruct v; auto with ty. constructor; red. apply Int.sign_ext_idem; omega. + destruct v; auto with ty. constructor; red. apply Int.zero_ext_idem; omega. + destruct Archi.ptr64 eqn:SF; destruct v; auto with ty. + destruct v; auto with ty. constructor; red. apply Int.zero_ext_idem; omega. +- inv AC. destruct Archi.ptr64 eqn:SF; destruct v; auto with ty. +- destruct f; inv AC; destruct v; auto with ty. +- inv AC. unfold Mptr. destruct Archi.ptr64 eqn:SF; destruct v; auto with ty. Qed. Lemma wt_decode_val: @@ -1560,19 +1584,26 @@ Lemma wt_decode_val: wt_val (decode_val chunk vl) ty. Proof. intros until vl; intros ACC. - destruct ty; simpl in ACC; try discriminate. -- destruct i; [destruct s|destruct s|idtac|idtac]; inv ACC; unfold decode_val; + assert (LR: forall v, wt_val (Val.load_result chunk v) ty) by (eauto using wt_load_result). + destruct ty; simpl in ACC; try discriminate. +- destruct i; [destruct s|destruct s|idtac|idtac]; inv ACC; unfold decode_val. destruct (proj_bytes vl); auto with ty. constructor; red. apply Int.sign_ext_idem; omega. + destruct (proj_bytes vl); auto with ty. constructor; red. apply Int.zero_ext_idem; omega. + destruct (proj_bytes vl); auto with ty. constructor; red. apply Int.sign_ext_idem; omega. + destruct (proj_bytes vl); auto with ty. constructor; red. apply Int.zero_ext_idem; omega. - apply wt_load_result. auto. + destruct (proj_bytes vl). auto with ty. destruct Archi.ptr64 eqn:SF; auto with ty. + destruct (proj_bytes vl); auto with ty. constructor; red. apply Int.zero_ext_idem; omega. -- inv ACC. unfold decode_val. destruct (proj_bytes vl); auto with ty. +- inv ACC. unfold decode_val. destruct (proj_bytes vl). auto with ty. + destruct Archi.ptr64 eqn:SF; auto with ty. - destruct f; inv ACC; unfold decode_val; destruct (proj_bytes vl); auto with ty. -- inv ACC. unfold decode_val. destruct (proj_bytes vl); auto with ty. - apply wt_load_result. auto. +- inv ACC. unfold decode_val. destruct (proj_bytes vl). + unfold Mptr in *. destruct Archi.ptr64 eqn:SF; auto with ty. + unfold Mptr in *. destruct Archi.ptr64 eqn:SF; auto with ty. Qed. Lemma wt_deref_loc: @@ -1604,15 +1635,19 @@ Qed. Lemma wt_bool_cast: forall ty, wt_bool ty -> wt_cast ty type_bool. Proof. - unfold wt_bool, wt_cast; unfold classify_bool; intros. destruct ty; simpl in *; try congruence. destruct f; congruence. + unfold wt_bool, wt_cast; unfold classify_bool; intros. + destruct ty; simpl in *; try congruence; + try (destruct Archi.ptr64; congruence). + destruct f; congruence. Qed. Lemma wt_cast_self: forall t1 t2, wt_cast t1 t2 -> wt_cast t2 t2. Proof. unfold wt_cast; intros. destruct t2; simpl in *; try congruence. - destruct i; congruence. - destruct f; congruence. +- apply (wt_cast_int i s a i s a). +- destruct Archi.ptr64; congruence. +- destruct f; congruence. Qed. Lemma binarith_type_int32s: @@ -1672,8 +1707,8 @@ Proof. - (* seqor false *) subst. constructor. auto. apply wt_bool_cast; auto. red; intros. inv H0; auto with ty. - (* condition *) constructor. destruct b; auto. destruct b; auto. red; auto. -- (* sizeof *) constructor; auto with ty. -- (* alignof *) constructor; auto with ty. +- (* sizeof *) unfold size_t, Vptrofs; destruct Archi.ptr64; constructor; auto with ty. +- (* alignof *) unfold size_t, Vptrofs; destruct Archi.ptr64; constructor; auto with ty. - (* assign *) inversion H5. constructor. eapply pres_sem_cast; eauto. - (* assignop *) subst tyres l r. constructor. auto. constructor. constructor. eapply wt_deref_loc; eauto. @@ -2105,7 +2140,7 @@ Proof. intros. inv H. econstructor. constructor. apply Genv.find_funct_ptr_prop with (p := prog) (b := b); auto. intros. inv WTPROG. destruct f0; simpl; auto. apply H4 with id; auto. - instantiate (1 := (Vptr b Int.zero)). rewrite Genv.find_funct_find_funct_ptr. auto. + instantiate (1 := (Vptr b Ptrofs.zero)). rewrite Genv.find_funct_find_funct_ptr. auto. Qed. End PRESERVATION. diff --git a/cfrontend/Initializers.v b/cfrontend/Initializers.v index 7228cd75..19518aea 100644 --- a/cfrontend/Initializers.v +++ b/cfrontend/Initializers.v @@ -12,18 +12,9 @@ (** Compile-time evaluation of initializers for global C variables. *) -Require Import Coqlib. -Require Import Maps. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import AST. -Require Import Memory. -Require Import Globalenvs. -Require Import Ctypes. -Require Import Cop. -Require Import Csyntax. +Require Import Coqlib Maps Errors. +Require Import Integers Floats Values AST Memory Globalenvs. +Require Import Ctypes Cop Csyntax. Open Scope error_monad_scope. @@ -38,7 +29,7 @@ Open Scope error_monad_scope. (** [constval a] evaluates the constant expression [a]. If [a] is a r-value, the returned value denotes: -- [Vint n], [Vfloat f]: the corresponding number +- [Vint n], [Vlong n], [Vfloat f], [Vsingle f]: the corresponding number - [Vptr id ofs]: address of global variable [id] plus byte offset [ofs] - [Vundef]: erroneous expression @@ -88,9 +79,9 @@ Fixpoint constval (ce: composite_env) (a: expr) : res val := | Ecast r ty => do v1 <- constval ce r; do_cast v1 (typeof r) ty | Esizeof ty1 ty => - OK (Vint (Int.repr (sizeof ce ty1))) + OK (Vptrofs (Ptrofs.repr (sizeof ce ty1))) | Ealignof ty1 ty => - OK (Vint (Int.repr (alignof ce ty1))) + OK (Vptrofs (Ptrofs.repr (alignof ce ty1))) | Eseqand r1 r2 ty => do v1 <- constval ce r1; do v2 <- constval ce r2; @@ -119,7 +110,7 @@ Fixpoint constval (ce: composite_env) (a: expr) : res val := | Ecomma r1 r2 ty => do v1 <- constval ce r1; constval ce r2 | Evar x ty => - OK(Vptr x Int.zero) + OK(Vptr x Ptrofs.zero) | Ederef r ty => constval ce r | Efield l f ty => @@ -128,7 +119,9 @@ Fixpoint constval (ce: composite_env) (a: expr) : res val := do co <- lookup_composite ce id; do delta <- field_offset ce f (co_members co); do v <- constval ce l; - OK (Val.add v (Vint (Int.repr delta))) + OK (if Archi.ptr64 + then Val.addl v (Vlong (Int64.repr delta)) + else Val.add v (Vint (Int.repr delta))) | Tunion id _ => constval ce l | _ => @@ -161,11 +154,13 @@ Definition transl_init_single (ce: composite_env) (ty: type) (a: expr) : res ini | Vint n, Tint (I8|IBool) sg _ => OK(Init_int8 n) | Vint n, Tint I16 sg _ => OK(Init_int16 n) | Vint n, Tint I32 sg _ => OK(Init_int32 n) - | Vint n, Tpointer _ _ => OK(Init_int32 n) + | Vint n, Tpointer _ _ => assertion (negb Archi.ptr64); OK(Init_int32 n) | Vlong n, Tlong _ _ => OK(Init_int64 n) + | Vlong n, Tpointer _ _ => assertion (Archi.ptr64); OK(Init_int64 n) | Vsingle f, Tfloat F32 _ => OK(Init_float32 f) | Vfloat f, Tfloat F64 _ => OK(Init_float64 f) - | Vptr id ofs, Tint I32 sg _ => OK(Init_addrof id ofs) + | Vptr id ofs, Tint I32 sg _ => assertion (negb Archi.ptr64); OK(Init_addrof id ofs) + | Vptr id ofs, Tlong _ _ => assertion (Archi.ptr64); OK(Init_addrof id ofs) | Vptr id ofs, Tpointer _ _ => OK(Init_addrof id ofs) | Vundef, _ => Error(msg "undefined operation in initializer") | _, _ => Error (msg "type mismatch in initializer") diff --git a/cfrontend/Initializersproof.v b/cfrontend/Initializersproof.v index d5f39d7d..fee25c48 100644 --- a/cfrontend/Initializersproof.v +++ b/cfrontend/Initializersproof.v @@ -12,21 +12,9 @@ (** Compile-time evaluation of initializers for global C variables. *) -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import AST. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Ctypes. -Require Import Cop. -Require Import Csyntax. -Require Import Csem. +Require Import Coqlib Maps. +Require Import Errors Integers Floats Values AST Memory Globalenvs Events Smallstep. +Require Import Ctypes Cop Csyntax Csem. Require Import Initializers. Open Scope error_monad_scope. @@ -77,23 +65,23 @@ Section SIMPLE_EXPRS. Variable e: env. Variable m: mem. -Inductive eval_simple_lvalue: expr -> block -> int -> Prop := +Inductive eval_simple_lvalue: expr -> block -> ptrofs -> Prop := | esl_loc: forall b ofs ty, eval_simple_lvalue (Eloc b ofs ty) b ofs | esl_var_local: forall x ty b, e!x = Some(b, ty) -> - eval_simple_lvalue (Evar x ty) b Int.zero + eval_simple_lvalue (Evar x ty) b Ptrofs.zero | esl_var_global: forall x ty b, e!x = None -> Genv.find_symbol ge x = Some b -> - eval_simple_lvalue (Evar x ty) b Int.zero + eval_simple_lvalue (Evar x ty) b Ptrofs.zero | esl_deref: forall r ty b ofs, eval_simple_rvalue r (Vptr b ofs) -> eval_simple_lvalue (Ederef r ty) b ofs | esl_field_struct: forall r f ty b ofs id co a delta, eval_simple_rvalue r (Vptr b ofs) -> typeof r = Tstruct id a -> ge.(genv_cenv)!id = Some co -> field_offset ge f (co_members co) = OK delta -> - eval_simple_lvalue (Efield r f ty) b (Int.add ofs (Int.repr delta)) + eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) | esl_field_union: forall r f ty b ofs id a, eval_simple_rvalue r (Vptr b ofs) -> typeof r = Tunion id a -> @@ -123,9 +111,9 @@ with eval_simple_rvalue: expr -> val -> Prop := sem_cast v1 (typeof r1) ty m = Some v -> eval_simple_rvalue (Ecast r1 ty) v | esr_sizeof: forall ty1 ty, - eval_simple_rvalue (Esizeof ty1 ty) (Vint (Int.repr (sizeof ge ty1))) + eval_simple_rvalue (Esizeof ty1 ty) (Vptrofs (Ptrofs.repr (sizeof ge ty1))) | esr_alignof: forall ty1 ty, - eval_simple_rvalue (Ealignof ty1 ty) (Vint (Int.repr (alignof ge ty1))) + eval_simple_rvalue (Ealignof ty1 ty) (Vptrofs (Ptrofs.repr (alignof ge ty1))) | esr_seqand_true: forall r1 r2 ty v1 v2 v3, eval_simple_rvalue r1 v1 -> bool_val v1 (typeof r1) m = Some true -> eval_simple_rvalue r2 v2 -> @@ -418,9 +406,9 @@ Proof. (* cast *) eapply sem_cast_match; eauto. (* sizeof *) - constructor. + auto. (* alignof *) - constructor. + auto. (* seqand *) destruct (bool_val x (typeof r1) Mem.empty) as [b|] eqn:E; inv EQ2. exploit bool_val_match. eexact E. eauto. instantiate (1 := m). intros E'. @@ -458,9 +446,10 @@ Proof. (* field struct *) rewrite H0 in CV. monadInv CV. unfold lookup_composite in EQ; rewrite H1 in EQ; monadInv EQ. exploit constval_rvalue; eauto. intro MV. inv MV. - simpl. replace x0 with delta by congruence. econstructor; eauto. - rewrite ! Int.add_assoc. f_equal. apply Int.add_commut. - simpl. auto. + replace x0 with delta by congruence. rewrite Ptrofs.add_assoc. rewrite (Ptrofs.add_commut (Ptrofs.repr delta0)). + simpl; destruct Archi.ptr64 eqn:SF; + econstructor; eauto; rewrite ! Ptrofs.add_assoc; f_equal; f_equal; symmetry; auto with ptrofs. + destruct Archi.ptr64; auto. (* field union *) rewrite H0 in CV. eauto. Qed. @@ -617,30 +606,36 @@ Proof. exploit sem_cast_match; eauto. intros D. unfold Genv.store_init_data. inv D. - (* int *) - destruct ty; try discriminate. - destruct i0; inv EQ2. +- (* int *) + remember Archi.ptr64 as ptr64. destruct ty; try discriminate EQ2. ++ destruct i0; inv EQ2. destruct s; simpl in H2; inv H2. rewrite <- Mem.store_signed_unsigned_8; auto. auto. destruct s; simpl in H2; inv H2. rewrite <- Mem.store_signed_unsigned_16; auto. auto. simpl in H2; inv H2. assumption. simpl in H2; inv H2. assumption. - inv EQ2. simpl in H2; inv H2. assumption. - (* long *) - destruct ty; inv EQ2. simpl in H2; inv H2. assumption. - (* float *) ++ destruct ptr64; inv EQ2. simpl in H2; unfold Mptr in H2; rewrite <- Heqptr64 in H2; inv H2. assumption. +- (* Long *) + remember Archi.ptr64 as ptr64. destruct ty; inv EQ2. ++ simpl in H2; inv H2. assumption. ++ simpl in H2; unfold Mptr in H2; destruct Archi.ptr64; inv H4. + inv H2; assumption. +- (* float *) destruct ty; try discriminate. destruct f1; inv EQ2; simpl in H2; inv H2; assumption. - (* single *) +- (* single *) destruct ty; try discriminate. destruct f1; inv EQ2; simpl in H2; inv H2; assumption. - (* pointer *) +- (* pointer *) unfold inj in H. - assert (data = Init_addrof b1 ofs1 /\ chunk = Mint32). - destruct ty; inv EQ2; inv H2. - destruct i; inv H5. intuition congruence. auto. + assert (data = Init_addrof b1 ofs1 /\ chunk = Mptr). + { remember Archi.ptr64 as ptr64. + destruct ty; inversion EQ2. + destruct i; inv H5. unfold Mptr. destruct Archi.ptr64; inv H6; inv H2; auto. + subst ptr64. unfold Mptr. destruct Archi.ptr64; inv H5; inv H2; auto. + inv H2. auto. } destruct H4; subst. destruct (Genv.find_symbol ge b1); inv H. - rewrite Int.add_zero in H3. auto. - (* undef *) + rewrite Ptrofs.add_zero in H3. auto. +- (* undef *) discriminate. Qed. @@ -651,19 +646,24 @@ Lemma transl_init_single_size: transl_init_single ge ty a = OK data -> init_data_size data = sizeof ge ty. Proof. - intros. monadInv H. destruct x0. + intros. monadInv H. remember Archi.ptr64 as ptr64. destruct x0. - monadInv EQ2. - destruct ty; try discriminate. destruct i0; inv EQ2; auto. - inv EQ2; auto. -- destruct ty; inv EQ2; auto. + destruct ptr64; inv EQ2. +Local Transparent sizeof. + unfold sizeof. rewrite <- Heqptr64; auto. +- destruct ty; inv EQ2; auto. + unfold sizeof. destruct Archi.ptr64; inv H0; auto. - destruct ty; try discriminate. destruct f0; inv EQ2; auto. - destruct ty; try discriminate. destruct f0; inv EQ2; auto. - destruct ty; try discriminate. destruct i0; inv EQ2; auto. - inv EQ2; auto. + destruct Archi.ptr64 eqn:SF; inv H0. simpl. rewrite SF; auto. + destruct ptr64; inv EQ2. simpl. rewrite <- Heqptr64; auto. + inv EQ2. unfold init_data_size, sizeof. auto. Qed. Notation idlsize := init_data_list_size. @@ -710,6 +710,7 @@ with tr_init_struct_size: sizeof_struct ge pos fl <= sizeof ge ty -> idlsize data + pos = sizeof ge ty. Proof. +Local Opaque sizeof. - destruct 1; simpl. + erewrite transl_init_single_size by eauto. omega. + Local Transparent sizeof. simpl. eapply tr_init_array_size; eauto. diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v index 64e52df8..ad7b296a 100644 --- a/cfrontend/SimplExprproof.v +++ b/cfrontend/SimplExprproof.v @@ -736,9 +736,15 @@ Remark sem_cast_deterministic: v1 = v2. Proof. unfold sem_cast; intros. destruct (classify_cast ty ty'); try congruence. - destruct v; try congruence. - destruct (Mem.weak_valid_pointer m1 b (Int.unsigned i)); inv H. - destruct (Mem.weak_valid_pointer m2 b (Int.unsigned i)); inv H0. +- destruct v; try congruence. + destruct Archi.ptr64; try discriminate. + destruct (Mem.weak_valid_pointer m1 b (Ptrofs.unsigned i)); inv H. + destruct (Mem.weak_valid_pointer m2 b (Ptrofs.unsigned i)); inv H0. + auto. +- destruct v; try congruence. + destruct (negb Archi.ptr64); try discriminate. + destruct (Mem.weak_valid_pointer m1 b (Ptrofs.unsigned i)); inv H. + destruct (Mem.weak_valid_pointer m2 b (Ptrofs.unsigned i)); inv H0. auto. Qed. @@ -756,9 +762,13 @@ Qed. Lemma static_bool_val_sound: forall v t m b, bool_val v t Mem.empty = Some b -> bool_val v t m = Some b. Proof. - intros until b; unfold bool_val. destruct (classify_bool t); destruct v; auto. - intros E. unfold Mem.weak_valid_pointer, Mem.valid_pointer, proj_sumbool in E. - rewrite ! pred_dec_false in E by (apply Mem.perm_empty). discriminate. + assert (A: forall b ofs, Mem.weak_valid_pointer Mem.empty b ofs = false). + { unfold Mem.weak_valid_pointer, Mem.valid_pointer, proj_sumbool; intros. + rewrite ! pred_dec_false by (apply Mem.perm_empty). auto. } + intros until b; unfold bool_val. + destruct (classify_bool t); destruct v; destruct Archi.ptr64 eqn:SF; auto. +- rewrite A; congruence. +- simpl; rewrite A; congruence. Qed. Lemma step_makeif: diff --git a/cfrontend/SimplLocals.v b/cfrontend/SimplLocals.v index 580f02c2..c0086a38 100644 --- a/cfrontend/SimplLocals.v +++ b/cfrontend/SimplLocals.v @@ -40,7 +40,7 @@ Definition is_liftable_var (cenv: compilenv) (a: expr) : option ident := Definition make_cast (a: expr) (tto: type) : expr := match classify_cast (typeof a) tto with - | cast_case_neutral => a + | cast_case_pointer => a | cast_case_i2i I32 _ => a | cast_case_f2f => a | cast_case_s2s => a diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v index 48a7a773..8ed924e5 100644 --- a/cfrontend/SimplLocalsproof.v +++ b/cfrontend/SimplLocalsproof.v @@ -187,21 +187,23 @@ Lemma val_casted_load_result: Val.load_result chunk v = v. Proof. intros. inversion H; clear H; subst v ty; simpl in H0. - destruct sz. +- destruct sz. destruct si; inversion H0; clear H0; subst chunk; simpl in *; congruence. destruct si; inversion H0; clear H0; subst chunk; simpl in *; congruence. clear H1. inv H0. auto. inversion H0; clear H0; subst chunk. simpl in *. destruct (Int.eq n Int.zero); subst n; reflexivity. - inv H0; auto. - inv H0; auto. - inv H0; auto. - inv H0; auto. - inv H0; auto. - inv H0; auto. - discriminate. - discriminate. - discriminate. +- inv H0; auto. +- inv H0; auto. +- inv H0; auto. +- inv H0. unfold Mptr, Val.load_result; destruct Archi.ptr64; auto. +- inv H0. unfold Mptr, Val.load_result; rewrite H1; auto. +- inv H0. unfold Val.load_result; rewrite H1; auto. +- inv H0. unfold Mptr, Val.load_result; rewrite H1; auto. +- inv H0. unfold Val.load_result; rewrite H1; auto. +- discriminate. +- discriminate. +- discriminate. Qed. Lemma val_casted_inject: @@ -209,7 +211,7 @@ Lemma val_casted_inject: Val.inject f v v' -> val_casted v ty -> val_casted v' ty. Proof. intros. inv H; auto. - inv H0; constructor. + inv H0; constructor; auto. inv H0; constructor. Qed. @@ -250,7 +252,7 @@ Proof. econstructor; eauto. unfold sem_cast, make_cast in *. destruct (classify_cast (typeof a) tto); auto. - destruct v1; inv H0; auto. + destruct v1; destruct Archi.ptr64; inv H0; auto. destruct sz2; auto. destruct v1; inv H0; auto. destruct v1; inv H0; auto. destruct v1; inv H0; auto. @@ -269,10 +271,19 @@ Lemma cast_typeconv: val_casted v ty -> sem_cast v ty (typeconv ty) m = Some v. Proof. - induction 1; simpl; auto. -- destruct sz; auto. -- unfold sem_cast. simpl. rewrite dec_eq_true; auto. + induction 1; simpl. +- unfold sem_cast, classify_cast; destruct sz, Archi.ptr64; auto. +- auto. +- auto. +- unfold sem_cast, classify_cast; destruct Archi.ptr64; auto. +- auto. +- unfold sem_cast; simpl; rewrite H; auto. +- unfold sem_cast; simpl; rewrite H; auto. +- unfold sem_cast; simpl; rewrite H; auto. +- unfold sem_cast; simpl; rewrite H; auto. +- unfold sem_cast; simpl. rewrite dec_eq_true; auto. - unfold sem_cast. simpl. rewrite dec_eq_true; auto. +- auto. Qed. Lemma step_Sdebug_temp: @@ -380,13 +391,13 @@ Lemma match_envs_assign_lifted: e!id = Some(b, ty) -> val_casted v ty -> Val.inject f v tv -> - assign_loc ge ty m b Int.zero v m' -> + assign_loc ge ty m b Ptrofs.zero v m' -> VSet.mem id cenv = true -> match_envs f cenv e le m' lo hi te (PTree.set id tv tle) tlo thi. Proof. intros. destruct H. generalize (me_vars0 id); intros MV; inv MV; try congruence. rewrite ENV in H0; inv H0. inv H3; try congruence. - unfold Mem.storev in H0. rewrite Int.unsigned_zero in H0. + unfold Mem.storev in H0. rewrite Ptrofs.unsigned_zero in H0. constructor; eauto; intros. (* vars *) destruct (peq id0 id). subst id0. @@ -746,7 +757,8 @@ Proof. unfold access_mode; intros. assert (size_chunk chunk = sizeof ge ty). { - destruct ty; try destruct i; try destruct s; try destruct f; inv H; auto. + destruct ty; try destruct i; try destruct s; try destruct f; inv H; auto; + unfold Mptr; simpl; destruct Archi.ptr64; auto. } omega. Qed. @@ -1019,10 +1031,10 @@ Proof. destruct (zeq (sizeof tge ty) 0). + (* special case size = 0 *) assert (bytes = nil). - { exploit (Mem.loadbytes_empty m bsrc (Int.unsigned osrc) (sizeof tge ty)). + { exploit (Mem.loadbytes_empty m bsrc (Ptrofs.unsigned osrc) (sizeof tge ty)). omega. congruence. } subst. - destruct (Mem.range_perm_storebytes tm bdst' (Int.unsigned (Int.add odst (Int.repr delta))) nil) + destruct (Mem.range_perm_storebytes tm bdst' (Ptrofs.unsigned (Ptrofs.add odst (Ptrofs.repr delta))) nil) as [tm' SB]. simpl. red; intros; omegaContradiction. exists tm'. @@ -1038,15 +1050,15 @@ Proof. exploit Mem.loadbytes_length; eauto. intros LEN. assert (SZPOS: sizeof tge ty > 0). { generalize (sizeof_pos tge ty); omega. } - assert (RPSRC: Mem.range_perm m bsrc (Int.unsigned osrc) (Int.unsigned osrc + sizeof tge ty) Cur Nonempty). + assert (RPSRC: Mem.range_perm m bsrc (Ptrofs.unsigned osrc) (Ptrofs.unsigned osrc + sizeof tge ty) Cur Nonempty). eapply Mem.range_perm_implies. eapply Mem.loadbytes_range_perm; eauto. auto with mem. - assert (RPDST: Mem.range_perm m bdst (Int.unsigned odst) (Int.unsigned odst + sizeof tge ty) Cur Nonempty). + assert (RPDST: Mem.range_perm m bdst (Ptrofs.unsigned odst) (Ptrofs.unsigned odst + sizeof tge ty) Cur Nonempty). replace (sizeof tge ty) with (Z_of_nat (length bytes)). eapply Mem.range_perm_implies. eapply Mem.storebytes_range_perm; eauto. auto with mem. rewrite LEN. apply nat_of_Z_eq. omega. - assert (PSRC: Mem.perm m bsrc (Int.unsigned osrc) Cur Nonempty). + assert (PSRC: Mem.perm m bsrc (Ptrofs.unsigned osrc) Cur Nonempty). apply RPSRC. omega. - assert (PDST: Mem.perm m bdst (Int.unsigned odst) Cur Nonempty). + assert (PDST: Mem.perm m bdst (Ptrofs.unsigned odst) Cur Nonempty). apply RPDST. omega. exploit Mem.address_inject. eauto. eexact PSRC. eauto. intros EQ1. exploit Mem.address_inject. eauto. eexact PDST. eauto. intros EQ2. @@ -1449,7 +1461,7 @@ Proof. rewrite ENV in H6; inv H6. inv H0; try congruence. assert (chunk0 = chunk). simpl in H. congruence. subst chunk0. - assert (v0 = v). unfold Mem.loadv in H2. rewrite Int.unsigned_zero in H2. congruence. subst v0. + assert (v0 = v). unfold Mem.loadv in H2. rewrite Ptrofs.unsigned_zero in H2. congruence. subst v0. exists tv; split; auto. constructor; auto. simpl in H; congruence. simpl in H; congruence. @@ -1464,13 +1476,13 @@ Proof. rewrite H1. exploit me_vars; eauto. instantiate (1 := id). intros MV. inv MV; try congruence. rewrite ENV in H; inv H. - exists b'; exists Int.zero; split. + exists b'; exists Ptrofs.zero; split. apply eval_Evar_local; auto. econstructor; eauto. (* global var *) rewrite H2. exploit me_vars; eauto. instantiate (1 := id). intros MV. inv MV; try congruence. - exists l; exists Int.zero; split. + exists l; exists Ptrofs.zero; split. apply eval_Evar_global. auto. rewrite <- H0. apply symbols_preserved. destruct GLOB as [bound GLOB1]. inv GLOB1. econstructor; eauto. @@ -1484,7 +1496,7 @@ Proof. inversion B. subst. econstructor; econstructor; split. eapply eval_Efield_struct; eauto. rewrite typeof_simpl_expr; eauto. - econstructor; eauto. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + econstructor; eauto. repeat rewrite Ptrofs.add_assoc. decEq. apply Ptrofs.add_commut. (* field union *) rewrite <- comp_env_preserved in *. exploit eval_simpl_expr; eauto. intros [tv [A B]]. @@ -1721,12 +1733,12 @@ Lemma match_cont_find_funct: exists tfd, Genv.find_funct tge tvf = Some tfd /\ transf_fundef fd = OK tfd. Proof. intros. exploit match_cont_globalenv; eauto. intros [bound1 MG]. destruct MG. - inv H1; simpl in H0; try discriminate. destruct (Int.eq_dec ofs1 Int.zero); try discriminate. + inv H1; simpl in H0; try discriminate. destruct (Ptrofs.eq_dec ofs1 Ptrofs.zero); try discriminate. subst ofs1. assert (f b1 = Some(b1, 0)). apply DOMAIN. eapply FUNCTIONS; eauto. rewrite H1 in H2; inv H2. - rewrite Int.add_zero. simpl. rewrite dec_eq_true. apply function_ptr_translated; auto. + rewrite Ptrofs.add_zero. simpl. rewrite dec_eq_true. apply function_ptr_translated; auto. Qed. (** Relating execution states *) diff --git a/common/AST.v b/common/AST.v index ae7178f4..e6fdec3c 100644 --- a/common/AST.v +++ b/common/AST.v @@ -18,6 +18,7 @@ Require Import String. Require Import Coqlib Maps Errors Integers Floats. +Require Archi. Set Implicit Arguments. @@ -50,6 +51,8 @@ Definition opt_typ_eq: forall (t1 t2: option typ), {t1=t2} + {t1<>t2} Definition list_typ_eq: forall (l1 l2: list typ), {l1=l2} + {l1<>l2} := list_eq_dec typ_eq. +Definition Tptr : typ := if Archi.ptr64 then Tlong else Tint. + Definition typesize (ty: typ) : Z := match ty with | Tint => 4 @@ -63,6 +66,9 @@ Definition typesize (ty: typ) : Z := Lemma typesize_pos: forall ty, typesize ty > 0. Proof. destruct ty; simpl; omega. Qed. +Lemma typesize_Tptr: typesize Tptr = if Archi.ptr64 then 8 else 4. +Proof. unfold Tptr; destruct Archi.ptr64; auto. Qed. + (** All values of size 32 bits are also of type [Tany32]. All values are of type [Tany64]. This corresponds to the following subtyping relation over types. *) @@ -150,6 +156,8 @@ Definition chunk_eq: forall (c1 c2: memory_chunk), {c1=c2} + {c1<>c2}. Proof. decide equality. Defined. Global Opaque chunk_eq. +Definition Mptr : memory_chunk := if Archi.ptr64 then Mint64 else Mint32. + (** The type (integer/pointer or float) of a chunk. *) Definition type_of_chunk (c: memory_chunk) : typ := @@ -166,6 +174,9 @@ Definition type_of_chunk (c: memory_chunk) : typ := | Many64 => Tany64 end. +Lemma type_of_Mptr: type_of_chunk Mptr = Tptr. +Proof. unfold Mptr, Tptr; destruct Archi.ptr64; auto. Qed. + (** The chunk that is appropriate to store and reload a value of the given type, without losing information. *) @@ -179,6 +190,9 @@ Definition chunk_of_type (ty: typ) := | Tany64 => Many64 end. +Lemma chunk_of_Tptr: chunk_of_type Tptr = Mptr. +Proof. unfold Mptr, Tptr; destruct Archi.ptr64; auto. Qed. + (** Initialization data for global variables. *) Inductive init_data: Type := @@ -189,7 +203,7 @@ Inductive init_data: Type := | Init_float32: float32 -> init_data | Init_float64: float -> init_data | Init_space: Z -> init_data - | Init_addrof: ident -> int -> init_data. (**r address of symbol + offset *) + | Init_addrof: ident -> ptrofs -> init_data. (**r address of symbol + offset *) Definition init_data_size (i: init_data) : Z := match i with @@ -199,7 +213,7 @@ Definition init_data_size (i: init_data) : Z := | Init_int64 _ => 8 | Init_float32 _ => 4 | Init_float64 _ => 8 - | Init_addrof _ _ => 4 + | Init_addrof _ _ => if Archi.ptr64 then 8 else 4 | Init_space n => Zmax n 0 end. @@ -212,7 +226,7 @@ Fixpoint init_data_list_size (il: list init_data) {struct il} : Z := Lemma init_data_size_pos: forall i, init_data_size i >= 0. Proof. - destruct i; simpl; xomega. + destruct i; simpl; try xomega. destruct Archi.ptr64; omega. Qed. Lemma init_data_list_size_pos: @@ -463,11 +477,11 @@ Definition ef_sig (ef: external_function): signature := | EF_external name sg => sg | EF_builtin name sg => sg | EF_runtime name sg => sg - | EF_vload chunk => mksignature (Tint :: nil) (Some (type_of_chunk chunk)) cc_default - | EF_vstore chunk => mksignature (Tint :: type_of_chunk chunk :: nil) None cc_default - | EF_malloc => mksignature (Tint :: nil) (Some Tint) cc_default - | EF_free => mksignature (Tint :: nil) None cc_default - | EF_memcpy sz al => mksignature (Tint :: Tint :: nil) None cc_default + | EF_vload chunk => mksignature (Tptr :: nil) (Some (type_of_chunk chunk)) cc_default + | EF_vstore chunk => mksignature (Tptr :: type_of_chunk chunk :: nil) None cc_default + | EF_malloc => mksignature (Tptr :: nil) (Some Tptr) cc_default + | EF_free => mksignature (Tptr :: nil) None cc_default + | EF_memcpy sz al => mksignature (Tptr :: Tptr :: nil) None cc_default | EF_annot text targs => mksignature targs None cc_default | EF_annot_val text targ => mksignature (targ :: nil) (Some targ) cc_default | EF_inline_asm text sg clob => sg @@ -609,10 +623,10 @@ Inductive builtin_arg (A: Type) : Type := | BA_long (n: int64) | BA_float (f: float) | BA_single (f: float32) - | BA_loadstack (chunk: memory_chunk) (ofs: int) - | BA_addrstack (ofs: int) - | BA_loadglobal (chunk: memory_chunk) (id: ident) (ofs: int) - | BA_addrglobal (id: ident) (ofs: int) + | BA_loadstack (chunk: memory_chunk) (ofs: ptrofs) + | BA_addrstack (ofs: ptrofs) + | BA_loadglobal (chunk: memory_chunk) (id: ident) (ofs: ptrofs) + | BA_addrglobal (id: ident) (ofs: ptrofs) | BA_splitlong (hi lo: builtin_arg A). Inductive builtin_res (A: Type) : Type := diff --git a/common/Determinism.v b/common/Determinism.v index a813dd92..7fa01c2d 100644 --- a/common/Determinism.v +++ b/common/Determinism.v @@ -42,18 +42,18 @@ Require Import Behaviors. CoInductive world: Type := World (io: string -> list eventval -> option (eventval * world)) - (vload: memory_chunk -> ident -> int -> option (eventval * world)) - (vstore: memory_chunk -> ident -> int -> eventval -> option world). + (vload: memory_chunk -> ident -> ptrofs -> option (eventval * world)) + (vstore: memory_chunk -> ident -> ptrofs -> eventval -> option world). Definition nextworld_io (w: world) (evname: string) (evargs: list eventval) : option (eventval * world) := match w with World io vl vs => io evname evargs end. -Definition nextworld_vload (w: world) (chunk: memory_chunk) (id: ident) (ofs: int) : +Definition nextworld_vload (w: world) (chunk: memory_chunk) (id: ident) (ofs: ptrofs) : option (eventval * world) := match w with World io vl vs => vl chunk id ofs end. -Definition nextworld_vstore (w: world) (chunk: memory_chunk) (id: ident) (ofs: int) (v: eventval): +Definition nextworld_vstore (w: world) (chunk: memory_chunk) (id: ident) (ofs: ptrofs) (v: eventval): option world := match w with World io vl vs => vs chunk id ofs v end. diff --git a/common/Events.v b/common/Events.v index c94d6d35..97d4f072 100644 --- a/common/Events.v +++ b/common/Events.v @@ -59,12 +59,12 @@ Inductive eventval: Type := | EVlong: int64 -> eventval | EVfloat: float -> eventval | EVsingle: float32 -> eventval - | EVptr_global: ident -> int -> eventval. + | EVptr_global: ident -> ptrofs -> eventval. Inductive event: Type := | Event_syscall: string -> list eventval -> eventval -> event - | Event_vload: memory_chunk -> ident -> int -> eventval -> event - | Event_vstore: memory_chunk -> ident -> int -> eventval -> event + | Event_vload: memory_chunk -> ident -> ptrofs -> eventval -> event + | Event_vstore: memory_chunk -> ident -> ptrofs -> eventval -> event | Event_annot: string -> list eventval -> event. (** The dynamic semantics for programs collect traces of events. @@ -278,7 +278,7 @@ Inductive eventval_match: eventval -> typ -> val -> Prop := | ev_match_ptr: forall id b ofs, Senv.public_symbol ge id = true -> Senv.find_symbol ge id = Some b -> - eventval_match (EVptr_global id ofs) Tint (Vptr b ofs). + eventval_match (EVptr_global id ofs) Tptr (Vptr b ofs). Inductive eventval_list_match: list eventval -> list typ -> list val -> Prop := | evl_match_nil: @@ -295,7 +295,7 @@ Lemma eventval_match_type: forall ev ty v, eventval_match ev ty v -> Val.has_type v ty. Proof. - intros. inv H; simpl; auto. + intros. inv H; simpl; auto. unfold Tptr; destruct Archi.ptr64; auto. Qed. Lemma eventval_list_match_length: @@ -359,7 +359,7 @@ Definition eventval_type (ev: eventval) : typ := | EVlong _ => Tlong | EVfloat _ => Tfloat | EVsingle _ => Tsingle - | EVptr_global id ofs => Tint + | EVptr_global id ofs => Tptr end. Lemma eventval_match_receptive: @@ -368,15 +368,23 @@ Lemma eventval_match_receptive: eventval_valid ev1 -> eventval_valid ev2 -> eventval_type ev1 = eventval_type ev2 -> exists v2, eventval_match ev2 ty v2. Proof. - intros. inv H; destruct ev2; simpl in H2; try discriminate. + intros. unfold eventval_type, Tptr in H2. remember Archi.ptr64 as ptr64. + inversion H; subst ev1 ty v1; clear H; destruct ev2; simpl in H2; inv H2. - exists (Vint i0); constructor. - simpl in H1; exploit Senv.public_symbol_exists; eauto. intros [b FS]. - exists (Vptr b i1); constructor; auto. + exists (Vptr b i1); rewrite H3. constructor; auto. - exists (Vlong i0); constructor. +- simpl in H1; exploit Senv.public_symbol_exists; eauto. intros [b FS]. + exists (Vptr b i1); rewrite H3; constructor; auto. - exists (Vfloat f0); constructor. +- destruct Archi.ptr64; discriminate. - exists (Vsingle f0); constructor; auto. -- exists (Vint i); constructor. -- simpl in H1. exploit Senv.public_symbol_exists. eexact H1. intros [b' FS]. +- destruct Archi.ptr64; discriminate. +- exists (Vint i); unfold Tptr; rewrite H5; constructor. +- exists (Vlong i); unfold Tptr; rewrite H5; constructor. +- destruct Archi.ptr64; discriminate. +- destruct Archi.ptr64; discriminate. +- exploit Senv.public_symbol_exists. eexact H1. intros [b' FS]. exists (Vptr b' i0); constructor; auto. Qed. @@ -458,7 +466,7 @@ Lemma eventval_match_inject: Proof. intros. inv H; inv H0; try constructor; auto. destruct symb_inj as (A & B & C & D). exploit C; eauto. intros [b3 [EQ FS]]. rewrite H4 in EQ; inv EQ. - rewrite Int.add_zero. constructor; auto. rewrite A; auto. + rewrite Ptrofs.add_zero. constructor; auto. rewrite A; auto. Qed. Lemma eventval_match_inject_2: @@ -469,7 +477,7 @@ Proof. intros. inv H; try (econstructor; split; eauto; constructor; fail). destruct symb_inj as (A & B & C & D). exploit C; eauto. intros [b2 [EQ FS]]. exists (Vptr b2 ofs); split. econstructor; eauto. - econstructor; eauto. rewrite Int.add_zero; auto. + econstructor; eauto. rewrite Ptrofs.add_zero; auto. Qed. Lemma eventval_list_match_inject: @@ -546,7 +554,7 @@ Fixpoint output_trace (t: trace) : Prop := (** * Semantics of volatile memory accesses *) Inductive volatile_load (ge: Senv.t): - memory_chunk -> mem -> block -> int -> trace -> val -> Prop := + memory_chunk -> mem -> block -> ptrofs -> trace -> val -> Prop := | volatile_load_vol: forall chunk m b ofs id ev v, Senv.block_is_volatile ge b = true -> Senv.find_symbol ge id = Some b -> @@ -556,11 +564,11 @@ Inductive volatile_load (ge: Senv.t): (Val.load_result chunk v) | volatile_load_nonvol: forall chunk m b ofs v, Senv.block_is_volatile ge b = false -> - Mem.load chunk m b (Int.unsigned ofs) = Some v -> + Mem.load chunk m b (Ptrofs.unsigned ofs) = Some v -> volatile_load ge chunk m b ofs E0 v. Inductive volatile_store (ge: Senv.t): - memory_chunk -> mem -> block -> int -> val -> trace -> mem -> Prop := + memory_chunk -> mem -> block -> ptrofs -> val -> trace -> mem -> Prop := | volatile_store_vol: forall chunk m b ofs id ev v, Senv.block_is_volatile ge b = true -> Senv.find_symbol ge id = Some b -> @@ -570,7 +578,7 @@ Inductive volatile_store (ge: Senv.t): m | volatile_store_nonvol: forall chunk m b ofs v m', Senv.block_is_volatile ge b = false -> - Mem.store chunk m b (Int.unsigned ofs) v = Some m' -> + Mem.store chunk m b (Ptrofs.unsigned ofs) v = Some m' -> volatile_store ge chunk m b ofs v E0 m'. (** * Semantics of external functions *) @@ -737,7 +745,7 @@ Proof. - (* volatile load *) inv VI. exploit B; eauto. intros [U V]. subst delta. exploit eventval_match_inject_2; eauto. intros (v2 & X & Y). - rewrite Int.add_zero. exists (Val.load_result chunk v2); split. + rewrite Ptrofs.add_zero. exists (Val.load_result chunk v2); split. constructor; auto. erewrite D; eauto. apply Val.load_result_inject. auto. @@ -762,7 +770,7 @@ Qed. Lemma volatile_load_ok: forall chunk, extcall_properties (volatile_load_sem chunk) - (mksignature (Tint :: nil) (Some (type_of_chunk chunk)) cc_default). + (mksignature (Tptr :: nil) (Some (type_of_chunk chunk)) cc_default). Proof. intros; constructor; intros. (* well typed *) @@ -880,7 +888,7 @@ Proof. inv VS. - (* volatile store *) inv AI. exploit Q; eauto. intros [A B]. subst delta. - rewrite Int.add_zero. exists m1'; split. + rewrite Ptrofs.add_zero. exists m1'; split. constructor; auto. erewrite S; eauto. eapply eventval_match_inject; eauto. apply Val.load_result_inject. auto. intuition auto with mem. @@ -894,7 +902,7 @@ Proof. unfold loc_unmapped; intros. inv AI; congruence. + eapply Mem.store_unchanged_on; eauto. unfold loc_out_of_reach; intros. red; intros. simpl in A. - assert (EQ: Int.unsigned (Int.add ofs (Int.repr delta)) = Int.unsigned ofs + delta) + assert (EQ: Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta)) = Ptrofs.unsigned ofs + delta) by (eapply Mem.address_inject; eauto with mem). rewrite EQ in *. eelim H3; eauto. @@ -913,7 +921,7 @@ Qed. Lemma volatile_store_ok: forall chunk, extcall_properties (volatile_store_sem chunk) - (mksignature (Tint :: type_of_chunk chunk :: nil) None cc_default). + (mksignature (Tptr :: type_of_chunk chunk :: nil) None cc_default). Proof. intros; constructor; intros. (* well typed *) @@ -951,19 +959,19 @@ Qed. Inductive extcall_malloc_sem (ge: Senv.t): list val -> mem -> trace -> val -> mem -> Prop := - | extcall_malloc_sem_intro: forall n m m' b m'', - Mem.alloc m (-4) (Int.unsigned n) = (m', b) -> - Mem.store Mint32 m' b (-4) (Vint n) = Some m'' -> - extcall_malloc_sem ge (Vint n :: nil) m E0 (Vptr b Int.zero) m''. + | extcall_malloc_sem_intro: forall sz m m' b m'', + Mem.alloc m (- size_chunk Mptr) (Ptrofs.unsigned sz) = (m', b) -> + Mem.store Mptr m' b (- size_chunk Mptr) (Vptrofs sz) = Some m'' -> + extcall_malloc_sem ge (Vptrofs sz :: nil) m E0 (Vptr b Ptrofs.zero) m''. Lemma extcall_malloc_ok: extcall_properties extcall_malloc_sem - (mksignature (Tint :: nil) (Some Tint) cc_default). + (mksignature (Tptr :: nil) (Some Tptr) cc_default). Proof. assert (UNCHANGED: - forall (P: block -> Z -> Prop) m n m' b m'', - Mem.alloc m (-4) (Int.unsigned n) = (m', b) -> - Mem.store Mint32 m' b (-4) (Vint n) = Some m'' -> + forall (P: block -> Z -> Prop) m lo hi v m' b m'', + Mem.alloc m lo hi = (m', b) -> + Mem.store Mptr m' b lo v = Some m'' -> Mem.unchanged_on P m m''). { intros. @@ -975,7 +983,7 @@ Proof. } constructor; intros. (* well typed *) -- inv H. unfold proj_sig_res; simpl. auto. +- inv H. unfold proj_sig_res, Tptr; simpl. destruct Archi.ptr64; auto. (* symbols preserved *) - inv H0; econstructor; eauto. (* valid block *) @@ -987,23 +995,28 @@ Proof. (* readonly *) - inv H. eapply UNCHANGED; eauto. (* mem extends *) -- inv H. inv H1. inv H5. inv H7. +- inv H. inv H1. inv H7. + assert (SZ: v2 = Vptrofs sz). + { unfold Vptrofs in *. destruct Archi.ptr64; inv H5; auto. } + subst v2. exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl. intros [m3' [A B]]. - exploit Mem.store_within_extends. eexact B. eauto. - instantiate (1 := Vint n). auto. + exploit Mem.store_within_extends. eexact B. eauto. eauto. intros [m2' [C D]]. - exists (Vptr b Int.zero); exists m2'; intuition. + exists (Vptr b Ptrofs.zero); exists m2'; intuition. econstructor; eauto. eapply UNCHANGED; eauto. (* mem injects *) -- inv H0. inv H2. inv H6. inv H8. +- inv H0. inv H2. inv H8. + assert (SZ: v' = Vptrofs sz). + { unfold Vptrofs in *. destruct Archi.ptr64; inv H6; auto. } + subst v'. exploit Mem.alloc_parallel_inject; eauto. apply Zle_refl. apply Zle_refl. intros [f' [m3' [b' [ALLOC [A [B [C D]]]]]]]. exploit Mem.store_mapped_inject. eexact A. eauto. eauto. - instantiate (1 := Vint n). auto. - intros [m2' [E G]]. - exists f'; exists (Vptr b' Int.zero); exists m2'; intuition. + instantiate (1 := Vptrofs sz). unfold Vptrofs; destruct Archi.ptr64; constructor. + rewrite Zplus_0_r. intros [m2' [E G]]. + exists f'; exists (Vptr b' Ptrofs.zero); exists m2'; intuition auto. econstructor; eauto. econstructor. eauto. auto. eapply UNCHANGED; eauto. @@ -1017,7 +1030,14 @@ Proof. - assert (t1 = t2). inv H; inv H0; auto. subst t2. exists vres1; exists m1; auto. (* determ *) -- inv H; inv H0. split. constructor. intuition congruence. +- inv H. simple inversion H0. + assert (EQ2: sz0 = sz). + { unfold Vptrofs in H4; destruct Archi.ptr64 eqn:SF. + rewrite <- (Ptrofs.of_int64_to_int64 SF sz0), <- (Ptrofs.of_int64_to_int64 SF sz). congruence. + rewrite <- (Ptrofs.of_int_to_int SF sz0), <- (Ptrofs.of_int_to_int SF sz). congruence. + } + subst. + split. constructor. intuition congruence. Qed. (** ** Semantics of dynamic memory deallocation (free) *) @@ -1025,14 +1045,14 @@ Qed. Inductive extcall_free_sem (ge: Senv.t): list val -> mem -> trace -> val -> mem -> Prop := | extcall_free_sem_intro: forall b lo sz m m', - Mem.load Mint32 m b (Int.unsigned lo - 4) = Some (Vint sz) -> - Int.unsigned sz > 0 -> - Mem.free m b (Int.unsigned lo - 4) (Int.unsigned lo + Int.unsigned sz) = Some m' -> + Mem.load Mptr m b (Ptrofs.unsigned lo - size_chunk Mptr) = Some (Vptrofs sz) -> + Ptrofs.unsigned sz > 0 -> + Mem.free m b (Ptrofs.unsigned lo - size_chunk Mptr) (Ptrofs.unsigned lo + Ptrofs.unsigned sz) = Some m' -> extcall_free_sem ge (Vptr b lo :: nil) m E0 Vundef m'. Lemma extcall_free_ok: extcall_properties extcall_free_sem - (mksignature (Tint :: nil) None cc_default). + (mksignature (Tptr :: nil) None cc_default). Proof. constructor; intros. (* well typed *) @@ -1050,7 +1070,10 @@ Proof. eapply Mem.free_range_perm; eauto. (* mem extends *) - inv H. inv H1. inv H8. inv H6. - exploit Mem.load_extends; eauto. intros [vsz [A B]]. inv B. + exploit Mem.load_extends; eauto. intros [v' [A B]]. + assert (v' = Vptrofs sz). + { unfold Vptrofs in *; destruct Archi.ptr64; inv B; auto. } + subst v'. exploit Mem.free_parallel_extends; eauto. intros [m2' [C D]]. exists Vundef; exists m2'; intuition. econstructor; eauto. @@ -1062,26 +1085,30 @@ Proof. tauto. (* mem inject *) - inv H0. inv H2. inv H7. inv H9. - exploit Mem.load_inject; eauto. intros [vsz [A B]]. inv B. - assert (Mem.range_perm m1 b (Int.unsigned lo - 4) (Int.unsigned lo + Int.unsigned sz) Cur Freeable). + exploit Mem.load_inject; eauto. intros [v' [A B]]. + assert (v' = Vptrofs sz). + { unfold Vptrofs in *; destruct Archi.ptr64; inv B; auto. } + subst v'. + assert (P: Mem.range_perm m1 b (Ptrofs.unsigned lo - size_chunk Mptr) (Ptrofs.unsigned lo + Ptrofs.unsigned sz) Cur Freeable). eapply Mem.free_range_perm; eauto. exploit Mem.address_inject; eauto. apply Mem.perm_implies with Freeable; auto with mem. - apply H0. instantiate (1 := lo). omega. + apply P. instantiate (1 := lo). + generalize (size_chunk_pos Mptr); omega. intro EQ. exploit Mem.free_parallel_inject; eauto. intros (m2' & C & D). exists f, Vundef, m2'; split. apply extcall_free_sem_intro with (sz := sz) (m' := m2'). rewrite EQ. rewrite <- A. f_equal. omega. - auto. + auto. auto. rewrite ! EQ. rewrite <- C. f_equal; omega. split. auto. split. auto. split. eapply Mem.free_unchanged_on; eauto. unfold loc_unmapped. intros; congruence. split. eapply Mem.free_unchanged_on; eauto. unfold loc_out_of_reach. - intros. red; intros. eelim H7; eauto. + intros. red; intros. eelim H2; eauto. apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. - apply H0. omega. + apply P. omega. split. auto. red; intros. congruence. (* trace length *) @@ -1090,7 +1117,15 @@ Proof. - assert (t1 = t2). inv H; inv H0; auto. subst t2. exists vres1; exists m1; auto. (* determ *) -- inv H; inv H0. split. constructor. intuition congruence. +- inv H; inv H0. + assert (EQ1: Vptrofs sz0 = Vptrofs sz) by congruence. + assert (EQ2: sz0 = sz). + { unfold Vptrofs in EQ1; destruct Archi.ptr64 eqn:SF. + rewrite <- (Ptrofs.of_int64_to_int64 SF sz0), <- (Ptrofs.of_int64_to_int64 SF sz). congruence. + rewrite <- (Ptrofs.of_int_to_int SF sz0), <- (Ptrofs.of_int_to_int SF sz). congruence. + } + subst sz0. + split. constructor. intuition congruence. Qed. (** ** Semantics of [memcpy] operations. *) @@ -1099,19 +1134,19 @@ Inductive extcall_memcpy_sem (sz al: Z) (ge: Senv.t): list val -> mem -> trace -> val -> mem -> Prop := | extcall_memcpy_sem_intro: forall bdst odst bsrc osrc m bytes m', al = 1 \/ al = 2 \/ al = 4 \/ al = 8 -> sz >= 0 -> (al | sz) -> - (sz > 0 -> (al | Int.unsigned osrc)) -> - (sz > 0 -> (al | Int.unsigned odst)) -> - bsrc <> bdst \/ Int.unsigned osrc = Int.unsigned odst - \/ Int.unsigned osrc + sz <= Int.unsigned odst - \/ Int.unsigned odst + sz <= Int.unsigned osrc -> - Mem.loadbytes m bsrc (Int.unsigned osrc) sz = Some bytes -> - Mem.storebytes m bdst (Int.unsigned odst) bytes = Some m' -> + (sz > 0 -> (al | Ptrofs.unsigned osrc)) -> + (sz > 0 -> (al | Ptrofs.unsigned odst)) -> + bsrc <> bdst \/ Ptrofs.unsigned osrc = Ptrofs.unsigned odst + \/ Ptrofs.unsigned osrc + sz <= Ptrofs.unsigned odst + \/ Ptrofs.unsigned odst + sz <= Ptrofs.unsigned osrc -> + Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz = Some bytes -> + Mem.storebytes m bdst (Ptrofs.unsigned odst) bytes = Some m' -> extcall_memcpy_sem sz al ge (Vptr bdst odst :: Vptr bsrc osrc :: nil) m E0 Vundef m'. Lemma extcall_memcpy_ok: forall sz al, extcall_properties (extcall_memcpy_sem sz al) - (mksignature (Tint :: Tint :: nil) None cc_default). + (mksignature (Tptr :: Tptr :: nil) None cc_default). Proof. intros. constructor. - (* return type *) @@ -1147,9 +1182,9 @@ Proof. destruct (zeq sz 0). + (* special case sz = 0 *) assert (bytes = nil). - { exploit (Mem.loadbytes_empty m1 bsrc (Int.unsigned osrc) sz). omega. congruence. } + { exploit (Mem.loadbytes_empty m1 bsrc (Ptrofs.unsigned osrc) sz). omega. congruence. } subst. - destruct (Mem.range_perm_storebytes m1' b0 (Int.unsigned (Int.add odst (Int.repr delta0))) nil) + destruct (Mem.range_perm_storebytes m1' b0 (Ptrofs.unsigned (Ptrofs.add odst (Ptrofs.repr delta0))) nil) as [m2' SB]. simpl. red; intros; omegaContradiction. exists f, Vundef, m2'. @@ -1168,15 +1203,15 @@ Proof. red; intros; congruence. + (* general case sz > 0 *) exploit Mem.loadbytes_length; eauto. intros LEN. - assert (RPSRC: Mem.range_perm m1 bsrc (Int.unsigned osrc) (Int.unsigned osrc + sz) Cur Nonempty). + assert (RPSRC: Mem.range_perm m1 bsrc (Ptrofs.unsigned osrc) (Ptrofs.unsigned osrc + sz) Cur Nonempty). eapply Mem.range_perm_implies. eapply Mem.loadbytes_range_perm; eauto. auto with mem. - assert (RPDST: Mem.range_perm m1 bdst (Int.unsigned odst) (Int.unsigned odst + sz) Cur Nonempty). + assert (RPDST: Mem.range_perm m1 bdst (Ptrofs.unsigned odst) (Ptrofs.unsigned odst + sz) Cur Nonempty). replace sz with (Z_of_nat (length bytes)). eapply Mem.range_perm_implies. eapply Mem.storebytes_range_perm; eauto. auto with mem. rewrite LEN. apply nat_of_Z_eq. omega. - assert (PSRC: Mem.perm m1 bsrc (Int.unsigned osrc) Cur Nonempty). + assert (PSRC: Mem.perm m1 bsrc (Ptrofs.unsigned osrc) Cur Nonempty). apply RPSRC. omega. - assert (PDST: Mem.perm m1 bdst (Int.unsigned odst) Cur Nonempty). + assert (PDST: Mem.perm m1 bdst (Ptrofs.unsigned odst) Cur Nonempty). apply RPDST. omega. exploit Mem.address_inject. eauto. eexact PSRC. eauto. intros EQ1. exploit Mem.address_inject. eauto. eexact PDST. eauto. intros EQ2. @@ -1509,10 +1544,10 @@ Inductive eval_builtin_arg: builtin_arg A -> val -> Prop := | eval_BA_single: forall n, eval_builtin_arg (BA_single n) (Vsingle n) | eval_BA_loadstack: forall chunk ofs v, - Mem.loadv chunk m (Val.add sp (Vint ofs)) = Some v -> + Mem.loadv chunk m (Val.offset_ptr sp ofs) = Some v -> eval_builtin_arg (BA_loadstack chunk ofs) v | eval_BA_addrstack: forall ofs, - eval_builtin_arg (BA_addrstack ofs) (Val.add sp (Vint ofs)) + eval_builtin_arg (BA_addrstack ofs) (Val.offset_ptr sp ofs) | eval_BA_loadglobal: forall chunk id ofs v, Mem.loadv chunk m (Senv.symbol_address ge id ofs) = Some v -> eval_builtin_arg (BA_loadglobal chunk id ofs) v diff --git a/common/Globalenvs.v b/common/Globalenvs.v index 2a8d6d97..9affd634 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -93,17 +93,37 @@ Record t: Type := mksenv { forall b, block_is_volatile b = true -> Plt b nextblock }. -Definition symbol_address (ge: t) (id: ident) (ofs: int) : val := +Definition symbol_address (ge: t) (id: ident) (ofs: ptrofs) : val := match find_symbol ge id with | Some b => Vptr b ofs | None => Vundef end. Theorem shift_symbol_address: + forall ge id ofs delta, + symbol_address ge id (Ptrofs.add ofs delta) = Val.offset_ptr (symbol_address ge id ofs) delta. +Proof. + intros. unfold symbol_address, Val.offset_ptr. destruct (find_symbol ge id); auto. +Qed. + +Theorem shift_symbol_address_32: + forall ge id ofs n, + Archi.ptr64 = false -> + symbol_address ge id (Ptrofs.add ofs (Ptrofs.of_int n)) = Val.add (symbol_address ge id ofs) (Vint n). +Proof. + intros. unfold symbol_address. destruct (find_symbol ge id). +- unfold Val.add. rewrite H. auto. +- auto. +Qed. + +Theorem shift_symbol_address_64: forall ge id ofs n, - symbol_address ge id (Int.add ofs n) = Val.add (symbol_address ge id ofs) (Vint n). + Archi.ptr64 = true -> + symbol_address ge id (Ptrofs.add ofs (Ptrofs.of_int64 n)) = Val.addl (symbol_address ge id ofs) (Vlong n). Proof. - intros. unfold symbol_address. destruct (find_symbol ge id); auto. + intros. unfold symbol_address. destruct (find_symbol ge id). +- unfold Val.addl. rewrite H. auto. +- auto. Qed. Definition equiv (se1 se2: t) : Prop := @@ -146,7 +166,7 @@ Definition find_symbol (ge: t) (id: ident) : option block := with [id], at byte offset [ofs]. [Vundef] is returned if no block is associated to [id]. *) -Definition symbol_address (ge: t) (id: ident) (ofs: int) : val := +Definition symbol_address (ge: t) (id: ident) (ofs: ptrofs) : val := match find_symbol ge id with | Some b => Vptr b ofs | None => Vundef @@ -176,7 +196,7 @@ Definition find_funct_ptr (ge: t) (b: block) : option F := Definition find_funct (ge: t) (v: val) : option F := match v with - | Vptr b ofs => if Int.eq_dec ofs Int.zero then find_funct_ptr ge b else None + | Vptr b ofs => if Ptrofs.eq_dec ofs Ptrofs.zero then find_funct_ptr ge b else None | _ => None end. @@ -341,25 +361,45 @@ Proof. Qed. Theorem shift_symbol_address: + forall ge id ofs delta, + symbol_address ge id (Ptrofs.add ofs delta) = Val.offset_ptr (symbol_address ge id ofs) delta. +Proof. + intros. unfold symbol_address, Val.offset_ptr. destruct (find_symbol ge id); auto. +Qed. + +Theorem shift_symbol_address_32: forall ge id ofs n, - symbol_address ge id (Int.add ofs n) = Val.add (symbol_address ge id ofs) (Vint n). + Archi.ptr64 = false -> + symbol_address ge id (Ptrofs.add ofs (Ptrofs.of_int n)) = Val.add (symbol_address ge id ofs) (Vint n). Proof. - intros. unfold symbol_address. destruct (find_symbol ge id); auto. + intros. unfold symbol_address. destruct (find_symbol ge id). +- unfold Val.add. rewrite H. auto. +- auto. +Qed. + +Theorem shift_symbol_address_64: + forall ge id ofs n, + Archi.ptr64 = true -> + symbol_address ge id (Ptrofs.add ofs (Ptrofs.of_int64 n)) = Val.addl (symbol_address ge id ofs) (Vlong n). +Proof. + intros. unfold symbol_address. destruct (find_symbol ge id). +- unfold Val.addl. rewrite H. auto. +- auto. Qed. Theorem find_funct_inv: forall ge v f, - find_funct ge v = Some f -> exists b, v = Vptr b Int.zero. + find_funct ge v = Some f -> exists b, v = Vptr b Ptrofs.zero. Proof. intros until f; unfold find_funct. destruct v; try congruence. - destruct (Int.eq_dec i Int.zero); try congruence. + destruct (Ptrofs.eq_dec i Ptrofs.zero); try congruence. intros. exists b; congruence. Qed. Theorem find_funct_find_funct_ptr: forall ge b, - find_funct ge (Vptr b Int.zero) = find_funct_ptr ge b. + find_funct ge (Vptr b Ptrofs.zero) = find_funct_ptr ge b. Proof. intros; simpl. apply dec_eq_true. Qed. @@ -594,7 +634,7 @@ Definition store_init_data (m: mem) (b: block) (p: Z) (id: init_data) : option m | Init_addrof symb ofs => match find_symbol ge symb with | None => None - | Some b' => Mem.store Mint32 m b p (Vptr b' ofs) + | Some b' => Mem.store Mptr m b p (Vptr b' ofs) end | Init_space n => Some m end. @@ -824,7 +864,8 @@ Proof. try (eapply Mem.store_unchanged_on; eauto; fail). inv H; apply Mem.unchanged_on_refl. destruct (find_symbol ge i); try congruence. - eapply Mem.store_unchanged_on; eauto. + eapply Mem.store_unchanged_on; eauto; + unfold Mptr; destruct Archi.ptr64; eauto. Qed. Remark store_init_data_list_unchanged: @@ -886,11 +927,17 @@ Definition bytes_of_init_data (i: init_data): list memval := | Init_space n => list_repeat (Z.to_nat n) (Byte Byte.zero) | Init_addrof id ofs => match find_symbol ge id with - | Some b => inj_value Q32 (Vptr b ofs) - | None => list_repeat 4%nat Undef + | Some b => inj_value (if Archi.ptr64 then Q64 else Q32) (Vptr b ofs) + | None => list_repeat (if Archi.ptr64 then 8%nat else 4%nat) Undef end end. +Remark init_data_size_addrof: + forall id ofs, init_data_size (Init_addrof id ofs) = size_chunk Mptr. +Proof. + intros. unfold Mptr. simpl. destruct Archi.ptr64; auto. +Qed. + Lemma store_init_data_loadbytes: forall m b p i m', store_init_data m b p i = Some m' -> @@ -902,8 +949,10 @@ Proof. assert (EQ: Z.of_nat (Z.to_nat z) = Z.max z 0). { destruct (zle 0 z). rewrite Z2Nat.id; xomega. destruct z; try discriminate. simpl. xomega. } rewrite <- EQ. apply H0. omega. simpl. omega. -- simpl; destruct (find_symbol ge i) as [b'|]; try discriminate. - apply (Mem.loadbytes_store_same _ _ _ _ _ _ H). +- rewrite init_data_size_addrof. simpl. + destruct (find_symbol ge i) as [b'|]; try discriminate. + rewrite (Mem.loadbytes_store_same _ _ _ _ _ _ H). + unfold encode_val, Mptr; destruct Archi.ptr64; reflexivity. Qed. Fixpoint bytes_of_init_data_list (il: list init_data): list memval := @@ -999,8 +1048,8 @@ Fixpoint load_store_init_data (m: mem) (b: block) (p: Z) (il: list init_data) {s Mem.load Mfloat64 m b p = Some(Vfloat n) /\ load_store_init_data m b (p + 8) il' | Init_addrof symb ofs :: il' => - (exists b', find_symbol ge symb = Some b' /\ Mem.load Mint32 m b p = Some(Vptr b' ofs)) - /\ load_store_init_data m b (p + 4) il' + (exists b', find_symbol ge symb = Some b' /\ Mem.load Mptr m b p = Some(Vptr b' ofs)) + /\ load_store_init_data m b (p + size_chunk Mptr) il' | Init_space n :: il' => read_as_zero m b p n /\ load_store_init_data m b (p + Zmax n 0) il' @@ -1024,8 +1073,8 @@ Proof. eapply Mem.load_store_same; eauto. } induction il; simpl. - auto. - intros. destruct (store_init_data m b p a) as [m1|] eqn:?; try congruence. +- auto. +- intros. destruct (store_init_data m b p a) as [m1|] eqn:?; try congruence. exploit IHil; eauto. set (P := fun (b': block) ofs' => p + init_data_size a <= ofs'). apply read_as_zero_unchanged with (m := m) (P := P). @@ -1034,21 +1083,27 @@ Proof. intros; unfold P. omega. intros; unfold P. omega. intro D. - destruct a; simpl in Heqo; intuition. - eapply (A Mint8unsigned (Vint i)); eauto. - eapply (A Mint16unsigned (Vint i)); eauto. - eapply (A Mint32 (Vint i)); eauto. - eapply (A Mint64 (Vlong i)); eauto. - eapply (A Mfloat32 (Vsingle f)); eauto. - eapply (A Mfloat64 (Vfloat f)); eauto. + destruct a; simpl in Heqo. ++ split; auto. eapply (A Mint8unsigned (Vint i)); eauto. ++ split; auto. eapply (A Mint16unsigned (Vint i)); eauto. ++ split; auto. eapply (A Mint32 (Vint i)); eauto. ++ split; auto. eapply (A Mint64 (Vlong i)); eauto. ++ split; auto. eapply (A Mfloat32 (Vsingle f)); eauto. ++ split; auto. eapply (A Mfloat64 (Vfloat f)); eauto. ++ split; auto. set (P := fun (b': block) ofs' => ofs' < p + init_data_size (Init_space z)). inv Heqo. apply read_as_zero_unchanged with (m := m1) (P := P). red; intros. apply H0; auto. simpl. generalize (init_data_list_size_pos il); xomega. eapply store_init_data_list_unchanged; eauto. intros; unfold P. omega. intros; unfold P. simpl; xomega. - destruct (find_symbol ge i); try congruence. exists b0; split; auto. - eapply (A Mint32 (Vptr b0 i0)); eauto. ++ rewrite init_data_size_addrof in *. + split; auto. + destruct (find_symbol ge i); try congruence. + exists b0; split; auto. + transitivity (Some (Val.load_result Mptr (Vptr b0 i0))). + eapply (A Mptr (Vptr b0 i0)); eauto. + unfold Val.load_result, Mptr; destruct Archi.ptr64; auto. Qed. Remark alloc_global_unchanged: @@ -1324,7 +1379,7 @@ Proof. destruct (find_symbol ge i) as [b'|] eqn:E; try discriminate. eapply Mem.store_inject_neutral; eauto. econstructor. unfold Mem.flat_inj. apply pred_dec_true; auto. eauto. - rewrite Int.add_zero. auto. + rewrite Ptrofs.add_zero. auto. Qed. Lemma store_init_data_list_neutral: @@ -1417,7 +1472,7 @@ Definition init_data_alignment (i: init_data) : Z := | Init_int64 n => 8 | Init_float32 n => 4 | Init_float64 n => 4 - | Init_addrof symb ofs => 4 + | Init_addrof symb ofs => if Archi.ptr64 then 8 else 4 | Init_space n => 1 end. @@ -1444,7 +1499,8 @@ Proof. { intros. apply Mem.store_valid_access_3 in H0. destruct H0. congruence. } destruct i; simpl in H; eauto. simpl. apply Z.divide_1_l. - destruct (find_symbol ge i); try discriminate. eauto. + destruct (find_symbol ge i); try discriminate. eapply DFL. eassumption. + unfold Mptr, init_data_alignment; destruct Archi.ptr64; auto. Qed. Lemma store_init_data_list_aligned: @@ -1531,7 +1587,9 @@ Proof. exists m'; auto. } destruct i; eauto. simpl. exists m; auto. - simpl. exploit H1; eauto. intros (b1 & FS). rewrite FS. eauto. + simpl. exploit H1; eauto. intros (b1 & FS). rewrite FS. eapply DFL. + unfold init_data_size, Mptr. destruct Archi.ptr64; auto. + unfold init_data_alignment, Mptr. destruct Archi.ptr64; auto. Qed. Lemma store_init_data_list_exists: diff --git a/common/Memdata.v b/common/Memdata.v index 4ef7836b..87547e1e 100644 --- a/common/Memdata.v +++ b/common/Memdata.v @@ -68,6 +68,11 @@ Proof. intros; exists n; auto. Qed. +Lemma size_chunk_Mptr: size_chunk Mptr = if Archi.ptr64 then 8 else 4. +Proof. + unfold Mptr; destruct Archi.ptr64; auto. +Qed. + (** Memory reads and writes must respect alignment constraints: the byte offset of the location being addressed should be an exact multiple of the natural alignment for the chunk being addressed. @@ -98,6 +103,11 @@ Proof. intro. destruct chunk; simpl; omega. Qed. +Lemma align_chunk_Mptr: align_chunk Mptr = if Archi.ptr64 then 8 else 4. +Proof. + unfold Mptr; destruct Archi.ptr64; auto. +Qed. + Lemma align_size_chunk_divides: forall chunk, (align_chunk chunk | size_chunk chunk). Proof. @@ -360,8 +370,9 @@ Definition encode_val (chunk: memory_chunk) (v: val) : list memval := | Vint n, (Mint8signed | Mint8unsigned) => inj_bytes (encode_int 1%nat (Int.unsigned n)) | Vint n, (Mint16signed | Mint16unsigned) => inj_bytes (encode_int 2%nat (Int.unsigned n)) | Vint n, Mint32 => inj_bytes (encode_int 4%nat (Int.unsigned n)) - | Vptr b ofs, Mint32 => inj_value Q32 v + | Vptr b ofs, Mint32 => if Archi.ptr64 then list_repeat 4%nat Undef else inj_value Q32 v | Vlong n, Mint64 => inj_bytes (encode_int 8%nat (Int64.unsigned n)) + | Vptr b ofs, Mint64 => if Archi.ptr64 then inj_value Q64 v else list_repeat 8%nat Undef | Vsingle n, Mfloat32 => inj_bytes (encode_int 4%nat (Int.unsigned (Float32.to_bits n))) | Vfloat n, Mfloat64 => inj_bytes (encode_int 8%nat (Int64.unsigned (Float.to_bits n))) | _, Many32 => inj_value Q32 v @@ -386,19 +397,26 @@ Definition decode_val (chunk: memory_chunk) (vl: list memval) : val := end | None => match chunk with - | Mint32 | Many32 => Val.load_result chunk (proj_value Q32 vl) + | Mint32 => if Archi.ptr64 then Vundef else Val.load_result chunk (proj_value Q32 vl) + | Many32 => Val.load_result chunk (proj_value Q32 vl) + | Mint64 => if Archi.ptr64 then Val.load_result chunk (proj_value Q64 vl) else Vundef | Many64 => Val.load_result chunk (proj_value Q64 vl) | _ => Vundef end end. +Ltac solve_encode_val_length := + match goal with + | [ |- length (inj_bytes _) = _ ] => rewrite length_inj_bytes; solve_encode_val_length + | [ |- length (encode_int _ _) = _ ] => apply encode_int_length + | [ |- length (if ?x then _ else _) = _ ] => destruct x eqn:?; solve_encode_val_length + | _ => reflexivity + end. + Lemma encode_val_length: forall chunk v, length(encode_val chunk v) = size_chunk_nat chunk. Proof. - intros. destruct v; simpl; destruct chunk; - solve [ reflexivity - | apply length_list_repeat - | rewrite length_inj_bytes; apply encode_int_length ]. + intros. destruct v; simpl; destruct chunk; solve_encode_val_length. Qed. Lemma check_inj_value: @@ -447,13 +465,15 @@ Definition decode_encode_val (v1: val) (chunk1 chunk2: memory_chunk) (v2: val) : | Vint n, Mint16signed, Mint16unsigned => v2 = Vint(Int.zero_ext 16 n) | Vint n, Mint16unsigned, Mint16unsigned => v2 = Vint(Int.zero_ext 16 n) | Vint n, Mint32, Mint32 => v2 = Vint n - | Vint n, Many32, (Mint32 | Many32) => v2 = Vint n + | Vint n, Many32, Many32 => v2 = Vint n | Vint n, Mint32, Mfloat32 => v2 = Vsingle(Float32.of_bits n) | Vint n, Many64, Many64 => v2 = Vint n | Vint n, (Mint64 | Mfloat32 | Mfloat64 | Many64), _ => v2 = Vundef | Vint n, _, _ => True (**r nothing meaningful to say about v2 *) - | Vptr b ofs, (Mint32 | Many32), (Mint32 | Many32) => v2 = Vptr b ofs + | Vptr b ofs, (Mint32 | Many32), (Mint32 | Many32) => v2 = if Archi.ptr64 then Vundef else Vptr b ofs + | Vptr b ofs, Mint64, (Mint64 | Many64) => v2 = if Archi.ptr64 then Vptr b ofs else Vundef | Vptr b ofs, Many64, Many64 => v2 = Vptr b ofs + | Vptr b ofs, Many64, Mint64 => v2 = if Archi.ptr64 then Vptr b ofs else Vundef | Vptr b ofs, _, _ => v2 = Vundef | Vlong n, Mint64, Mint64 => v2 = Vlong n | Vlong n, Mint64, Mfloat64 => v2 = Vfloat(Float.of_bits n) @@ -476,7 +496,7 @@ Definition decode_encode_val (v1: val) (chunk1 chunk2: memory_chunk) (v2: val) : Remark decode_val_undef: forall bl chunk, decode_val chunk (Undef :: bl) = Vundef. Proof. - intros. unfold decode_val. simpl. destruct chunk; auto. + intros. unfold decode_val. simpl. destruct chunk, Archi.ptr64; auto. Qed. Remark proj_bytes_inj_value: @@ -485,33 +505,33 @@ Proof. intros. destruct q; reflexivity. Qed. +Ltac solve_decode_encode_val_general := + exact I || reflexivity || + match goal with + | |- context [ if Archi.ptr64 then _ else _ ] => destruct Archi.ptr64 eqn:? + | |- context [ proj_bytes (inj_bytes _) ] => rewrite proj_inj_bytes + | |- context [ proj_bytes (inj_value _ _) ] => rewrite proj_bytes_inj_value + | |- context [ proj_value _ (inj_value _ _) ] => rewrite ?proj_inj_value, ?proj_inj_value_mismatch by congruence + | |- context [ Int.repr(decode_int (encode_int 1 (Int.unsigned _))) ] => rewrite decode_encode_int_1 + | |- context [ Int.repr(decode_int (encode_int 2 (Int.unsigned _))) ] => rewrite decode_encode_int_2 + | |- context [ Int.repr(decode_int (encode_int 4 (Int.unsigned _))) ] => rewrite decode_encode_int_4 + | |- context [ Int64.repr(decode_int (encode_int 8 (Int64.unsigned _))) ] => rewrite decode_encode_int_8 + | |- Vint (Int.sign_ext _ (Int.sign_ext _ _)) = Vint _ => f_equal; apply Int.sign_ext_idem; omega + | |- Vint (Int.zero_ext _ (Int.zero_ext _ _)) = Vint _ => f_equal; apply Int.zero_ext_idem; omega + | |- Vint (Int.sign_ext _ (Int.zero_ext _ _)) = Vint _ => f_equal; apply Int.sign_ext_zero_ext; omega + end. + Lemma decode_encode_val_general: forall v chunk1 chunk2, decode_encode_val v chunk1 chunk2 (decode_val chunk2 (encode_val chunk1 v)). Proof. Opaque inj_value. intros. - destruct v; destruct chunk1 eqn:C1; simpl; try (apply decode_val_undef); - destruct chunk2 eqn:C2; unfold decode_val; auto; - try (rewrite proj_inj_bytes); try (rewrite proj_bytes_inj_value); - try (rewrite proj_inj_value); try (rewrite proj_inj_value_mismatch by congruence); - auto. - rewrite decode_encode_int_1. decEq. apply Int.sign_ext_zero_ext. omega. - rewrite decode_encode_int_1. decEq. apply Int.zero_ext_idem. omega. - rewrite decode_encode_int_1. decEq. apply Int.sign_ext_zero_ext. omega. - rewrite decode_encode_int_1. decEq. apply Int.zero_ext_idem. omega. - rewrite decode_encode_int_2. decEq. apply Int.sign_ext_zero_ext. omega. - rewrite decode_encode_int_2. decEq. apply Int.zero_ext_idem. omega. - rewrite decode_encode_int_2. decEq. apply Int.sign_ext_zero_ext. omega. - rewrite decode_encode_int_2. decEq. apply Int.zero_ext_idem. omega. - rewrite decode_encode_int_4. auto. - rewrite decode_encode_int_4. auto. - rewrite decode_encode_int_8. auto. - rewrite decode_encode_int_8. auto. - rewrite decode_encode_int_8. auto. - rewrite decode_encode_int_8. decEq. apply Float.of_to_bits. - rewrite decode_encode_int_4. auto. - rewrite decode_encode_int_4. decEq. apply Float32.of_to_bits. + destruct v; destruct chunk1 eqn:C1; try (apply decode_val_undef); + destruct chunk2 eqn:C2; unfold decode_encode_val, decode_val, encode_val, Val.load_result; + repeat solve_decode_encode_val_general. +- rewrite Float.of_to_bits; auto. +- rewrite Float32.of_to_bits; auto. Qed. Lemma decode_encode_val_similar: @@ -533,7 +553,9 @@ Proof. intros. unfold decode_val. destruct (proj_bytes cl). destruct chunk; simpl; auto. - destruct chunk; exact I || apply Val.load_result_type. +Local Opaque Val.load_result. + destruct chunk; simpl; + (exact I || apply Val.load_result_type || destruct Archi.ptr64; (exact I || apply Val.load_result_type)). Qed. Lemma encode_val_int8_signed_unsigned: @@ -601,7 +623,7 @@ Definition quantity_chunk (chunk: memory_chunk) := Inductive shape_encoding (chunk: memory_chunk) (v: val): list memval -> Prop := | shape_encoding_f: forall q i mvl, - (chunk = Mint32 \/ chunk = Many32 \/ chunk = Many64) -> + (chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) -> q = quantity_chunk chunk -> S i = size_quantity_nat q -> (forall mv, In mv mvl -> exists j, mv = Fragment v q j /\ S j <> size_quantity_nat q) -> @@ -628,7 +650,7 @@ Proof. } assert (B: forall q, q = quantity_chunk chunk -> - (chunk = Mint32 \/ chunk = Many32 \/ chunk = Many64) -> + (chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) -> shape_encoding chunk v (inj_value q v)). { Local Transparent inj_value. @@ -651,12 +673,15 @@ Local Transparent inj_value. intros. eapply in_list_repeat; eauto. } generalize (encode_val_length chunk v). intros LEN. - unfold encode_val; unfold encode_val in LEN; destruct v; destruct chunk; (apply B || apply C || apply D); auto; red; auto. + unfold encode_val; unfold encode_val in LEN; + destruct v; destruct chunk; + (apply B || apply C || apply D || (destruct Archi.ptr64; (apply B || apply D))); + auto. Qed. Inductive shape_decoding (chunk: memory_chunk): list memval -> val -> Prop := | shape_decoding_f: forall v q i mvl, - (chunk = Mint32 \/ chunk = Many32 \/ chunk = Many64) -> + (chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) -> q = quantity_chunk chunk -> S i = size_quantity_nat q -> (forall mv, In mv mvl -> exists j, mv = Fragment v q j /\ S j <> size_quantity_nat q) -> @@ -696,7 +721,7 @@ Proof. destruct chunk; auto. } assert (C: forall q, size_quantity_nat q = size_chunk_nat chunk -> - (chunk = Mint32 \/ chunk = Many32 \/ chunk = Many64) -> + (chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) -> shape_decoding chunk (mv1 :: mvl) (Val.load_result chunk (proj_value q (mv1 :: mvl)))). { intros. unfold proj_value. destruct mv1; auto. @@ -706,7 +731,7 @@ Proof. destruct (beq_nat sz n) eqn:EQN; auto. destruct (check_value sz v q mvl) eqn:CHECK; auto. simpl. apply beq_nat_true in EQN. subst n q0. constructor. auto. - destruct H0 as [E|[E|E]]; subst chunk; destruct q; auto || discriminate. + destruct H0 as [E|[E|[E|E]]]; subst chunk; destruct q; auto || discriminate. congruence. intros. eapply B; eauto. omega. } @@ -714,7 +739,7 @@ Proof. destruct (proj_bytes (mv1 :: mvl)) as [bl|] eqn:PB. exploit (A mv1); eauto with coqlib. intros [b1 EQ1]; subst mv1. destruct chunk; (apply shape_decoding_u || apply shape_decoding_b); eauto with coqlib. - destruct chunk; (apply shape_decoding_u || apply C); auto. + destruct chunk, Archi.ptr64; (apply shape_decoding_u || apply C); auto. Qed. (** * Compatibility with memory injections *) @@ -835,7 +860,7 @@ Proof. rewrite proj_value_undef. destruct chunk; auto. eapply proj_bytes_not_inject; eauto. congruence. apply Val.load_result_inject. apply proj_value_inject; auto. } - destruct chunk; auto. + destruct chunk; destruct Archi.ptr64; auto. Qed. (** Symmetrically, [encode_val], applied to values related by [Val.inject], @@ -883,10 +908,13 @@ Theorem encode_val_inject: Val.inject f v1 v2 -> list_forall2 (memval_inject f) (encode_val chunk v1) (encode_val chunk v2). Proof. +Local Opaque list_repeat. intros. inversion H; subst; simpl; destruct chunk; auto using inj_bytes_inject, inj_value_inject, repeat_Undef_inject_self, repeat_Undef_inject_encode_val. - unfold encode_val. destruct v2; apply inj_value_inject; auto. - unfold encode_val. destruct v2; apply inj_value_inject; auto. +- destruct Archi.ptr64; auto using inj_value_inject, repeat_Undef_inject_self. +- destruct Archi.ptr64; auto using inj_value_inject, repeat_Undef_inject_self. +- unfold encode_val. destruct v2; apply inj_value_inject; auto. +- unfold encode_val. destruct v2; apply inj_value_inject; auto. Qed. Definition memval_lessdef: memval -> memval -> Prop := memval_inject inject_id. @@ -964,20 +992,20 @@ Qed. Lemma decode_val_int64: forall l1 l2, - length l1 = 4%nat -> length l2 = 4%nat -> + length l1 = 4%nat -> length l2 = 4%nat -> Archi.ptr64 = false -> Val.lessdef (decode_val Mint64 (l1 ++ l2)) (Val.longofwords (decode_val Mint32 (if Archi.big_endian then l1 else l2)) (decode_val Mint32 (if Archi.big_endian then l2 else l1))). Proof. - intros. unfold decode_val. + intros. unfold decode_val. rewrite H1. rewrite proj_bytes_append. destruct (proj_bytes l1) as [b1|] eqn:B1; destruct (proj_bytes l2) as [b2|] eqn:B2; auto. exploit length_proj_bytes. eexact B1. rewrite H; intro L1. exploit length_proj_bytes. eexact B2. rewrite H0; intro L2. assert (UR: forall l, length l = 4%nat -> Int.unsigned (Int.repr (int_of_bytes l)) = int_of_bytes l). intros. apply Int.unsigned_repr. - generalize (int_of_bytes_range l). rewrite H1. + generalize (int_of_bytes_range l). rewrite H2. change (two_p (Z.of_nat 4 * 8)) with (Int.max_unsigned + 1). omega. apply Val.lessdef_same. @@ -1029,11 +1057,13 @@ Qed. Lemma encode_val_int64: forall v, + Archi.ptr64 = false -> encode_val Mint64 v = encode_val Mint32 (if Archi.big_endian then Val.hiword v else Val.loword v) ++ encode_val Mint32 (if Archi.big_endian then Val.loword v else Val.hiword v). Proof. - intros. destruct v; destruct Archi.big_endian eqn:BI; try reflexivity; + intros. unfold encode_val. rewrite H. + destruct v; destruct Archi.big_endian eqn:BI; try reflexivity; unfold Val.loword, Val.hiword, encode_val. unfold inj_bytes. rewrite <- map_app. f_equal. unfold encode_int, rev_if_be. rewrite BI. rewrite <- rev_app_distr. f_equal. diff --git a/common/Memory.v b/common/Memory.v index 672012be..d0cbe8a0 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -450,7 +450,7 @@ Definition load (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z): option val : Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val := match addr with - | Vptr b ofs => load chunk m b (Int.unsigned ofs) + | Vptr b ofs => load chunk m b (Ptrofs.unsigned ofs) | _ => None end. @@ -566,7 +566,7 @@ Qed. Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) : option mem := match addr with - | Vptr b ofs => store chunk m b (Int.unsigned ofs) v + | Vptr b ofs => store chunk m b (Ptrofs.unsigned ofs) v | _ => None end. @@ -873,7 +873,7 @@ Qed. Theorem load_int64_split: forall m b ofs v, - load Mint64 m b ofs = Some v -> + load Mint64 m b ofs = Some v -> Archi.ptr64 = false -> exists v1 v2, load Mint32 m b ofs = Some (if Archi.big_endian then v1 else v2) /\ load Mint32 m b (ofs + 4) = Some (if Archi.big_endian then v2 else v1) @@ -897,29 +897,47 @@ Proof. exists (decode_val Mint32 (if Archi.big_endian then bytes2 else bytes1)). split. destruct Archi.big_endian; auto. split. destruct Archi.big_endian; auto. - rewrite EQ. rewrite APP. apply decode_val_int64. + rewrite EQ. rewrite APP. apply decode_val_int64; auto. erewrite loadbytes_length; eauto. reflexivity. erewrite loadbytes_length; eauto. reflexivity. Qed. +Lemma addressing_int64_split: + forall i, + Archi.ptr64 = false -> + (8 | Ptrofs.unsigned i) -> + Ptrofs.unsigned (Ptrofs.add i (Ptrofs.of_int (Int.repr 4))) = Ptrofs.unsigned i + 4. +Proof. + intros. + rewrite Ptrofs.add_unsigned. + replace (Ptrofs.unsigned (Ptrofs.of_int (Int.repr 4))) with (Int.unsigned (Int.repr 4)) + by (symmetry; apply Ptrofs.agree32_of_int; auto). + change (Int.unsigned (Int.repr 4)) with 4. + apply Ptrofs.unsigned_repr. + exploit (Zdivide_interval (Ptrofs.unsigned i) Ptrofs.modulus 8). + omega. apply Ptrofs.unsigned_range. auto. + exists (two_p (Ptrofs.zwordsize - 3)). + unfold Ptrofs.modulus, Ptrofs.zwordsize, Ptrofs.wordsize. + unfold Wordsize_Ptrofs.wordsize. destruct Archi.ptr64; reflexivity. + unfold Ptrofs.max_unsigned. omega. +Qed. + Theorem loadv_int64_split: forall m a v, - loadv Mint64 m a = Some v -> + loadv Mint64 m a = Some v -> Archi.ptr64 = false -> exists v1 v2, loadv Mint32 m a = Some (if Archi.big_endian then v1 else v2) - /\ loadv Mint32 m (Val.add a (Vint (Int.repr 4))) = Some (if Archi.big_endian then v2 else v1) + /\ loadv Mint32 m (Val.add a (Vint (Int.repr 4))) = Some (if Archi.big_endian then v2 else v1) /\ Val.lessdef v (Val.longofwords v1 v2). Proof. - intros. destruct a; simpl in H; try discriminate. + intros. destruct a; simpl in H; inv H. exploit load_int64_split; eauto. intros (v1 & v2 & L1 & L2 & EQ). - assert (NV: Int.unsigned (Int.add i (Int.repr 4)) = Int.unsigned i + 4). - rewrite Int.add_unsigned. apply Int.unsigned_repr. - exploit load_valid_access. eexact H. intros [P Q]. simpl in Q. - exploit (Zdivide_interval (Int.unsigned i) Int.modulus 8). - omega. apply Int.unsigned_range. auto. exists (two_p (32-3)); reflexivity. - unfold Int.max_unsigned. omega. - exists v1; exists v2. -Opaque Int.repr. + unfold Val.add; rewrite H0. + assert (NV: Ptrofs.unsigned (Ptrofs.add i (Ptrofs.of_int (Int.repr 4))) = Ptrofs.unsigned i + 4). + { apply addressing_int64_split; auto. + exploit load_valid_access. eexact H2. intros [P Q]. auto. } + exists v1, v2. +Opaque Ptrofs.repr. split. auto. split. simpl. rewrite NV. auto. auto. @@ -1205,18 +1223,18 @@ Qed. Definition compat_pointer_chunks (chunk1 chunk2: memory_chunk) : Prop := match chunk1, chunk2 with | (Mint32 | Many32), (Mint32 | Many32) => True - | Many64, Many64 => True + | (Mint64 | Many64), (Mint64 | Many64) => True | _, _ => False end. Lemma compat_pointer_chunks_true: forall chunk1 chunk2, - (chunk1 = Mint32 \/ chunk1 = Many32 \/ chunk1 = Many64) -> - (chunk2 = Mint32 \/ chunk2 = Many32 \/ chunk2 = Many64) -> + (chunk1 = Mint32 \/ chunk1 = Many32 \/ chunk1 = Mint64 \/ chunk1 = Many64) -> + (chunk2 = Mint32 \/ chunk2 = Many32 \/ chunk2 = Mint64 \/ chunk2 = Many64) -> quantity_chunk chunk1 = quantity_chunk chunk2 -> compat_pointer_chunks chunk1 chunk2. Proof. - intros. destruct H as [P|[P|P]]; destruct H0 as [Q|[Q|Q]]; + intros. destruct H as [P|[P|[P|P]]]; destruct H0 as [Q|[Q|[Q|Q]]]; subst; red; auto; discriminate. Qed. @@ -1237,10 +1255,11 @@ Proof. destruct CASES as [(A & B) | [(A & B) | (A & B)]]. - (* Same offset *) subst. inv ENC. - assert (chunk = Mint32 \/ chunk = Many32 \/ chunk = Many64) + assert (chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) by (destruct chunk; auto || contradiction). left; split. rewrite H3. - destruct H4 as [P|[P|P]]; subst chunk'; destruct v0; simpl in H3; congruence. + destruct H4 as [P|[P|[P|P]]]; subst chunk'; destruct v0; simpl in H3; + try congruence; destruct Archi.ptr64; congruence. split. apply compat_pointer_chunks_true; auto. auto. - (* ofs' > ofs *) @@ -1612,7 +1631,7 @@ Qed. Theorem store_int64_split: forall m b ofs v m', - store Mint64 m b ofs v = Some m' -> + store Mint64 m b ofs v = Some m' -> Archi.ptr64 = false -> exists m1, store Mint32 m b ofs (if Archi.big_endian then Val.hiword v else Val.loword v) = Some m1 /\ store Mint32 m1 b (ofs + 4) (if Archi.big_endian then Val.loword v else Val.hiword v) = Some m'. @@ -1620,7 +1639,7 @@ Proof. intros. exploit store_valid_access_3; eauto. intros [A B]. simpl in *. exploit store_storebytes. eexact H. intros SB. - rewrite encode_val_int64 in SB. + rewrite encode_val_int64 in SB by auto. exploit storebytes_split. eexact SB. intros [m1 [SB1 SB2]]. rewrite encode_val_length in SB2. simpl in SB2. exists m1; split. @@ -1632,20 +1651,18 @@ Qed. Theorem storev_int64_split: forall m a v m', - storev Mint64 m a v = Some m' -> + storev Mint64 m a v = Some m' -> Archi.ptr64 = false -> exists m1, storev Mint32 m a (if Archi.big_endian then Val.hiword v else Val.loword v) = Some m1 /\ storev Mint32 m1 (Val.add a (Vint (Int.repr 4))) (if Archi.big_endian then Val.loword v else Val.hiword v) = Some m'. Proof. - intros. destruct a; simpl in H; try discriminate. + intros. destruct a; simpl in H; inv H. rewrite H2. exploit store_int64_split; eauto. intros [m1 [A B]]. exists m1; split. exact A. - unfold storev, Val.add. rewrite Int.add_unsigned. rewrite Int.unsigned_repr. exact B. - exploit store_valid_access_3. eexact H. intros [P Q]. simpl in Q. - exploit (Zdivide_interval (Int.unsigned i) Int.modulus 8). - omega. apply Int.unsigned_range. auto. exists (two_p (32-3)); reflexivity. - change (Int.unsigned (Int.repr 4)) with 4. unfold Int.max_unsigned. omega. + unfold storev, Val.add. rewrite H0. + rewrite addressing_int64_split; auto. + exploit store_valid_access_3. eexact H2. intros [P Q]. exact Q. Qed. (** ** Properties related to [alloc]. *) @@ -1811,7 +1828,8 @@ Theorem load_alloc_same: Proof. intros. exploit load_result; eauto. intro. rewrite H0. injection ALLOC; intros. rewrite <- H2; simpl. rewrite <- H1. - rewrite PMap.gss. destruct chunk; simpl; repeat rewrite ZMap.gi; reflexivity. + rewrite PMap.gss. destruct (size_chunk_nat_pos chunk) as [n E]. rewrite E. simpl. + rewrite ZMap.gi. apply decode_val_undef. Qed. Theorem load_alloc_same': @@ -3142,8 +3160,8 @@ Record inject' (f: meminj) (m1 m2: mem) : Prop := mi_representable: forall b b' delta ofs, f b = Some(b', delta) -> - perm m1 b (Int.unsigned ofs) Max Nonempty \/ perm m1 b (Int.unsigned ofs - 1) Max Nonempty -> - delta >= 0 /\ 0 <= Int.unsigned ofs + delta <= Int.max_unsigned; + perm m1 b (Ptrofs.unsigned ofs) Max Nonempty \/ perm m1 b (Ptrofs.unsigned ofs - 1) Max Nonempty -> + delta >= 0 /\ 0 <= Ptrofs.unsigned ofs + delta <= Ptrofs.max_unsigned; mi_perm_inv: forall b1 ofs b2 delta k p, f b1 = Some(b2, delta) -> @@ -3246,24 +3264,24 @@ Qed. Lemma address_inject: forall f m1 m2 b1 ofs1 b2 delta p, inject f m1 m2 -> - perm m1 b1 (Int.unsigned ofs1) Cur p -> + perm m1 b1 (Ptrofs.unsigned ofs1) Cur p -> f b1 = Some (b2, delta) -> - Int.unsigned (Int.add ofs1 (Int.repr delta)) = Int.unsigned ofs1 + delta. + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) = Ptrofs.unsigned ofs1 + delta. Proof. intros. - assert (perm m1 b1 (Int.unsigned ofs1) Max Nonempty) by eauto with mem. + assert (perm m1 b1 (Ptrofs.unsigned ofs1) Max Nonempty) by eauto with mem. exploit mi_representable; eauto. intros [A B]. - assert (0 <= delta <= Int.max_unsigned). - generalize (Int.unsigned_range ofs1). omega. - unfold Int.add. repeat rewrite Int.unsigned_repr; omega. + assert (0 <= delta <= Ptrofs.max_unsigned). + generalize (Ptrofs.unsigned_range ofs1). omega. + unfold Ptrofs.add. repeat rewrite Ptrofs.unsigned_repr; omega. Qed. Lemma address_inject': forall f m1 m2 chunk b1 ofs1 b2 delta, inject f m1 m2 -> - valid_access m1 chunk b1 (Int.unsigned ofs1) Nonempty -> + valid_access m1 chunk b1 (Ptrofs.unsigned ofs1) Nonempty -> f b1 = Some (b2, delta) -> - Int.unsigned (Int.add ofs1 (Int.repr delta)) = Int.unsigned ofs1 + delta. + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) = Ptrofs.unsigned ofs1 + delta. Proof. intros. destruct H0. eapply address_inject; eauto. apply H0. generalize (size_chunk_pos chunk). omega. @@ -3272,24 +3290,24 @@ Qed. Theorem weak_valid_pointer_inject_no_overflow: forall f m1 m2 b ofs b' delta, inject f m1 m2 -> - weak_valid_pointer m1 b (Int.unsigned ofs) = true -> + weak_valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> f b = Some(b', delta) -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. Proof. intros. rewrite weak_valid_pointer_spec in H0. rewrite ! valid_pointer_nonempty_perm in H0. exploit mi_representable; eauto. destruct H0; eauto with mem. intros [A B]. - pose proof (Int.unsigned_range ofs). - rewrite Int.unsigned_repr; omega. + pose proof (Ptrofs.unsigned_range ofs). + rewrite Ptrofs.unsigned_repr; omega. Qed. Theorem valid_pointer_inject_no_overflow: forall f m1 m2 b ofs b' delta, inject f m1 m2 -> - valid_pointer m1 b (Int.unsigned ofs) = true -> + valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> f b = Some(b', delta) -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. Proof. eauto using weak_valid_pointer_inject_no_overflow, valid_pointer_implies. Qed. @@ -3297,9 +3315,9 @@ Qed. Theorem valid_pointer_inject_val: forall f m1 m2 b ofs b' ofs', inject f m1 m2 -> - valid_pointer m1 b (Int.unsigned ofs) = true -> + valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> Val.inject f (Vptr b ofs) (Vptr b' ofs') -> - valid_pointer m2 b' (Int.unsigned ofs') = true. + valid_pointer m2 b' (Ptrofs.unsigned ofs') = true. Proof. intros. inv H1. erewrite address_inject'; eauto. @@ -3310,9 +3328,9 @@ Qed. Theorem weak_valid_pointer_inject_val: forall f m1 m2 b ofs b' ofs', inject f m1 m2 -> - weak_valid_pointer m1 b (Int.unsigned ofs) = true -> + weak_valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> Val.inject f (Vptr b ofs) (Vptr b' ofs') -> - weak_valid_pointer m2 b' (Int.unsigned ofs') = true. + weak_valid_pointer m2 b' (Ptrofs.unsigned ofs') = true. Proof. intros. inv H1. exploit weak_valid_pointer_inject; eauto. intros W. @@ -3320,8 +3338,8 @@ Proof. rewrite ! valid_pointer_nonempty_perm in H0. exploit mi_representable; eauto. destruct H0; eauto with mem. intros [A B]. - pose proof (Int.unsigned_range ofs). - unfold Int.add. repeat rewrite Int.unsigned_repr; auto; omega. + pose proof (Ptrofs.unsigned_range ofs). + unfold Ptrofs.add. repeat rewrite Ptrofs.unsigned_repr; auto; omega. Qed. Theorem inject_no_overlap: @@ -3341,13 +3359,13 @@ Theorem different_pointers_inject: forall f m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, inject f m m' -> b1 <> b2 -> - valid_pointer m b1 (Int.unsigned ofs1) = true -> - valid_pointer m b2 (Int.unsigned ofs2) = true -> + valid_pointer m b1 (Ptrofs.unsigned ofs1) = true -> + valid_pointer m b2 (Ptrofs.unsigned ofs2) = true -> f b1 = Some (b1', delta1) -> f b2 = Some (b2', delta2) -> b1' <> b2' \/ - Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> - Int.unsigned (Int.add ofs2 (Int.repr delta2)). + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> + Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). Proof. intros. rewrite valid_pointer_valid_access in H1. @@ -3356,8 +3374,8 @@ Proof. rewrite (address_inject' _ _ _ _ _ _ _ _ H H2 H4). inv H1. simpl in H5. inv H2. simpl in H1. eapply mi_no_overlap; eauto. - apply perm_cur_max. apply (H5 (Int.unsigned ofs1)). omega. - apply perm_cur_max. apply (H1 (Int.unsigned ofs2)). omega. + apply perm_cur_max. apply (H5 (Ptrofs.unsigned ofs1)). omega. + apply perm_cur_max. apply (H1 (Ptrofs.unsigned ofs2)). omega. Qed. Require Intv. @@ -3439,8 +3457,8 @@ Proof. intros. inv H1; simpl in H0; try discriminate. exploit load_inject; eauto. intros [v2 [LOAD INJ]]. exists v2; split; auto. unfold loadv. - replace (Int.unsigned (Int.add ofs1 (Int.repr delta))) - with (Int.unsigned ofs1 + delta). + replace (Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta))) + with (Ptrofs.unsigned ofs1 + delta). auto. symmetry. eapply address_inject'; eauto with mem. Qed. @@ -3547,8 +3565,8 @@ Theorem storev_mapped_inject: Proof. intros. inv H1; simpl in H0; try discriminate. unfold storev. - replace (Int.unsigned (Int.add ofs1 (Int.repr delta))) - with (Int.unsigned ofs1 + delta). + replace (Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta))) + with (Ptrofs.unsigned ofs1 + delta). eapply store_mapped_inject; eauto. symmetry. eapply address_inject'; eauto with mem. Qed. @@ -3740,8 +3758,8 @@ Theorem alloc_left_mapped_inject: inject f m1 m2 -> alloc m1 lo hi = (m1', b1) -> valid_block m2 b2 -> - 0 <= delta <= Int.max_unsigned -> - (forall ofs k p, perm m2 b2 ofs k p -> delta = 0 \/ 0 <= ofs < Int.max_unsigned) -> + 0 <= delta <= Ptrofs.max_unsigned -> + (forall ofs k p, perm m2 b2 ofs k p -> delta = 0 \/ 0 <= ofs < Ptrofs.max_unsigned) -> (forall ofs k p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) k p) -> inj_offset_aligned delta (hi-lo) -> (forall b delta' ofs k p, @@ -3803,10 +3821,10 @@ Proof. subst. injection H9; intros; subst b' delta0. destruct H10. exploit perm_alloc_inv; eauto; rewrite dec_eq_true; intro. exploit H3. apply H4 with (k := Max) (p := Nonempty); eauto. - generalize (Int.unsigned_range_2 ofs). omega. + generalize (Ptrofs.unsigned_range_2 ofs). omega. exploit perm_alloc_inv; eauto; rewrite dec_eq_true; intro. exploit H3. apply H4 with (k := Max) (p := Nonempty); eauto. - generalize (Int.unsigned_range_2 ofs). omega. + generalize (Ptrofs.unsigned_range_2 ofs). omega. eapply mi_representable0; try eassumption. destruct H10; eauto using perm_alloc_4. (* perm inv *) @@ -3843,7 +3861,7 @@ Proof. eapply alloc_right_inject; eauto. eauto. instantiate (1 := b2). eauto with mem. - instantiate (1 := 0). unfold Int.max_unsigned. generalize Int.modulus_pos; omega. + instantiate (1 := 0). unfold Ptrofs.max_unsigned. generalize Ptrofs.modulus_pos; omega. auto. intros. apply perm_implies with Freeable; auto with mem. eapply perm_alloc_2; eauto. omega. @@ -4054,13 +4072,13 @@ Proof. destruct (f b) as [[b1 delta1] |] eqn:?; try discriminate. destruct (f' b1) as [[b2 delta2] |] eqn:?; inv H. exploit mi_representable0; eauto. intros [A B]. - set (ofs' := Int.repr (Int.unsigned ofs + delta1)). - assert (Int.unsigned ofs' = Int.unsigned ofs + delta1). - unfold ofs'; apply Int.unsigned_repr. auto. + set (ofs' := Ptrofs.repr (Ptrofs.unsigned ofs + delta1)). + assert (Ptrofs.unsigned ofs' = Ptrofs.unsigned ofs + delta1). + unfold ofs'; apply Ptrofs.unsigned_repr. auto. exploit mi_representable1. eauto. instantiate (1 := ofs'). rewrite H. - replace (Int.unsigned ofs + delta1 - 1) with - ((Int.unsigned ofs - 1) + delta1) by omega. + replace (Ptrofs.unsigned ofs + delta1 - 1) with + ((Ptrofs.unsigned ofs - 1) + delta1) by omega. destruct H0; eauto using perm_inj. rewrite H. omega. (* perm inv *) @@ -4185,7 +4203,7 @@ Proof. apply flat_inj_no_overlap. (* range *) unfold flat_inj; intros. - destruct (plt b (nextblock m)); inv H0. generalize (Int.unsigned_range_2 ofs); omega. + destruct (plt b (nextblock m)); inv H0. generalize (Ptrofs.unsigned_range_2 ofs); omega. (* perm inv *) unfold flat_inj; intros. destruct (plt b1 (nextblock m)); inv H0. diff --git a/common/Memtype.v b/common/Memtype.v index 5dbb66dc..b055668c 100644 --- a/common/Memtype.v +++ b/common/Memtype.v @@ -124,13 +124,13 @@ Parameter store: forall (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: v Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val := match addr with - | Vptr b ofs => load chunk m b (Int.unsigned ofs) + | Vptr b ofs => load chunk m b (Ptrofs.unsigned ofs) | _ => None end. Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) : option mem := match addr with - | Vptr b ofs => store chunk m b (Int.unsigned ofs) v + | Vptr b ofs => store chunk m b (Ptrofs.unsigned ofs) v | _ => None end. @@ -445,7 +445,7 @@ Axiom load_store_other: Definition compat_pointer_chunks (chunk1 chunk2: memory_chunk) : Prop := match chunk1, chunk2 with | (Mint32 | Many32), (Mint32 | Many32) => True - | Many64, Many64 => True + | (Mint64 | Many64), (Mint64 | Many64) => True | _, _ => False end. @@ -978,37 +978,37 @@ Axiom weak_valid_pointer_inject: Axiom address_inject: forall f m1 m2 b1 ofs1 b2 delta p, inject f m1 m2 -> - perm m1 b1 (Int.unsigned ofs1) Cur p -> + perm m1 b1 (Ptrofs.unsigned ofs1) Cur p -> f b1 = Some (b2, delta) -> - Int.unsigned (Int.add ofs1 (Int.repr delta)) = Int.unsigned ofs1 + delta. + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) = Ptrofs.unsigned ofs1 + delta. Axiom valid_pointer_inject_no_overflow: forall f m1 m2 b ofs b' delta, inject f m1 m2 -> - valid_pointer m1 b (Int.unsigned ofs) = true -> + valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> f b = Some(b', delta) -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. Axiom weak_valid_pointer_inject_no_overflow: forall f m1 m2 b ofs b' delta, inject f m1 m2 -> - weak_valid_pointer m1 b (Int.unsigned ofs) = true -> + weak_valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> f b = Some(b', delta) -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. Axiom valid_pointer_inject_val: forall f m1 m2 b ofs b' ofs', inject f m1 m2 -> - valid_pointer m1 b (Int.unsigned ofs) = true -> + valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> Val.inject f (Vptr b ofs) (Vptr b' ofs') -> - valid_pointer m2 b' (Int.unsigned ofs') = true. + valid_pointer m2 b' (Ptrofs.unsigned ofs') = true. Axiom weak_valid_pointer_inject_val: forall f m1 m2 b ofs b' ofs', inject f m1 m2 -> - weak_valid_pointer m1 b (Int.unsigned ofs) = true -> + weak_valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> Val.inject f (Vptr b ofs) (Vptr b' ofs') -> - weak_valid_pointer m2 b' (Int.unsigned ofs') = true. + weak_valid_pointer m2 b' (Ptrofs.unsigned ofs') = true. Axiom inject_no_overlap: forall f m1 m2 b1 b2 b1' b2' delta1 delta2 ofs1 ofs2, @@ -1024,13 +1024,13 @@ Axiom different_pointers_inject: forall f m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, inject f m m' -> b1 <> b2 -> - valid_pointer m b1 (Int.unsigned ofs1) = true -> - valid_pointer m b2 (Int.unsigned ofs2) = true -> + valid_pointer m b1 (Ptrofs.unsigned ofs1) = true -> + valid_pointer m b2 (Ptrofs.unsigned ofs2) = true -> f b1 = Some (b1', delta1) -> f b2 = Some (b2', delta2) -> b1' <> b2' \/ - Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> - Int.unsigned (Int.add ofs2 (Int.repr delta2)). + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> + Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). Axiom load_inject: forall f m1 m2 chunk b1 ofs b2 delta v1, @@ -1141,8 +1141,8 @@ Axiom alloc_left_mapped_inject: inject f m1 m2 -> alloc m1 lo hi = (m1', b1) -> valid_block m2 b2 -> - 0 <= delta <= Int.max_unsigned -> - (forall ofs k p, perm m2 b2 ofs k p -> delta = 0 \/ 0 <= ofs < Int.max_unsigned) -> + 0 <= delta <= Ptrofs.max_unsigned -> + (forall ofs k p, perm m2 b2 ofs k p -> delta = 0 \/ 0 <= ofs < Ptrofs.max_unsigned) -> (forall ofs k p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) k p) -> inj_offset_aligned delta (hi-lo) -> (forall b delta' ofs k p, diff --git a/common/Separation.v b/common/Separation.v index efcd3281..c0a3c9cf 100644 --- a/common/Separation.v +++ b/common/Separation.v @@ -319,7 +319,7 @@ Qed. Program Definition range (b: block) (lo hi: Z) : massert := {| m_pred := fun m => - 0 <= lo /\ hi <= Int.modulus + 0 <= lo /\ hi <= Ptrofs.modulus /\ (forall i k p, lo <= i < hi -> Mem.perm m b i k p); m_footprint := fun b' ofs' => b' = b /\ lo <= ofs' < hi |}. @@ -333,7 +333,7 @@ Qed. Lemma alloc_rule: forall m lo hi b m' P, Mem.alloc m lo hi = (m', b) -> - 0 <= lo -> hi <= Int.modulus -> + 0 <= lo -> hi <= Ptrofs.modulus -> m |= P -> m' |= range b lo hi ** P. Proof. @@ -413,7 +413,7 @@ Qed. Program Definition contains (chunk: memory_chunk) (b: block) (ofs: Z) (spec: val -> Prop) : massert := {| m_pred := fun m => - 0 <= ofs <= Int.max_unsigned + 0 <= ofs <= Ptrofs.max_unsigned /\ Mem.valid_access m chunk b ofs Freeable /\ exists v, Mem.load chunk m b ofs = Some v /\ spec v; m_footprint := fun b' ofs' => b' = b /\ ofs <= ofs' < ofs + size_chunk chunk @@ -431,7 +431,7 @@ Qed. Lemma contains_no_overflow: forall spec m chunk b ofs, m |= contains chunk b ofs spec -> - 0 <= ofs <= Int.max_unsigned. + 0 <= ofs <= Ptrofs.max_unsigned. Proof. intros. simpl in H. tauto. Qed. @@ -448,10 +448,10 @@ Qed. Lemma loadv_rule: forall spec m chunk b ofs, m |= contains chunk b ofs spec -> - exists v, Mem.loadv chunk m (Vptr b (Int.repr ofs)) = Some v /\ spec v. + exists v, Mem.loadv chunk m (Vptr b (Ptrofs.repr ofs)) = Some v /\ spec v. Proof. intros. exploit load_rule; eauto. intros (v & A & B). exists v; split; auto. - simpl. rewrite Int.unsigned_repr; auto. eapply contains_no_overflow; eauto. + simpl. rewrite Ptrofs.unsigned_repr; auto. eapply contains_no_overflow; eauto. Qed. Lemma store_rule: @@ -477,10 +477,10 @@ Lemma storev_rule: m |= contains chunk b ofs spec1 ** P -> spec (Val.load_result chunk v) -> exists m', - Mem.storev chunk m (Vptr b (Int.repr ofs)) v = Some m' /\ m' |= contains chunk b ofs spec ** P. + Mem.storev chunk m (Vptr b (Ptrofs.repr ofs)) v = Some m' /\ m' |= contains chunk b ofs spec ** P. Proof. intros. exploit store_rule; eauto. intros (m' & A & B). exists m'; split; auto. - simpl. rewrite Int.unsigned_repr; auto. eapply contains_no_overflow. eapply sep_pick1; eauto. + simpl. rewrite Ptrofs.unsigned_repr; auto. eapply contains_no_overflow. eapply sep_pick1; eauto. Qed. Lemma range_contains: @@ -493,7 +493,7 @@ Proof. split; [|split]. - assert (Mem.valid_access m chunk b ofs Freeable). { split; auto. red; auto. } - split. generalize (size_chunk_pos chunk). unfold Int.max_unsigned. omega. + split. generalize (size_chunk_pos chunk). unfold Ptrofs.max_unsigned. omega. split. auto. + destruct (Mem.valid_access_load m chunk b ofs) as [v LOAD]. eauto with mem. @@ -530,7 +530,7 @@ Lemma storev_rule': forall chunk m b ofs v (spec1: val -> Prop) P, m |= contains chunk b ofs spec1 ** P -> exists m', - Mem.storev chunk m (Vptr b (Int.repr ofs)) v = Some m' /\ m' |= hasvalue chunk b ofs (Val.load_result chunk v) ** P. + Mem.storev chunk m (Vptr b (Ptrofs.repr ofs)) v = Some m' /\ m' |= hasvalue chunk b ofs (Val.load_result chunk v) ** P. Proof. intros. eapply storev_rule; eauto. Qed. @@ -656,9 +656,9 @@ Proof. intros. destruct H as (A & B & C). simpl in A. exploit Mem.storev_mapped_inject; eauto. intros (m2' & STORE & INJ). inv H1; simpl in STORE; try discriminate. - assert (VALID: Mem.valid_access m1 chunk b1 (Int.unsigned ofs1) Writable) + assert (VALID: Mem.valid_access m1 chunk b1 (Ptrofs.unsigned ofs1) Writable) by eauto with mem. - assert (EQ: Int.unsigned (Int.add ofs1 (Int.repr delta)) = Int.unsigned ofs1 + delta). + assert (EQ: Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) = Ptrofs.unsigned ofs1 + delta). { eapply Mem.address_inject'; eauto with mem. } exists m2'; split; auto. split; [|split]. @@ -681,7 +681,7 @@ Lemma alloc_parallel_rule: (8 | delta) -> lo = delta -> hi = delta + Zmax 0 sz1 -> - 0 <= sz2 <= Int.max_unsigned -> + 0 <= sz2 <= Ptrofs.max_unsigned -> 0 <= delta -> hi <= sz2 -> exists j', m2' |= range b2 0 lo ** range b2 hi sz2 ** minjection j' m1' ** P @@ -709,7 +709,7 @@ Proof. exists j'; split; auto. rewrite <- ! sep_assoc. split; [|split]. -+ simpl. intuition auto; try (unfold Int.max_unsigned in *; omega). ++ simpl. intuition auto; try (unfold Ptrofs.max_unsigned in *; omega). * apply Mem.perm_implies with Freeable; auto with mem. eapply Mem.perm_alloc_2; eauto. omega. * apply Mem.perm_implies with Freeable; auto with mem. @@ -891,7 +891,7 @@ Lemma alloc_parallel_rule_2: (8 | delta) -> lo = delta -> hi = delta + Zmax 0 sz1 -> - 0 <= sz2 <= Int.max_unsigned -> + 0 <= sz2 <= Ptrofs.max_unsigned -> 0 <= delta -> hi <= sz2 -> exists j', m2' |= range b2 0 lo ** range b2 hi sz2 ** minjection j' m1' ** globalenv_inject ge j' ** P diff --git a/common/Values.v b/common/Values.v index 663bddf6..cfabb7a5 100644 --- a/common/Values.v +++ b/common/Values.v @@ -16,6 +16,7 @@ (** This module defines the type of values that is used in the dynamic semantics of all our intermediate languages. *) +Require Archi. Require Import Coqlib. Require Import AST. Require Import Integers. @@ -39,7 +40,7 @@ Inductive val: Type := | Vlong: int64 -> val | Vfloat: float -> val | Vsingle: float32 -> val - | Vptr: block -> int -> val. + | Vptr: block -> ptrofs -> val. Definition Vzero: val := Vint Int.zero. Definition Vone: val := Vint Int.one. @@ -48,6 +49,12 @@ Definition Vmone: val := Vint Int.mone. Definition Vtrue: val := Vint Int.one. Definition Vfalse: val := Vint Int.zero. +Definition Vnullptr := + if Archi.ptr64 then Vlong Int64.zero else Vint Int.zero. + +Definition Vptrofs (n: ptrofs) := + if Archi.ptr64 then Vlong (Ptrofs.to_int64 n) else Vint (Ptrofs.to_int n). + (** * Operations over values *) (** The module [Val] defines a number of arithmetic and logical operations @@ -63,7 +70,7 @@ Proof. apply Int64.eq_dec. apply Float.eq_dec. apply Float32.eq_dec. - apply Int.eq_dec. + apply Ptrofs.eq_dec. apply eq_block. Defined. Global Opaque eq. @@ -75,8 +82,10 @@ Definition has_type (v: val) (t: typ) : Prop := | Vlong _, Tlong => True | Vfloat _, Tfloat => True | Vsingle _, Tsingle => True - | Vptr _ _, Tint => True - | (Vint _ | Vptr _ _ | Vsingle _), Tany32 => True + | Vptr _ _, Tint => Archi.ptr64 = false + | Vptr _ _, Tlong => Archi.ptr64 = true + | (Vint _ | Vsingle _), Tany32 => True + | Vptr _ _, Tany32 => Archi.ptr64 = false | _, Tany64 => True | _, _ => False end. @@ -94,12 +103,25 @@ Definition has_opttype (v: val) (ot: option typ) : Prop := | Some t => has_type v t end. +Lemma Vptr_has_type: + forall b ofs, has_type (Vptr b ofs) Tptr. +Proof. + intros. unfold Tptr, has_type; destruct Archi.ptr64; reflexivity. +Qed. + +Lemma Vnullptr_has_type: + has_type Vnullptr Tptr. +Proof. + unfold has_type, Vnullptr, Tptr; destruct Archi.ptr64; reflexivity. +Qed. + Lemma has_subtype: forall ty1 ty2 v, subtype ty1 ty2 = true -> has_type v ty1 -> has_type v ty2. Proof. - intros. destruct ty1; destruct ty2; simpl in H; discriminate || assumption || idtac; - unfold has_type in *; destruct v; auto. + intros. destruct ty1; destruct ty2; simpl in H; + (contradiction || discriminate || assumption || idtac); + unfold has_type in *; destruct v; auto; contradiction. Qed. Lemma has_subtype_list: @@ -257,17 +279,18 @@ Definition floatofsingle (v: val) : val := Definition add (v1 v2: val): val := match v1, v2 with | Vint n1, Vint n2 => Vint(Int.add n1 n2) - | Vptr b1 ofs1, Vint n2 => Vptr b1 (Int.add ofs1 n2) - | Vint n1, Vptr b2 ofs2 => Vptr b2 (Int.add ofs2 n1) + | Vptr b1 ofs1, Vint n2 => if Archi.ptr64 then Vundef else Vptr b1 (Ptrofs.add ofs1 (Ptrofs.of_int n2)) + | Vint n1, Vptr b2 ofs2 => if Archi.ptr64 then Vundef else Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int n1)) | _, _ => Vundef end. Definition sub (v1 v2: val): val := match v1, v2 with | Vint n1, Vint n2 => Vint(Int.sub n1 n2) - | Vptr b1 ofs1, Vint n2 => Vptr b1 (Int.sub ofs1 n2) + | Vptr b1 ofs1, Vint n2 => if Archi.ptr64 then Vundef else Vptr b1 (Ptrofs.sub ofs1 (Ptrofs.of_int n2)) | Vptr b1 ofs1, Vptr b2 ofs2 => - if eq_block b1 b2 then Vint(Int.sub ofs1 ofs2) else Vundef + if Archi.ptr64 then Vundef else + if eq_block b1 b2 then Vint(Ptrofs.to_int (Ptrofs.sub ofs1 ofs2)) else Vundef | _, _ => Vundef end. @@ -571,12 +594,19 @@ Definition singleoflongu (v: val) : option val := Definition addl (v1 v2: val): val := match v1, v2 with | Vlong n1, Vlong n2 => Vlong(Int64.add n1 n2) + | Vptr b1 ofs1, Vlong n2 => if Archi.ptr64 then Vptr b1 (Ptrofs.add ofs1 (Ptrofs.of_int64 n2)) else Vundef + | Vlong n1, Vptr b2 ofs2 => if Archi.ptr64 then Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int64 n1)) else Vundef | _, _ => Vundef end. Definition subl (v1 v2: val): val := match v1, v2 with | Vlong n1, Vlong n2 => Vlong(Int64.sub n1 n2) + | Vptr b1 ofs1, Vlong n2 => + if Archi.ptr64 then Vptr b1 (Ptrofs.sub ofs1 (Ptrofs.of_int64 n2)) else Vundef + | Vptr b1 ofs1, Vptr b2 ofs2 => + if negb Archi.ptr64 then Vundef else + if eq_block b1 b2 then Vlong(Ptrofs.to_int64 (Ptrofs.sub ofs1 ofs2)) else Vundef | _, _ => Vundef end. @@ -592,6 +622,18 @@ Definition mull' (v1 v2: val): val := | _, _ => Vundef end. +Definition mullhs (v1 v2: val): val := + match v1, v2 with + | Vlong n1, Vlong n2 => Vlong(Int64.mulhs n1 n2) + | _, _ => Vundef + end. + +Definition mullhu (v1 v2: val): val := + match v1, v2 with + | Vlong n1, Vlong n2 => Vlong(Int64.mulhu n1 n2) + | _, _ => Vundef + end. + Definition divls (v1 v2: val): option val := match v1, v2 with | Vlong n1, Vlong n2 => @@ -626,6 +668,18 @@ Definition modlu (v1 v2: val): option val := | _, _ => None end. +Definition subl_overflow (v1 v2: val) : val := + match v1, v2 with + | Vlong n1, Vlong n2 => Vint (Int.repr (Int64.unsigned (Int64.sub_overflow n1 n2 Int64.zero))) + | _, _ => Vundef + end. + +Definition negativel (v: val) : val := + match v with + | Vlong n => Vint (Int.repr (Int64.unsigned (Int64.negative n))) + | _ => Vundef + end. + Definition andl (v1 v2: val): val := match v1, v2 with | Vlong n1, Vlong n2 => Vlong(Int64.and n1 n2) @@ -671,6 +725,33 @@ Definition shrlu (v1 v2: val): val := | _, _ => Vundef end. +Definition shrxl (v1 v2: val): option val := + match v1, v2 with + | Vlong n1, Vint n2 => + if Int.ltu n2 (Int.repr 63) + then Some(Vlong(Int64.shrx' n1 n2)) + else None + | _, _ => None + end. + +Definition roll (v1 v2: val): val := + match v1, v2 with + | Vlong n1, Vint n2 => Vlong(Int64.rol n1 (Int64.repr (Int.unsigned n2))) + | _, _ => Vundef + end. + +Definition rorl (v1 v2: val): val := + match v1, v2 with + | Vlong n1, Vint n2 => Vlong(Int64.ror n1 (Int64.repr (Int.unsigned n2))) + | _, _ => Vundef + end. + +Definition rolml (v: val) (amount mask: int64): val := + match v with + | Vlong n => Vlong(Int64.rolm n amount mask) + | _ => Vundef + end. + (** Comparisons *) Section COMPARISONS. @@ -696,22 +777,25 @@ Definition cmpu_bool (c: comparison) (v1 v2: val): option bool := | Vint n1, Vint n2 => Some (Int.cmpu c n1 n2) | Vint n1, Vptr b2 ofs2 => - if Int.eq n1 Int.zero && weak_valid_ptr b2 (Int.unsigned ofs2) + if Archi.ptr64 then None else + if Int.eq n1 Int.zero && weak_valid_ptr b2 (Ptrofs.unsigned ofs2) then cmp_different_blocks c else None | Vptr b1 ofs1, Vptr b2 ofs2 => + if Archi.ptr64 then None else if eq_block b1 b2 then - if weak_valid_ptr b1 (Int.unsigned ofs1) - && weak_valid_ptr b2 (Int.unsigned ofs2) - then Some (Int.cmpu c ofs1 ofs2) + if weak_valid_ptr b1 (Ptrofs.unsigned ofs1) + && weak_valid_ptr b2 (Ptrofs.unsigned ofs2) + then Some (Ptrofs.cmpu c ofs1 ofs2) else None else - if valid_ptr b1 (Int.unsigned ofs1) - && valid_ptr b2 (Int.unsigned ofs2) + if valid_ptr b1 (Ptrofs.unsigned ofs1) + && valid_ptr b2 (Ptrofs.unsigned ofs2) then cmp_different_blocks c else None | Vptr b1 ofs1, Vint n2 => - if Int.eq n2 Int.zero && weak_valid_ptr b1 (Int.unsigned ofs1) + if Archi.ptr64 then None else + if Int.eq n2 Int.zero && weak_valid_ptr b1 (Ptrofs.unsigned ofs1) then cmp_different_blocks c else None | _, _ => None @@ -738,6 +822,28 @@ Definition cmpl_bool (c: comparison) (v1 v2: val): option bool := Definition cmplu_bool (c: comparison) (v1 v2: val): option bool := match v1, v2 with | Vlong n1, Vlong n2 => Some (Int64.cmpu c n1 n2) + | Vlong n1, Vptr b2 ofs2 => + if negb Archi.ptr64 then None else + if Int64.eq n1 Int64.zero && weak_valid_ptr b2 (Ptrofs.unsigned ofs2) + then cmp_different_blocks c + else None + | Vptr b1 ofs1, Vptr b2 ofs2 => + if negb Archi.ptr64 then None else + if eq_block b1 b2 then + if weak_valid_ptr b1 (Ptrofs.unsigned ofs1) + && weak_valid_ptr b2 (Ptrofs.unsigned ofs2) + then Some (Ptrofs.cmpu c ofs1 ofs2) + else None + else + if valid_ptr b1 (Ptrofs.unsigned ofs1) + && valid_ptr b2 (Ptrofs.unsigned ofs2) + then cmp_different_blocks c + else None + | Vptr b1 ofs1, Vlong n2 => + if negb Archi.ptr64 then None else + if Int64.eq n2 Int64.zero && weak_valid_ptr b1 (Ptrofs.unsigned ofs1) + then cmp_different_blocks c + else None | _, _ => None end. @@ -770,6 +876,14 @@ Definition maskzero_bool (v: val) (mask: int): option bool := End COMPARISONS. +(** Add the given offset to the given pointer. *) + +Definition offset_ptr (v: val) (delta: ptrofs) : val := + match v with + | Vptr b ofs => Vptr b (Ptrofs.add ofs delta) + | _ => Vundef + end. + (** [load_result] reflects the effect of storing a value with a given memory chunk, then reading it back with the same chunk. Depending on the chunk and the type of the value, some normalization occurs. @@ -786,11 +900,13 @@ Definition load_result (chunk: memory_chunk) (v: val) := | Mint16signed, Vint n => Vint (Int.sign_ext 16 n) | Mint16unsigned, Vint n => Vint (Int.zero_ext 16 n) | Mint32, Vint n => Vint n - | Mint32, Vptr b ofs => Vptr b ofs + | Mint32, Vptr b ofs => if Archi.ptr64 then Vundef else Vptr b ofs | Mint64, Vlong n => Vlong n + | Mint64, Vptr b ofs => if Archi.ptr64 then Vptr b ofs else Vundef | Mfloat32, Vsingle f => Vsingle f | Mfloat64, Vfloat f => Vfloat f - | Many32, (Vint _ | Vptr _ _ | Vsingle _) => v + | Many32, (Vint _ | Vsingle _) => v + | Many32, Vptr _ _ => if Archi.ptr64 then Vundef else v | Many64, _ => v | _, _ => Vundef end. @@ -798,13 +914,14 @@ Definition load_result (chunk: memory_chunk) (v: val) := Lemma load_result_type: forall chunk v, has_type (load_result chunk v) (type_of_chunk chunk). Proof. - intros. destruct chunk; destruct v; simpl; auto. + intros. unfold has_type; destruct chunk; destruct v; simpl; auto; destruct Archi.ptr64 eqn:SF; simpl; auto. Qed. Lemma load_result_same: forall v ty, has_type v ty -> load_result (chunk_of_type ty) v = v. Proof. - unfold has_type; intros. destruct v; destruct ty; try contradiction; auto. + unfold has_type, load_result; intros. + destruct v; destruct ty; destruct Archi.ptr64; try contradiction; try discriminate; auto. Qed. (** Theorems on arithmetic operations. *) @@ -882,13 +999,15 @@ Qed. Theorem add_assoc: forall x y z, add (add x y) z = add x (add y z). Proof. - destruct x; destruct y; destruct z; simpl; auto. - rewrite Int.add_assoc; auto. - rewrite Int.add_assoc; auto. - decEq. decEq. apply Int.add_commut. - decEq. rewrite Int.add_commut. rewrite <- Int.add_assoc. - decEq. apply Int.add_commut. - decEq. rewrite Int.add_assoc. auto. + unfold add; intros; destruct Archi.ptr64 eqn:SF, x, y, z; simpl; auto. +- rewrite Int.add_assoc; auto. +- rewrite Int.add_assoc; auto. +- rewrite ! Ptrofs.add_assoc. f_equal. f_equal. + rewrite Ptrofs.add_commut. auto with ptrofs. +- rewrite ! Ptrofs.add_assoc. f_equal. f_equal. + apply Ptrofs.add_commut. +- rewrite ! Ptrofs.add_assoc. f_equal. f_equal. + symmetry. auto with ptrofs. Qed. Theorem add_permut: forall x y z, add x (add y z) = add y (add x z). @@ -910,7 +1029,8 @@ Qed. Theorem neg_add_distr: forall x y, neg(add x y) = add (neg x) (neg y). Proof. - destruct x; destruct y; simpl; auto. decEq. apply Int.neg_add_distr. + unfold neg, add; intros; destruct Archi.ptr64 eqn:SF, x, y; simpl; auto; + rewrite Int.neg_add_distr; auto. Qed. Theorem sub_zero_r: forall x, sub Vzero x = neg x. @@ -920,37 +1040,40 @@ Qed. Theorem sub_add_opp: forall x y, sub x (Vint y) = add x (Vint (Int.neg y)). Proof. - destruct x; intro y; simpl; auto; rewrite Int.sub_add_opp; auto. + unfold sub, add; intros; destruct Archi.ptr64 eqn:SF, x; auto. +- rewrite Int.sub_add_opp; auto. +- rewrite Int.sub_add_opp; auto. +- rewrite Ptrofs.sub_add_opp. f_equal. f_equal. symmetry. auto with ptrofs. Qed. Theorem sub_opp_add: forall x y, sub x (Vint (Int.neg y)) = add x (Vint y). Proof. - intros. unfold sub, add. - destruct x; auto; rewrite Int.sub_add_opp; rewrite Int.neg_involutive; auto. + intros. rewrite sub_add_opp. rewrite Int.neg_involutive. auto. Qed. Theorem sub_add_l: forall v1 v2 i, sub (add v1 (Vint i)) v2 = add (sub v1 v2) (Vint i). Proof. - destruct v1; destruct v2; intros; simpl; auto. - rewrite Int.sub_add_l. auto. - rewrite Int.sub_add_l. auto. - case (eq_block b b0); intro. rewrite Int.sub_add_l. auto. reflexivity. + unfold sub, add; intros; destruct Archi.ptr64 eqn:SF, v1, v2; auto. +- rewrite Int.sub_add_l; auto. +- rewrite Int.sub_add_l; auto. +- rewrite Ptrofs.sub_add_l; auto. +- destruct (eq_block b b0); auto. + f_equal. rewrite Ptrofs.sub_add_l. auto with ptrofs. Qed. Theorem sub_add_r: forall v1 v2 i, sub v1 (add v2 (Vint i)) = add (sub v1 v2) (Vint (Int.neg i)). Proof. - destruct v1; destruct v2; intros; simpl; auto. - rewrite Int.sub_add_r. auto. - repeat rewrite Int.sub_add_opp. decEq. - repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - decEq. repeat rewrite Int.sub_add_opp. - rewrite Int.add_assoc. decEq. apply Int.neg_add_distr. - case (eq_block b b0); intro. simpl. decEq. - repeat rewrite Int.sub_add_opp. rewrite Int.add_assoc. decEq. - apply Int.neg_add_distr. - reflexivity. + unfold sub, add; intros; destruct Archi.ptr64 eqn:SF, v1, v2; auto. +- rewrite Int.add_commut. rewrite Int.sub_add_r. auto. +- rewrite Int.add_commut. rewrite Int.sub_add_r. auto. +- f_equal. replace (Ptrofs.of_int (Int.add i1 i)) with (Ptrofs.add (Ptrofs.of_int i) (Ptrofs.of_int i1)). + rewrite Ptrofs.sub_add_r. f_equal. + symmetry. auto with ptrofs. + symmetry. rewrite Int.add_commut. auto with ptrofs. +- destruct (eq_block b b0); auto. + f_equal. rewrite Ptrofs.add_commut. rewrite Ptrofs.sub_add_r. auto with ptrofs. Qed. Theorem mul_commut: forall x y, mul x y = mul y x. @@ -967,16 +1090,15 @@ Qed. Theorem mul_add_distr_l: forall x y z, mul (add x y) z = add (mul x z) (mul y z). Proof. - destruct x; destruct y; destruct z; simpl; auto. - decEq. apply Int.mul_add_distr_l. + unfold mul, add; intros; destruct Archi.ptr64 eqn:SF, x, y, z; simpl; auto; + rewrite Int.mul_add_distr_l; auto. Qed. - Theorem mul_add_distr_r: forall x y z, mul x (add y z) = add (mul x y) (mul x z). Proof. - destruct x; destruct y; destruct z; simpl; auto. - decEq. apply Int.mul_add_distr_r. + unfold mul, add; intros; destruct Archi.ptr64 eqn:SF, x, y, z; simpl; auto; + rewrite Int.mul_add_distr_r; auto. Qed. Theorem mul_pow2: @@ -1139,6 +1261,32 @@ Proof. rewrite Int.shrx_shr; auto. destruct (Int.lt i Int.zero); simpl; rewrite H0; auto. Qed. +Theorem shrx_shr_2: + forall n x z, + shrx x (Vint n) = Some z -> + z = (if Int.eq n Int.zero then x else + shr (add x (shru (shr x (Vint (Int.repr 31))) + (Vint (Int.sub (Int.repr 32) n)))) + (Vint n)). +Proof. + intros. destruct x; simpl in H; try discriminate. + destruct (Int.ltu n (Int.repr 31)) eqn:LT; inv H. + exploit Int.ltu_inv; eauto. change (Int.unsigned (Int.repr 31)) with 31; intros LT'. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. unfold Int.shrx. rewrite Int.shl_zero. unfold Int.divs. change (Int.signed Int.one) with 1. + rewrite Z.quot_1_r. rewrite Int.repr_signed; auto. +- simpl. change (Int.ltu (Int.repr 31) Int.iwordsize) with true. simpl. + replace (Int.ltu (Int.sub (Int.repr 32) n) Int.iwordsize) with true. simpl. + replace (Int.ltu n Int.iwordsize) with true. + f_equal; apply Int.shrx_shr_2; assumption. + symmetry; apply zlt_true. change (Int.unsigned n < 32); omega. + symmetry; apply zlt_true. unfold Int.sub. change (Int.unsigned (Int.repr 32)) with 32. + assert (Int.unsigned n <> 0). { red; intros; elim H. rewrite <- (Int.repr_unsigned n), H0. auto. } + rewrite Int.unsigned_repr. + change (Int.unsigned Int.iwordsize) with 32; omega. + assert (32 < Int.max_unsigned) by reflexivity. omega. +Qed. + Theorem or_rolm: forall x n m1 m2, or (rolm x n m1) (rolm x n m2) = rolm x n (Int.or m1 m2). @@ -1165,6 +1313,209 @@ Proof. intros; destruct x; simpl; auto. decEq. apply Int.rolm_zero. Qed. +Theorem addl_commut: forall x y, addl x y = addl y x. +Proof. + destruct x; destruct y; simpl; auto. + decEq. apply Int64.add_commut. +Qed. + +Theorem addl_assoc: forall x y z, addl (addl x y) z = addl x (addl y z). +Proof. + unfold addl; intros; destruct Archi.ptr64 eqn:SF, x, y, z; simpl; auto. +- rewrite Int64.add_assoc; auto. +- rewrite ! Ptrofs.add_assoc. f_equal. f_equal. + rewrite Ptrofs.add_commut. auto with ptrofs. +- rewrite ! Ptrofs.add_assoc. f_equal. f_equal. + apply Ptrofs.add_commut. +- rewrite ! Ptrofs.add_assoc. f_equal. f_equal. + symmetry. auto with ptrofs. +- rewrite Int64.add_assoc; auto. +Qed. + +Theorem addl_permut: forall x y z, addl x (addl y z) = addl y (addl x z). +Proof. + intros. rewrite (addl_commut y z). rewrite <- addl_assoc. apply addl_commut. +Qed. + +Theorem addl_permut_4: + forall x y z t, addl (addl x y) (addl z t) = addl (addl x z) (addl y t). +Proof. + intros. rewrite addl_permut. rewrite addl_assoc. + rewrite addl_permut. symmetry. apply addl_assoc. +Qed. + +Theorem negl_addl_distr: forall x y, negl(addl x y) = addl (negl x) (negl y). +Proof. + unfold negl, addl; intros; destruct Archi.ptr64 eqn:SF; destruct x; destruct y; simpl; auto; + decEq; apply Int64.neg_add_distr. +Qed. + +Theorem subl_addl_opp: forall x y, subl x (Vlong y) = addl x (Vlong (Int64.neg y)). +Proof. + unfold subl, addl; intros; destruct Archi.ptr64 eqn:SF, x; auto. +- rewrite Int64.sub_add_opp; auto. +- rewrite Ptrofs.sub_add_opp. f_equal. f_equal. symmetry. auto with ptrofs. +- rewrite Int64.sub_add_opp; auto. +Qed. + +Theorem subl_opp_addl: forall x y, subl x (Vlong (Int64.neg y)) = addl x (Vlong y). +Proof. + intros. rewrite subl_addl_opp. rewrite Int64.neg_involutive. auto. +Qed. + +Theorem subl_addl_l: + forall v1 v2 i, subl (addl v1 (Vlong i)) v2 = addl (subl v1 v2) (Vlong i). +Proof. + unfold subl, addl; intros; destruct Archi.ptr64 eqn:SF, v1, v2; auto. +- rewrite Int64.sub_add_l; auto. +- rewrite Ptrofs.sub_add_l; auto. +- destruct (eq_block b b0); auto. + simpl. f_equal. rewrite Ptrofs.sub_add_l. auto with ptrofs. +- rewrite Int64.sub_add_l; auto. +Qed. + +Theorem subl_addl_r: + forall v1 v2 i, subl v1 (addl v2 (Vlong i)) = addl (subl v1 v2) (Vlong (Int64.neg i)). +Proof. + unfold subl, addl; intros; destruct Archi.ptr64 eqn:SF, v1, v2; auto. +- rewrite Int64.add_commut. rewrite Int64.sub_add_r. auto. +- f_equal. replace (Ptrofs.of_int64 (Int64.add i1 i)) with (Ptrofs.add (Ptrofs.of_int64 i) (Ptrofs.of_int64 i1)). + rewrite Ptrofs.sub_add_r. f_equal. + symmetry. auto with ptrofs. + symmetry. rewrite Int64.add_commut. auto with ptrofs. +- destruct (eq_block b b0); auto. + simpl; f_equal. rewrite Ptrofs.add_commut. rewrite Ptrofs.sub_add_r. auto with ptrofs. +- rewrite Int64.add_commut. rewrite Int64.sub_add_r. auto. +Qed. + +Theorem mull_commut: forall x y, mull x y = mull y x. +Proof. + destruct x; destruct y; simpl; auto. decEq. apply Int64.mul_commut. +Qed. + +Theorem mull_assoc: forall x y z, mull (mull x y) z = mull x (mull y z). +Proof. + destruct x; destruct y; destruct z; simpl; auto. + decEq. apply Int64.mul_assoc. +Qed. + +Theorem mull_addl_distr_l: + forall x y z, mull (addl x y) z = addl (mull x z) (mull y z). +Proof. + unfold mull, addl; intros; destruct Archi.ptr64 eqn:SF; destruct x; destruct y; destruct z; simpl; auto; + decEq; apply Int64.mul_add_distr_l. +Qed. + +Theorem mull_addl_distr_r: + forall x y z, mull x (addl y z) = addl (mull x y) (mull x z). +Proof. + unfold mull, addl; intros; destruct Archi.ptr64 eqn:SF; destruct x; destruct y; destruct z; simpl; auto; + decEq; apply Int64.mul_add_distr_r. +Qed. + +Theorem andl_commut: forall x y, andl x y = andl y x. +Proof. + destruct x; destruct y; simpl; auto. decEq. apply Int64.and_commut. +Qed. + +Theorem andl_assoc: forall x y z, andl (andl x y) z = andl x (andl y z). +Proof. + destruct x; destruct y; destruct z; simpl; auto. + decEq. apply Int64.and_assoc. +Qed. + +Theorem orl_commut: forall x y, orl x y = orl y x. +Proof. + destruct x; destruct y; simpl; auto. decEq. apply Int64.or_commut. +Qed. + +Theorem orl_assoc: forall x y z, orl (orl x y) z = orl x (orl y z). +Proof. + destruct x; destruct y; destruct z; simpl; auto. + decEq. apply Int64.or_assoc. +Qed. + +Theorem xorl_commut: forall x y, xorl x y = xorl y x. +Proof. + destruct x; destruct y; simpl; auto. decEq. apply Int64.xor_commut. +Qed. + +Theorem xorl_assoc: forall x y z, xorl (xorl x y) z = xorl x (xorl y z). +Proof. + destruct x; destruct y; destruct z; simpl; auto. + decEq. apply Int64.xor_assoc. +Qed. + +Theorem notl_xorl: forall x, notl x = xorl x (Vlong Int64.mone). +Proof. + destruct x; simpl; auto. +Qed. + +Theorem divls_pow2: + forall x n logn y, + Int64.is_power2' n = Some logn -> Int.ltu logn (Int.repr 63) = true -> + divls x (Vlong n) = Some y -> + shrxl x (Vint logn) = Some y. +Proof. + intros; destruct x; simpl in H1; inv H1. + destruct (Int64.eq n Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n Int64.mone); inv H3. + simpl. rewrite H0. decEq. decEq. + generalize (Int64.is_power2'_correct _ _ H); intro. + unfold Int64.shrx'. rewrite Int64.shl'_mul_two_p. rewrite <- H1. + rewrite Int64.mul_commut. rewrite Int64.mul_one. + rewrite Int64.repr_unsigned. auto. +Qed. + +Theorem divlu_pow2: + forall x n logn y, + Int64.is_power2' n = Some logn -> + divlu x (Vlong n) = Some y -> + shrlu x (Vint logn) = y. +Proof. + intros; destruct x; simpl in H0; inv H0. + destruct (Int64.eq n Int64.zero); inv H2. + simpl. + rewrite (Int64.is_power2'_range _ _ H). + decEq. symmetry. apply Int64.divu_pow2'. auto. +Qed. + +Theorem modlu_pow2: + forall x n logn y, + Int64.is_power2 n = Some logn -> + modlu x (Vlong n) = Some y -> + andl x (Vlong (Int64.sub n Int64.one)) = y. +Proof. + intros; destruct x; simpl in H0; inv H0. + destruct (Int64.eq n Int64.zero); inv H2. + simpl. decEq. symmetry. eapply Int64.modu_and; eauto. +Qed. + +Theorem shrxl_shrl_2: + forall n x z, + shrxl x (Vint n) = Some z -> + z = (if Int.eq n Int.zero then x else + shrl (addl x (shrlu (shrl x (Vint (Int.repr 63))) + (Vint (Int.sub (Int.repr 64) n)))) + (Vint n)). +Proof. + intros. destruct x; simpl in H; try discriminate. + destruct (Int.ltu n (Int.repr 63)) eqn:LT; inv H. + exploit Int.ltu_inv; eauto. change (Int.unsigned (Int.repr 63)) with 63; intros LT'. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. rewrite Int64.shrx'_zero. auto. +- simpl. change (Int.ltu (Int.repr 63) Int64.iwordsize') with true. simpl. + replace (Int.ltu (Int.sub (Int.repr 64) n) Int64.iwordsize') with true. simpl. + replace (Int.ltu n Int64.iwordsize') with true. + f_equal; apply Int64.shrx'_shr_2; assumption. + symmetry; apply zlt_true. change (Int.unsigned n < 64); omega. + symmetry; apply zlt_true. unfold Int.sub. change (Int.unsigned (Int.repr 64)) with 64. + assert (Int.unsigned n <> 0). { red; intros; elim H. rewrite <- (Int.repr_unsigned n), H0. auto. } + rewrite Int.unsigned_repr. + change (Int.unsigned Int64.iwordsize') with 64; omega. + assert (64 < Int.max_unsigned) by reflexivity. omega. +Qed. + Theorem negate_cmp_bool: forall c x y, cmp_bool (negate_comparison c) x y = option_map negb (cmp_bool c x y). Proof. @@ -1177,17 +1528,44 @@ Theorem negate_cmpu_bool: Proof. assert (forall c, cmp_different_blocks (negate_comparison c) = option_map negb (cmp_different_blocks c)). - destruct c; auto. - destruct x; destruct y; simpl; auto. - rewrite Int.negate_cmpu. auto. - destruct (Int.eq i Int.zero && (valid_ptr b (Int.unsigned i0) || valid_ptr b (Int.unsigned i0 - 1))); auto. - destruct (Int.eq i0 Int.zero && (valid_ptr b (Int.unsigned i) || valid_ptr b (Int.unsigned i - 1))); auto. - destruct (eq_block b b0). - destruct ((valid_ptr b (Int.unsigned i) || valid_ptr b (Int.unsigned i - 1)) && - (valid_ptr b0 (Int.unsigned i0) || valid_ptr b0 (Int.unsigned i0 - 1))). - rewrite Int.negate_cmpu. auto. + { destruct c; auto. } + unfold cmpu_bool; intros; destruct Archi.ptr64 eqn:SF, x, y; auto. +- rewrite Int.negate_cmpu. auto. +- rewrite Int.negate_cmpu. auto. +- destruct (Int.eq i Int.zero && (valid_ptr b (Ptrofs.unsigned i0) || valid_ptr b (Ptrofs.unsigned i0 - 1))); auto. +- destruct (Int.eq i0 Int.zero && (valid_ptr b (Ptrofs.unsigned i) || valid_ptr b (Ptrofs.unsigned i - 1))); auto. +- destruct (eq_block b b0). + destruct ((valid_ptr b (Ptrofs.unsigned i) || valid_ptr b (Ptrofs.unsigned i - 1)) && + (valid_ptr b0 (Ptrofs.unsigned i0) || valid_ptr b0 (Ptrofs.unsigned i0 - 1))). + rewrite Ptrofs.negate_cmpu. auto. + auto. + destruct (valid_ptr b (Ptrofs.unsigned i) && valid_ptr b0 (Ptrofs.unsigned i0)); auto. +Qed. + +Theorem negate_cmpl_bool: + forall c x y, cmpl_bool (negate_comparison c) x y = option_map negb (cmpl_bool c x y). +Proof. + destruct x; destruct y; simpl; auto. rewrite Int64.negate_cmp. auto. +Qed. + +Theorem negate_cmplu_bool: + forall valid_ptr c x y, + cmplu_bool valid_ptr (negate_comparison c) x y = option_map negb (cmplu_bool valid_ptr c x y). +Proof. + assert (forall c, + cmp_different_blocks (negate_comparison c) = option_map negb (cmp_different_blocks c)). + { destruct c; auto. } + unfold cmplu_bool; intros; destruct Archi.ptr64 eqn:SF, x, y; auto. +- rewrite Int64.negate_cmpu. auto. +- simpl. destruct (Int64.eq i Int64.zero && (valid_ptr b (Ptrofs.unsigned i0) || valid_ptr b (Ptrofs.unsigned i0 - 1))); auto. +- simpl. destruct (Int64.eq i0 Int64.zero && (valid_ptr b (Ptrofs.unsigned i) || valid_ptr b (Ptrofs.unsigned i - 1))); auto. +- simpl. destruct (eq_block b b0). + destruct ((valid_ptr b (Ptrofs.unsigned i) || valid_ptr b (Ptrofs.unsigned i - 1)) && + (valid_ptr b0 (Ptrofs.unsigned i0) || valid_ptr b0 (Ptrofs.unsigned i0 - 1))). + rewrite Ptrofs.negate_cmpu. auto. auto. - destruct (valid_ptr b (Int.unsigned i) && valid_ptr b0 (Int.unsigned i0)); auto. + destruct (valid_ptr b (Ptrofs.unsigned i) && valid_ptr b0 (Ptrofs.unsigned i0)); auto. +- rewrite Int64.negate_cmpu. auto. Qed. Lemma not_of_optbool: @@ -1223,21 +1601,47 @@ Theorem swap_cmpu_bool: cmpu_bool valid_ptr (swap_comparison c) x y = cmpu_bool valid_ptr c y x. Proof. - assert (forall c, cmp_different_blocks (swap_comparison c) = cmp_different_blocks c). - destruct c; auto. - destruct x; destruct y; simpl; auto. - rewrite Int.swap_cmpu. auto. - destruct (Int.eq i Int.zero && (valid_ptr b (Int.unsigned i0) || valid_ptr b (Int.unsigned i0 - 1))); auto. - destruct (Int.eq i0 Int.zero && (valid_ptr b (Int.unsigned i) || valid_ptr b (Int.unsigned i - 1))); auto. - destruct (eq_block b b0); subst. + assert (E: forall c, cmp_different_blocks (swap_comparison c) = cmp_different_blocks c). + { destruct c; auto. } + intros; unfold cmpu_bool. rewrite ! E. destruct Archi.ptr64 eqn:SF, x, y; auto. +- rewrite Int.swap_cmpu. auto. +- rewrite Int.swap_cmpu. auto. +- destruct (eq_block b b0); subst. + rewrite dec_eq_true. + destruct (valid_ptr b0 (Ptrofs.unsigned i) || valid_ptr b0 (Ptrofs.unsigned i - 1)); + destruct (valid_ptr b0 (Ptrofs.unsigned i0) || valid_ptr b0 (Ptrofs.unsigned i0 - 1)); + simpl; auto. + rewrite Ptrofs.swap_cmpu. auto. + rewrite dec_eq_false by auto. + destruct (valid_ptr b (Ptrofs.unsigned i)); + destruct (valid_ptr b0 (Ptrofs.unsigned i0)); simpl; auto. +Qed. + +Theorem swap_cmpl_bool: + forall c x y, + cmpl_bool (swap_comparison c) x y = cmpl_bool c y x. +Proof. + destruct x; destruct y; simpl; auto. rewrite Int64.swap_cmp. auto. +Qed. + +Theorem swap_cmplu_bool: + forall valid_ptr c x y, + cmplu_bool valid_ptr (swap_comparison c) x y = cmplu_bool valid_ptr c y x. +Proof. + assert (E: forall c, cmp_different_blocks (swap_comparison c) = cmp_different_blocks c). + { destruct c; auto. } + intros; unfold cmplu_bool. rewrite ! E. destruct Archi.ptr64 eqn:SF, x, y; auto. +- rewrite Int64.swap_cmpu. auto. +- destruct (eq_block b b0); subst. rewrite dec_eq_true. - destruct (valid_ptr b0 (Int.unsigned i) || valid_ptr b0 (Int.unsigned i - 1)); - destruct (valid_ptr b0 (Int.unsigned i0) || valid_ptr b0 (Int.unsigned i0 - 1)); + destruct (valid_ptr b0 (Ptrofs.unsigned i) || valid_ptr b0 (Ptrofs.unsigned i - 1)); + destruct (valid_ptr b0 (Ptrofs.unsigned i0) || valid_ptr b0 (Ptrofs.unsigned i0 - 1)); simpl; auto. - rewrite Int.swap_cmpu. auto. + rewrite Ptrofs.swap_cmpu. auto. rewrite dec_eq_false by auto. - destruct (valid_ptr b (Int.unsigned i)); - destruct (valid_ptr b0 (Int.unsigned i0)); simpl; auto. + destruct (valid_ptr b (Ptrofs.unsigned i)); + destruct (valid_ptr b0 (Ptrofs.unsigned i0)); simpl; auto. +- rewrite Int64.swap_cmpu. auto. Qed. Theorem negate_cmpf_eq: @@ -1426,6 +1830,13 @@ Proof. intros. inv H. inv H0. auto. destruct v1'; simpl; auto. simpl; auto. Qed. +Lemma addl_lessdef: + forall v1 v1' v2 v2', + lessdef v1 v1' -> lessdef v2 v2' -> lessdef (addl v1 v2) (addl v1' v2'). +Proof. + intros. inv H. inv H0. auto. destruct v1'; simpl; auto. simpl; auto. +Qed. + Lemma cmpu_bool_lessdef: forall valid_ptr valid_ptr' c v1 v1' v2 v2' b, (forall b ofs, valid_ptr b ofs = true -> valid_ptr' b ofs = true) -> @@ -1434,23 +1845,60 @@ Lemma cmpu_bool_lessdef: cmpu_bool valid_ptr' c v1' v2' = Some b. Proof. intros. - assert (A: forall b ofs, valid_ptr b ofs || valid_ptr b (ofs - 1) = true -> - valid_ptr' b ofs || valid_ptr' b (ofs - 1) = true). - { intros until ofs. rewrite ! orb_true_iff. intuition. } - destruct v1; simpl in H2; try discriminate; - destruct v2; simpl in H2; try discriminate; - inv H0; inv H1; simpl; auto. - destruct (Int.eq i Int.zero && (valid_ptr b0 (Int.unsigned i0) || valid_ptr b0 (Int.unsigned i0 - 1))) eqn:E; try discriminate. - InvBooleans. rewrite H0, A by auto. auto. - destruct (Int.eq i0 Int.zero && (valid_ptr b0 (Int.unsigned i) || valid_ptr b0 (Int.unsigned i - 1))) eqn:E; try discriminate. - InvBooleans. rewrite H0, A by auto. auto. - destruct (eq_block b0 b1). - destruct (valid_ptr b0 (Int.unsigned i) || valid_ptr b0 (Int.unsigned i - 1)) eqn:?; try discriminate. - destruct (valid_ptr b1 (Int.unsigned i0) || valid_ptr b1 (Int.unsigned i0 - 1)) eqn:?; try discriminate. - erewrite ! A by eauto. auto. - destruct (valid_ptr b0 (Int.unsigned i)) eqn:?; try discriminate. - destruct (valid_ptr b1 (Int.unsigned i0)) eqn:?; try discriminate. - erewrite ! H by eauto. auto. + assert (X: forall b ofs, + valid_ptr b ofs || valid_ptr b (ofs - 1) = true -> + valid_ptr' b ofs || valid_ptr' b (ofs - 1) = true). + { intros. apply orb_true_intro. destruct (orb_prop _ _ H3). + rewrite (H b0 ofs); auto. + rewrite (H b0 (ofs - 1)); auto. } + inv H0; [ | discriminate]. + inv H1; [ | destruct v1'; discriminate ]. + unfold cmpu_bool in *. remember Archi.ptr64 as ptr64. + destruct v1'; auto; destruct v2'; auto; destruct ptr64; auto. +- destruct (Int.eq i Int.zero); auto. + destruct (valid_ptr b0 (Ptrofs.unsigned i0) || valid_ptr b0 (Ptrofs.unsigned i0 - 1)) eqn:A; inv H2. + rewrite X; auto. +- destruct (Int.eq i0 Int.zero); auto. + destruct (valid_ptr b0 (Ptrofs.unsigned i) || valid_ptr b0 (Ptrofs.unsigned i - 1)) eqn:A; inv H2. + rewrite X; auto. +- destruct (eq_block b0 b1). ++ destruct (valid_ptr b0 (Ptrofs.unsigned i) || valid_ptr b0 (Ptrofs.unsigned i - 1)) eqn:A; inv H2. + destruct (valid_ptr b1 (Ptrofs.unsigned i0) || valid_ptr b1 (Ptrofs.unsigned i0 - 1)) eqn:B; inv H1. + rewrite ! X; auto. ++ destruct (valid_ptr b0 (Ptrofs.unsigned i) && valid_ptr b1 (Ptrofs.unsigned i0)) eqn:A; inv H2. + InvBooleans. rewrite ! H; auto. +Qed. + +Lemma cmplu_bool_lessdef: + forall valid_ptr valid_ptr' c v1 v1' v2 v2' b, + (forall b ofs, valid_ptr b ofs = true -> valid_ptr' b ofs = true) -> + lessdef v1 v1' -> lessdef v2 v2' -> + cmplu_bool valid_ptr c v1 v2 = Some b -> + cmplu_bool valid_ptr' c v1' v2' = Some b. +Proof. + intros. + assert (X: forall b ofs, + valid_ptr b ofs || valid_ptr b (ofs - 1) = true -> + valid_ptr' b ofs || valid_ptr' b (ofs - 1) = true). + { intros. apply orb_true_intro. destruct (orb_prop _ _ H3). + rewrite (H b0 ofs); auto. + rewrite (H b0 (ofs - 1)); auto. } + inv H0; [ | discriminate]. + inv H1; [ | destruct v1'; discriminate ]. + unfold cmplu_bool in *. remember Archi.ptr64 as ptr64. + destruct v1'; auto; destruct v2'; auto; destruct ptr64; auto. +- destruct (Int64.eq i Int64.zero); auto. + destruct (valid_ptr b0 (Ptrofs.unsigned i0) || valid_ptr b0 (Ptrofs.unsigned i0 - 1)) eqn:A; inv H2. + rewrite X; auto. +- destruct (Int64.eq i0 Int64.zero); auto. + destruct (valid_ptr b0 (Ptrofs.unsigned i) || valid_ptr b0 (Ptrofs.unsigned i - 1)) eqn:A; inv H2. + rewrite X; auto. +- destruct (eq_block b0 b1). ++ destruct (valid_ptr b0 (Ptrofs.unsigned i) || valid_ptr b0 (Ptrofs.unsigned i - 1)) eqn:A; inv H2. + destruct (valid_ptr b1 (Ptrofs.unsigned i0) || valid_ptr b1 (Ptrofs.unsigned i0 - 1)) eqn:B; inv H1. + rewrite ! X; auto. ++ destruct (valid_ptr b0 (Ptrofs.unsigned i) && valid_ptr b1 (Ptrofs.unsigned i0)) eqn:A; inv H2. + InvBooleans. rewrite ! H; auto. Qed. Lemma of_optbool_lessdef: @@ -1480,6 +1928,18 @@ Proof. intros. inv H; auto. Qed. +Lemma offset_ptr_zero: + forall v, lessdef (offset_ptr v Ptrofs.zero) v. +Proof. + intros. destruct v; simpl; auto. rewrite Ptrofs.add_zero; auto. +Qed. + +Lemma offset_ptr_assoc: + forall v d1 d2, offset_ptr (offset_ptr v d1) d2 = offset_ptr v (Ptrofs.add d1 d2). +Proof. + intros. destruct v; simpl; auto. f_equal. apply Ptrofs.add_assoc. +Qed. + (** * Values and memory injections *) (** A memory injection [f] is a function from addresses to either [None] @@ -1509,7 +1969,7 @@ Inductive inject (mi: meminj): val -> val -> Prop := | inject_ptr: forall b1 ofs1 b2 ofs2 delta, mi b1 = Some (b2, delta) -> - ofs2 = Int.add ofs1 (Int.repr delta) -> + ofs2 = Ptrofs.add ofs1 (Ptrofs.repr delta) -> inject mi (Vptr b1 ofs1) (Vptr b2 ofs2) | val_inject_undef: forall v, inject mi Vundef v. @@ -1525,6 +1985,14 @@ Inductive inject_list (mi: meminj): list val -> list val-> Prop:= Hint Resolve inject_list_nil inject_list_cons. +Lemma inject_ptrofs: + forall mi i, inject mi (Vptrofs i) (Vptrofs i). +Proof. + unfold Vptrofs; intros. destruct Archi.ptr64; auto. +Qed. + +Hint Resolve inject_ptrofs. + Section VAL_INJ_OPS. Variable f: meminj. @@ -1534,7 +2002,7 @@ Lemma load_result_inject: inject f v1 v2 -> inject f (Val.load_result chunk v1) (Val.load_result chunk v2). Proof. - intros. inv H; destruct chunk; simpl; econstructor; eauto. + intros. inv H; destruct chunk; simpl; try constructor; destruct Archi.ptr64; econstructor; eauto. Qed. Remark add_inject: @@ -1543,9 +2011,13 @@ Remark add_inject: inject f v2 v2' -> inject f (Val.add v1 v2) (Val.add v1' v2'). Proof. - intros. inv H; inv H0; simpl; econstructor; eauto. - repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + intros. unfold Val.add. destruct Archi.ptr64 eqn:SF. +- inv H; inv H0; constructor. +- inv H; inv H0; simpl; auto. ++ econstructor; eauto. + rewrite ! Ptrofs.add_assoc. decEq. apply Ptrofs.add_commut. ++ econstructor; eauto. + rewrite ! Ptrofs.add_assoc. decEq. apply Ptrofs.add_commut. Qed. Remark sub_inject: @@ -1554,10 +2026,52 @@ Remark sub_inject: inject f v2 v2' -> inject f (Val.sub v1 v2) (Val.sub v1' v2'). Proof. - intros. inv H; inv H0; simpl; auto. - econstructor; eauto. rewrite Int.sub_add_l. auto. - destruct (eq_block b1 b0); auto. subst. rewrite H1 in H. inv H. rewrite dec_eq_true. - rewrite Int.sub_shifted. auto. + intros. unfold Val.sub. destruct Archi.ptr64 eqn:SF. +- inv H; inv H0; constructor. +- inv H; inv H0; simpl; auto. ++ econstructor; eauto. + rewrite Ptrofs.sub_add_l. auto. ++ destruct (eq_block b1 b0); auto. + subst. rewrite H1 in H. inv H. rewrite dec_eq_true. + rewrite Ptrofs.sub_shifted. auto. +Qed. + +Remark addl_inject: + forall v1 v1' v2 v2', + inject f v1 v1' -> + inject f v2 v2' -> + inject f (Val.addl v1 v2) (Val.addl v1' v2'). +Proof. + intros. unfold Val.addl. destruct Archi.ptr64 eqn:SF. +- inv H; inv H0; simpl; auto. ++ econstructor; eauto. + rewrite ! Ptrofs.add_assoc. decEq. apply Ptrofs.add_commut. ++ econstructor; eauto. + rewrite ! Ptrofs.add_assoc. decEq. apply Ptrofs.add_commut. +- inv H; inv H0; constructor. +Qed. + +Remark subl_inject: + forall v1 v1' v2 v2', + inject f v1 v1' -> + inject f v2 v2' -> + inject f (Val.subl v1 v2) (Val.subl v1' v2'). +Proof. + intros. unfold Val.subl. destruct Archi.ptr64 eqn:SF. +- inv H; inv H0; simpl; auto. ++ econstructor; eauto. + rewrite Ptrofs.sub_add_l. auto. ++ destruct (eq_block b1 b0); auto. + subst. rewrite H1 in H. inv H. rewrite dec_eq_true. + rewrite Ptrofs.sub_shifted. auto. +- inv H; inv H0; constructor. +Qed. + +Lemma offset_ptr_inject: + forall v v' ofs, inject f v v' -> inject f (offset_ptr v ofs) (offset_ptr v' ofs). +Proof. + intros. inv H; simpl; econstructor; eauto. + rewrite ! Ptrofs.add_assoc. f_equal. apply Ptrofs.add_commut. Qed. Lemma cmp_bool_inject: @@ -1578,30 +2092,30 @@ Let weak_valid_ptr2 b ofs := valid_ptr2 b ofs || valid_ptr2 b (ofs - 1). Hypothesis valid_ptr_inj: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - valid_ptr1 b1 (Int.unsigned ofs) = true -> - valid_ptr2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + valid_ptr1 b1 (Ptrofs.unsigned ofs) = true -> + valid_ptr2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Hypothesis weak_valid_ptr_inj: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - weak_valid_ptr1 b1 (Int.unsigned ofs) = true -> - weak_valid_ptr2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + weak_valid_ptr1 b1 (Ptrofs.unsigned ofs) = true -> + weak_valid_ptr2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Hypothesis weak_valid_ptr_no_overflow: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - weak_valid_ptr1 b1 (Int.unsigned ofs) = true -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + weak_valid_ptr1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. Hypothesis valid_different_ptrs_inj: forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, b1 <> b2 -> - valid_ptr1 b1 (Int.unsigned ofs1) = true -> - valid_ptr1 b2 (Int.unsigned ofs2) = true -> + valid_ptr1 b1 (Ptrofs.unsigned ofs1) = true -> + valid_ptr1 b2 (Ptrofs.unsigned ofs2) = true -> f b1 = Some (b1', delta1) -> f b2 = Some (b2', delta2) -> b1' <> b2' \/ - Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)). + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). Lemma cmpu_bool_inject: forall c v1 v2 v1' v2' b, @@ -1610,38 +2124,84 @@ Lemma cmpu_bool_inject: Val.cmpu_bool valid_ptr1 c v1 v2 = Some b -> Val.cmpu_bool valid_ptr2 c v1' v2' = Some b. Proof. - Local Opaque Int.add. - intros. inv H; simpl in H1; try discriminate; inv H0; simpl in H1; try discriminate; simpl; auto. -- fold (weak_valid_ptr1 b1 (Int.unsigned ofs1)) in H1. - fold (weak_valid_ptr2 b2 (Int.unsigned (Int.add ofs1 (Int.repr delta)))). + Local Opaque Int.add Ptrofs.add. + intros. + unfold cmpu_bool in *; destruct Archi.ptr64; + inv H; simpl in H1; try discriminate; inv H0; simpl in H1; try discriminate; simpl; auto. +- fold (weak_valid_ptr1 b1 (Ptrofs.unsigned ofs1)) in H1. + fold (weak_valid_ptr2 b2 (Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)))). destruct (Int.eq i Int.zero); auto. - destruct (weak_valid_ptr1 b1 (Int.unsigned ofs1)) eqn:E; try discriminate. + destruct (weak_valid_ptr1 b1 (Ptrofs.unsigned ofs1)) eqn:E; try discriminate. erewrite weak_valid_ptr_inj by eauto. auto. -- fold (weak_valid_ptr1 b1 (Int.unsigned ofs1)) in H1. - fold (weak_valid_ptr2 b2 (Int.unsigned (Int.add ofs1 (Int.repr delta)))). +- fold (weak_valid_ptr1 b1 (Ptrofs.unsigned ofs1)) in H1. + fold (weak_valid_ptr2 b2 (Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)))). destruct (Int.eq i Int.zero); auto. - destruct (weak_valid_ptr1 b1 (Int.unsigned ofs1)) eqn:E; try discriminate. + destruct (weak_valid_ptr1 b1 (Ptrofs.unsigned ofs1)) eqn:E; try discriminate. + erewrite weak_valid_ptr_inj by eauto. auto. +- fold (weak_valid_ptr1 b1 (Ptrofs.unsigned ofs1)) in H1. + fold (weak_valid_ptr1 b0 (Ptrofs.unsigned ofs0)) in H1. + fold (weak_valid_ptr2 b2 (Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)))). + fold (weak_valid_ptr2 b3 (Ptrofs.unsigned (Ptrofs.add ofs0 (Ptrofs.repr delta0)))). + destruct (eq_block b1 b0); subst. + rewrite H in H2. inv H2. rewrite dec_eq_true. + destruct (weak_valid_ptr1 b0 (Ptrofs.unsigned ofs1)) eqn:?; try discriminate. + destruct (weak_valid_ptr1 b0 (Ptrofs.unsigned ofs0)) eqn:?; try discriminate. + erewrite !weak_valid_ptr_inj by eauto. simpl. + rewrite <-H1. simpl. decEq. apply Ptrofs.translate_cmpu; eauto. + destruct (valid_ptr1 b1 (Ptrofs.unsigned ofs1)) eqn:?; try discriminate. + destruct (valid_ptr1 b0 (Ptrofs.unsigned ofs0)) eqn:?; try discriminate. + destruct (eq_block b2 b3); subst. + assert (valid_ptr_implies: forall b ofs, valid_ptr1 b ofs = true -> weak_valid_ptr1 b ofs = true). + intros. unfold weak_valid_ptr1. rewrite H0; auto. + erewrite !weak_valid_ptr_inj by eauto using valid_ptr_implies. simpl. + exploit valid_different_ptrs_inj; eauto. intros [?|?]; [congruence |]. + destruct c; simpl in H1; inv H1. + simpl; decEq. rewrite Ptrofs.eq_false; auto. congruence. + simpl; decEq. rewrite Ptrofs.eq_false; auto. congruence. + now erewrite !valid_ptr_inj by eauto. +Qed. + +Lemma cmplu_bool_inject: + forall c v1 v2 v1' v2' b, + inject f v1 v1' -> + inject f v2 v2' -> + Val.cmplu_bool valid_ptr1 c v1 v2 = Some b -> + Val.cmplu_bool valid_ptr2 c v1' v2' = Some b. +Proof. + Local Opaque Int64.add Ptrofs.add. + intros. + unfold cmplu_bool in *; destruct Archi.ptr64; + inv H; simpl in H1; try discriminate; inv H0; simpl in H1; try discriminate; simpl; auto. +- fold (weak_valid_ptr1 b1 (Ptrofs.unsigned ofs1)) in H1. + fold (weak_valid_ptr2 b2 (Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)))). + destruct (Int64.eq i Int64.zero); auto. + destruct (weak_valid_ptr1 b1 (Ptrofs.unsigned ofs1)) eqn:E; try discriminate. + erewrite weak_valid_ptr_inj by eauto. auto. +- fold (weak_valid_ptr1 b1 (Ptrofs.unsigned ofs1)) in H1. + fold (weak_valid_ptr2 b2 (Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)))). + destruct (Int64.eq i Int64.zero); auto. + destruct (weak_valid_ptr1 b1 (Ptrofs.unsigned ofs1)) eqn:E; try discriminate. erewrite weak_valid_ptr_inj by eauto. auto. -- fold (weak_valid_ptr1 b1 (Int.unsigned ofs1)) in H1. - fold (weak_valid_ptr1 b0 (Int.unsigned ofs0)) in H1. - fold (weak_valid_ptr2 b2 (Int.unsigned (Int.add ofs1 (Int.repr delta)))). - fold (weak_valid_ptr2 b3 (Int.unsigned (Int.add ofs0 (Int.repr delta0)))). +- fold (weak_valid_ptr1 b1 (Ptrofs.unsigned ofs1)) in H1. + fold (weak_valid_ptr1 b0 (Ptrofs.unsigned ofs0)) in H1. + fold (weak_valid_ptr2 b2 (Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)))). + fold (weak_valid_ptr2 b3 (Ptrofs.unsigned (Ptrofs.add ofs0 (Ptrofs.repr delta0)))). destruct (eq_block b1 b0); subst. rewrite H in H2. inv H2. rewrite dec_eq_true. - destruct (weak_valid_ptr1 b0 (Int.unsigned ofs1)) eqn:?; try discriminate. - destruct (weak_valid_ptr1 b0 (Int.unsigned ofs0)) eqn:?; try discriminate. + destruct (weak_valid_ptr1 b0 (Ptrofs.unsigned ofs1)) eqn:?; try discriminate. + destruct (weak_valid_ptr1 b0 (Ptrofs.unsigned ofs0)) eqn:?; try discriminate. erewrite !weak_valid_ptr_inj by eauto. simpl. - rewrite <-H1. simpl. decEq. apply Int.translate_cmpu; eauto. - destruct (valid_ptr1 b1 (Int.unsigned ofs1)) eqn:?; try discriminate. - destruct (valid_ptr1 b0 (Int.unsigned ofs0)) eqn:?; try discriminate. + rewrite <-H1. simpl. decEq. apply Ptrofs.translate_cmpu; eauto. + destruct (valid_ptr1 b1 (Ptrofs.unsigned ofs1)) eqn:?; try discriminate. + destruct (valid_ptr1 b0 (Ptrofs.unsigned ofs0)) eqn:?; try discriminate. destruct (eq_block b2 b3); subst. assert (valid_ptr_implies: forall b ofs, valid_ptr1 b ofs = true -> weak_valid_ptr1 b ofs = true). intros. unfold weak_valid_ptr1. rewrite H0; auto. erewrite !weak_valid_ptr_inj by eauto using valid_ptr_implies. simpl. exploit valid_different_ptrs_inj; eauto. intros [?|?]; [congruence |]. destruct c; simpl in H1; inv H1. - simpl; decEq. rewrite Int.eq_false; auto. congruence. - simpl; decEq. rewrite Int.eq_false; auto. congruence. + simpl; decEq. rewrite Ptrofs.eq_false; auto. congruence. + simpl; decEq. rewrite Ptrofs.eq_false; auto. congruence. now erewrite !valid_ptr_inj by eauto. Qed. @@ -1710,8 +2270,8 @@ Lemma val_inject_lessdef: forall v1 v2, Val.lessdef v1 v2 <-> Val.inject (fun b => Some(b, 0)) v1 v2. Proof. intros; split; intros. - inv H; auto. destruct v2; econstructor; eauto. rewrite Int.add_zero; auto. - inv H; auto. inv H0. rewrite Int.add_zero; auto. + inv H; auto. destruct v2; econstructor; eauto. rewrite Ptrofs.add_zero; auto. + inv H; auto. inv H0. rewrite Ptrofs.add_zero; auto. Qed. Lemma val_inject_list_lessdef: @@ -1732,8 +2292,8 @@ Lemma val_inject_id: Proof. intros; split; intros. inv H; auto. - unfold inject_id in H0. inv H0. rewrite Int.add_zero. constructor. - inv H. destruct v2; econstructor. unfold inject_id; reflexivity. rewrite Int.add_zero; auto. + unfold inject_id in H0. inv H0. rewrite Ptrofs.add_zero. constructor. + inv H. destruct v2; econstructor. unfold inject_id; reflexivity. rewrite Ptrofs.add_zero; auto. constructor. Qed. @@ -1757,5 +2317,5 @@ Lemma val_inject_compose: Proof. intros. inv H; auto; inv H0; auto. econstructor. unfold compose_meminj; rewrite H1; rewrite H3; eauto. - rewrite Int.add_assoc. decEq. unfold Int.add. apply Int.eqm_samerepr. auto with ints. + rewrite Ptrofs.add_assoc. decEq. unfold Ptrofs.add. apply Ptrofs.eqm_samerepr. auto with ints. Qed. @@ -37,12 +37,16 @@ Supported targets: armeb-linux (ARM, EABI, big endian) armeb-eabihf (ARM, EABI using hardware FP registers, big endian) armeb-hardfloat (ARM, EABI using hardware FP registers, big endian) - ia32-linux (x86 32 bits, Linux) - ia32-bsd (x86 32 bits, BSD) - ia32-macosx (x86 32 bits, MacOS X) - ia32-cygwin (x86 32 bits, Cygwin environment under Windows) + x86_32-linux (x86 32 bits, Linux) + x86_32-bsd (x86 32 bits, BSD) + x86_32-macosx (x86 32 bits, MacOS X) + x86_32-cygwin (x86 32 bits, Cygwin environment under Windows) + x86_64-linux (x86 64 bits, Linux) + x86_64-macosx (x86 64 bits, MacOS X) manual (edit configuration file by hand) +For x86 targets, the "x86_32-" prefix can also be written "ia32-". + For PowerPC targets, the "ppc-" prefix can be refined into: ppc64- PowerPC 64 bits e5500- Freescale e5500 core (PowerPC 64 bit, EREF extensions) @@ -106,29 +110,31 @@ done # case "$target" in arm-*|armv7a-*) - arch="arm"; model="armv7a"; endianness="little";; + arch="arm"; model="armv7a"; endianness="little"; bitsize=32;; armv6-*) - arch="arm"; model="armv6"; endianness="little";; + arch="arm"; model="armv6"; endianness="little"; bitsize=32;; armv7r-*) - arch="arm"; model="armv7r"; endianness="little";; + arch="arm"; model="armv7r"; endianness="little"; bitsize=32;; armv7m-*) - arch="arm"; model="armv7m"; endianness="little";; + arch="arm"; model="armv7m"; endianness="little"; bitsize=32;; armeb-*|armebv7a-*) - arch="arm"; model="armv7a"; endianness="big";; + arch="arm"; model="armv7a"; endianness="big"; bitsize=32;; armebv6-*) - arch="arm"; model="armv6"; endianness="big";; + arch="arm"; model="armv6"; endianness="big"; bitsize=32;; armebv7r-*) - arch="arm"; model="armv7r"; endianness="big";; + arch="arm"; model="armv7r"; endianness="big"; bitsize=32;; armebv7m-*) - arch="arm"; model="armv7m"; endianness="big";; - ia32-*) - arch="ia32"; model="sse2"; endianness="little";; + arch="arm"; model="armv7m"; endianness="big"; bitsize=32;; + x86_32-*|ia32-*) + arch="x86"; model="32sse2"; endianness="little"; bitsize=32;; + x86_64-*) + arch="x86"; model="64"; endianness="little"; bitsize=64;; powerpc-*|ppc-*) - arch="powerpc"; model="ppc32"; endianness="big";; + arch="powerpc"; model="ppc32"; endianness="big"; bitsize=32;; powerpc64-*|ppc64-*) - arch="powerpc"; model="ppc64"; endianness="big";; + arch="powerpc"; model="ppc64"; endianness="big"; bitsize=32;; e5500-*) - arch="powerpc"; model="e5500"; endianness="big";; + arch="powerpc"; model="e5500"; endianness="big"; bitsize=32;; manual) ;; "") @@ -243,9 +249,9 @@ fi # -# IA32 Target Configuration +# x86 (32 bits) Target Configuration # -if test "$arch" = "ia32"; then +if test "$arch" = "x86" -a "$bitsize" = "32"; then case "$target" in bsd) @@ -300,7 +306,7 @@ if test "$arch" = "ia32"; then cc="${toolprefix}gcc -arch i386" clinker="${toolprefix}gcc" cprepro="${toolprefix}gcc" - cprepro_options="-std=c99 -arch i386 -U__GNUC__ -U__clang__ -U__BLOCKS__ '-D__attribute__(x)=' '-D__asm(x)=' '-D_Nullable=' -E" + cprepro_options="-std=c99 -arch i386 -U__GNUC__ -U__clang__ -U__BLOCKS__ '-D__attribute__(x)=' '-D__asm(x)=' '-D_Nullable=' '-D_Nonnull=' -E" libmath="" struct_passing="ints" struct_return="int1248" @@ -315,7 +321,50 @@ if test "$arch" = "ia32"; then fi ;; *) - echo "Error: invalid eabi/system '$target' for architecture IA32." 1>&2 + echo "Error: invalid eabi/system '$target' for architecture IA32/X86_32." 1>&2 + echo "$usage" 1>&2 + exit 2;; + esac +fi + +# +# IA32 (64 bits) Target Configuration +# +if test "$arch" = "x86" -a "$bitsize" = "64"; then + + case "$target" in + linux) + abi="standard" + casm="${toolprefix}gcc" + casm_options="-m64 -c" + cc="${toolprefix}gcc -m64" + clinker="${toolprefix}gcc" + clinker_options="-m64" + cprepro="${toolprefix}gcc" + cprepro_options="-std=c99 -m64 -U__GNUC__ -E" + libmath="-lm" + struct_passing="ref-callee" # wrong! + struct_return="ref" # to check! + system="linux" + ;; + macosx) + # kernel major versions count upwards from 4 for OSX 10.0 to 15 for OSX 10.11 + kernel_major=`uname -r | cut -d "." -f 1` + + abi="macosx" + casm="${toolprefix}gcc" + casm_options="-arch x86_64 -c" + cc="${toolprefix}gcc -arch x86_64" + clinker="${toolprefix}gcc" + cprepro="${toolprefix}gcc" + cprepro_options="-std=c99 -arch x86_64 -U__GNUC__ -U__clang__ -U__BLOCKS__ '-D__attribute__(x)=' '-D__asm(x)=' '-D_Nullable=' '-D_Nonnull=' -E" + libmath="" + struct_passing="ref-callee" # wrong! + struct_return="ref" # to check! + system="macosx" + ;; + *) + echo "Error: invalid eabi/system '$target' for architecture X86_64." 1>&2 echo "$usage" 1>&2 exit 2;; esac @@ -493,6 +542,7 @@ cat >> Makefile.config <<EOF ABI=$abi ARCH=$arch ASM_SUPPORTS_CFI=$asm_supports_cfi +BITSIZE=$bitsize CASM=$casm CASM_OPTIONS=$casm_options CASMRUNTIME=$casmruntime @@ -518,7 +568,7 @@ cat >> Makefile.config <<'EOF' # Target architecture # ARCH=powerpc # ARCH=arm -# ARCH=ia32 +# ARCH=x86 ARCH= # Hardware variant @@ -529,19 +579,25 @@ ARCH= # MODEL=armv7a # for ARM # MODEL=armv7r # for ARM # MODEL=armv7m # for ARM -# MODEL=sse2 # for IA32 +# MODEL=32sse2 # for x86 in 32-bit mode +# MODEL=64 # for x86 in 64-bit mode MODEL= # Target ABI # ABI=eabi # for PowerPC / Linux and other SVR4 or EABI platforms # ABI=eabi # for ARM # ABI=hardfloat # for ARM -# ABI=standard # for IA32 +# ABI=standard # for x86 ABI= +# Target bit width +# BITSIZE=64 # for x86 in 64-bit mode +# BITSIZE=32 # otherwise +BITSIZE= + # Target endianness # ENDIANNESS=big # for ARM or PowerPC -# ENDIANNESS=little # for ARM or IA32 +# ENDIANNESS=little # for ARM or x86 ENDIANNESS= # Default calling conventions for passing structs and unions by value @@ -566,7 +622,7 @@ STRUCT_RETURN=ref # Possible choices for ARM: # SYSTEM=linux # -# Possible choices for IA32: +# Possible choices for x86: # SYSTEM=linux # SYSTEM=bsd # SYSTEM=macosx @@ -610,6 +666,10 @@ RESPONSEFILE="none" EOF fi +# +# Clean up target-dependent files to force their recompilation +# +rm -f .depend $arch/Archi.vo ${arch}_${bitsize}/Archi.vo runtime/*.o # # Summarize Configuration @@ -648,7 +708,5 @@ CompCert configuration: Standard headers installed in. $libdirexp/include Build command to use.......... $make -If anything above looks wrong, please edit file ./Makefile.config to correct. - EOF fi diff --git a/cparser/PackedStructs.ml b/cparser/PackedStructs.ml index a921e2d8..b74a29d4 100644 --- a/cparser/PackedStructs.ml +++ b/cparser/PackedStructs.ml @@ -36,7 +36,7 @@ let byteswapped_fields : (ident * string, unit) Hashtbl.t let rec can_byte_swap env ty = match unroll env ty with - | TInt(ik, _) -> (sizeof_ikind ik <= 4, sizeof_ikind ik > 1) + | TInt(ik, _) -> (sizeof_ikind ik <= !config.sizeof_ptr (*FIXME*), sizeof_ikind ik > 1) | TEnum(_, _) -> (true, sizeof_ikind enum_ikind > 1) | TPtr(_, _) -> (true, true) (* tolerance? *) | TArray(ty_elt, _, _) -> can_byte_swap env ty_elt @@ -155,7 +155,7 @@ let use_reversed = ref false let bswap_read loc env lval = let ty = lval.etyp in let (bsize, aty) = accessor_type loc env ty in - assert (bsize = 16 || bsize = 32); + assert (bsize = 16 || bsize = 32 || (bsize = 64 && !config.sizeof_ptr = 8)); try if !use_reversed then begin let (id, fty) = @@ -182,7 +182,7 @@ let bswap_write loc env lhs rhs = let ty = lhs.etyp in let (bsize, aty) = accessor_type loc env ty in - assert (bsize = 16 || bsize = 32); + assert (bsize = 16 || bsize = 32 || (bsize = 64 && !config.sizeof_ptr = 8)); try if !use_reversed then begin let (id, fty) = diff --git a/driver/Configuration.ml b/driver/Configuration.ml index 87e29e0f..85a163bf 100644 --- a/driver/Configuration.ml +++ b/driver/Configuration.ml @@ -117,7 +117,7 @@ let linker = let arch = match get_config_string "arch" with - | "powerpc"|"arm"|"ia32" as a -> a + | "powerpc"|"arm"|"ia32"|"x86_64"|"x86" as a -> a | v -> bad_config "arch" [v] let model = get_config_string "model" let abi = get_config_string "abi" diff --git a/driver/Driver.ml b/driver/Driver.ml index a273a91a..145de6c5 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -511,9 +511,12 @@ let _ = | "arm" -> if Configuration.is_big_endian then Machine.arm_bigendian else Machine.arm_littleendian - | "ia32" -> if Configuration.abi = "macosx" - then Machine.x86_32_macosx - else Machine.x86_32 + | "x86" -> if Configuration.model = "64" then + Machine.x86_64 + else + if Configuration.abi = "macosx" + then Machine.x86_32_macosx + else Machine.x86_32 | _ -> assert false end; Builtins.set C2C.builtins; diff --git a/driver/Interp.ml b/driver/Interp.ml index d7e0b1bc..1e328a70 100644 --- a/driver/Interp.ml +++ b/driver/Interp.ml @@ -366,14 +366,14 @@ let (>>=) opt f = match opt with None -> None | Some arg -> f arg (* Like eventval_of_val, but accepts static globals as well *) let convert_external_arg ge v t = - match v, t with - | Vint i, AST.Tint -> Some (EVint i) - | Vfloat f, AST.Tfloat -> Some (EVfloat f) - | Vsingle f, AST.Tsingle -> Some (EVsingle f) - | Vlong n, AST.Tlong -> Some (EVlong n) - | Vptr(b, ofs), AST.Tint -> + match v with + | Vint i -> Some (EVint i) + | Vfloat f -> Some (EVfloat f) + | Vsingle f -> Some (EVsingle f) + | Vlong n -> Some (EVlong n) + | Vptr(b, ofs) -> Senv.invert_symbol ge b >>= fun id -> Some (EVptr_global(id, ofs)) - | _, _ -> None + | _ -> None let rec convert_external_args ge vl tl = match vl, tl with diff --git a/extraction/extraction.v b/extraction/extraction.v index 8e13264c..ffa06ddf 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -166,6 +166,7 @@ Separate Extraction Ctyping.typecheck_program Ctyping.epostincr Ctyping.epostdecr Ctyping.epreincr Ctyping.epredecr Ctypes.make_program + Conventions1.is_float_reg Conventions1.int_caller_save_regs Conventions1.float_caller_save_regs Conventions1.int_callee_save_regs Conventions1.float_callee_save_regs Conventions1.dummy_int_reg Conventions1.dummy_float_reg diff --git a/ia32/ConstpropOp.vp b/ia32/ConstpropOp.vp deleted file mode 100644 index a3de748c..00000000 --- a/ia32/ConstpropOp.vp +++ /dev/null @@ -1,227 +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. *) -(* *) -(* *********************************************************************) - -(** Strength reduction for operators and conditions. - This is the machine-dependent part of [Constprop]. *) - -Require Import Coqlib. -Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Op. -Require Import Registers. -Require Import ValueDomain. - -(** * 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. *) - -Nondetfunction cond_strength_reduction - (cond: condition) (args: list reg) (vl: list aval) := - match cond, args, vl with - | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => - (Ccompimm (swap_comparison c) n1, r2 :: nil) - | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Ccompimm c n2, r1 :: nil) - | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => - (Ccompuimm (swap_comparison c) n1, r2 :: nil) - | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Ccompuimm c n2, r1 :: nil) - | _, _, _ => - (cond, args) - end. - -Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) := - let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args'). - -Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := - match c, args, vl with - | Ccompimm Ceq n, r1 :: nil, v1 :: nil => - if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) - else if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) - else make_cmp_base c args vl - | Ccompimm Cne n, r1 :: nil, v1 :: nil => - if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) - else if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) - else make_cmp_base c args vl - | _, _, _ => - make_cmp_base c args vl - end. - -Nondetfunction addr_strength_reduction - (addr: addressing) (args: list reg) (vl: list aval) := - match addr, args, vl with - - | Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil => - (Aglobal symb (Int.add n ofs), nil) - | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil => - (Ainstack (Int.add n ofs), nil) - - | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil => - (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) - | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Gl symb n2) :: nil => - (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) - | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil => - (Ainstack (Int.add (Int.add n1 n2) ofs), nil) - | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Stk n2) :: nil => - (Ainstack (Int.add (Int.add n1 n2) ofs), nil) - | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil => - (Abased symb (Int.add n1 ofs), r2 :: nil) - | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil => - (Abased symb (Int.add n2 ofs), r1 :: nil) - | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => - (Aindexed (Int.add n1 ofs), r2 :: nil) - | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Aindexed (Int.add n2 ofs), r1 :: nil) - - | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil => - (Aglobal symb (Int.add (Int.add n1 (Int.mul n2 sc)) ofs), nil) - | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil => - (Abasedscaled sc symb (Int.add n1 ofs), r2 :: nil) - | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Aindexed (Int.add (Int.mul n2 sc) ofs), r1 :: nil) - - | Abased id ofs, r1 :: nil, I n1 :: nil => - (Aglobal id (Int.add ofs n1), nil) - - | Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil => - (Aglobal id (Int.add ofs (Int.mul sc n1)), nil) - - | _, _ => - (addr, args) - end. - -Definition make_addimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Olea (Aindexed n), r :: nil). - -Definition make_shlimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int.iwordsize then (Oshlimm n, r1 :: nil) - else (Oshl, r1 :: r2 :: nil). - -Definition make_shrimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int.iwordsize then (Oshrimm n, r1 :: nil) - else (Oshr, r1 :: r2 :: nil). - -Definition make_shruimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int.iwordsize then (Oshruimm n, r1 :: nil) - else (Oshru, r1 :: r2 :: 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 => (Oshlimm l, r :: nil) - | None => (Omulimm n, r :: nil) - end. - -Definition make_andimm (n: int) (r: reg) (a: aval) := - if Int.eq n Int.zero then (Ointconst Int.zero, nil) - else if Int.eq n Int.mone then (Omove, r :: nil) - else if match a with Uns _ m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero - | _ => false end - 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 make_divimm n (r1 r2: reg) := - match Int.is_power2 n with - | Some l => if Int.ltu l (Int.repr 31) - then (Oshrximm l, r1 :: nil) - else (Odiv, r1 :: r2 :: nil) - | None => (Odiv, r1 :: r2 :: nil) - end. - -Definition make_divuimm n (r1 r2: reg) := - match Int.is_power2 n with - | Some l => (Oshruimm l, r1 :: nil) - | None => (Odivu, r1 :: r2 :: nil) - end. - -Definition make_moduimm n (r1 r2: reg) := - match Int.is_power2 n with - | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) - | None => (Omodu, r1 :: r2 :: nil) - end. - -Definition make_mulfimm (n: float) (r r1 r2: reg) := - if Float.eq_dec n (Float.of_int (Int.repr 2)) - then (Oaddf, r :: r :: nil) - else (Omulf, r1 :: r2 :: nil). - -Definition make_mulfsimm (n: float32) (r r1 r2: reg) := - if Float32.eq_dec n (Float32.of_int (Int.repr 2)) - then (Oaddfs, r :: r :: nil) - else (Omulfs, r1 :: r2 :: nil). - -Definition make_cast8signed (r: reg) (a: aval) := - if vincl a (Sgn Ptop 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil). -Definition make_cast8unsigned (r: reg) (a: aval) := - if vincl a (Uns Ptop 8) then (Omove, r :: nil) else (Ocast8unsigned, r :: nil). -Definition make_cast16signed (r: reg) (a: aval) := - if vincl a (Sgn Ptop 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil). -Definition make_cast16unsigned (r: reg) (a: aval) := - if vincl a (Uns Ptop 16) then (Omove, r :: nil) else (Ocast16unsigned, r :: nil). - -Nondetfunction op_strength_reduction - (op: operation) (args: list reg) (vl: list aval) := - match op, args, vl with - | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1 - | Ocast8unsigned, r1 :: nil, v1 :: nil => make_cast8unsigned r1 v1 - | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1 - | Ocast16unsigned, r1 :: nil, v1 :: nil => make_cast16unsigned r1 v1 - | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 - | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 - | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 - | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 - | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 - | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2 - | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2 - | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1 - | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1 - | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2 - | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 - | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2 - | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 - | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2 - | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 - | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 - | Olea addr, args, vl => - let (addr', args') := addr_strength_reduction addr args vl in - (Olea addr', args') - | Ocmp c, args, vl => make_cmp c args vl - | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 - | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 - | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 - | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2 - | _, _, _ => (op, args) - end. diff --git a/ia32/ConstpropOpproof.v b/ia32/ConstpropOpproof.v deleted file mode 100644 index 3dfb8ccf..00000000 --- a/ia32/ConstpropOpproof.v +++ /dev/null @@ -1,543 +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 operator strength reduction. *) - -Require Import Coqlib. -Require Import Compopts. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import ValueDomain. -Require Import ConstpropOp. - -(** 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 bc: block_classification. -Variable ge: genv. -Hypothesis GENV: genv_match bc ge. -Variable sp: block. -Hypothesis STACK: bc sp = BCstack. -Variable ae: AE.t. -Variable e: regset. -Variable m: mem. -Hypothesis MATCH: ematch bc e ae. - -Lemma match_G: - forall r id ofs, - AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef e#r (Genv.symbol_address ge id ofs). -Proof. - intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH. -Qed. - -Lemma match_S: - forall r ofs, - AE.get r ae = Ptr(Stk ofs) -> Val.lessdef e#r (Vptr sp ofs). -Proof. - intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH. -Qed. - -Ltac InvApproxRegs := - match goal with - | [ H: _ :: _ = _ :: _ |- _ ] => - injection H; clear H; intros; InvApproxRegs - | [ H: ?v = AE.get ?r ae |- _ ] => - generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs - | _ => idtac - end. - -Ltac SimplVM := - match goal with - | [ H: vmatch _ ?v (I ?n) |- _ ] => - let E := fresh in - assert (E: v = Vint n) by (inversion H; auto); - rewrite E in *; clear H; SimplVM - | [ H: vmatch _ ?v (F ?n) |- _ ] => - let E := fresh in - assert (E: v = Vfloat n) by (inversion H; auto); - rewrite E in *; clear H; SimplVM - | [ H: vmatch _ ?v (FS ?n) |- _ ] => - let E := fresh in - assert (E: v = Vsingle n) by (inversion H; auto); - rewrite E in *; clear H; SimplVM - | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] => - let E := fresh in - assert (E: Val.lessdef v (Genv.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto); - clear H; SimplVM - | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] => - let E := fresh in - assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto); - clear H; SimplVM - | _ => idtac - end. - -Lemma cond_strength_reduction_correct: - forall cond args vl, - vl = map (fun r => AE.get r ae) args -> - let (cond', args') := cond_strength_reduction cond args vl in - eval_condition cond' e##args' m = eval_condition cond e##args m. -Proof. - intros until vl. unfold cond_strength_reduction. - case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVM. -- apply Val.swap_cmp_bool. -- auto. -- apply Val.swap_cmpu_bool. -- auto. -- auto. -Qed. - -Lemma addr_strength_reduction_correct: - forall addr args vl res, - vl = map (fun r => AE.get r ae) args -> - eval_addressing ge (Vptr sp Int.zero) addr e##args = Some res -> - let (addr', args') := addr_strength_reduction addr args vl in - exists res', eval_addressing ge (Vptr sp Int.zero) addr' e##args' = Some res' /\ Val.lessdef res res'. -Proof. - intros until res. unfold addr_strength_reduction. - destruct (addr_strength_reduction_match addr args vl); simpl; - intros VL EA; InvApproxRegs; SimplVM; try (inv EA). -- rewrite Genv.shift_symbol_address. econstructor; split. eauto. apply Val.add_lessdef; auto. -- econstructor; split; eauto. rewrite Int.add_zero_l. - change (Vptr sp (Int.add n ofs)) with (Val.add (Vptr sp n) (Vint ofs)). apply Val.add_lessdef; auto. -- econstructor; split; eauto. rewrite Int.add_assoc. rewrite Genv.shift_symbol_address. - rewrite Val.add_assoc. apply Val.add_lessdef; auto. -- econstructor; split; eauto. - fold (Val.add (Vint n1) e#r2). rewrite (Val.add_commut (Vint n1)). - rewrite Genv.shift_symbol_address. apply Val.add_lessdef; auto. - rewrite Int.add_commut. rewrite Genv.shift_symbol_address. apply Val.add_lessdef; auto. -- econstructor; split; eauto. rewrite Int.add_zero_l. rewrite Int.add_assoc. - change (Vptr sp (Int.add n1 (Int.add n2 ofs))) - with (Val.add (Vptr sp n1) (Vint (Int.add n2 ofs))). - rewrite Val.add_assoc. apply Val.add_lessdef; auto. -- econstructor; split; eauto. rewrite Int.add_zero_l. - fold (Val.add (Vint n1) e#r2). rewrite (Int.add_commut n1). - change (Vptr sp (Int.add (Int.add n2 n1) ofs)) - with (Val.add (Val.add (Vint n1) (Vptr sp n2)) (Vint ofs)). - apply Val.add_lessdef; auto. apply Val.add_lessdef; auto. -- econstructor; split; eauto. rewrite Genv.shift_symbol_address. - rewrite ! Val.add_assoc. apply Val.add_lessdef; auto. - rewrite Val.add_commut. apply Val.add_lessdef; auto. -- econstructor; split; eauto. rewrite Genv.shift_symbol_address. - rewrite (Val.add_commut e#r1). rewrite ! Val.add_assoc. - apply Val.add_lessdef; auto. rewrite Val.add_commut. apply Val.add_lessdef; auto. -- fold (Val.add (Vint n1) e#r2). econstructor; split; eauto. - rewrite (Val.add_commut (Vint n1)). rewrite Val.add_assoc. - apply Val.add_lessdef; eauto. -- econstructor; split; eauto. rewrite ! Val.add_assoc. - apply Val.add_lessdef; eauto. -- econstructor; split; eauto. rewrite Int.add_assoc. - rewrite Genv.shift_symbol_address. apply Val.add_lessdef; auto. -- econstructor; split; eauto. - rewrite Genv.shift_symbol_address. rewrite ! Val.add_assoc. apply Val.add_lessdef; auto. - rewrite Val.add_commut; auto. -- econstructor; split; eauto. -- econstructor; split; eauto. rewrite Genv.shift_symbol_address. auto. -- econstructor; split; eauto. rewrite Genv.shift_symbol_address. rewrite Int.mul_commut; auto. -- econstructor; eauto. -Qed. - -Lemma make_cmp_base_correct: - forall c args vl, - vl = map (fun r => AE.get r ae) args -> - let (op', args') := make_cmp_base c args vl in - exists v, eval_operation ge (Vptr sp Int.zero) op' e##args' m = Some v - /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. -Proof. - intros. unfold make_cmp_base. - generalize (cond_strength_reduction_correct c args vl H). - destruct (cond_strength_reduction c args vl) as [c' args']. intros EQ. - econstructor; split. simpl; eauto. rewrite EQ. auto. -Qed. - -Lemma make_cmp_correct: - forall c args vl, - vl = map (fun r => AE.get r ae) args -> - let (op', args') := make_cmp c args vl in - exists v, eval_operation ge (Vptr sp Int.zero) op' e##args' m = Some v - /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. -Proof. - intros c args vl. - assert (Y: forall r, vincl (AE.get r ae) (Uns Ptop 1) = true -> - e#r = Vundef \/ e#r = Vint Int.zero \/ e#r = Vint Int.one). - { intros. apply vmatch_Uns_1 with bc Ptop. eapply vmatch_ge. eapply vincl_ge; eauto. apply MATCH. } - unfold make_cmp. case (make_cmp_match c args vl); intros. -- destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. - simpl in H; inv H. InvBooleans. subst n. - exists (e#r1); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. - destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. - simpl in H; inv H. InvBooleans. subst n. - exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. - apply make_cmp_base_correct; auto. -- destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. - simpl in H; inv H. InvBooleans. subst n. - exists (e#r1); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. - destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. - simpl in H; inv H. InvBooleans. subst n. - exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. - apply make_cmp_base_correct; auto. -- apply make_cmp_base_correct; auto. -Qed. - -Lemma make_addimm_correct: - forall n r, - let (op, args) := make_addimm n r in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.add e#r (Vint n)) v. -Proof. - intros. unfold make_addimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst. exists (e#r); split; auto. destruct (e#r); simpl; auto; rewrite Int.add_zero; auto. - exists (Val.add e#r (Vint n)); auto. -Qed. - -Lemma make_shlimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_shlimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.shl e#r1 (Vint n)) v. -Proof. - intros; unfold make_shlimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shl_zero. auto. - destruct (Int.ltu n Int.iwordsize). - econstructor; split. simpl. eauto. auto. - econstructor; split. simpl. eauto. rewrite H; auto. -Qed. - -Lemma make_shrimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_shrimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.shr e#r1 (Vint n)) v. -Proof. - intros; unfold make_shrimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shr_zero. auto. - destruct (Int.ltu n Int.iwordsize). - econstructor; split. simpl. eauto. auto. - econstructor; split. simpl. eauto. rewrite H; auto. -Qed. - -Lemma make_shruimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_shruimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.shru e#r1 (Vint n)) v. -Proof. - intros; unfold make_shruimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shru_zero. auto. - destruct (Int.ltu n Int.iwordsize). - econstructor; split. simpl. eauto. auto. - econstructor; split. simpl. eauto. rewrite H; auto. -Qed. - -Lemma make_mulimm_correct: - forall n r1, - let (op, args) := make_mulimm n r1 in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mul e#r1 (Vint n)) v. -Proof. - intros; unfold make_mulimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (Vint Int.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_zero; auto. - predSpec Int.eq Int.eq_spec n Int.one; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_one; auto. - destruct (Int.is_power2 n) eqn:?; intros. - rewrite (Val.mul_pow2 e#r1 _ _ Heqo). econstructor; split. simpl; eauto. auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_divimm_correct: - forall n r1 r2 v, - Val.divs e#r1 e#r2 = Some v -> - e#r2 = Vint n -> - let (op, args) := make_divimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Int.zero) op e##args m = Some w /\ Val.lessdef v w. -Proof. - intros; unfold make_divimm. - destruct (Int.is_power2 n) eqn:?. - destruct (Int.ltu i (Int.repr 31)) eqn:?. - exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. - exists v; auto. - exists v; auto. -Qed. - -Lemma make_divuimm_correct: - forall n r1 r2 v, - Val.divu e#r1 e#r2 = Some v -> - e#r2 = Vint n -> - let (op, args) := make_divuimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Int.zero) op e##args m = Some w /\ Val.lessdef v w. -Proof. - intros; unfold make_divuimm. - destruct (Int.is_power2 n) eqn:?. - econstructor; split. simpl; eauto. - rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto. - exists v; auto. -Qed. - -Lemma make_moduimm_correct: - forall n r1 r2 v, - Val.modu e#r1 e#r2 = Some v -> - e#r2 = Vint n -> - let (op, args) := make_moduimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Int.zero) op e##args m = Some w /\ Val.lessdef v w. -Proof. - intros; unfold make_moduimm. - destruct (Int.is_power2 n) eqn:?. - exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence. - exists v; auto. -Qed. - -Lemma make_andimm_correct: - forall n r x, - vmatch bc e#r x -> - let (op, args) := make_andimm n r x in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.and e#r (Vint n)) v. -Proof. - intros; unfold make_andimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst n. exists (Vint Int.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_zero; auto. - predSpec Int.eq Int.eq_spec n Int.mone; intros. - subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_mone; auto. - destruct (match x with Uns _ k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero - | _ => false end) eqn:UNS. - destruct x; try congruence. - exists (e#r); split; auto. - inv H; auto. simpl. replace (Int.and i n) with i; auto. - generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ. - Int.bit_solve. destruct (zlt i0 n0). - replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). - rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. - rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. - rewrite Int.bits_not by auto. apply negb_involutive. - rewrite H6 by auto. auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_orimm_correct: - forall n r, - let (op, args) := make_orimm n r in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.or e#r (Vint n)) v. -Proof. - intros; unfold make_orimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_zero; auto. - predSpec Int.eq Int.eq_spec n Int.mone; intros. - subst n. exists (Vint Int.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_mone; auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_xorimm_correct: - forall n r, - let (op, args) := make_xorimm n r in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.xor e#r (Vint n)) v. -Proof. - intros; unfold make_xorimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.xor_zero; auto. - predSpec Int.eq Int.eq_spec n Int.mone; intros. - subst n. exists (Val.notint e#r); split; auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_mulfimm_correct: - forall n r1 r2, - e#r2 = Vfloat n -> - let (op, args) := make_mulfimm n r1 r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. -Proof. - intros; unfold make_mulfimm. - destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. - simpl. econstructor; split. eauto. rewrite H; subst n. - destruct (e#r1); simpl; auto. rewrite Float.mul2_add; auto. - simpl. econstructor; split; eauto. -Qed. - -Lemma make_mulfimm_correct_2: - forall n r1 r2, - e#r1 = Vfloat n -> - let (op, args) := make_mulfimm n r2 r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. -Proof. - intros; unfold make_mulfimm. - destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. - simpl. econstructor; split. eauto. rewrite H; subst n. - destruct (e#r2); simpl; auto. rewrite Float.mul2_add; auto. - rewrite Float.mul_commut; auto. - simpl. econstructor; split; eauto. -Qed. - -Lemma make_mulfsimm_correct: - forall n r1 r2, - e#r2 = Vsingle n -> - let (op, args) := make_mulfsimm n r1 r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. -Proof. - intros; unfold make_mulfsimm. - destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. - simpl. econstructor; split. eauto. rewrite H; subst n. - destruct (e#r1); simpl; auto. rewrite Float32.mul2_add; auto. - simpl. econstructor; split; eauto. -Qed. - -Lemma make_mulfsimm_correct_2: - forall n r1 r2, - e#r1 = Vsingle n -> - let (op, args) := make_mulfsimm n r2 r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. -Proof. - intros; unfold make_mulfsimm. - destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. - simpl. econstructor; split. eauto. rewrite H; subst n. - destruct (e#r2); simpl; auto. rewrite Float32.mul2_add; auto. - rewrite Float32.mul_commut; auto. - simpl. econstructor; split; eauto. -Qed. - -Lemma make_cast8signed_correct: - forall r x, - vmatch bc e#r x -> - let (op, args) := make_cast8signed r x in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 8 e#r) v. -Proof. - intros; unfold make_cast8signed. destruct (vincl x (Sgn Ptop 8)) eqn:INCL. - exists e#r; split; auto. - assert (V: vmatch bc e#r (Sgn Ptop 8)). - { eapply vmatch_ge; eauto. apply vincl_ge; auto. } - inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto. - econstructor; split; simpl; eauto. -Qed. - -Lemma make_cast8unsigned_correct: - forall r x, - vmatch bc e#r x -> - let (op, args) := make_cast8unsigned r x in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext 8 e#r) v. -Proof. - intros; unfold make_cast8unsigned. destruct (vincl x (Uns Ptop 8)) eqn:INCL. - exists e#r; split; auto. - assert (V: vmatch bc e#r (Uns Ptop 8)). - { eapply vmatch_ge; eauto. apply vincl_ge; auto. } - inv V; simpl; auto. rewrite is_uns_zero_ext in H4 by auto. rewrite H4; auto. - econstructor; split; simpl; eauto. -Qed. - -Lemma make_cast16signed_correct: - forall r x, - vmatch bc e#r x -> - let (op, args) := make_cast16signed r x in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 16 e#r) v. -Proof. - intros; unfold make_cast16signed. destruct (vincl x (Sgn Ptop 16)) eqn:INCL. - exists e#r; split; auto. - assert (V: vmatch bc e#r (Sgn Ptop 16)). - { eapply vmatch_ge; eauto. apply vincl_ge; auto. } - inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto. - econstructor; split; simpl; eauto. -Qed. - -Lemma make_cast16unsigned_correct: - forall r x, - vmatch bc e#r x -> - let (op, args) := make_cast16unsigned r x in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext 16 e#r) v. -Proof. - intros; unfold make_cast16unsigned. destruct (vincl x (Uns Ptop 16)) eqn:INCL. - exists e#r; split; auto. - assert (V: vmatch bc e#r (Uns Ptop 16)). - { eapply vmatch_ge; eauto. apply vincl_ge; auto. } - inv V; simpl; auto. rewrite is_uns_zero_ext in H4 by auto. rewrite H4; auto. - econstructor; split; simpl; eauto. -Qed. - -Lemma op_strength_reduction_correct: - forall op args vl v, - vl = map (fun r => AE.get r ae) args -> - eval_operation ge (Vptr sp Int.zero) op e##args m = Some v -> - let (op', args') := op_strength_reduction op args vl in - exists w, eval_operation ge (Vptr sp Int.zero) op' e##args' m = Some w /\ Val.lessdef v w. -Proof. - intros until v; unfold op_strength_reduction; - case (op_strength_reduction_match op args vl); simpl; intros. -(* cast8signed *) - InvApproxRegs; SimplVM; inv H0. apply make_cast8signed_correct; auto. -(* cast8unsigned *) - InvApproxRegs; SimplVM; inv H0. apply make_cast8unsigned_correct; auto. -(* cast16signed *) - InvApproxRegs; SimplVM; inv H0. apply make_cast16signed_correct; auto. -(* cast16unsigned *) - InvApproxRegs; SimplVM; inv H0. apply make_cast16unsigned_correct; auto. -(* sub *) - InvApproxRegs; SimplVM; inv H0. rewrite Val.sub_add_opp. apply make_addimm_correct; auto. -(* mul *) - rewrite Val.mul_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. - InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. -(* divs *) - assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divimm_correct; auto. -(* divu *) - assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divuimm_correct; auto. -(* modu *) - assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_moduimm_correct; auto. -(* and *) - rewrite Val.and_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. - InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. - inv H; inv H0. apply make_andimm_correct; auto. -(* or *) - rewrite Val.or_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. - InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. -(* xor *) - rewrite Val.xor_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. - InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. -(* shl *) - InvApproxRegs; SimplVM; inv H0. apply make_shlimm_correct; auto. -(* shr *) - InvApproxRegs; SimplVM; inv H0. apply make_shrimm_correct; auto. -(* shru *) - InvApproxRegs; SimplVM; inv H0. apply make_shruimm_correct; auto. -(* lea *) - exploit addr_strength_reduction_correct; eauto. - destruct (addr_strength_reduction addr args0 vl0) as [addr' args']. - auto. -(* cond *) - inv H0. apply make_cmp_correct; auto. -(* mulf *) - InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto. - InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2). - rewrite <- H2. apply make_mulfimm_correct_2; auto. -(* mulfs *) - InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfsimm_correct; auto. - InvApproxRegs; SimplVM; inv H0. fold (Val.mulfs (Vsingle n1) e#r2). - rewrite <- H2. apply make_mulfsimm_correct_2; auto. -(* default *) - exists v; auto. -Qed. - -End STRENGTH_REDUCTION. diff --git a/ia32/Conventions1.v b/ia32/Conventions1.v deleted file mode 100644 index 08a86815..00000000 --- a/ia32/Conventions1.v +++ /dev/null @@ -1,240 +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 Decidableplus. -Require Import AST. -Require Import Events. -Require Import Locations. - -(** * Classification of machine registers *) - -(** Machine registers (type [mreg] in module [Locations]) are divided in - the following groups: -- 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 x86-32 application binary interface (ABI) in our choice - of callee- and caller-save registers. -*) - -Definition is_callee_save (r: mreg) : bool := - match r with - | AX | CX | DX => false - | BX | SI | DI | BP => true - | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 => false - | FP0 => false - end. - -Definition int_caller_save_regs := AX :: CX :: DX :: nil. - -Definition float_caller_save_regs := X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: nil. - -Definition int_callee_save_regs := BX :: SI :: DI :: BP :: nil. - -Definition float_callee_save_regs : list mreg := nil. - -Definition destroyed_at_call := - List.filter (fun r => negb (is_callee_save r)) all_mregs. - -Definition dummy_int_reg := AX. (**r Used in [Regalloc]. *) -Definition dummy_float_reg := X0. (**r Used in [Regalloc]. *) - -(** * 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 compiler, we - implement the standard x86 conventions. *) - -(** ** Location of function result *) - -(** The result value of a function is passed back to the caller in - registers [AX] or [DX:AX] or [FP0], 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) : rpair mreg := - match s.(sig_res) with - | None => One AX - | Some (Tint | Tany32) => One AX - | Some (Tfloat | Tsingle) => One FP0 - | Some Tany64 => One X0 - | Some Tlong => Twolong DX AX - end. - -(** The result registers have types compatible with that given in the signature. *) - -Lemma loc_result_type: - forall sig, - subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true. -Proof. - intros. unfold proj_sig_res, loc_result. destruct (sig_res sig) as [[]|]; auto. -Qed. - -(** The result locations are caller-save registers *) - -Lemma loc_result_caller_save: - forall (s: signature), - forall_rpair (fun r => is_callee_save r = false) (loc_result s). -Proof. - intros. - unfold loc_result. destruct (sig_res s) as [[]|]; simpl; auto. -Qed. - -(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) - -Lemma loc_result_pair: - forall sg, - match loc_result sg with - | One _ => True - | Twolong r1 r2 => r1 <> r2 /\ sg.(sig_res) = Some Tlong /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true - end. -Proof. - intros; unfold loc_result; destruct (sig_res sg) as [[]|]; auto. intuition congruence. -Qed. - -(** ** Location of function arguments *) - -(** All arguments are passed on stack. (Snif.) *) - -Fixpoint loc_arguments_rec - (tyl: list typ) (ofs: Z) {struct tyl} : list (rpair loc) := - match tyl with - | nil => nil - | ty :: tys => - match ty with - | Tlong => Twolong (S Outgoing (ofs + 1) Tint) (S Outgoing ofs Tint) - | _ => One (S Outgoing ofs ty) - end - :: loc_arguments_rec tys (ofs + typesize ty) - end. - -(** [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 (rpair loc) := - loc_arguments_rec s.(sig_args) 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) (ofs: Z) {struct tyl} : Z := - match tyl with - | nil => ofs - | ty :: tys => size_arguments_rec tys (ofs + typesize ty) - end. - -Definition size_arguments (s: signature) : Z := - size_arguments_rec s.(sig_args) 0. - -(** Argument locations are either caller-save registers or [Outgoing] - stack slots at nonnegative offsets. *) - -Definition loc_argument_acceptable (l: loc) : Prop := - match l with - | R r => is_callee_save r = false - | S Outgoing ofs ty => ofs >= 0 /\ (typealign ty | ofs) - | _ => False - end. - -Definition loc_argument_charact (ofs: Z) (l: loc) : Prop := - match l with - | S Outgoing ofs' ty => ofs' >= ofs /\ typealign ty = 1 - | _ => False - end. - -Remark loc_arguments_rec_charact: - forall tyl ofs p, - In p (loc_arguments_rec tyl ofs) -> forall_rpair (loc_argument_charact ofs) p. -Proof. - assert (X: forall ofs1 ofs2 l, loc_argument_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_charact ofs1 l). - { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } - induction tyl as [ | ty tyl]; simpl loc_arguments_rec; intros. -- contradiction. -- destruct H. -+ destruct ty; subst p; simpl; omega. -+ apply IHtyl in H. generalize (typesize_pos ty); intros. destruct p; simpl in *. -* eapply X; eauto; omega. -* destruct H; split; eapply X; eauto; omega. -Qed. - -Lemma loc_arguments_acceptable: - forall (s: signature) (p: rpair loc), - In p (loc_arguments s) -> forall_rpair loc_argument_acceptable p. -Proof. - unfold loc_arguments; intros. - exploit loc_arguments_rec_charact; eauto. - assert (X: forall l, loc_argument_charact 0 l -> loc_argument_acceptable l). - { destruct l as [r | [] ofs ty]; simpl; intuition auto. rewrite H2; apply Z.divide_1_l. } - destruct p; simpl; intuition auto. -Qed. - -Hint Resolve loc_arguments_acceptable: locs. - -(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) - -Remark size_arguments_rec_above: - forall tyl ofs0, ofs0 <= size_arguments_rec tyl ofs0. -Proof. - induction tyl; simpl; intros. - omega. - apply Zle_trans with (ofs0 + typesize a); auto. - generalize (typesize_pos a); omega. -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) (regs_of_rpairs (loc_arguments s)) -> - ofs + typesize ty <= size_arguments s. -Proof. - intros until ty. unfold loc_arguments, size_arguments. generalize (sig_args s) 0. - induction l as [ | t l]; simpl; intros x IN. -- contradiction. -- rewrite in_app_iff in IN; destruct IN as [IN|IN]. -+ apply Zle_trans with (x + typesize t); [|apply size_arguments_rec_above]. - Ltac decomp := - match goal with - | [ H: _ \/ _ |- _ ] => destruct H; decomp - | [ H: S _ _ _ = S _ _ _ |- _ ] => inv H - | [ H: False |- _ ] => contradiction - end. - destruct t; simpl in IN; decomp; simpl; omega. -+ apply IHl; auto. -Qed. - -Lemma loc_arguments_main: - loc_arguments signature_main = nil. -Proof. - reflexivity. -Qed. diff --git a/ia32/Op.v b/ia32/Op.v deleted file mode 100644 index f21d7c6a..00000000 --- a/ia32/Op.v +++ /dev/null @@ -1,1075 +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 IA32-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 Memory. -Require Import Globalenvs. -Require Import Events. - -Set Implicit Arguments. - -(** Conditions (boolean-valued operators). *) - -Inductive condition : Type := - | 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 64-bit floating-point comparison *) - | Cnotcompf: comparison -> condition (**r negation of a floating-point comparison *) - | Ccompfs: comparison -> condition (**r 32-bit floating-point comparison *) - | Cnotcompfs: 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] *) - -(** Addressing modes. [r1], [r2], etc, are the arguments to the - addressing. *) - -Inductive addressing: Type := - | Aindexed: int -> addressing (**r Address is [r1 + offset] *) - | Aindexed2: int -> addressing (**r Address is [r1 + r2 + offset] *) - | Ascaled: int -> int -> addressing (**r Address is [r1 * scale + offset] *) - | Aindexed2scaled: int -> int -> addressing - (**r Address is [r1 + r2 * scale + offset] *) - | Aglobal: ident -> int -> addressing (**r Address is [symbol + offset] *) - | Abased: ident -> int -> addressing (**r Address is [symbol + offset + r1] *) - | Abasedscaled: int -> ident -> int -> addressing (**r Address is [symbol + offset + r1 * scale] *) - | Ainstack: int -> addressing. (**r Address is [stack_pointer + offset] *) - -(** Arithmetic and logical operations. In the descriptions, [rd] is the - result of the operation and [r1], [r2], etc, are the arguments. *) - -Inductive operation : Type := - | 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 *) - | Osingleconst: float32 -> operation (**r [rd] is set to the given float constant *) - | Oindirectsymbol: ident -> operation (**r [rd] is set to the address of the symbol *) -(*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] *) - | Oneg: operation (**r [rd = - r1] *) - | Osub: operation (**r [rd = r1 - r2] *) - | Omul: operation (**r [rd = r1 * r2] *) - | Omulimm: int -> operation (**r [rd = r1 * n] *) - | Omulhs: operation (**r [rd = high part of r1 * r2, signed] *) - | Omulhu: operation (**r [rd = high part of r1 * r2, unsigned] *) - | Odiv: operation (**r [rd = r1 / r2] (signed) *) - | Odivu: operation (**r [rd = r1 / r2] (unsigned) *) - | Omod: operation (**r [rd = r1 % r2] (signed) *) - | Omodu: 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] *) - | Onot: operation (**r [rd = ~r1] *) - | Oshl: operation (**r [rd = r1 << r2] *) - | Oshlimm: int -> operation (**r [rd = r1 << n] *) - | 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) *) - | Oshruimm: int -> operation (**r [rd = r1 >> n] (unsigned) *) - | Ororimm: int -> operation (**r rotate right immediate *) - | Oshldimm: int -> operation (**r [rd = r1 << n | r2 >> (32-n)] *) - | Olea: addressing -> operation (**r effective address *) -(*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] *) - | Onegfs: operation (**r [rd = - r1] *) - | Oabsfs: operation (**r [rd = abs(r1)] *) - | Oaddfs: operation (**r [rd = r1 + r2] *) - | Osubfs: operation (**r [rd = r1 - r2] *) - | Omulfs: operation (**r [rd = r1 * r2] *) - | Odivfs: operation (**r [rd = r1 / r2] *) - | Osingleoffloat: operation (**r [rd] is [r1] truncated to single-precision float *) - | Ofloatofsingle: operation (**r [rd] is [r1] extended to double-precision float *) -(*c Conversions between int and float: *) - | Ointoffloat: operation (**r [rd = signed_int_of_float64(r1)] *) - | Ofloatofint: operation (**r [rd = float64_of_signed_int(r1)] *) - | Ointofsingle: operation (**r [rd = signed_int_of_float32(r1)] *) - | Osingleofint: operation (**r [rd = float32_of_signed_int(r1)] *) -(*c Manipulating 64-bit integers: *) - | Omakelong: operation (**r [rd = r1 << 32 | r2] *) - | Olowlong: operation (**r [rd = low-word(r1)] *) - | Ohighlong: operation (**r [rd = high-word(r1)] *) -(*c Boolean tests: *) - | Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) - -(** Derived operators. *) - -Definition Oaddrsymbol (id: ident) (ofs: int) : operation := Olea (Aglobal id ofs). -Definition Oaddrstack (ofs: int) : operation := Olea (Ainstack ofs). -Definition Oaddimm (n: int) : operation := Olea (Aindexed n). - -(** Comparison functions (used in modules [CSE] and [Allocation]). *) - -Definition eq_condition (x y: condition) : {x=y} + {x<>y}. -Proof. - generalize Int.eq_dec; intro. - assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. - decide equality. -Defined. - -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. -Defined. - -Definition eq_operation (x y: operation): {x=y} + {x<>y}. -Proof. - generalize Int.eq_dec; intro. - generalize Float.eq_dec; intro. - generalize Float32.eq_dec; intro. - generalize Int64.eq_dec; intro. - decide equality. - apply peq. - apply eq_addressing. - apply eq_condition. -Defined. - -Global Opaque eq_condition eq_addressing eq_operation. - -(** * Evaluation functions *) - -(** Evaluation of conditions, operators and addressing modes applied - to lists of values. Return [None] when the computation can trigger an - error, e.g. integer division by zero. [eval_condition] returns a boolean, - [eval_operation] and [eval_addressing] return a value. *) - -Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := - match cond, vl with - | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 - | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 - | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n) - | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n) - | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2 - | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2) - | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2 - | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) - | Cmaskzero n, v1 :: nil => Val.maskzero_bool v1 n - | Cmasknotzero n, v1 :: nil => option_map negb (Val.maskzero_bool v1 n) - | _, _ => None - end. - -Definition eval_addressing - (F V: Type) (genv: Genv.t F V) (sp: val) - (addr: addressing) (vl: list val) : option val := - match addr, vl with - | Aindexed n, v1::nil => - Some (Val.add v1 (Vint n)) - | Aindexed2 n, v1::v2::nil => - Some (Val.add (Val.add v1 v2) (Vint n)) - | Ascaled sc ofs, v1::nil => - Some (Val.add (Val.mul v1 (Vint sc)) (Vint ofs)) - | Aindexed2scaled sc ofs, v1::v2::nil => - Some(Val.add v1 (Val.add (Val.mul v2 (Vint sc)) (Vint ofs))) - | Aglobal s ofs, nil => - Some (Genv.symbol_address genv s ofs) - | Abased s ofs, v1::nil => - Some (Val.add (Genv.symbol_address genv s ofs) v1) - | Abasedscaled sc s ofs, v1::nil => - Some (Val.add (Genv.symbol_address genv s ofs) (Val.mul v1 (Vint sc))) - | Ainstack ofs, nil => - Some(Val.add sp (Vint ofs)) - | _, _ => None - end. - -Definition eval_operation - (F V: Type) (genv: Genv.t F V) (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) - | Osingleconst n, nil => Some (Vsingle n) - | Oindirectsymbol id, nil => Some (Genv.symbol_address genv id Int.zero) - | 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) - | Oneg, v1::nil => Some (Val.neg v1) - | Osub, v1::v2::nil => Some (Val.sub v1 v2) - | Omul, v1::v2::nil => Some (Val.mul v1 v2) - | Omulimm n, v1::nil => Some (Val.mul v1 (Vint n)) - | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2) - | Omulhu, v1::v2::nil => Some (Val.mulhu v1 v2) - | Odiv, v1::v2::nil => Val.divs v1 v2 - | Odivu, v1::v2::nil => Val.divu v1 v2 - | Omod, v1::v2::nil => Val.mods v1 v2 - | Omodu, v1::v2::nil => Val.modu v1 v2 - | Oand, v1::v2::nil => Some(Val.and v1 v2) - | Oandimm n, v1::nil => Some (Val.and v1 (Vint n)) - | Oor, v1::v2::nil => Some(Val.or v1 v2) - | Oorimm n, v1::nil => Some (Val.or v1 (Vint n)) - | Oxor, v1::v2::nil => Some(Val.xor v1 v2) - | Oxorimm n, v1::nil => Some (Val.xor v1 (Vint n)) - | Onot, v1::nil => Some(Val.notint v1) - | Oshl, v1::v2::nil => Some (Val.shl v1 v2) - | Oshlimm n, v1::nil => Some (Val.shl v1 (Vint n)) - | Oshr, v1::v2::nil => Some (Val.shr v1 v2) - | Oshrimm n, v1::nil => Some (Val.shr v1 (Vint n)) - | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) - | Oshru, v1::v2::nil => Some (Val.shru v1 v2) - | Oshruimm n, v1::nil => Some (Val.shru v1 (Vint n)) - | Ororimm n, v1::nil => Some (Val.ror v1 (Vint n)) - | Oshldimm n, v1::v2::nil => Some (Val.or (Val.shl v1 (Vint n)) - (Val.shru v2 (Vint (Int.sub Int.iwordsize n)))) - | Olea addr, _ => eval_addressing genv sp addr vl - | Onegf, v1::nil => Some(Val.negf v1) - | Oabsf, v1::nil => Some(Val.absf v1) - | Oaddf, v1::v2::nil => Some(Val.addf v1 v2) - | Osubf, v1::v2::nil => Some(Val.subf v1 v2) - | Omulf, v1::v2::nil => Some(Val.mulf v1 v2) - | Odivf, v1::v2::nil => Some(Val.divf v1 v2) - | Onegfs, v1::nil => Some(Val.negfs v1) - | Oabsfs, v1::nil => Some(Val.absfs v1) - | Oaddfs, v1::v2::nil => Some(Val.addfs v1 v2) - | Osubfs, v1::v2::nil => Some(Val.subfs v1 v2) - | Omulfs, v1::v2::nil => Some(Val.mulfs v1 v2) - | Odivfs, v1::v2::nil => Some(Val.divfs v1 v2) - | Osingleoffloat, v1::nil => Some(Val.singleoffloat v1) - | Ofloatofsingle, v1::nil => Some(Val.floatofsingle v1) - | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ofloatofint, v1::nil => Val.floatofint v1 - | Ointofsingle, v1::nil => Val.intofsingle v1 - | Osingleofint, v1::nil => Val.singleofint v1 - | Omakelong, v1::v2::nil => Some(Val.longofwords v1 v2) - | Olowlong, v1::nil => Some(Val.loword v1) - | Ohighlong, v1::nil => Some(Val.hiword v1) - | Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m)) - | _, _ => None - 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. - -(** * 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 - | Ccompfs _ => Tsingle :: Tsingle :: nil - | Cnotcompfs _ => Tsingle :: Tsingle :: nil - | Cmaskzero _ => Tint :: nil - | Cmasknotzero _ => Tint :: nil - end. - -Definition type_of_addressing (addr: addressing) : list typ := - match addr with - | Aindexed _ => Tint :: nil - | Aindexed2 _ => Tint :: Tint :: nil - | Ascaled _ _ => Tint :: nil - | Aindexed2scaled _ _ => Tint :: Tint :: nil - | Aglobal _ _ => nil - | Abased _ _ => Tint :: nil - | Abasedscaled _ _ _ => Tint :: nil - | Ainstack _ => nil - end. - -Definition type_of_operation (op: operation) : list typ * typ := - match op with - | Omove => (nil, Tint) (* treated specially *) - | Ointconst _ => (nil, Tint) - | Ofloatconst f => (nil, Tfloat) - | Osingleconst f => (nil, Tsingle) - | Oindirectsymbol _ => (nil, Tint) - | Ocast8signed => (Tint :: nil, Tint) - | Ocast8unsigned => (Tint :: nil, Tint) - | Ocast16signed => (Tint :: nil, Tint) - | Ocast16unsigned => (Tint :: nil, Tint) - | Oneg => (Tint :: nil, Tint) - | Osub => (Tint :: Tint :: nil, Tint) - | Omul => (Tint :: Tint :: nil, Tint) - | Omulimm _ => (Tint :: nil, Tint) - | Omulhs => (Tint :: Tint :: nil, Tint) - | Omulhu => (Tint :: Tint :: nil, Tint) - | Odiv => (Tint :: Tint :: nil, Tint) - | Odivu => (Tint :: Tint :: nil, Tint) - | Omod => (Tint :: Tint :: nil, Tint) - | Omodu => (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) - | Onot => (Tint :: nil, Tint) - | Oshl => (Tint :: Tint :: nil, Tint) - | Oshlimm _ => (Tint :: nil, Tint) - | Oshr => (Tint :: Tint :: nil, Tint) - | Oshrimm _ => (Tint :: nil, Tint) - | Oshrximm _ => (Tint :: nil, Tint) - | Oshru => (Tint :: Tint :: nil, Tint) - | Oshruimm _ => (Tint :: nil, Tint) - | Ororimm _ => (Tint :: nil, Tint) - | Oshldimm _ => (Tint :: Tint :: nil, Tint) - | Olea addr => (type_of_addressing addr, 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) - | Onegfs => (Tsingle :: nil, Tsingle) - | Oabsfs => (Tsingle :: nil, Tsingle) - | Oaddfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Osubfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Omulfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Odivfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Osingleoffloat => (Tfloat :: nil, Tsingle) - | Ofloatofsingle => (Tsingle :: nil, Tfloat) - | Ointoffloat => (Tfloat :: nil, Tint) - | Ofloatofint => (Tint :: nil, Tfloat) - | Ointofsingle => (Tsingle :: nil, Tint) - | Osingleofint => (Tint :: nil, Tsingle) - | Omakelong => (Tint :: Tint :: nil, Tlong) - | Olowlong => (Tlong :: nil, Tint) - | Ohighlong => (Tlong :: nil, Tint) - | Ocmp c => (type_of_condition c, Tint) - 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 V: Type. -Variable genv: Genv.t A V. - -Lemma type_of_addressing_sound: - forall addr vl sp v, - eval_addressing genv sp addr vl = Some v -> - Val.has_type v Tint. -Proof with (try exact I). - intros. destruct addr; simpl in H; FuncInv; subst; simpl. - destruct v0... - destruct v0... destruct v1... destruct v1... - destruct v0... - destruct v0... destruct v1... destruct v1... - unfold Genv.symbol_address; destruct (Genv.find_symbol genv i)... - unfold Genv.symbol_address; destruct (Genv.find_symbol genv i)... - unfold Genv.symbol_address; destruct (Genv.find_symbol genv i)... destruct v0... - destruct v0... - unfold Genv.symbol_address; destruct (Genv.find_symbol genv i0)... destruct v0... - destruct sp... -Qed. - -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 with (try exact I). - intros. - destruct op; simpl in H0; FuncInv; subst; simpl. - congruence. - exact I. - exact I. - exact I. - unfold Genv.symbol_address; destruct (Genv.find_symbol genv i)... - destruct v0... - destruct v0... - destruct v0... - destruct v0... - destruct v0... - destruct v0; destruct v1... simpl. destruct (eq_block b b0)... - destruct v0; destruct v1... - destruct v0... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... - destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... - destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... - destruct v0; destruct v1... - destruct v0... - destruct v0; destruct v1... - destruct v0... - destruct v0; destruct v1... - destruct v0... - destruct v0... - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu i (Int.repr 31)); inv H0... - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... - destruct v0... - destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... - destruct v1; simpl... destruct (Int.ltu (Int.sub Int.iwordsize i) Int.iwordsize)... - eapply type_of_addressing_sound; eauto. - destruct v0... - destruct v0... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0... - destruct v0... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0... - destruct v0... - destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... - destruct v0; simpl in H0; inv H0... - destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); inv H2... - destruct v0; simpl in H0; inv H0... - destruct v0; destruct v1... - destruct v0... - destruct v0... - destruct (eval_condition c vl m); simpl... destruct b... -Qed. - -End SOUNDNESS. - -(** * Manipulating and transforming operations *) - -(** Recognition of move operations. *) - -Definition is_move_operation - (A: Type) (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: Type) (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. - -(** [negate_condition cond] returns a condition that is logically - equivalent to the negation of [cond]. *) - -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 - | Ccompfs c => Cnotcompfs c - | Cnotcompfs c => Ccompfs c - | Cmaskzero n => Cmasknotzero n - | Cmasknotzero n => Cmaskzero n - end. - -Lemma eval_negate_condition: - forall cond vl m, - eval_condition (negate_condition cond) vl m = option_map negb (eval_condition cond vl m). -Proof. - intros. destruct cond; simpl. - repeat (destruct vl; auto). apply Val.negate_cmp_bool. - repeat (destruct vl; auto). apply Val.negate_cmpu_bool. - repeat (destruct vl; auto). apply Val.negate_cmp_bool. - repeat (destruct vl; auto). apply Val.negate_cmpu_bool. - repeat (destruct vl; auto). - repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0) as [[]|]; auto. - repeat (destruct vl; auto). - repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto. - destruct vl; auto. destruct vl; auto. - destruct vl; auto. destruct vl; auto. destruct (Val.maskzero_bool v i) as [[]|]; auto. -Qed. - -(** Shifting stack-relative references. This is used in [Stacking]. *) - -Definition shift_stack_addressing (delta: int) (addr: addressing) := - match addr with - | Ainstack ofs => Ainstack (Int.add delta ofs) - | _ => addr - end. - -Definition shift_stack_operation (delta: int) (op: operation) := - match op with - | Olea addr => Olea (shift_stack_addressing delta addr) - | _ => op - end. - -Lemma type_shift_stack_addressing: - forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. -Proof. - intros. destruct addr; auto. -Qed. - -Lemma type_shift_stack_operation: - forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. -Proof. - intros. destruct op; auto. simpl. decEq. apply type_shift_stack_addressing. -Qed. - -Lemma eval_shift_stack_addressing: - forall F V (ge: Genv.t F V) sp addr vl delta, - eval_addressing ge sp (shift_stack_addressing delta addr) vl = - eval_addressing ge (Val.add sp (Vint delta)) addr vl. -Proof. - intros. destruct addr; simpl; auto. - rewrite Val.add_assoc. simpl. auto. -Qed. - -Lemma eval_shift_stack_operation: - forall F V (ge: Genv.t F V) sp op vl m delta, - eval_operation ge sp (shift_stack_operation delta op) vl m = - eval_operation ge (Val.add sp (Vint delta)) op vl m. -Proof. - intros. destruct op; simpl; auto. - apply eval_shift_stack_addressing. -Qed. - -(** Offset an addressing mode [addr] by a quantity [delta], so that - it designates the pointer [delta] bytes past the pointer designated - by [addr]. On PowerPC and ARM, this may be undefined, in which case - [None] is returned. On IA32, it is always defined, but we keep the - same interface. *) - -Definition offset_addressing_total (addr: addressing) (delta: int) : addressing := - match addr with - | Aindexed n => Aindexed (Int.add n delta) - | Aindexed2 n => Aindexed2 (Int.add n delta) - | Ascaled sc n => Ascaled sc (Int.add n delta) - | Aindexed2scaled sc n => Aindexed2scaled sc (Int.add n delta) - | Aglobal s n => Aglobal s (Int.add n delta) - | Abased s n => Abased s (Int.add n delta) - | Abasedscaled sc s n => Abasedscaled sc s (Int.add n delta) - | Ainstack n => Ainstack (Int.add n delta) - end. - -Definition offset_addressing (addr: addressing) (delta: int) : option addressing := - Some(offset_addressing_total addr delta). - -Lemma eval_offset_addressing_total: - forall (F V: Type) (ge: Genv.t F V) sp addr args delta v, - eval_addressing ge sp addr args = Some v -> - eval_addressing ge sp (offset_addressing_total addr delta) args = - Some(Val.add v (Vint delta)). -Proof. - intros. destruct addr; simpl in *; FuncInv; subst. - rewrite Val.add_assoc; auto. - rewrite !Val.add_assoc; auto. - rewrite !Val.add_assoc; auto. - rewrite !Val.add_assoc; auto. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); auto. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); auto. - rewrite Val.add_assoc. rewrite Val.add_permut. rewrite Val.add_commut. auto. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge i0); auto. - rewrite Val.add_assoc. rewrite Val.add_permut. rewrite Val.add_commut. auto. - rewrite Val.add_assoc. auto. -Qed. - -Lemma eval_offset_addressing: - forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v, - offset_addressing addr delta = Some addr' -> - eval_addressing ge sp addr args = Some v -> - eval_addressing ge sp addr' args = Some(Val.add v (Vint delta)). -Proof. - intros. unfold offset_addressing in H; inv H. - eapply eval_offset_addressing_total; eauto. -Qed. - -(** Operations that are so cheap to recompute that CSE should not factor them out. *) - -Definition is_trivial_op (op: operation) : bool := - match op with - | Omove => true - | Ointconst _ => true - | Olea (Aglobal _ _) => true - | Olea (Ainstack _) => true - | _ => false - end. - -(** Operations that depend on the memory state. *) - -Definition op_depends_on_memory (op: operation) : bool := - match op with - | Ocmp (Ccompu _) => true - | Ocmp (Ccompuimm _ _) => true - | _ => false - end. - -Lemma op_depends_on_memory_correct: - forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, - op_depends_on_memory op = false -> - eval_operation ge sp op args m1 = eval_operation ge sp op args m2. -Proof. - intros until m2. destruct op; simpl; try congruence. - destruct c; simpl; auto; congruence. -Qed. - -(** Global variables mentioned in an operation or addressing mode *) - -Definition globals_addressing (addr: addressing) : list ident := - match addr with - | Aglobal s n => s :: nil - | Abased s n => s :: nil - | Abasedscaled sc s n => s :: nil - | _ => nil - end. - -Definition globals_operation (op: operation) : list ident := - match op with - | Oindirectsymbol s => s :: nil - | Olea addr => globals_addressing addr - | _ => nil - end. - -(** * Invariance and compatibility properties. *) - -(** [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 V1 V2: Type. -Variable ge1: Genv.t F1 V1. -Variable ge2: Genv.t F2 V2. -Hypothesis agree_on_symbols: - forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. - -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, Genv.symbol_address; destruct addr; try rewrite agree_on_symbols; - reflexivity. -Qed. - -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; auto. - unfold Genv.symbol_address. rewrite agree_on_symbols. auto. - apply eval_addressing_preserved. -Qed. - -End GENV_TRANSF. - -(** Compatibility of the evaluation functions with value injections. *) - -Section EVAL_COMPAT. - -Variable F1 F2 V1 V2: Type. -Variable ge1: Genv.t F1 V1. -Variable ge2: Genv.t F2 V2. -Variable f: meminj. - -Variable m1: mem. -Variable m2: mem. - -Hypothesis valid_pointer_inj: - forall b1 ofs b2 delta, - f b1 = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. - -Hypothesis weak_valid_pointer_inj: - forall b1 ofs b2 delta, - f b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. - -Hypothesis weak_valid_pointer_no_overflow: - forall b1 ofs b2 delta, - f b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. - -Hypothesis valid_different_pointers_inj: - forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, - b1 <> b2 -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> - f b1 = Some (b1', delta1) -> - f b2 = Some (b2', delta2) -> - b1' <> b2' \/ - Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)). - -Ltac InvInject := - match goal with - | [ H: Val.inject _ (Vint _) _ |- _ ] => - inv H; InvInject - | [ H: Val.inject _ (Vfloat _) _ |- _ ] => - inv H; InvInject - | [ H: Val.inject _ (Vptr _ _) _ |- _ ] => - inv H; InvInject - | [ H: Val.inject_list _ nil _ |- _ ] => - inv H; InvInject - | [ H: Val.inject_list _ (_ :: _) _ |- _ ] => - inv H; InvInject - | _ => idtac - end. - -Lemma eval_condition_inj: - forall cond vl1 vl2 b, - Val.inject_list f vl1 vl2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. - inv H3; inv H2; simpl in H0; inv H0; auto. - eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. - inv H3; simpl in H0; inv H0; auto. - eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. - inv H3; inv H2; simpl in H0; inv H0; auto. - inv H3; inv H2; simpl in H0; inv H0; auto. - inv H3; inv H2; simpl in H0; inv H0; auto. - inv H3; inv H2; simpl in H0; inv H0; auto. - inv H3; try discriminate; auto. - inv H3; try discriminate; auto. -Qed. - -Ltac TrivialExists := - match goal with - | [ |- exists v2, Some ?v1 = Some v2 /\ Val.inject _ _ v2 ] => - exists v1; split; auto - | _ => idtac - end. - -Lemma eval_addressing_inj: - forall addr sp1 vl1 sp2 vl2 v1, - (forall id ofs, - In id (globals_addressing addr) -> - Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> - Val.inject f sp1 sp2 -> - Val.inject_list f vl1 vl2 -> - eval_addressing ge1 sp1 addr vl1 = Some v1 -> - exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. -Proof. - intros. destruct addr; simpl in H2; simpl; FuncInv; InvInject; TrivialExists. - apply Values.Val.add_inject; auto. - apply Values.Val.add_inject; auto. apply Values.Val.add_inject; auto. - apply Values.Val.add_inject; auto. inv H5; simpl; auto. - apply Values.Val.add_inject; auto. apply Values.Val.add_inject; auto. inv H3; simpl; auto. - apply H; simpl; auto. - apply Values.Val.add_inject; auto. apply H; simpl; auto. - apply Values.Val.add_inject; auto. apply H; simpl; auto. inv H5; simpl; auto. - apply Values.Val.add_inject; auto. -Qed. - -Lemma eval_operation_inj: - forall op sp1 vl1 sp2 vl2 v1, - (forall id ofs, - In id (globals_operation op) -> - Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> - Val.inject f sp1 sp2 -> - Val.inject_list f vl1 vl2 -> - eval_operation ge1 sp1 op vl1 m1 = Some v1 -> - exists v2, eval_operation ge2 sp2 op vl2 m2 = Some v2 /\ Val.inject f v1 v2. -Proof. - intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. - apply GL; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. econstructor; eauto. - rewrite Int.sub_add_l. auto. - destruct (eq_block b1 b0); auto. subst. rewrite H1 in H0. inv H0. rewrite dec_eq_true. - rewrite Int.sub_shifted. auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. TrivialExists. - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. TrivialExists. - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. - inv H4; simpl in H1; try discriminate. simpl. - destruct (Int.ltu i (Int.repr 31)); inv H1. TrivialExists. - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. - inv H4; simpl; auto. - inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. - inv H2; simpl; auto. destruct (Int.ltu (Int.sub Int.iwordsize i) Int.iwordsize); auto. - eapply eval_addressing_inj; eauto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2. - exists (Vint i); auto. - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2. - exists (Vint i); auto. - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - subst v1. destruct (eval_condition c vl1 m1) eqn:?. - exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. - destruct b; simpl; constructor. - simpl; constructor. -Qed. - -End EVAL_COMPAT. - -(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) - -Section EVAL_LESSDEF. - -Variable F V: Type. -Variable genv: Genv.t F V. - -Remark valid_pointer_extends: - forall m1 m2, Mem.extends m1 m2 -> - forall b1 ofs b2 delta, - Some(b1, 0) = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. -Proof. - intros. inv H0. rewrite Int.add_zero. eapply Mem.valid_pointer_extends; eauto. -Qed. - -Remark weak_valid_pointer_extends: - forall m1 m2, Mem.extends m1 m2 -> - forall b1 ofs b2 delta, - Some(b1, 0) = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. -Proof. - intros. inv H0. rewrite Int.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. -Qed. - -Remark weak_valid_pointer_no_overflow_extends: - forall m1 b1 ofs b2 delta, - Some(b1, 0) = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. -Proof. - intros. inv H. rewrite Zplus_0_r. apply Int.unsigned_range_2. -Qed. - -Remark valid_different_pointers_extends: - forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, - b1 <> b2 -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> - Some(b1, 0) = Some (b1', delta1) -> - Some(b2, 0) = Some (b2', delta2) -> - b1' <> b2' \/ - Int.unsigned(Int.add ofs1 (Int.repr delta1)) <> Int.unsigned(Int.add ofs2 (Int.repr delta2)). -Proof. - intros. inv H2; inv H3. auto. -Qed. - -Lemma eval_condition_lessdef: - forall cond vl1 vl2 b m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1). - apply valid_pointer_extends; auto. - apply weak_valid_pointer_extends; auto. - apply weak_valid_pointer_no_overflow_extends. - apply valid_different_pointers_extends; auto. - rewrite <- val_inject_list_lessdef. eauto. auto. -Qed. - -Lemma eval_operation_lessdef: - forall sp op vl1 vl2 v1 m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> - 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. rewrite val_inject_list_lessdef in H. - assert (exists v2 : val, - eval_operation genv sp op vl2 m2 = Some v2 - /\ Val.inject (fun b => Some(b, 0)) v1 v2). - eapply eval_operation_inj with (m1 := m1) (sp1 := sp). - apply valid_pointer_extends; auto. - apply weak_valid_pointer_extends; auto. - apply weak_valid_pointer_no_overflow_extends. - apply valid_different_pointers_extends; auto. - intros. apply val_inject_lessdef. auto. - apply val_inject_lessdef; auto. - eauto. - auto. - destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. -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. rewrite val_inject_list_lessdef in H. - assert (exists v2 : val, - eval_addressing genv sp addr vl2 = Some v2 - /\ Val.inject (fun b => Some(b, 0)) v1 v2). - eapply eval_addressing_inj with (sp1 := sp). - intros. rewrite <- val_inject_lessdef; auto. - rewrite <- val_inject_lessdef; auto. - eauto. auto. - destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. -Qed. - -End EVAL_LESSDEF. - -(** Compatibility of the evaluation functions with memory injections. *) - -Section EVAL_INJECT. - -Variable F V: Type. -Variable genv: Genv.t F V. -Variable f: meminj. -Hypothesis globals: meminj_preserves_globals genv f. -Variable sp1: block. -Variable sp2: block. -Variable delta: Z. -Hypothesis sp_inj: f sp1 = Some(sp2, delta). - -Remark symbol_address_inject: - forall id ofs, Val.inject f (Genv.symbol_address genv id ofs) (Genv.symbol_address genv id ofs). -Proof. - intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto. - exploit (proj1 globals); eauto. intros. - econstructor; eauto. rewrite Int.add_zero; auto. -Qed. - -Lemma eval_condition_inject: - forall cond vl1 vl2 b m1 m2, - Val.inject_list f vl1 vl2 -> - Mem.inject f m1 m2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto. - intros; eapply Mem.valid_pointer_inject_val; eauto. - intros; eapply Mem.weak_valid_pointer_inject_val; eauto. - intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. - intros; eapply Mem.different_pointers_inject; eauto. -Qed. - -Lemma eval_addressing_inject: - forall addr vl1 vl2 v1, - Val.inject_list f vl1 vl2 -> - eval_addressing genv (Vptr sp1 Int.zero) addr vl1 = Some v1 -> - exists v2, - eval_addressing genv (Vptr sp2 Int.zero) (shift_stack_addressing (Int.repr delta) addr) vl2 = Some v2 - /\ Val.inject f v1 v2. -Proof. - intros. - rewrite eval_shift_stack_addressing. simpl. - eapply eval_addressing_inj with (sp1 := Vptr sp1 Int.zero); eauto. - intros. apply symbol_address_inject. -Qed. - -Lemma eval_operation_inject: - forall op vl1 vl2 v1 m1 m2, - Val.inject_list f vl1 vl2 -> - Mem.inject f m1 m2 -> - eval_operation genv (Vptr sp1 Int.zero) op vl1 m1 = Some v1 -> - exists v2, - eval_operation genv (Vptr sp2 Int.zero) (shift_stack_operation (Int.repr delta) op) vl2 m2 = Some v2 - /\ Val.inject f v1 v2. -Proof. - intros. - rewrite eval_shift_stack_operation. simpl. - eapply eval_operation_inj with (sp1 := Vptr sp1 Int.zero) (m1 := m1); eauto. - intros; eapply Mem.valid_pointer_inject_val; eauto. - intros; eapply Mem.weak_valid_pointer_inject_val; eauto. - intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. - intros; eapply Mem.different_pointers_inject; eauto. - intros. apply symbol_address_inject. -Qed. - -End EVAL_INJECT. diff --git a/lib/Integers.v b/lib/Integers.v index 16c95e01..8fd09dd1 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -15,10 +15,9 @@ (** Formalizations of machine integers modulo $2^N$ #2<sup>N</sup>#. *) -Require Import Eqdep_dec. -Require Import Zquot. -Require Import Zwf. +Require Import Eqdep_dec Zquot Zwf. Require Import Coqlib. +Require Archi. (** * Comparisons *) @@ -3652,6 +3651,53 @@ Proof. unfold min_signed, max_signed; omega. Qed. +Lemma signed_eq: + forall x y, eq x y = zeq (signed x) (signed y). +Proof. + intros. unfold eq. unfold proj_sumbool. + destruct (zeq (unsigned x) (unsigned y)); + destruct (zeq (signed x) (signed y)); auto. + elim n. unfold signed. rewrite e; auto. + elim n. apply eqm_small_eq; auto with ints. + eapply eqm_trans. apply eqm_sym. apply eqm_signed_unsigned. + rewrite e. apply eqm_signed_unsigned. +Qed. + +Lemma not_lt: + forall x y, negb (lt y x) = (lt x y || eq x y). +Proof. + intros. unfold lt. rewrite signed_eq. unfold proj_sumbool. + destruct (zlt (signed y) (signed x)). + rewrite zlt_false. rewrite zeq_false. auto. omega. omega. + destruct (zeq (signed x) (signed y)). + rewrite zlt_false. auto. omega. + rewrite zlt_true. auto. omega. +Qed. + +Lemma lt_not: + forall x y, lt y x = negb (lt x y) && negb (eq x y). +Proof. + intros. rewrite <- negb_orb. rewrite <- not_lt. rewrite negb_involutive. auto. +Qed. + +Lemma not_ltu: + forall x y, negb (ltu y x) = (ltu x y || eq x y). +Proof. + intros. unfold ltu, eq. + destruct (zlt (unsigned y) (unsigned x)). + rewrite zlt_false. rewrite zeq_false. auto. omega. omega. + destruct (zeq (unsigned x) (unsigned y)). + rewrite zlt_false. auto. omega. + rewrite zlt_true. auto. omega. +Qed. + +Lemma ltu_not: + forall x y, ltu y x = negb (ltu x y) && negb (eq x y). +Proof. + intros. rewrite <- negb_orb. rewrite <- not_ltu. rewrite negb_involutive. auto. +Qed. + + (** Non-overlapping test *) Definition no_overlap (ofs1: int) (sz1: Z) (ofs2: int) (sz2: Z) : bool := @@ -3968,6 +4014,8 @@ Definition shru' (x: int) (y: Int.int): int := repr (Z.shiftr (unsigned x) (Int.unsigned y)). Definition shr' (x: int) (y: Int.int): int := repr (Z.shiftr (signed x) (Int.unsigned y)). +Definition shrx' (x: int) (y: Int.int): int := + divs x (shl' one y). Lemma bits_shl': forall x y i, @@ -4007,6 +4055,272 @@ Proof. omega. Qed. +Lemma shl'_mul_two_p: + forall x y, + shl' x y = mul x (repr (two_p (Int.unsigned y))). +Proof. + intros. unfold shl', mul. apply eqm_samerepr. + rewrite Zshiftl_mul_two_p. apply eqm_mult. apply eqm_refl. apply eqm_unsigned_repr. + generalize (Int.unsigned_range y); omega. +Qed. + +Lemma shl'_one_two_p: + forall y, shl' one y = repr (two_p (Int.unsigned y)). +Proof. + intros. rewrite shl'_mul_two_p. rewrite mul_commut. rewrite mul_one. auto. +Qed. + +Theorem shl'_mul: + forall x y, + shl' x y = mul x (shl' one y). +Proof. + intros. rewrite shl'_one_two_p. apply shl'_mul_two_p. +Qed. + +Theorem shrx'_zero: + forall x, shrx' x Int.zero = x. +Proof. + intros. unfold shrx'. rewrite shl'_one_two_p. unfold divs. + change (signed (repr (two_p (Int.unsigned Int.zero)))) with 1. + rewrite Z.quot_1_r. apply repr_signed. +Qed. + +Theorem shrx'_shr_2: + forall x y, + Int.ltu y (Int.repr 63) = true -> + shrx' x y = shr' (add x (shru' (shr' x (Int.repr 63)) (Int.sub (Int.repr 64) y))) y. +Proof. + intros. + set (z := repr (Int.unsigned y)). + apply Int.ltu_inv in H. change (Int.unsigned (Int.repr 63)) with 63 in H. + assert (N1: 63 < max_unsigned) by reflexivity. + assert (N2: 63 < Int.max_unsigned) by reflexivity. + assert (A: unsigned z = Int.unsigned y). + { unfold z; apply unsigned_repr; omega. } + assert (B: unsigned (sub (repr 64) z) = Int.unsigned (Int.sub (Int.repr 64) y)). + { unfold z. unfold sub, Int.sub. + change (unsigned (repr 64)) with 64. + change (Int.unsigned (Int.repr 64)) with 64. + rewrite (unsigned_repr (Int.unsigned y)) by omega. + rewrite unsigned_repr, Int.unsigned_repr by omega. + auto. } + unfold shrx', shr', shru', shl'. + rewrite <- A. + change (Int.unsigned (Int.repr 63)) with (unsigned (repr 63)). + rewrite <- B. + apply shrx_shr_2. + unfold ltu. apply zlt_true. change (unsigned z < 63). rewrite A; omega. +Qed. + +Remark int_ltu_2_inv: + forall y z, + Int.ltu y iwordsize' = true -> + Int.ltu z iwordsize' = true -> + Int.unsigned (Int.add y z) <= Int.unsigned iwordsize' -> + let y' := repr (Int.unsigned y) in + let z' := repr (Int.unsigned z) in + Int.unsigned y = unsigned y' + /\ Int.unsigned z = unsigned z' + /\ ltu y' iwordsize = true + /\ ltu z' iwordsize = true + /\ Int.unsigned (Int.add y z) = unsigned (add y' z') + /\ add y' z' = repr (Int.unsigned (Int.add y z)). +Proof. + intros. apply Int.ltu_inv in H. apply Int.ltu_inv in H0. + change (Int.unsigned iwordsize') with 64 in *. + assert (128 < max_unsigned) by reflexivity. + assert (128 < Int.max_unsigned) by reflexivity. + assert (Y: unsigned y' = Int.unsigned y) by (apply unsigned_repr; omega). + assert (Z: unsigned z' = Int.unsigned z) by (apply unsigned_repr; omega). + assert (P: Int.unsigned (Int.add y z) = unsigned (add y' z')). + { unfold Int.add. rewrite Int.unsigned_repr by omega. + unfold add. rewrite unsigned_repr by omega. congruence. } + intuition auto. + apply zlt_true. rewrite Y; auto. + apply zlt_true. rewrite Z; auto. + rewrite P. rewrite repr_unsigned. auto. +Qed. + +Theorem or_ror': + forall x y z, + Int.ltu y iwordsize' = true -> + Int.ltu z iwordsize' = true -> + Int.add y z = iwordsize' -> + ror x (repr (Int.unsigned z)) = or (shl' x y) (shru' x z). +Proof. + intros. destruct (int_ltu_2_inv y z) as (A & B & C & D & E & F); auto. rewrite H1; omega. + replace (shl' x y) with (shl x (repr (Int.unsigned y))). + replace (shru' x z) with (shru x (repr (Int.unsigned z))). + apply or_ror; auto. rewrite F, H1. reflexivity. + unfold shru, shru'; rewrite <- B; auto. + unfold shl, shl'; rewrite <- A; auto. +Qed. + +Theorem shl'_shl': + forall x y z, + Int.ltu y iwordsize' = true -> + Int.ltu z iwordsize' = true -> + Int.ltu (Int.add y z) iwordsize' = true -> + shl' (shl' x y) z = shl' x (Int.add y z). +Proof. + intros. apply Int.ltu_inv in H1. + destruct (int_ltu_2_inv y z) as (A & B & C & D & E & F); auto. omega. + set (y' := repr (Int.unsigned y)) in *. + set (z' := repr (Int.unsigned z)) in *. + replace (shl' x y) with (shl x y'). + replace (shl' (shl x y') z) with (shl (shl x y') z'). + replace (shl' x (Int.add y z)) with (shl x (add y' z')). + apply shl_shl; auto. apply zlt_true. rewrite <- E. + change (unsigned iwordsize) with zwordsize. tauto. + unfold shl, shl'. rewrite E; auto. + unfold shl at 1, shl'. rewrite <- B; auto. + unfold shl, shl'; rewrite <- A; auto. +Qed. + +Theorem shru'_shru': + forall x y z, + Int.ltu y iwordsize' = true -> + Int.ltu z iwordsize' = true -> + Int.ltu (Int.add y z) iwordsize' = true -> + shru' (shru' x y) z = shru' x (Int.add y z). +Proof. + intros. apply Int.ltu_inv in H1. + destruct (int_ltu_2_inv y z) as (A & B & C & D & E & F); auto. omega. + set (y' := repr (Int.unsigned y)) in *. + set (z' := repr (Int.unsigned z)) in *. + replace (shru' x y) with (shru x y'). + replace (shru' (shru x y') z) with (shru (shru x y') z'). + replace (shru' x (Int.add y z)) with (shru x (add y' z')). + apply shru_shru; auto. apply zlt_true. rewrite <- E. + change (unsigned iwordsize) with zwordsize. tauto. + unfold shru, shru'. rewrite E; auto. + unfold shru at 1, shru'. rewrite <- B; auto. + unfold shru, shru'; rewrite <- A; auto. +Qed. + +Theorem shr'_shr': + forall x y z, + Int.ltu y iwordsize' = true -> + Int.ltu z iwordsize' = true -> + Int.ltu (Int.add y z) iwordsize' = true -> + shr' (shr' x y) z = shr' x (Int.add y z). +Proof. + intros. apply Int.ltu_inv in H1. + destruct (int_ltu_2_inv y z) as (A & B & C & D & E & F); auto. omega. + set (y' := repr (Int.unsigned y)) in *. + set (z' := repr (Int.unsigned z)) in *. + replace (shr' x y) with (shr x y'). + replace (shr' (shr x y') z) with (shr (shr x y') z'). + replace (shr' x (Int.add y z)) with (shr x (add y' z')). + apply shr_shr; auto. apply zlt_true. rewrite <- E. + change (unsigned iwordsize) with zwordsize. tauto. + unfold shr, shr'. rewrite E; auto. + unfold shr at 1, shr'. rewrite <- B; auto. + unfold shr, shr'; rewrite <- A; auto. +Qed. + +(** Powers of two with exponents given as 32-bit ints *) + +Definition one_bits' (x: int) : list Int.int := + List.map Int.repr (Z_one_bits wordsize (unsigned x) 0). + +Definition is_power2' (x: int) : option Int.int := + match Z_one_bits wordsize (unsigned x) 0 with + | i :: nil => Some (Int.repr i) + | _ => None + end. + +Theorem one_bits'_range: + forall x i, In i (one_bits' x) -> Int.ltu i iwordsize' = true. +Proof. + intros. + destruct (list_in_map_inv _ _ _ H) as [i0 [EQ IN]]. + exploit Z_one_bits_range; eauto. intros R. + unfold Int.ltu. rewrite EQ. rewrite Int.unsigned_repr. + change (Int.unsigned iwordsize') with zwordsize. apply zlt_true. omega. + assert (zwordsize < Int.max_unsigned) by reflexivity. omega. +Qed. + +Fixpoint int_of_one_bits' (l: list Int.int) : int := + match l with + | nil => zero + | a :: b => add (shl' one a) (int_of_one_bits' b) + end. + +Theorem one_bits'_decomp: + forall x, x = int_of_one_bits' (one_bits' x). +Proof. + assert (REC: forall l, + (forall i, In i l -> 0 <= i < zwordsize) -> + int_of_one_bits' (List.map Int.repr l) = repr (powerserie l)). + { induction l; simpl; intros. + - auto. + - rewrite IHl by eauto. apply eqm_samerepr; apply eqm_add. + + rewrite shl'_one_two_p. rewrite Int.unsigned_repr. apply eqm_sym; apply eqm_unsigned_repr. + exploit (H a). auto. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. + + apply eqm_sym; apply eqm_unsigned_repr. + } + intros. rewrite <- (repr_unsigned x) at 1. unfold one_bits'. rewrite REC. + rewrite <- Z_one_bits_powerserie. auto. apply unsigned_range. + apply Z_one_bits_range. +Qed. + +Lemma is_power2'_rng: + forall n logn, + is_power2' n = Some logn -> + 0 <= Int.unsigned logn < zwordsize. +Proof. + unfold is_power2'; intros n logn P2. + destruct (Z_one_bits wordsize (unsigned n) 0) as [ | i [ | ? ?]] eqn:B; inv P2. + assert (0 <= i < zwordsize). + { apply Z_one_bits_range with (unsigned n). rewrite B; auto with coqlib. } + rewrite Int.unsigned_repr. auto. + assert (zwordsize < Int.max_unsigned) by reflexivity. + omega. +Qed. + +Theorem is_power2'_range: + forall n logn, + is_power2' n = Some logn -> Int.ltu logn iwordsize' = true. +Proof. + intros. unfold Int.ltu. change (Int.unsigned iwordsize') with zwordsize. + apply zlt_true. generalize (is_power2'_rng _ _ H). tauto. +Qed. + +Lemma is_power2'_correct: + forall n logn, + is_power2' n = Some logn -> + unsigned n = two_p (Int.unsigned logn). +Proof. + unfold is_power2'; intros. + destruct (Z_one_bits wordsize (unsigned n) 0) as [ | i [ | ? ?]] eqn:B; inv H. + rewrite (Z_one_bits_powerserie (unsigned n)) by (apply unsigned_range). + rewrite Int.unsigned_repr. rewrite B; simpl. omega. + assert (0 <= i < zwordsize). + { apply Z_one_bits_range with (unsigned n). rewrite B; auto with coqlib. } + assert (zwordsize < Int.max_unsigned) by reflexivity. + omega. +Qed. + +Theorem mul_pow2': + forall x n logn, + is_power2' n = Some logn -> + mul x n = shl' x logn. +Proof. + intros. rewrite shl'_mul. f_equal. rewrite shl'_one_two_p. + rewrite <- (repr_unsigned n). f_equal. apply is_power2'_correct; auto. +Qed. + +Theorem divu_pow2': + forall x n logn, + is_power2' n = Some logn -> + divu x n = shru' x logn. +Proof. + intros. generalize (is_power2'_correct n logn H). intro. + symmetry. unfold divu. rewrite H0. unfold shru'. rewrite Zshiftr_div_two_p. auto. + eapply is_power2'_rng; eauto. +Qed. + (** Decomposing 64-bit ints as pairs of 32-bit ints *) Definition loword (n: int) : Int.int := Int.repr (unsigned n). @@ -4528,3 +4842,284 @@ Strategy 0 [Wordsize_64.wordsize]. Notation int64 := Int64.int. Global Opaque Int.repr Int64.repr Byte.repr. + +(** * Specialization to offsets in pointer values *) + +Module Wordsize_Ptrofs. + Definition wordsize := if Archi.ptr64 then 64%nat else 32%nat. + Remark wordsize_not_zero: wordsize <> 0%nat. + Proof. unfold wordsize; destruct Archi.ptr64; congruence. Qed. +End Wordsize_Ptrofs. + +Strategy opaque [Wordsize_Ptrofs.wordsize]. + +Module Ptrofs. + +Include Make(Wordsize_Ptrofs). + +Definition to_int (x: int): Int.int := Int.repr (unsigned x). + +Definition to_int64 (x: int): Int64.int := Int64.repr (unsigned x). + +Definition of_int (x: Int.int) : int := repr (Int.unsigned x). + +Definition of_intu := of_int. + +Definition of_ints (x: Int.int) : int := repr (Int.signed x). + +Definition of_int64 (x: Int64.int) : int := repr (Int64.unsigned x). + +Definition of_int64u := of_int64. + +Definition of_int64s (x: Int64.int) : int := repr (Int64.signed x). + +Section AGREE32. + +Hypothesis _32: Archi.ptr64 = false. + +Lemma modulus_eq32: modulus = Int.modulus. +Proof. + unfold modulus, wordsize. + change Wordsize_Ptrofs.wordsize with (if Archi.ptr64 then 64%nat else 32%nat). + rewrite _32. reflexivity. +Qed. + +Lemma eqm32: + forall x y, Int.eqm x y <-> eqm x y. +Proof. + intros. unfold Int.eqm, eqm. rewrite modulus_eq32; tauto. +Qed. + +Definition agree32 (a: Ptrofs.int) (b: Int.int) : Prop := + Ptrofs.unsigned a = Int.unsigned b. + +Lemma agree32_repr: + forall i, agree32 (Ptrofs.repr i) (Int.repr i). +Proof. + intros; red. rewrite Ptrofs.unsigned_repr_eq, Int.unsigned_repr_eq. + apply f_equal2. auto. apply modulus_eq32. +Qed. + +Lemma agree32_signed: + forall a b, agree32 a b -> Ptrofs.signed a = Int.signed b. +Proof. + unfold agree32; intros. unfold signed, Int.signed, half_modulus, Int.half_modulus. + rewrite modulus_eq32. rewrite H. auto. +Qed. + +Lemma agree32_of_int: + forall b, agree32 (of_int b) b. +Proof. + unfold of_int; intros. rewrite <- (Int.repr_unsigned b) at 2. apply agree32_repr. +Qed. + +Lemma agree32_of_ints: + forall b, agree32 (of_ints b) b. +Proof. + unfold of_int; intros. rewrite <- (Int.repr_signed b) at 2. apply agree32_repr. +Qed. + +Lemma agree32_of_int_eq: + forall a b, agree32 a b -> of_int b = a. +Proof. + unfold agree32, of_int; intros. rewrite <- H. apply repr_unsigned. +Qed. + +Lemma agree32_of_ints_eq: + forall a b, agree32 a b -> of_ints b = a. +Proof. + unfold of_ints; intros. erewrite <- agree32_signed by eauto. apply repr_signed. +Qed. + +Lemma agree32_to_int: + forall a, agree32 a (to_int a). +Proof. + unfold agree32, to_int; intros. rewrite <- (agree32_repr (unsigned a)). + rewrite repr_unsigned; auto. +Qed. + +Lemma agree32_to_int_eq: + forall a b, agree32 a b -> to_int a = b. +Proof. + unfold agree32, to_int; intros. rewrite H. apply Int.repr_unsigned. +Qed. + +Lemma agree32_neg: + forall a1 b1, agree32 a1 b1 -> agree32 (Ptrofs.neg a1) (Int.neg b1). +Proof. + unfold agree32, Ptrofs.neg, Int.neg; intros. rewrite H. apply agree32_repr. +Qed. + +Lemma agree32_add: + forall a1 b1 a2 b2, + agree32 a1 b1 -> agree32 a2 b2 -> agree32 (Ptrofs.add a1 a2) (Int.add b1 b2). +Proof. + unfold agree32, Ptrofs.add, Int.add; intros. rewrite H, H0. apply agree32_repr. +Qed. + +Lemma agree32_sub: + forall a1 b1 a2 b2, + agree32 a1 b1 -> agree32 a2 b2 -> agree32 (Ptrofs.sub a1 a2) (Int.sub b1 b2). +Proof. + unfold agree32, Ptrofs.sub, Int.sub; intros. rewrite H, H0. apply agree32_repr. +Qed. + +Lemma agree32_mul: + forall a1 b1 a2 b2, + agree32 a1 b1 -> agree32 a2 b2 -> agree32 (Ptrofs.mul a1 a2) (Int.mul b1 b2). +Proof. + unfold agree32, Ptrofs.mul, Int.mul; intros. rewrite H, H0. apply agree32_repr. +Qed. + +Lemma agree32_divs: + forall a1 b1 a2 b2, + agree32 a1 b1 -> agree32 a2 b2 -> agree32 (Ptrofs.divs a1 a2) (Int.divs b1 b2). +Proof. + intros; unfold agree32, Ptrofs.divs, Int.divs. + erewrite ! agree32_signed by eauto. apply agree32_repr. +Qed. + +Lemma of_int_to_int: + forall n, of_int (to_int n) = n. +Proof. + intros; unfold of_int, to_int. apply eqm_repr_eq. rewrite <- eqm32. + apply Int.eqm_sym; apply Int.eqm_unsigned_repr. +Qed. + +End AGREE32. + +Section AGREE64. + +Hypothesis _64: Archi.ptr64 = true. + +Lemma modulus_eq64: modulus = Int64.modulus. +Proof. + unfold modulus, wordsize. + change Wordsize_Ptrofs.wordsize with (if Archi.ptr64 then 64%nat else 32%nat). + rewrite _64. reflexivity. +Qed. + +Lemma eqm64: + forall x y, Int64.eqm x y <-> eqm x y. +Proof. + intros. unfold Int64.eqm, eqm. rewrite modulus_eq64; tauto. +Qed. + +Definition agree64 (a: Ptrofs.int) (b: Int64.int) : Prop := + Ptrofs.unsigned a = Int64.unsigned b. + +Lemma agree64_repr: + forall i, agree64 (Ptrofs.repr i) (Int64.repr i). +Proof. + intros; red. rewrite Ptrofs.unsigned_repr_eq, Int64.unsigned_repr_eq. + apply f_equal2. auto. apply modulus_eq64. +Qed. + +Lemma agree64_signed: + forall a b, agree64 a b -> Ptrofs.signed a = Int64.signed b. +Proof. + unfold agree64; intros. unfold signed, Int64.signed, half_modulus, Int64.half_modulus. + rewrite modulus_eq64. rewrite H. auto. +Qed. + +Lemma agree64_of_int: + forall b, agree64 (of_int64 b) b. +Proof. + unfold of_int64; intros. rewrite <- (Int64.repr_unsigned b) at 2. apply agree64_repr. +Qed. + +Lemma agree64_of_int_eq: + forall a b, agree64 a b -> of_int64 b = a. +Proof. + unfold agree64, of_int64; intros. rewrite <- H. apply repr_unsigned. +Qed. + +Lemma agree64_to_int: + forall a, agree64 a (to_int64 a). +Proof. + unfold agree64, to_int64; intros. rewrite <- (agree64_repr (unsigned a)). + rewrite repr_unsigned; auto. +Qed. + +Lemma agree64_to_int_eq: + forall a b, agree64 a b -> to_int64 a = b. +Proof. + unfold agree64, to_int64; intros. rewrite H. apply Int64.repr_unsigned. +Qed. + +Lemma agree64_neg: + forall a1 b1, agree64 a1 b1 -> agree64 (Ptrofs.neg a1) (Int64.neg b1). +Proof. + unfold agree64, Ptrofs.neg, Int64.neg; intros. rewrite H. apply agree64_repr. +Qed. + +Lemma agree64_add: + forall a1 b1 a2 b2, + agree64 a1 b1 -> agree64 a2 b2 -> agree64 (Ptrofs.add a1 a2) (Int64.add b1 b2). +Proof. + unfold agree64, Ptrofs.add, Int.add; intros. rewrite H, H0. apply agree64_repr. +Qed. + +Lemma agree64_sub: + forall a1 b1 a2 b2, + agree64 a1 b1 -> agree64 a2 b2 -> agree64 (Ptrofs.sub a1 a2) (Int64.sub b1 b2). +Proof. + unfold agree64, Ptrofs.sub, Int.sub; intros. rewrite H, H0. apply agree64_repr. +Qed. + +Lemma agree64_mul: + forall a1 b1 a2 b2, + agree64 a1 b1 -> agree64 a2 b2 -> agree64 (Ptrofs.mul a1 a2) (Int64.mul b1 b2). +Proof. + unfold agree64, Ptrofs.mul, Int.mul; intros. rewrite H, H0. apply agree64_repr. +Qed. + +Lemma agree64_divs: + forall a1 b1 a2 b2, + agree64 a1 b1 -> agree64 a2 b2 -> agree64 (Ptrofs.divs a1 a2) (Int64.divs b1 b2). +Proof. + intros; unfold agree64, Ptrofs.divs, Int64.divs. + erewrite ! agree64_signed by eauto. apply agree64_repr. +Qed. + +Lemma of_int64_to_int64: + forall n, of_int64 (to_int64 n) = n. +Proof. + intros; unfold of_int64, to_int64. apply eqm_repr_eq. rewrite <- eqm64. + apply Int64.eqm_sym; apply Int64.eqm_unsigned_repr. +Qed. + +End AGREE64. + +Hint Resolve + agree32_repr agree32_of_int agree32_of_ints agree32_of_int_eq agree32_of_ints_eq + agree32_to_int agree32_to_int_eq agree32_neg agree32_add agree32_sub agree32_mul agree32_divs + agree64_repr agree64_of_int agree64_of_int_eq + agree64_to_int agree64_to_int_eq agree64_neg agree64_add agree64_sub agree64_mul agree64_divs : ptrofs. + +End Ptrofs. + +Strategy 0 [Wordsize_Ptrofs.wordsize]. + +Notation ptrofs := Ptrofs.int. + +Global Opaque Ptrofs.repr. + +Hint Resolve Int.modulus_pos Int.eqm_refl Int.eqm_refl2 Int.eqm_sym Int.eqm_trans + Int.eqm_small_eq Int.eqm_add Int.eqm_neg Int.eqm_sub Int.eqm_mult + Int.eqm_unsigned_repr Int.eqm_unsigned_repr_l Int.eqm_unsigned_repr_r + Int.unsigned_range Int.unsigned_range_2 + Int.repr_unsigned Int.repr_signed Int.unsigned_repr : ints. + +Hint Resolve Int64.modulus_pos Int64.eqm_refl Int64.eqm_refl2 Int64.eqm_sym Int64.eqm_trans + Int64.eqm_small_eq Int64.eqm_add Int64.eqm_neg Int64.eqm_sub Int64.eqm_mult + Int64.eqm_unsigned_repr Int64.eqm_unsigned_repr_l Int64.eqm_unsigned_repr_r + Int64.unsigned_range Int64.unsigned_range_2 + Int64.repr_unsigned Int64.repr_signed Int64.unsigned_repr : ints. + +Hint Resolve Ptrofs.modulus_pos Ptrofs.eqm_refl Ptrofs.eqm_refl2 Ptrofs.eqm_sym Ptrofs.eqm_trans + Ptrofs.eqm_small_eq Ptrofs.eqm_add Ptrofs.eqm_neg Ptrofs.eqm_sub Ptrofs.eqm_mult + Ptrofs.eqm_unsigned_repr Ptrofs.eqm_unsigned_repr_l Ptrofs.eqm_unsigned_repr_r + Ptrofs.unsigned_range Ptrofs.unsigned_range_2 + Ptrofs.repr_unsigned Ptrofs.repr_signed Ptrofs.unsigned_repr : ints. + diff --git a/powerpc/Archi.v b/powerpc/Archi.v index 89f53ffd..10dc5534 100644 --- a/powerpc/Archi.v +++ b/powerpc/Archi.v @@ -20,10 +20,19 @@ Require Import ZArith. Require Import Fappli_IEEE. Require Import Fappli_IEEE_bits. +Definition ptr64 := false. + Definition big_endian := true. -Notation align_int64 := 8%Z (only parsing). -Notation align_float64 := 8%Z (only parsing). +Definition align_int64 := 8%Z. +Definition align_float64 := 8%Z. + +Definition splitlong := true. + +Lemma splitlong_ptr32: splitlong = true -> ptr64 = false. +Proof. + unfold splitlong, ptr64; congruence. +Qed. Program Definition default_pl_64 : bool * nan_pl 53 := (false, iter_nat 51 _ xO xH). @@ -39,7 +48,7 @@ Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_p Definition float_of_single_preserves_sNaN := true. -Global Opaque big_endian +Global Opaque ptr64 big_endian splitlong default_pl_64 choose_binop_pl_64 default_pl_32 choose_binop_pl_32 float_of_single_preserves_sNaN. diff --git a/powerpc/Asm.v b/powerpc/Asm.v index 9f8231e0..3c269083 100644 --- a/powerpc/Asm.v +++ b/powerpc/Asm.v @@ -100,11 +100,11 @@ Notation "'RA'" := LR (only parsing). Inductive constant: Type := | Cint: int -> constant - | Csymbol_low: ident -> int -> constant - | Csymbol_high: ident -> int -> constant - | Csymbol_sda: ident -> int -> constant - | Csymbol_rel_low: ident -> int -> constant - | Csymbol_rel_high: ident -> int -> constant. + | Csymbol_low: ident -> ptrofs -> constant + | Csymbol_high: ident -> ptrofs -> constant + | Csymbol_sda: ident -> ptrofs -> constant + | Csymbol_rel_low: ident -> ptrofs -> constant + | Csymbol_rel_high: ident -> ptrofs -> constant. (** A note on constants: while immediate operands to PowerPC instructions must be representable in 16 bits (with @@ -142,7 +142,7 @@ Inductive instruction : Type := | Paddic: ireg -> ireg -> constant -> instruction (**r add immediate and set carry *) | Paddis: ireg -> ireg -> constant -> instruction (**r add immediate high *) | Paddze: ireg -> ireg -> instruction (**r add carry *) - | Pallocframe: Z -> int -> int -> instruction (**r allocate new stack frame (pseudo) *) + | Pallocframe: Z -> ptrofs -> ptrofs -> instruction (**r allocate new stack frame (pseudo) *) | 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 *) @@ -179,7 +179,7 @@ Inductive instruction : Type := | Pextsb: ireg -> ireg -> instruction (**r 8-bit sign extension *) | Pextsh: ireg -> ireg -> instruction (**r 16-bit sign extension *) | Pextsw: ireg -> ireg -> instruction (**r 64-bit sign extension (PPC64) *) - | Pfreeframe: Z -> int -> instruction (**r deallocate stack frame and restore previous frame (pseudo) *) + | Pfreeframe: Z -> ptrofs -> instruction (**r deallocate stack frame and restore previous frame (pseudo) *) | Pfabs: freg -> freg -> instruction (**r float absolute value *) | Pfabss: freg -> freg -> instruction (**r float absolute value *) | Pfadd: freg -> freg -> freg -> instruction (**r float addition *) @@ -458,8 +458,8 @@ Variable ge: genv. symbolic references [symbol + offset] and splits their actual values into two 16-bit halves. *) -Parameter low_half: genv -> ident -> int -> val. -Parameter high_half: genv -> ident -> int -> val. +Parameter low_half: genv -> ident -> ptrofs -> val. +Parameter high_half: genv -> ident -> ptrofs -> val. (** The fundamental property of these operations is that, when applied to the address of a symbol, their results can be recombined by @@ -477,15 +477,15 @@ Axiom low_high_half: register pointing to the base of the small data area containing symbol [symb]. We leave this transformation up to the linker. *) -Parameter symbol_is_small_data: ident -> int -> bool. -Parameter small_data_area_offset: genv -> ident -> int -> val. +Parameter symbol_is_small_data: ident -> ptrofs -> bool. +Parameter small_data_area_offset: genv -> ident -> ptrofs -> val. Axiom small_data_area_addressing: forall id ofs, symbol_is_small_data id ofs = true -> small_data_area_offset ge id ofs = Genv.symbol_address ge id ofs. -Parameter symbol_is_rel_data: ident -> int -> bool. +Parameter symbol_is_rel_data: ident -> ptrofs -> bool. (** Armed with the [low_half] and [high_half] functions, we can define the evaluation of a symbolic constant. @@ -529,14 +529,14 @@ Inductive outcome: Type := instruction ([nextinstr]) or branching to a label ([goto_label]). *) Definition nextinstr (rs: regset) := - rs#PC <- (Val.add rs#PC Vone). + rs#PC <- (Val.offset_ptr rs#PC Ptrofs.one). Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := match label_pos lbl 0 (fn_code f) with | None => Stuck | Some pos => match rs#PC with - | Vptr b ofs => Next (rs#PC <- (Vptr b (Int.repr pos))) m + | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m | _ => Stuck end end. @@ -635,8 +635,8 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out #CARRY <- (Val.add_carry rs#r1 Vzero rs#CARRY))) m | Pallocframe sz ofs _ => let (m1, stk) := Mem.alloc m 0 sz in - let sp := Vptr stk Int.zero in - match Mem.storev Mint32 m1 (Val.add sp (Vint ofs)) rs#GPR1 with + let sp := Vptr stk Ptrofs.zero in + match Mem.storev Mint32 m1 (Val.offset_ptr sp ofs) rs#GPR1 with | None => Stuck | Some m2 => Next (nextinstr (rs#GPR1 <- sp #GPR0 <- Vundef)) m2 end @@ -656,16 +656,16 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pbctr sg => Next (rs#PC <- (rs#CTR)) m | Pbctrl sg => - Next (rs#LR <- (Val.add rs#PC Vone) #PC <- (rs#CTR)) m + Next (rs#LR <- (Val.offset_ptr rs#PC Ptrofs.one) #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 f lbl rs m else Next (nextinstr rs) m | _ => Stuck end | Pbl ident sg => - Next (rs#LR <- (Val.add rs#PC Vone) #PC <- (Genv.symbol_address ge ident Int.zero)) m + Next (rs#LR <- (Val.offset_ptr rs#PC Ptrofs.one) #PC <- (Genv.symbol_address ge ident Ptrofs.zero)) m | Pbs ident sg => - Next (rs#PC <- (Genv.symbol_address ge ident Int.zero)) m + Next (rs#PC <- (Genv.symbol_address ge ident Ptrofs.zero)) m | Pblr => Next (rs#PC <- (rs#LR)) m | Pbt bit lbl => @@ -703,7 +703,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pextsh rd r1 => Next (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m | Pfreeframe sz ofs => - match Mem.loadv Mint32 m (Val.add rs#GPR1 (Vint ofs)) with + match Mem.loadv Mint32 m (Val.offset_ptr rs#GPR1 ofs) with | None => Stuck | Some v => match rs#GPR1 with @@ -977,7 +977,7 @@ Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := | extcall_arg_stack: forall ofs ty bofs v, bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> Mem.loadv (chunk_of_type ty) m - (Val.add (rs (IR GPR1)) (Vint (Int.repr bofs))) = Some v -> + (Val.offset_ptr (rs (IR GPR1)) (Ptrofs.repr bofs)) = Some v -> extcall_arg rs m (S Outgoing ofs ty) v. Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := @@ -1006,14 +1006,14 @@ Inductive step: state -> trace -> state -> Prop := forall b ofs f i rs m rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Int.unsigned ofs) f.(fn_code) = Some i -> + find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some i -> exec_instr f i rs m = Next rs' m' -> step (State rs m) E0 (State rs' m') | exec_step_builtin: forall b ofs f ef args res rs m vargs t vres rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Int.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> + find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> eval_builtin_args ge rs (rs GPR1) m args vargs -> external_call ef ge vargs m t vres m' -> rs' = nextinstr @@ -1022,7 +1022,7 @@ Inductive step: state -> trace -> state -> Prop := step (State rs m) t (State rs' m') | exec_step_external: forall b ef args res rs m t rs' m', - rs PC = Vptr b Int.zero -> + rs PC = Vptr b Ptrofs.zero -> Genv.find_funct_ptr ge b = Some (External ef) -> external_call ef ge args m t res m' -> extcall_arguments rs m (ef_sig ef) args -> @@ -1039,14 +1039,14 @@ Inductive initial_state (p: program): state -> Prop := let ge := Genv.globalenv p in let rs0 := (Pregmap.init Vundef) - # PC <- (Genv.symbol_address ge p.(prog_main) Int.zero) - # LR <- Vzero - # GPR1 <- Vzero in + # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) + # LR <- Vnullptr + # GPR1 <- Vnullptr in initial_state p (State rs0 m0). Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m r, - rs#PC = Vzero -> + rs#PC = Vnullptr -> rs#GPR3 = Vint r -> final_state (State rs m) r. @@ -1105,7 +1105,7 @@ Ltac Equalities := (* initial states *) inv H; inv H0. f_equal. congruence. (* final no step *) - inv H. unfold Vzero in H0. red; intros; red; intros. inv H; congruence. + inv H. red; intros; red; intros. inv H; rewrite H0 in *; discriminate. (* final states *) inv H; inv H0. congruence. Qed. diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v index 4ad5e2f9..799d208e 100644 --- a/powerpc/Asmgen.v +++ b/powerpc/Asmgen.v @@ -125,12 +125,13 @@ Definition rolm (r1 r2: ireg) (amount mask: int) (k: code) := Definition accessind {A: Type} (instr1: A -> constant -> ireg -> instruction) (instr2: A -> ireg -> ireg -> instruction) - (base: ireg) (ofs: int) (r: A) (k: code) := + (base: ireg) (ofs: ptrofs) (r: A) (k: code) := + let ofs := Ptrofs.to_int ofs in if Int.eq (high_s ofs) Int.zero then instr1 r (Cint ofs) base :: k else loadimm GPR0 ofs (instr2 r base GPR0 :: k). -Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) := +Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := match ty, preg_of dst with | Tint, IR r => OK(accessind Plwz Plwzx base ofs r k) | Tany32, IR r => OK(accessind Plwz_a Plwzx_a base ofs r k) @@ -140,7 +141,7 @@ Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) := | _, _ => Error (msg "Asmgen.loadind") end. -Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) := +Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) := match ty, preg_of src with | Tint, IR r => OK(accessind Pstw Pstwx base ofs r k) | Tany32, IR r => OK(accessind Pstw_a Pstwx_a base ofs r k) @@ -340,7 +341,7 @@ Definition transl_op Paddis r GPR0 (Csymbol_high s ofs) :: Paddi r r (Csymbol_low s ofs) :: k) | Oaddrstack n, nil => - do r <- ireg_of res; OK (addimm r GPR1 n k) + do r <- ireg_of res; OK (addimm r GPR1 (Ptrofs.to_int n) k) | Ocast8signed, a1 :: nil => do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pextsb r r1 :: k) | Ocast16signed, a1 :: nil => @@ -559,6 +560,7 @@ Definition transl_memory_access Paddis temp r1 (Csymbol_high symb ofs) :: mk1 (Csymbol_low symb ofs) temp :: k) | Ainstack ofs, nil => + let ofs := Ptrofs.to_int ofs in OK (if Int.eq (high_s ofs) Int.zero then mk1 (Cint ofs) GPR1 :: k else @@ -647,12 +649,12 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) | Mtailcall sig (inl r) => do r1 <- ireg_of r; OK (Pmtctr r1 :: - Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 :: + Plwz GPR0 (Cint (Ptrofs.to_int f.(fn_retaddr_ofs))) GPR1 :: Pmtlr GPR0 :: Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbctr sig :: k) | Mtailcall sig (inr symb) => - OK (Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 :: + OK (Plwz GPR0 (Cint (Ptrofs.to_int f.(fn_retaddr_ofs))) GPR1 :: Pmtlr GPR0 :: Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbs symb sig :: k) @@ -670,7 +672,7 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) do r <- ireg_of arg; OK (Pbtbl r tbl :: k) | Mreturn => - OK (Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 :: + OK (Plwz GPR0 (Cint (Ptrofs.to_int f.(fn_retaddr_ofs))) GPR1 :: Pmtlr GPR0 :: Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pblr :: k) @@ -722,12 +724,12 @@ Definition transl_function (f: Mach.function) := OK (mkfunction f.(Mach.fn_sig) (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) f.(fn_retaddr_ofs) :: Pmflr GPR0 :: - Pstw GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 :: - Pcfi_rel_offset f.(fn_retaddr_ofs) :: c)). + Pstw GPR0 (Cint (Ptrofs.to_int f.(fn_retaddr_ofs))) GPR1 :: + Pcfi_rel_offset (Ptrofs.to_int f.(fn_retaddr_ofs)) :: c)). Definition transf_function (f: Mach.function) : res Asm.function := do tf <- transl_function f; - if zlt Int.max_unsigned (list_length_z tf.(fn_code)) + if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) then Error (msg "code size exceeded") else OK tf. diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v index 44c81735..447a53a0 100644 --- a/powerpc/Asmgenproof.v +++ b/powerpc/Asmgenproof.v @@ -18,6 +18,8 @@ Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Mach Conventions Asm. Require Import Asmgen Asmgenproof0 Asmgenproof1. +Local Transparent Archi.ptr64. + Definition match_prog (p: Mach.program) (tp: Asm.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. @@ -64,9 +66,9 @@ Qed. Lemma transf_function_no_overflow: forall f tf, - transf_function f = OK tf -> list_length_z tf.(fn_code) <= Int.max_unsigned. + transf_function f = OK tf -> list_length_z tf.(fn_code) <= Ptrofs.max_unsigned. Proof. - intros. monadInv H. destruct (zlt Int.max_unsigned (list_length_z x.(fn_code))); inv EQ0. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. omega. Qed. @@ -181,10 +183,10 @@ Remark loadind_label: forall base ofs ty dst k c, loadind base ofs ty dst k = OK c -> tail_nolabel k c. Proof. - unfold loadind, accessind; intros. + unfold loadind, accessind; intros. set (ofs' := Ptrofs.to_int ofs) in *. destruct ty; try discriminate; destruct (preg_of dst); try discriminate; - destruct (Int.eq (high_s ofs) Int.zero); + destruct (Int.eq (high_s ofs') Int.zero); TailNoLabel; eapply tail_nolabel_trans; TailNoLabel. Qed. @@ -192,10 +194,10 @@ Remark storeind_label: forall base ofs ty src k c, storeind src base ofs ty k = OK c -> tail_nolabel k c. Proof. - unfold storeind, accessind; intros. + unfold storeind, accessind; intros. set (ofs' := Ptrofs.to_int ofs) in *. destruct ty; try discriminate; destruct (preg_of src); try discriminate; - destruct (Int.eq (high_s ofs) Int.zero); + destruct (Int.eq (high_s ofs') Int.zero); TailNoLabel; eapply tail_nolabel_trans; TailNoLabel. Qed. @@ -250,7 +252,7 @@ Proof. destruct (Int.eq (high_s i) Int.zero); TailNoLabel. destruct (symbol_is_small_data i i0). TailNoLabel. destruct (symbol_is_rel_data i i0); TailNoLabel. destruct (symbol_is_small_data i i0). TailNoLabel. destruct (symbol_is_rel_data i i0); TailNoLabel. - destruct (Int.eq (high_s i) Int.zero); TailNoLabel. + destruct (Int.eq (high_s (Ptrofs.to_int i)) Int.zero); TailNoLabel. Qed. Lemma transl_instr_label: @@ -307,7 +309,7 @@ Lemma transl_find_label: | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc end. Proof. - intros. monadInv H. destruct (zlt Int.max_unsigned (list_length_z x.(fn_code))); inv EQ0. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ. rewrite transl_code'_transl_code in EQ0. simpl. eapply transl_code_label; eauto. Qed. @@ -332,10 +334,10 @@ Proof. intros [tc [A B]]. exploit label_pos_code_tail; eauto. instantiate (1 := 0). intros [pos' [P [Q R]]]. - exists tc; exists (rs#PC <- (Vptr b (Int.repr pos'))). + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). split. unfold goto_label. rewrite P. rewrite H1. auto. split. rewrite Pregmap.gss. constructor; auto. - rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in Q. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. auto. omega. generalize (transf_function_no_overflow _ _ H0). omega. intros. apply Pregmap.gso; auto. @@ -351,7 +353,7 @@ Proof. - intros. exploit transl_instr_label; eauto. destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor. - intros. monadInv H0. - destruct (zlt Int.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ. + destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ. rewrite transl_code'_transl_code in EQ0. exists x; exists false; split; auto. unfold fn_code. repeat constructor. - exact transf_function_no_overflow. @@ -391,7 +393,7 @@ Inductive match_states: Mach.state -> Asm.state -> Prop := (STACKS: match_stack ge s) (MEXT: Mem.extends m m') (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Int.zero) + (ATPC: rs PC = Vptr fb Ptrofs.zero) (ATLR: rs RA = parent_ra s), match_states (Mach.Callstate s fb ms m) (Asm.State rs m') @@ -598,14 +600,14 @@ Opaque loadind. eapply transf_function_no_overflow; eauto. destruct ros as [rf|fid]; simpl in H; monadInv H5. + (* Indirect call *) - assert (rs rf = Vptr f' Int.zero). + assert (rs rf = Vptr f' Ptrofs.zero). destruct (rs rf); try discriminate. - revert H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Int.zero). + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. generalize (code_tail_next_int _ _ _ _ NOOV CT1). intro CT2. - assert (TCA: transl_code_at_pc ge (Vptr fb (Int.add (Int.add ofs Int.one) Int.one)) fb f c false tf x). + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add (Ptrofs.add ofs Ptrofs.one) Ptrofs.one)) fb f c false tf x). econstructor; eauto. exploit return_address_offset_correct; eauto. intros; subst ra. left; econstructor; split. @@ -623,7 +625,7 @@ Opaque loadind. Simpl. rewrite <- H2. auto. + (* Direct call *) generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Int.add ofs Int.one)) fb f c false tf x). + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). econstructor; eauto. exploit return_address_offset_correct; eauto. intros; subst ra. left; econstructor; split. @@ -639,7 +641,7 @@ Opaque loadind. - (* Mtailcall *) assert (f0 = f) by congruence. subst f0. inversion AT; subst. - assert (NOOV: list_length_z tf.(fn_code) <= Int.max_unsigned). + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). eapply transf_function_no_overflow; eauto. exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]]. exploit Mem.loadv_extends. eauto. eexact H2. auto. simpl. intros [ra' [C D]]. exploit lessdef_parent_sp; eauto. intros. subst parent'. clear B. @@ -647,18 +649,18 @@ Opaque loadind. exploit Mem.free_parallel_extends; eauto. intros [m2' [E F]]. destruct ros as [rf|fid]; simpl in H; monadInv H7. + (* Indirect call *) - assert (rs rf = Vptr f' Int.zero). + assert (rs rf = Vptr f' Ptrofs.zero). destruct (rs rf); try discriminate. - revert H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Int.zero). + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. - set (rs2 := nextinstr (rs0#CTR <- (Vptr f' Int.zero))). + set (rs2 := nextinstr (rs0#CTR <- (Vptr f' Ptrofs.zero))). set (rs3 := nextinstr (rs2#GPR0 <- (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 tf - (Pmtctr x0 :: Plwz GPR0 (Cint (fn_retaddr_ofs f)) GPR1 :: Pmtlr GPR0 + (Pmtctr x0 :: Plwz GPR0 (Cint (Ptrofs.to_int (fn_retaddr_ofs f))) GPR1 :: Pmtlr GPR0 :: Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: Pbctr sig :: x) rs0 m'0 (Pbctr sig :: x) rs5 m2'). @@ -667,7 +669,7 @@ Opaque loadind. apply exec_straight_step with rs3 m'0. simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. change (rs2 GPR1) with (rs0 GPR1). rewrite <- (sp_val _ _ _ AG). - simpl. rewrite C. auto. congruence. auto. + erewrite loadv_offset_ptr by eexact C. auto. congruence. auto. apply exec_straight_step with rs4 m'0. simpl. reflexivity. reflexivity. apply exec_straight_one. @@ -678,7 +680,7 @@ Opaque loadind. (* execution *) eapply plus_right'. eapply exec_straight_exec; eauto. econstructor. - change (rs5 PC) with (Val.add (Val.add (Val.add (Val.add (rs0 PC) Vone) Vone) Vone) Vone). + change (rs5 PC) with (Val.offset_ptr (Val.offset_ptr (Val.offset_ptr (Val.offset_ptr (rs0 PC) Ptrofs.one) Ptrofs.one) Ptrofs.one) Ptrofs.one). rewrite <- H4; simpl. eauto. eapply functions_transl; eauto. eapply find_instr_tail. @@ -697,15 +699,15 @@ Hint Resolve agree_nextinstr agree_set_other: asmgen. set (rs2 := nextinstr (rs0#GPR0 <- (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)). + set (rs5 := rs4#PC <- (Vptr f' Ptrofs.zero)). assert (exec_straight tge tf - (Plwz GPR0 (Cint (fn_retaddr_ofs f)) GPR1 :: Pmtlr GPR0 + (Plwz GPR0 (Cint (Ptrofs.to_int (fn_retaddr_ofs f))) GPR1 :: Pmtlr GPR0 :: Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: Pbs fid sig :: x) rs0 m'0 (Pbs fid sig :: x) rs4 m2'). apply exec_straight_step with rs2 m'0. simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. - rewrite <- (sp_val _ _ _ AG). simpl. rewrite C. auto. congruence. auto. + rewrite <- (sp_val _ _ _ AG). erewrite loadv_offset_ptr by eexact C. auto. congruence. auto. apply exec_straight_step with rs3 m'0. simpl. reflexivity. reflexivity. apply exec_straight_one. @@ -715,7 +717,7 @@ Hint Resolve agree_nextinstr agree_set_other: asmgen. (* execution *) eapply plus_right'. eapply exec_straight_exec; eauto. econstructor. - change (rs4 PC) with (Val.add (Val.add (Val.add (rs0 PC) Vone) Vone) Vone). + change (rs4 PC) with (Val.offset_ptr (Val.offset_ptr (Val.offset_ptr (rs0 PC) Ptrofs.one) Ptrofs.one) Ptrofs.one). rewrite <- H4; simpl. eauto. eapply functions_transl; eauto. eapply find_instr_tail. @@ -824,7 +826,7 @@ Local Transparent destroyed_by_jumptable. - (* Mreturn *) assert (f0 = f) by congruence. subst f0. inversion AT; subst. - assert (NOOV: list_length_z tf.(fn_code) <= Int.max_unsigned). + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). eapply transf_function_no_overflow; eauto. rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *. exploit Mem.loadv_extends. eauto. eexact H0. auto. simpl. intros [parent' [A B]]. @@ -838,12 +840,13 @@ Local Transparent destroyed_by_jumptable. set (rs4 := nextinstr (rs3#GPR1 <- (parent_sp s))). set (rs5 := rs4#PC <- (parent_ra s)). assert (exec_straight tge tf - (Plwz GPR0 (Cint (fn_retaddr_ofs f)) GPR1 + (Plwz GPR0 (Cint (Ptrofs.to_int (fn_retaddr_ofs f))) GPR1 :: Pmtlr GPR0 :: Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: Pblr :: x) rs0 m'0 (Pblr :: x) rs4 m2'). simpl. apply exec_straight_three with rs2 m'0 rs3 m'0. - simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. rewrite C. auto. congruence. + simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. + erewrite loadv_offset_ptr by eexact C. auto. congruence. simpl. auto. simpl. change (rs3 GPR1) with (rs0 GPR1). rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. auto. @@ -853,7 +856,7 @@ Local Transparent destroyed_by_jumptable. apply plus_right' with E0 (State rs4 m2') E0. eapply exec_straight_exec; eauto. econstructor. - change (rs4 PC) with (Val.add (Val.add (Val.add (rs0 PC) Vone) Vone) Vone). + change (rs4 PC) with (Val.offset_ptr (Val.offset_ptr (Val.offset_ptr (rs0 PC) Ptrofs.one) Ptrofs.one) Ptrofs.one). rewrite <- H3. simpl. eauto. eapply functions_transl; eauto. eapply find_instr_tail. @@ -873,7 +876,7 @@ Local Transparent destroyed_by_jumptable. - (* internal function *) exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Int.max_unsigned (list_length_z x0.(fn_code))); inversion EQ1. clear EQ1. + destruct (zlt Ptrofs.max_unsigned (list_length_z x0.(fn_code))); inversion EQ1. clear EQ1. unfold store_stack in *. exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl. intros [m1' [C D]]. @@ -900,13 +903,13 @@ Local Transparent destroyed_by_jumptable. simpl. auto. auto. apply exec_straight_two with rs4 m3'. simpl. unfold store1. rewrite gpr_or_zero_not_zero. - change (rs3 GPR1) with sp. change (rs3 GPR0) with (rs0 LR). simpl. - rewrite Int.add_zero_l. simpl in P. rewrite Int.add_zero_l in P. rewrite ATLR. rewrite P. auto. congruence. + change (rs3 GPR1) with sp. change (rs3 GPR0) with (rs0 LR). + simpl const_low. rewrite ATLR. erewrite storev_offset_ptr by eexact P. auto. congruence. auto. auto. auto. left; exists (State rs5 m3'); split. eapply exec_straight_steps_1; eauto. omega. constructor. econstructor; eauto. - change (rs5 PC) with (Val.add (Val.add (Val.add (Val.add (rs0 PC) Vone) Vone) Vone) Vone). + change (rs5 PC) with (Val.offset_ptr (Val.offset_ptr (Val.offset_ptr (Val.offset_ptr (rs0 PC) Ptrofs.one) Ptrofs.one) Ptrofs.one) Ptrofs.one). rewrite ATPC. simpl. constructor; eauto. subst x; simpl in g. unfold fn_code. eapply code_tail_next_int. omega. @@ -950,12 +953,12 @@ Proof. econstructor; split. econstructor. eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Int.zero) - with (Vptr fb Int.zero). + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). econstructor; eauto. constructor. apply Mem.extends_refl. - split. auto. simpl. unfold Vzero; congruence. intros. rewrite Regmap.gi. auto. + split. auto. simpl. unfold Vnullptr; simpl; congruence. intros. rewrite Regmap.gi. auto. unfold Genv.symbol_address. rewrite (match_program_main TRANSF). rewrite symbols_preserved. diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v index aa2645f3..a7dcf41e 100644 --- a/powerpc/Asmgenproof1.v +++ b/powerpc/Asmgenproof1.v @@ -29,6 +29,8 @@ Require Import Asmgen. Require Import Conventions. Require Import Asmgenproof0. +Local Transparent Archi.ptr64. + (** * Properties of low half/high half decomposition *) Lemma low_high_u: @@ -97,7 +99,7 @@ Lemma add_zero_symbol_address: Val.add Vzero (Genv.symbol_address ge id ofs) = Genv.symbol_address ge id ofs. Proof. unfold Genv.symbol_address; intros. destruct (Genv.find_symbol ge id); auto. - simpl. rewrite Int.add_zero; auto. + simpl. rewrite Ptrofs.add_zero; auto. Qed. Lemma low_high_half_zero: @@ -147,6 +149,24 @@ Ltac Simplif := Ltac Simpl := repeat Simplif. +(** Useful properties of pointer addition *) + +Lemma loadv_offset_ptr: + forall chunk m a delta v, + Mem.loadv chunk m (Val.offset_ptr a delta) = Some v -> + Mem.loadv chunk m (Val.add a (Vint (Ptrofs.to_int delta))) = Some v. +Proof. + intros. destruct a; try discriminate H. simpl. rewrite Ptrofs.of_int_to_int by auto. assumption. +Qed. + +Lemma storev_offset_ptr: + forall chunk m a delta v m', + Mem.storev chunk m (Val.offset_ptr a delta) v = Some m' -> + Mem.storev chunk m (Val.add a (Vint (Ptrofs.to_int delta))) v = Some m'. +Proof. + intros. destruct a; try discriminate H. simpl. rewrite Ptrofs.of_int_to_int by auto. assumption. +Qed. + (** * Correctness of PowerPC constructor functions *) Section CONSTRUCTORS. @@ -425,23 +445,26 @@ Lemma accessind_load_correct: exec_instr ge fn (instr1 r1 cst r2) rs m = load1 ge chunk (inj r1) cst r2 rs m) -> (forall rs m r1 r2 r3, exec_instr ge fn (instr2 r1 r2 r3) rs m = load2 chunk (inj r1) r2 r3 rs m) -> - Mem.loadv chunk m (Val.add rs#base (Vint ofs)) = Some v -> + Mem.loadv chunk m (Val.offset_ptr rs#base ofs) = Some v -> base <> GPR0 -> inj rx <> PC -> exists rs', exec_straight ge fn (accessind instr1 instr2 base ofs rx k) rs m k rs' m /\ rs'#(inj rx) = v /\ forall r, r <> PC -> r <> inj rx -> r <> GPR0 -> rs'#r = rs#r. Proof. - intros. unfold accessind. destruct (Int.eq (high_s ofs) Int.zero). + intros. unfold accessind. set (ofs' := Ptrofs.to_int ofs) in *. + assert (LD: Mem.loadv chunk m (Val.add (rs base) (Vint ofs')) = Some v) + by (apply loadv_offset_ptr; auto). + destruct (Int.eq (high_s ofs') Int.zero). - econstructor; split. apply exec_straight_one. rewrite H. unfold load1. rewrite gpr_or_zero_not_zero by auto. simpl. - rewrite H1. eauto. unfold nextinstr. repeat Simplif. + rewrite LD. eauto. unfold nextinstr. repeat Simplif. split. unfold nextinstr. repeat Simplif. intros. repeat Simplif. -- exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [P [Q R]]]. +- exploit (loadimm_correct GPR0 ofs'); eauto. intros [rs' [P [Q R]]]. econstructor; split. eapply exec_straight_trans. eexact P. apply exec_straight_one. rewrite H0. unfold load2. rewrite Q, R by auto with asmgen. - rewrite H1. reflexivity. unfold nextinstr. repeat Simplif. + rewrite LD. reflexivity. unfold nextinstr. repeat Simplif. split. repeat Simplif. intros. repeat Simplif. Qed. @@ -449,7 +472,7 @@ Qed. Lemma loadind_correct: forall (base: ireg) ofs ty dst k (rs: regset) m v c, loadind base ofs ty dst k = OK c -> - Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v -> + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> base <> GPR0 -> exists rs', exec_straight ge fn c rs m k rs' m @@ -475,29 +498,32 @@ Lemma accessind_store_correct: exec_instr ge fn (instr1 r1 cst r2) rs m = store1 ge chunk (inj r1) cst r2 rs m) -> (forall rs m r1 r2 r3, exec_instr ge fn (instr2 r1 r2 r3) rs m = store2 chunk (inj r1) r2 r3 rs m) -> - Mem.storev chunk m (Val.add rs#base (Vint ofs)) (rs (inj rx)) = Some m' -> + Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs (inj rx)) = Some m' -> base <> GPR0 -> inj rx <> PC -> inj rx <> GPR0 -> exists rs', exec_straight ge fn (accessind instr1 instr2 base ofs rx k) rs m k rs' m' /\ forall r, r <> PC -> r <> GPR0 -> rs'#r = rs#r. Proof. - intros. unfold accessind. destruct (Int.eq (high_s ofs) Int.zero). + intros. unfold accessind. set (ofs' := Ptrofs.to_int ofs) in *. + assert (ST: Mem.storev chunk m (Val.add (rs base) (Vint ofs')) (rs (inj rx)) = Some m') + by (apply storev_offset_ptr; auto). + destruct (Int.eq (high_s ofs') Int.zero). - econstructor; split. apply exec_straight_one. rewrite H. unfold store1. rewrite gpr_or_zero_not_zero by auto. simpl. - rewrite H1. eauto. unfold nextinstr. repeat Simplif. + rewrite ST. eauto. unfold nextinstr. repeat Simplif. intros. repeat Simplif. -- exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [P [Q R]]]. +- exploit (loadimm_correct GPR0 ofs'); eauto. intros [rs' [P [Q R]]]. econstructor; split. eapply exec_straight_trans. eexact P. apply exec_straight_one. rewrite H0. unfold store2. rewrite Q. rewrite R by auto with asmgen. rewrite R by auto. - rewrite H1. reflexivity. unfold nextinstr. repeat Simplif. + rewrite ST. reflexivity. unfold nextinstr. repeat Simplif. intros. repeat Simplif. Qed. Lemma storeind_correct: forall (base: ireg) ofs ty src k (rs: regset) m m' c, storeind src base ofs ty k = OK c -> - Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' -> + Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) (rs#(preg_of src)) = Some m' -> base <> GPR0 -> exists rs', exec_straight ge fn c rs m k rs' m' @@ -822,7 +848,7 @@ Qed. Ltac TranslOpSimpl := econstructor; split; [ apply exec_straight_one; [simpl; eauto | reflexivity] - | split; intros; Simpl; fail ]. + | split; [ apply Val.lessdef_same; Simpl; fail | intros; Simpl; fail ] ]. Lemma transl_op_correct_aux: forall op args res k (rs: regset) m v c, @@ -830,9 +856,10 @@ Lemma transl_op_correct_aux: eval_operation ge (rs#GPR1) op (map rs (map preg_of args)) m = Some v -> exists rs', exec_straight ge fn c rs m k rs' m - /\ rs'#(preg_of res) = v + /\ Val.lessdef v rs'#(preg_of res) /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. Proof. + assert (SAME: forall v1 v2, v1 = v2 -> Val.lessdef v2 v1). { intros; subst; auto. } Opaque Int.eq. intros. unfold transl_op in H; destruct op; ArgsInv; simpl in H0; try (inv H0); try TranslOpSimpl. (* Omove *) @@ -841,28 +868,32 @@ Opaque Int.eq. TranslOpSimpl. (* Ointconst *) destruct (loadimm_correct x i k rs m) as [rs' [A [B C]]]. - exists rs'. auto with asmgen. + exists rs'. rewrite B. auto with asmgen. (* Oaddrsymbol *) set (v' := Genv.symbol_address ge i i0). destruct (symbol_is_small_data i i0) eqn:SD; [ | destruct (symbol_is_rel_data i i0) ]. (* small data *) Opaque Val.add. econstructor; split. apply exec_straight_one; simpl; reflexivity. - split. Simpl. rewrite small_data_area_addressing by auto. apply add_zero_symbol_address. + split. apply SAME. Simpl. rewrite small_data_area_addressing by auto. apply add_zero_symbol_address. intros; Simpl. (* relative data *) econstructor; split. eapply exec_straight_two; simpl; reflexivity. - split. Simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen. Simpl. + split. apply SAME. Simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen. Simpl. apply low_high_half_zero. intros; Simpl. (* absolute data *) econstructor; split. eapply exec_straight_two; simpl; reflexivity. - split. Simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. Simpl. + split. apply SAME. Simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. Simpl. apply low_high_half_zero. intros; Simpl. (* Oaddrstack *) - destruct (addimm_correct x GPR1 i k rs m) as [rs' [EX [RES OTH]]]; eauto with asmgen. - exists rs'; auto with asmgen. + destruct (addimm_correct x GPR1 (Ptrofs.to_int i) k rs m) as [rs' [EX [RES OTH]]]; eauto with asmgen. + exists rs'; split. auto. split; auto with asmgen. + rewrite RES. destruct (rs GPR1); simpl; auto. +Transparent Val.add. + simpl. rewrite Ptrofs.of_int_to_int; auto. +Opaque Val.add. (* Oaddimm *) destruct (addimm_correct x0 x i k rs m) as [rs' [A [B C]]]; eauto with asmgen. exists rs'; auto with asmgen. @@ -870,7 +901,7 @@ Opaque Val.add. destruct (symbol_is_small_data i i0) eqn:SD; [ | destruct (symbol_is_rel_data i i0) ]. (* small data *) econstructor; split. eapply exec_straight_two; simpl; reflexivity. - split. Simpl. rewrite (Val.add_commut (rs x)). f_equal. + split. apply SAME. Simpl. rewrite (Val.add_commut (rs x)). f_equal. rewrite small_data_area_addressing by auto. apply add_zero_symbol_address. intros; Simpl. (* relative data *) @@ -918,7 +949,8 @@ Opaque Val.add. split. rewrite D; auto with asmgen. unfold rs1; Simpl. intros. rewrite D; auto with asmgen. unfold rs1; Simpl. (* Oandimm *) - destruct (andimm_correct x0 x i k rs m) as [rs' [A [B C]]]; eauto with asmgen. + destruct (andimm_correct x0 x i k rs m) as [rs' [A [B C]]]. eauto with asmgen. + exists rs'; auto with asmgen. (* Oorimm *) destruct (orimm_correct x0 x i k rs m) as [rs' [A [B C]]]. exists rs'; auto with asmgen. @@ -933,10 +965,11 @@ Opaque Val.add. (* Oshrximm *) econstructor; split. eapply exec_straight_two; simpl; reflexivity. - split. Simpl. apply Val.shrx_carry. auto. + split. Simpl. apply SAME. apply Val.shrx_carry. auto. intros; Simpl. (* Orolm *) - destruct (rolm_correct x0 x i i0 k rs m) as [rs' [A [B C]]]; eauto with asmgen. + destruct (rolm_correct x0 x i i0 k rs m) as [rs' [A [B C]]]. eauto with asmgen. + exists rs'; auto. (* Ointoffloat *) replace v with (Val.maketotal (Val.intoffloat (rs x))). TranslOpSimpl. @@ -973,9 +1006,8 @@ Proof. exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eauto. intros [v' [A B]]. rewrite (sp_val _ _ _ H0) in A. exploit transl_op_correct_aux; eauto. intros [rs' [P [Q R]]]. - rewrite <- Q in B. exists rs'; split. eexact P. - split. apply agree_set_undef_mreg with rs; auto. + split. apply agree_set_undef_mreg with rs; auto. eapply Val.lessdef_trans; eauto. auto. Qed. @@ -987,12 +1019,12 @@ Lemma transl_memory_access_correct: eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a -> temp <> GPR0 -> (forall cst (r1: ireg) (rs1: regset) k, - Val.add (gpr_or_zero rs1 r1) (const_low ge cst) = a -> + Val.lessdef a (Val.add (gpr_or_zero rs1 r1) (const_low ge cst)) -> (forall r, r <> PC -> r <> temp -> r <> GPR0 -> rs1 r = rs r) -> exists rs', exec_straight ge fn (mk1 cst r1 :: k) rs1 m k rs' m' /\ P rs') -> (forall (r1 r2: ireg) (rs1: regset) k, - Val.add rs1#r1 rs1#r2 = a -> + Val.lessdef a (Val.add rs1#r1 rs1#r2) -> (forall r, r <> PC -> r <> temp -> r <> GPR0 -> rs1 r = rs r) -> exists rs', exec_straight ge fn (mk2 r1 r2 :: k) rs1 m k rs' m' /\ P rs') -> @@ -1023,14 +1055,14 @@ Transparent Val.add. destruct (symbol_is_small_data i i0) eqn:SISD; [ | destruct (symbol_is_rel_data i i0) ]; inv TR. (* Aglobal from small data *) apply MK1. unfold const_low. rewrite small_data_area_addressing by auto. - apply add_zero_symbol_address. + rewrite add_zero_symbol_address. auto. auto. (* Aglobal from relative data *) set (rs1 := nextinstr (rs#temp <- (Val.add Vzero (high_half ge i i0)))). set (rs2 := nextinstr (rs1#temp <- (Genv.symbol_address ge i i0))). exploit (MK1 (Cint Int.zero) temp rs2). simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen. - unfold rs2. Simpl. rewrite Val.add_commut. apply add_zero_symbol_address. + unfold rs2. Simpl. rewrite Val.add_commut. rewrite add_zero_symbol_address. auto. intros; unfold rs2, rs1; Simpl. intros [rs' [EX' AG']]. exists rs'; split. apply exec_straight_step with rs1 m; auto. @@ -1042,7 +1074,7 @@ Transparent Val.add. set (rs1 := nextinstr (rs#temp <- (Val.add Vzero (high_half ge i i0)))). exploit (MK1 (Csymbol_low i i0) temp rs1). simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen. - unfold rs1. Simpl. apply low_high_half_zero. + unfold rs1. Simpl. rewrite low_high_half_zero. auto. intros; unfold rs1; Simpl. intros [rs' [EX' AG']]. exists rs'; split. apply exec_straight_step with rs1 m; auto. @@ -1052,7 +1084,7 @@ Transparent Val.add. (* Abased from small data *) set (rs1 := nextinstr (rs#GPR0 <- (Genv.symbol_address ge i i0))). exploit (MK2 x GPR0 rs1 k). - unfold rs1; Simpl. apply Val.add_commut. + unfold rs1; Simpl. rewrite Val.add_commut. auto. intros. unfold rs1; Simpl. intros [rs' [EX' AG']]. exists rs'; split. apply exec_straight_step with rs1 m. @@ -1079,17 +1111,20 @@ Transparent Val.add. exploit (MK1 (Csymbol_low i i0) temp rs1 k). simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. unfold rs1. Simpl. - rewrite Val.add_assoc. rewrite low_high_half. apply Val.add_commut. + rewrite Val.add_assoc. rewrite low_high_half. rewrite Val.add_commut. auto. intros; unfold rs1; Simpl. intros [rs' [EX' AG']]. exists rs'. split. apply exec_straight_step with rs1 m. unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. assumption. assumption. (* Ainstack *) - destruct (Int.eq (high_s i) Int.zero); inv TR. + set (ofs := Ptrofs.to_int i) in *. + assert (L: Val.lessdef (Val.offset_ptr (rs GPR1) i) (Val.add (rs GPR1) (Vint ofs))). + { destruct (rs GPR1); simpl; auto. unfold ofs; rewrite Ptrofs.of_int_to_int; auto. } + destruct (Int.eq (high_s ofs) Int.zero); inv TR. apply MK1. simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. - set (rs1 := nextinstr (rs#temp <- (Val.add rs#GPR1 (Vint (Int.shl (high_s i) (Int.repr 16)))))). - exploit (MK1 (Cint (low_s i)) temp rs1 k). + set (rs1 := nextinstr (rs#temp <- (Val.add rs#GPR1 (Vint (Int.shl (high_s ofs) (Int.repr 16)))))). + exploit (MK1 (Cint (low_s ofs)) temp rs1 k). simpl. rewrite gpr_or_zero_not_zero; auto. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. rewrite Val.add_assoc. simpl. rewrite low_high_s. auto. @@ -1114,6 +1149,8 @@ Lemma transl_load_correct: /\ forall r, r <> PC -> r <> GPR12 -> r <> GPR0 -> r <> preg_of dst -> rs' r = rs r. Proof. intros. + assert (LD: forall v, Val.lessdef a v -> v = a). + { intros. inv H2; auto. discriminate H1. } assert (BASE: forall mk1 mk2 k' chunk' v', transl_memory_access mk1 mk2 addr args GPR12 k' = OK c -> Mem.loadv chunk' m a = Some v' -> @@ -1130,11 +1167,11 @@ Proof. { intros. eapply transl_memory_access_correct; eauto. congruence. intros. econstructor; split. apply exec_straight_one. - rewrite H4. unfold load1. rewrite H6. rewrite H3. eauto. + rewrite H4. unfold load1. apply LD in H6. rewrite H6. rewrite H3. eauto. unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso; auto with asmgen. intuition Simpl. intros. econstructor; split. apply exec_straight_one. - rewrite H5. unfold load2. rewrite H6. rewrite H3. eauto. + rewrite H5. unfold load2. apply LD in H6. rewrite H6. rewrite H3. eauto. unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso; auto with asmgen. intuition Simpl. } @@ -1144,10 +1181,10 @@ Proof. { destruct a; simpl in *; try discriminate. rewrite Mem.load_int8_signed_unsigned in H1. - destruct (Mem.load Mint8unsigned m b (Int.unsigned i)); simpl in H1; inv H1. + destruct (Mem.load Mint8unsigned m b (Ptrofs.unsigned i)); simpl in H1; inv H1. exists v0; auto. } - destruct H as [v1 [LD SG]]. clear H1. + destruct H as [v1 [LD' SG]]. clear H1. exploit BASE; eauto; erewrite ireg_of_eq by eauto; auto. intros [rs1 [A [B C]]]. econstructor; split. @@ -1180,6 +1217,8 @@ Lemma transl_store_correct: Proof. Local Transparent destroyed_by_store. intros. + assert (LD: forall v, Val.lessdef a v -> v = a). + { intros. inv H2; auto. discriminate H1. } assert (TEMP0: int_temp_for src = GPR11 \/ int_temp_for src = GPR12). unfold int_temp_for. destruct (mreg_eq src R12); auto. assert (TEMP1: int_temp_for src <> GPR0). @@ -1204,10 +1243,10 @@ Local Transparent destroyed_by_store. { intros. eapply transl_memory_access_correct; eauto. intros. econstructor; split. apply exec_straight_one. - rewrite H4. unfold store1. rewrite H6. rewrite H7; auto with asmgen. rewrite H3. eauto. auto. + rewrite H4. unfold store1. apply LD in H6. rewrite H6. rewrite H7; auto with asmgen. rewrite H3. eauto. auto. intros; Simpl. apply H7; auto. destruct TEMP0; destruct H10; congruence. intros. econstructor; split. apply exec_straight_one. - rewrite H5. unfold store2. rewrite H6. rewrite H7; auto with asmgen. rewrite H3. eauto. auto. + rewrite H5. unfold store2. apply LD in H6. rewrite H6. rewrite H7; auto with asmgen. rewrite H3. eauto. auto. intros; Simpl. apply H7; auto. destruct TEMP0; destruct H10; congruence. } destruct chunk; monadInv H. diff --git a/powerpc/ConstpropOp.vp b/powerpc/ConstpropOp.vp index 7265337d..403a7a77 100644 --- a/powerpc/ConstpropOp.vp +++ b/powerpc/ConstpropOp.vp @@ -13,15 +13,23 @@ (** Strength reduction for operators and conditions. This is the machine-dependent part of [Constprop]. *) -Require Import Coqlib. -Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Op. -Require Import Registers. +Require Import Coqlib Compopts. +Require Import AST Integers Floats. +Require Import Op Registers. Require Import ValueDomain. +(** * Converting known values to constants *) + +Definition const_for_result (a: aval) : option operation := + match a with + | I n => Some(Ointconst n) + | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None + | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None + | Ptr(Gl id ofs) => Some (Oaddrsymbol id ofs) + | Ptr(Stk ofs) => Some(Oaddrstack ofs) + | _ => None + end. + (** * Operator strength reduction *) (** We now define auxiliary functions for strength reduction of @@ -187,13 +195,13 @@ Nondetfunction addr_strength_reduction (addr: addressing) (args: list reg) (vl: list aval) := match addr, args, vl with | Aindexed2, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil => - (Aglobal symb (Int.add n1 n2), nil) + (Aglobal symb (Ptrofs.add n1 (Ptrofs.of_int n2)), nil) | Aindexed2, r1 :: r2 :: nil, I n1 :: Ptr(Gl symb n2) :: nil => - (Aglobal symb (Int.add n1 n2), nil) + (Aglobal symb (Ptrofs.add (Ptrofs.of_int n1) n2), nil) | Aindexed2, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil => - (Ainstack (Int.add n1 n2), nil) + (Ainstack (Ptrofs.add n1 (Ptrofs.of_int n2)), nil) | Aindexed2, r1 :: r2 :: nil, I n1 :: Ptr(Stk n2) :: nil => - (Ainstack (Int.add n1 n2), nil) + (Ainstack (Ptrofs.add (Ptrofs.of_int n1) n2), nil) | Aindexed2, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil => (Abased symb n1, r2 :: nil) | Aindexed2, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil => @@ -203,11 +211,11 @@ Nondetfunction addr_strength_reduction | Aindexed2, r1 :: r2 :: nil, v1 :: I n2 :: nil => (Aindexed n2, r1 :: nil) | Abased symb ofs, r1 :: nil, I n1 :: nil => - (Aglobal symb (Int.add ofs n1), nil) + (Aglobal symb (Ptrofs.add ofs (Ptrofs.of_int n1)), nil) | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil => - (Aglobal symb (Int.add n1 n), nil) + (Aglobal symb (Ptrofs.add n1 (Ptrofs.of_int n)), nil) | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => - (Ainstack (Int.add n1 n), nil) + (Ainstack (Ptrofs.add n1 (Ptrofs.of_int n)), nil) | _, _, _ => (addr, args) end. diff --git a/powerpc/ConstpropOpproof.v b/powerpc/ConstpropOpproof.v index eb68f586..bb0605ee 100644 --- a/powerpc/ConstpropOpproof.v +++ b/powerpc/ConstpropOpproof.v @@ -12,21 +12,13 @@ (** Correctness proof for operator strength reduction. *) -Require Import Coqlib. -Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import ValueDomain. +Require Import Coqlib Compopts. +Require Import Integers Floats Values Memory Globalenvs Events. +Require Import Op Registers RTL ValueDomain. Require Import ConstpropOp. +Local Transparent Archi.ptr64. + (** * Correctness of strength reduction *) (** We now show that strength reduction over operators and addressing @@ -95,6 +87,28 @@ Ltac SimplVM := | _ => idtac end. +Lemma const_for_result_correct: + forall a op v, + const_for_result a = Some op -> + vmatch bc v a -> + exists v', eval_operation ge (Vptr sp Ptrofs.zero) op nil m = Some v' /\ Val.lessdef v v'. +Proof. + unfold const_for_result; intros. + destruct a; inv H; SimplVM. +- (* integer *) + exists (Vint n); auto. +- (* float *) + destruct (generate_float_constants tt); inv H2. exists (Vfloat f); auto. +- (* single *) + destruct (generate_float_constants tt); inv H2. exists (Vsingle f); auto. +- (* pointer *) + destruct p; try discriminate; SimplVM. + + (* global *) + inv H2. exists (Genv.symbol_address ge id ofs); auto. + + (* stack *) + inv H2. exists (Vptr sp ofs); split; auto. simpl. rewrite Ptrofs.add_zero_l; auto. +Qed. + Lemma cond_strength_reduction_correct: forall cond args vl, vl = map (fun r => AE.get r ae) args -> @@ -114,7 +128,7 @@ Lemma make_cmp_base_correct: forall c args vl, vl = map (fun r => AE.get r ae) args -> let (op', args') := make_cmp_base c args vl in - exists v, eval_operation ge (Vptr sp Int.zero) op' rs##args' m = Some v + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' rs##args' m = Some v /\ Val.lessdef (Val.of_optbool (eval_condition c rs##args m)) v. Proof. intros. unfold make_cmp_base. @@ -127,7 +141,7 @@ Lemma make_cmp_correct: forall c args vl, vl = map (fun r => AE.get r ae) args -> let (op', args') := make_cmp c args vl in - exists v, eval_operation ge (Vptr sp Int.zero) op' rs##args' m = Some v + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' rs##args' m = Some v /\ Val.lessdef (Val.of_optbool (eval_condition c rs##args m)) v. Proof. intros c args vl. @@ -159,11 +173,11 @@ Qed. Lemma make_addimm_correct: forall n r, let (op, args) := make_addimm n r in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v. Proof. intros. unfold make_addimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto. + subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.add_zero; auto. rewrite Ptrofs.add_zero; auto. exists (Val.add rs#r (Vint n)); auto. Qed. @@ -171,7 +185,7 @@ Lemma make_shlimm_correct: forall n r1 r2, rs#r2 = Vint n -> let (op, args) := make_shlimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v. Proof. intros; unfold make_shlimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. @@ -185,7 +199,7 @@ Lemma make_shrimm_correct: forall n r1 r2, rs#r2 = Vint n -> let (op, args) := make_shrimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v. Proof. intros; unfold make_shrimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. @@ -199,7 +213,7 @@ Lemma make_shruimm_correct: forall n r1 r2, rs#r2 = Vint n -> let (op, args) := make_shruimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v. Proof. intros; unfold make_shruimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. @@ -213,7 +227,7 @@ Lemma make_mulimm_correct: forall n r1 r2, rs#r2 = Vint n -> let (op, args) := make_mulimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v. Proof. intros; unfold make_mulimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. @@ -232,7 +246,7 @@ Lemma make_divimm_correct: Val.divs rs#r1 rs#r2 = Some v -> rs#r2 = Vint n -> let (op, args) := make_divimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some w /\ Val.lessdef v w. + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_divimm. destruct (Int.is_power2 n) eqn:?. @@ -247,7 +261,7 @@ Lemma make_divuimm_correct: Val.divu rs#r1 rs#r2 = Some v -> rs#r2 = Vint n -> let (op, args) := make_divuimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some w /\ Val.lessdef v w. + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_divuimm. destruct (Int.is_power2 n) eqn:?. @@ -264,7 +278,7 @@ Lemma make_andimm_correct: forall n r x, vmatch bc rs#r x -> let (op, args) := make_andimm n r x in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v. Proof. intros; unfold make_andimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. @@ -289,7 +303,7 @@ Qed. Lemma make_orimm_correct: forall n r, let (op, args) := make_orimm n r in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v. Proof. intros; unfold make_orimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. @@ -302,7 +316,7 @@ Qed. Lemma make_xorimm_correct: forall n r, let (op, args) := make_xorimm n r in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v. Proof. intros; unfold make_xorimm. predSpec Int.eq Int.eq_spec n Int.zero; intros. @@ -316,7 +330,7 @@ Lemma make_mulfimm_correct: forall n r1 r2, rs#r2 = Vfloat n -> let (op, args) := make_mulfimm n r1 r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v. Proof. intros; unfold make_mulfimm. destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. @@ -329,7 +343,7 @@ Lemma make_mulfimm_correct_2: forall n r1 r2, rs#r1 = Vfloat n -> let (op, args) := make_mulfimm n r2 r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v. Proof. intros; unfold make_mulfimm. destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. @@ -343,7 +357,7 @@ Lemma make_mulfsimm_correct: forall n r1 r2, rs#r2 = Vsingle n -> let (op, args) := make_mulfsimm n r1 r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulfs rs#r1 rs#r2) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulfs rs#r1 rs#r2) v. Proof. intros; unfold make_mulfsimm. destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. @@ -356,7 +370,7 @@ Lemma make_mulfsimm_correct_2: forall n r1 r2, rs#r1 = Vsingle n -> let (op, args) := make_mulfsimm n r2 r1 r2 in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulfs rs#r1 rs#r2) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulfs rs#r1 rs#r2) v. Proof. intros; unfold make_mulfsimm. destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. @@ -370,7 +384,7 @@ Lemma make_cast8signed_correct: forall r x, vmatch bc rs#r x -> let (op, args) := make_cast8signed r x in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.sign_ext 8 rs#r) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.sign_ext 8 rs#r) v. Proof. intros; unfold make_cast8signed. destruct (vincl x (Sgn Ptop 8)) eqn:INCL. exists rs#r; split; auto. @@ -384,7 +398,7 @@ Lemma make_cast16signed_correct: forall r x, vmatch bc rs#r x -> let (op, args) := make_cast16signed r x in - exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.sign_ext 16 rs#r) v. + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v /\ Val.lessdef (Val.sign_ext 16 rs#r) v. Proof. intros; unfold make_cast16signed. destruct (vincl x (Sgn Ptop 16)) eqn:INCL. exists rs#r; split; auto. @@ -397,9 +411,9 @@ Qed. Lemma op_strength_reduction_correct: forall op args vl v, vl = map (fun r => AE.get r ae) args -> - eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v -> + eval_operation ge (Vptr sp Ptrofs.zero) op rs##args m = Some v -> let (op', args') := op_strength_reduction op args vl in - exists w, eval_operation ge (Vptr sp Int.zero) op' rs##args' m = Some w /\ Val.lessdef v w. + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op' rs##args' m = Some w /\ Val.lessdef v w. Proof. intros until v; unfold op_strength_reduction; case (op_strength_reduction_match op args vl); simpl; intros. @@ -408,7 +422,12 @@ Proof. (* cast8signed *) InvApproxRegs; SimplVM; inv H0. apply make_cast16signed_correct; auto. (* add *) - InvApproxRegs; SimplVM; inv H0. fold (Val.add (Vint n1) rs#r2). rewrite Val.add_commut. apply make_addimm_correct. + InvApproxRegs; SimplVM; inv H0. + change (let (op', args') := make_addimm n1 r2 in + exists w : val, + eval_operation ge (Vptr sp Ptrofs.zero) op' rs ## args' m = Some w /\ + Val.lessdef (Val.add (Vint n1) rs#r2) w). + rewrite Val.add_commut. apply make_addimm_correct. InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct. InvApproxRegs; SimplVM; inv H0. econstructor; split; eauto. apply Val.add_lessdef; auto. InvApproxRegs; SimplVM; inv H0. econstructor; split; eauto. rewrite Val.add_commut. apply Val.add_lessdef; auto. @@ -454,34 +473,46 @@ Proof. exists v; auto. Qed. +Remark shift_symbol_address: + forall id ofs delta, + Genv.symbol_address ge id (Ptrofs.add ofs (Ptrofs.of_int delta)) = Val.add (Genv.symbol_address ge id ofs) (Vint delta). +Proof. + intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id); auto. +Qed. + Lemma addr_strength_reduction_correct: forall addr args vl res, vl = map (fun r => AE.get r ae) args -> - eval_addressing ge (Vptr sp Int.zero) addr rs##args = Some res -> + eval_addressing ge (Vptr sp Ptrofs.zero) addr rs##args = Some res -> let (addr', args') := addr_strength_reduction addr args vl in - exists res', eval_addressing ge (Vptr sp Int.zero) addr' rs##args' = Some res' /\ Val.lessdef res res'. + exists res', eval_addressing ge (Vptr sp Ptrofs.zero) addr' rs##args' = Some res' /\ Val.lessdef res res'. Proof. intros until res. unfold addr_strength_reduction. destruct (addr_strength_reduction_match addr args vl); simpl; intros VL EA; InvApproxRegs; SimplVM; try (inv EA). -- rewrite Genv.shift_symbol_address. econstructor; split; eauto. apply Val.add_lessdef; auto. -- fold (Val.add (Vint n1) rs#r2). rewrite Int.add_commut. rewrite Genv.shift_symbol_address. rewrite Val.add_commut. - econstructor; split; eauto. apply Val.add_lessdef; auto. -- rewrite Int.add_zero_l. - change (Vptr sp (Int.add n1 n2)) with (Val.add (Vptr sp n1) (Vint n2)). +- rewrite shift_symbol_address. econstructor; split; eauto. apply Val.add_lessdef; auto. +- econstructor; split; eauto. + change (Val.lessdef (Val.add (Vint n1) rs#r2) (Genv.symbol_address ge symb (Ptrofs.add (Ptrofs.of_int n1) n2))). + rewrite Ptrofs.add_commut. rewrite shift_symbol_address. rewrite Val.add_commut. + apply Val.add_lessdef; auto. +- rewrite Ptrofs.add_zero_l. + change (Vptr sp (Ptrofs.add n1 (Ptrofs.of_int n2))) with (Val.add (Vptr sp n1) (Vint n2)). econstructor; split; eauto. apply Val.add_lessdef; auto. -- fold (Val.add (Vint n1) rs#r2). rewrite Int.add_zero_l. rewrite Int.add_commut. - change (Vptr sp (Int.add n2 n1)) with (Val.add (Vptr sp n2) (Vint n1)). - rewrite Val.add_commut. econstructor; split; eauto. apply Val.add_lessdef; auto. +- econstructor; split; eauto. + change (Val.lessdef (Val.add (Vint n1) rs#r2) (Vptr sp (Ptrofs.add Ptrofs.zero (Ptrofs.add (Ptrofs.of_int n1) n2)))). + rewrite Ptrofs.add_zero_l. rewrite Ptrofs.add_commut. + change (Val.lessdef (Val.add (Vint n1) rs#r2) (Val.add (Vptr sp n2) (Vint n1))). + rewrite Val.add_commut. apply Val.add_lessdef; auto. - econstructor; split; eauto. apply Val.add_lessdef; auto. - rewrite Val.add_commut. econstructor; split; eauto. apply Val.add_lessdef; auto. -- fold (Val.add (Vint n1) rs#r2). - rewrite Val.add_commut. econstructor; split; eauto. - econstructor; split; eauto. -- rewrite Genv.shift_symbol_address. econstructor; split; eauto. -- rewrite Genv.shift_symbol_address. econstructor; split; eauto. apply Val.add_lessdef; auto. -- rewrite Int.add_zero_l. - change (Vptr sp (Int.add n1 n)) with (Val.add (Vptr sp n1) (Vint n)). + change (Val.lessdef (Val.add (Vint n1) rs#r2) (Val.add rs#r2 (Vint n1))). + rewrite Val.add_commut. auto. +- econstructor; split; eauto. +- rewrite shift_symbol_address. econstructor; split; eauto. +- rewrite shift_symbol_address. econstructor; split; eauto. apply Val.add_lessdef; auto. +- rewrite Ptrofs.add_zero_l. + change (Vptr sp (Ptrofs.add n1 (Ptrofs.of_int n))) with (Val.add (Vptr sp n1) (Vint n)). econstructor; split; eauto. apply Val.add_lessdef; auto. - exists res; auto. Qed. diff --git a/powerpc/Conventions1.v b/powerpc/Conventions1.v index 1605de73..b83ab6da 100644 --- a/powerpc/Conventions1.v +++ b/powerpc/Conventions1.v @@ -61,6 +61,17 @@ Definition destroyed_at_call := Definition dummy_int_reg := R3. (**r Used in [Coloring]. *) Definition dummy_float_reg := F0. (**r Used in [Coloring]. *) +Definition is_float_reg (r: mreg): bool := + match r with + | R3 | R4 | R5 | R6 | R7 | R8 | R9 | R10 | R11 | R12 + | R14 | R15 | R16 | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24 + | R25 | R26 | R27 | R28 | R29 | R30 | R31 => false + | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 + | F8 | F9 | F10 | F11 | F12 | F13 + | F14 | F15 | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23 + | F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31 => true + end. + (** * Function calling conventions *) (** The functions in this section determine the locations (machine registers @@ -118,11 +129,22 @@ Lemma loc_result_pair: forall sg, match loc_result sg with | One _ => True - | Twolong r1 r2 => r1 <> r2 /\ sg.(sig_res) = Some Tlong /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true + | Twolong r1 r2 => + r1 <> r2 /\ sg.(sig_res) = Some Tlong + /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true + /\ Archi.splitlong = true end. Proof. intros; unfold loc_result; destruct (sig_res sg) as [[]|]; auto. - simpl; destruct Archi.ppc64; intuition congruence. + simpl; intuition congruence. +Qed. + +(** The location of the result depends only on the result part of the signature *) + +Lemma loc_result_exten: + forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2. +Proof. + intros. unfold loc_result. rewrite H; auto. Qed. (** ** Location of function arguments *) diff --git a/powerpc/NeedOp.v b/powerpc/NeedOp.v index 4d8c32bd..956b5d43 100644 --- a/powerpc/NeedOp.v +++ b/powerpc/NeedOp.v @@ -108,11 +108,11 @@ Qed. Lemma needs_of_operation_sound: forall op args v nv args', - eval_operation ge (Vptr sp Int.zero) op args m = Some v -> + eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v -> vagree_list args args' (needs_of_operation op nv) -> nv <> Nothing -> exists v', - eval_operation ge (Vptr sp Int.zero) op args' m' = Some v' + eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v' /\ vagree v v' nv. Proof. unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail); @@ -147,7 +147,7 @@ Qed. Lemma operation_is_redundant_sound: forall op nv arg1 args v arg1' args', operation_is_redundant op nv = true -> - eval_operation ge (Vptr sp Int.zero) op (arg1 :: args) m = Some v -> + eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m = Some v -> vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) -> vagree v arg1' nv. Proof. diff --git a/powerpc/Op.v b/powerpc/Op.v index c8028557..d59afd97 100644 --- a/powerpc/Op.v +++ b/powerpc/Op.v @@ -34,6 +34,7 @@ Require Import Globalenvs. Require Import Events. Set Implicit Arguments. +Local Transparent Archi.ptr64. (** Conditions (boolean-valued operators). *) @@ -55,14 +56,14 @@ Inductive operation : Type := | Ointconst: int -> operation (**r [rd] is set to the given integer constant *) | Ofloatconst: float -> operation (**r [rd] is set to the given float constant *) | Osingleconst: float32 -> 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 *) + | Oaddrsymbol: ident -> ptrofs -> operation (**r [rd] is set to the the address of the symbol plus the offset *) + | Oaddrstack: ptrofs -> 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] *) | Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *) | Oadd: operation (**r [rd = r1 + r2] *) | Oaddimm: int -> operation (**r [rd = r1 + n] *) - | Oaddsymbol: ident -> int -> operation (**r [rd = addr(id + ofs) + r1] *) + | Oaddsymbol: ident -> ptrofs -> operation (**r [rd = addr(id + ofs) + r1] *) | Osub: operation (**r [rd = r1 - r2] *) | Osubimm: int -> operation (**r [rd = n - r1] *) | Omul: operation (**r [rd = r1 * r2] *) @@ -124,9 +125,9 @@ Inductive operation : Type := Inductive addressing: Type := | 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] *) + | Aglobal: ident -> ptrofs -> addressing (**r Address is [symbol + offset] *) + | Abased: ident -> ptrofs -> addressing (**r Address is [symbol + offset + r1] *) + | Ainstack: ptrofs -> addressing. (**r Address is [stack_pointer + offset] *) (** Comparison functions (used in module [CSE]). *) @@ -140,17 +141,15 @@ Defined. Definition eq_operation (x y: operation): {x=y} + {x<>y}. Proof. - generalize Int.eq_dec; intro. + generalize Int.eq_dec Ptrofs.eq_dec ident_eq; intro. generalize Float.eq_dec Float32.eq_dec; intros. - assert (forall (x y: ident), {x=y}+{x<>y}). exact peq. generalize eq_condition; intro. decide equality. Defined. 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. + generalize Int.eq_dec Ptrofs.eq_dec ident_eq; intro. decide equality. Defined. @@ -185,7 +184,7 @@ Definition eval_operation | Ofloatconst n, nil => Some (Vfloat n) | Osingleconst n, nil => Some (Vsingle n) | Oaddrsymbol s ofs, nil => Some (Genv.symbol_address genv s ofs) - | Oaddrstack ofs, nil => Some (Val.add sp (Vint ofs)) + | Oaddrstack ofs, nil => Some (Val.offset_ptr sp ofs) | Ocast8signed, v1::nil => Some (Val.sign_ext 8 v1) | Ocast16signed, v1::nil => Some (Val.sign_ext 16 v1) | Oadd, v1::v2::nil => Some (Val.add v1 v2) @@ -253,10 +252,24 @@ Definition eval_addressing | Aindexed2, v1::v2::nil => Some (Val.add v1 v2) | Aglobal s ofs, nil => Some (Genv.symbol_address genv s ofs) | Abased s ofs, v1::nil => Some (Val.add (Genv.symbol_address genv s ofs) v1) - | Ainstack ofs, nil => Some(Val.add sp (Vint ofs)) + | Ainstack ofs, nil => Some(Val.offset_ptr sp ofs) | _, _ => None end. +Remark eval_addressing_Ainstack: + forall (F V: Type) (genv: Genv.t F V) sp ofs, + eval_addressing genv sp (Ainstack ofs) nil = Some (Val.offset_ptr sp ofs). +Proof. + intros. reflexivity. +Qed. + +Remark eval_addressing_Ainstack_inv: + forall (F V: Type) (genv: Genv.t F V) sp ofs vl v, + eval_addressing genv sp (Ainstack ofs) vl = Some v -> vl = nil /\ v = Val.offset_ptr sp ofs. +Proof. + unfold eval_addressing; intros; destruct vl; inv H; auto. +Qed. + Ltac FuncInv := match goal with | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => @@ -371,7 +384,7 @@ Lemma type_of_operation_sound: op <> Omove -> eval_operation genv sp op vl m = Some v -> Val.has_type v (snd (type_of_operation op)). -Proof with (try exact I). +Proof with (try exact I; try reflexivity). intros. destruct op; simpl in H0; FuncInv; subst; simpl. congruence. @@ -496,15 +509,15 @@ Qed. (** Shifting stack-relative references. This is used in [Stacking]. *) -Definition shift_stack_addressing (delta: int) (addr: addressing) := +Definition shift_stack_addressing (delta: Z) (addr: addressing) := match addr with - | Ainstack ofs => Ainstack (Int.add delta ofs) + | Ainstack ofs => Ainstack (Ptrofs.add (Ptrofs.repr delta) ofs) | _ => addr end. -Definition shift_stack_operation (delta: int) (op: operation) := +Definition shift_stack_operation (delta: Z) (op: operation) := match op with - | Oaddrstack ofs => Oaddrstack (Int.add delta ofs) + | Oaddrstack ofs => Oaddrstack (Ptrofs.add (Ptrofs.repr delta) ofs) | _ => op end. @@ -522,47 +535,50 @@ Qed. Lemma eval_shift_stack_addressing: forall F V (ge: Genv.t F V) sp addr vl delta, - eval_addressing ge sp (shift_stack_addressing delta addr) vl = - eval_addressing ge (Val.add sp (Vint delta)) addr vl. + eval_addressing ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl = + eval_addressing ge (Vptr sp (Ptrofs.repr delta)) addr vl. Proof. intros. destruct addr; simpl; auto. - rewrite Val.add_assoc. simpl. auto. + rewrite Ptrofs.add_zero_l; auto. Qed. Lemma eval_shift_stack_operation: forall F V (ge: Genv.t F V) sp op vl m delta, - eval_operation ge sp (shift_stack_operation delta op) vl m = - eval_operation ge (Val.add sp (Vint delta)) op vl m. + eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m = + eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m. Proof. intros. destruct op; simpl; auto. - rewrite Val.add_assoc. simpl. auto. + rewrite Ptrofs.add_zero_l; auto. Qed. (** Offset an addressing mode [addr] by a quantity [delta], so that it designates the pointer [delta] bytes past the pointer designated by [addr]. May be undefined, in which case [None] is returned. *) -Definition offset_addressing (addr: addressing) (delta: int) : option addressing := +Definition offset_addressing (addr: addressing) (delta: Z) : option addressing := match addr with - | Aindexed n => Some(Aindexed (Int.add n delta)) + | Aindexed n => Some(Aindexed (Int.add n (Int.repr delta))) | Aindexed2 => None - | Aglobal s n => Some(Aglobal s (Int.add n delta)) - | Abased s n => Some(Abased s (Int.add n delta)) - | Ainstack n => Some(Ainstack (Int.add n delta)) + | Aglobal s n => Some(Aglobal s (Ptrofs.add n (Ptrofs.repr delta))) + | Abased s n => Some(Abased s (Ptrofs.add n (Ptrofs.repr delta))) + | Ainstack n => Some(Ainstack (Ptrofs.add n (Ptrofs.repr delta))) end. Lemma eval_offset_addressing: forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v, offset_addressing addr delta = Some addr' -> eval_addressing ge sp addr args = Some v -> - eval_addressing ge sp addr' args = Some(Val.add v (Vint delta)). + eval_addressing ge sp addr' args = Some(Val.add v (Vint (Int.repr delta))). Proof. - intros. destruct addr; simpl in H; inv H; simpl in *; FuncInv; subst. - rewrite Val.add_assoc; auto. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); auto. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); auto. - rewrite Val.add_assoc. rewrite Val.add_permut. rewrite Val.add_commut. auto. - rewrite Val.add_assoc. auto. + intros. + assert (D: Ptrofs.repr delta = Ptrofs.of_int (Int.repr delta)) by (symmetry; auto with ptrofs). + destruct addr; simpl in H; inv H; simpl in *; FuncInv; subst. +- rewrite Val.add_assoc; auto. +- unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); auto. rewrite D; auto. +- unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); auto. + rewrite Val.add_assoc. rewrite Val.add_permut. rewrite Val.add_commut. + simpl. rewrite D. auto. +- destruct sp; simpl; auto. rewrite Ptrofs.add_assoc, D. auto. Qed. (** Operations that are so cheap to recompute that CSE should not factor them out. *) @@ -662,30 +678,30 @@ Variable m2: mem. Hypothesis valid_pointer_inj: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Hypothesis weak_valid_pointer_inj: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Hypothesis weak_valid_pointer_no_overflow: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. Hypothesis valid_different_pointers_inj: forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, b1 <> b2 -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> f b1 = Some (b1', delta1) -> f b2 = Some (b2', delta2) -> b1' <> b2' \/ - Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)). + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). Ltac InvInject := match goal with @@ -740,16 +756,13 @@ Lemma eval_operation_inj: Proof. intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. apply GL; simpl; auto. - apply Values.Val.add_inject; auto. + apply Val.offset_ptr_inject; auto. inv H4; simpl; auto. inv H4; simpl; auto. - apply Values.Val.add_inject; auto. - apply Values.Val.add_inject; auto. - apply Values.Val.add_inject; auto. apply GL; simpl; auto. - inv H4; inv H2; simpl; auto. econstructor; eauto. - rewrite Int.sub_add_l. auto. - destruct (eq_block b1 b0); auto. subst. rewrite H1 in H0. inv H0. rewrite dec_eq_true. - rewrite Int.sub_shifted. auto. + apply Val.add_inject; auto. + apply Val.add_inject; auto. + apply Val.add_inject; auto. apply GL; simpl; auto. + apply Val.sub_inject; auto. inv H4; auto. inv H4; inv H2; simpl; auto. inv H4; simpl; auto. @@ -820,9 +833,9 @@ Lemma eval_addressing_inj: exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. Proof. intros. destruct addr; simpl in H2; simpl; FuncInv; InvInject; TrivialExists; - auto using Values.Val.add_inject. + auto using Val.add_inject, Val.offset_ptr_inject. apply H; simpl; auto. - apply Values.Val.add_inject; auto. apply H; simpl; auto. + apply Val.add_inject; auto. apply H; simpl; auto. Qed. End EVAL_COMPAT. @@ -838,40 +851,40 @@ Remark valid_pointer_extends: forall m1 m2, Mem.extends m1 m2 -> forall b1 ofs b2 delta, Some(b1, 0) = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Proof. - intros. inv H0. rewrite Int.add_zero. eapply Mem.valid_pointer_extends; eauto. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.valid_pointer_extends; eauto. Qed. Remark weak_valid_pointer_extends: forall m1 m2, Mem.extends m1 m2 -> forall b1 ofs b2 delta, Some(b1, 0) = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. Proof. - intros. inv H0. rewrite Int.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. Qed. Remark weak_valid_pointer_no_overflow_extends: forall m1 b1 ofs b2 delta, Some(b1, 0) = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. Proof. - intros. inv H. rewrite Zplus_0_r. apply Int.unsigned_range_2. + intros. inv H. rewrite Zplus_0_r. apply Ptrofs.unsigned_range_2. Qed. Remark valid_different_pointers_extends: forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, b1 <> b2 -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> Some(b1, 0) = Some (b1', delta1) -> Some(b2, 0) = Some (b2', delta2) -> b1' <> b2' \/ - Int.unsigned(Int.add ofs1 (Int.repr delta1)) <> Int.unsigned(Int.add ofs2 (Int.repr delta2)). + Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)). Proof. intros. inv H2; inv H3. auto. Qed. @@ -950,7 +963,7 @@ Remark symbol_address_inject: Proof. intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto. exploit (proj1 globals); eauto. intros. - econstructor; eauto. rewrite Int.add_zero; auto. + econstructor; eauto. rewrite Ptrofs.add_zero; auto. Qed. Lemma eval_condition_inject: @@ -970,34 +983,36 @@ Qed. Lemma eval_addressing_inject: forall addr vl1 vl2 v1, Val.inject_list f vl1 vl2 -> - eval_addressing genv (Vptr sp1 Int.zero) addr vl1 = Some v1 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 -> exists v2, - eval_addressing genv (Vptr sp2 Int.zero) (shift_stack_addressing (Int.repr delta) addr) vl2 = Some v2 + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = Some v2 /\ Val.inject f v1 v2. Proof. intros. - rewrite eval_shift_stack_addressing. simpl. - eapply eval_addressing_inj with (sp1 := Vptr sp1 Int.zero); eauto. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj with (sp1 := Vptr sp1 Ptrofs.zero); eauto. intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. Qed. Lemma eval_operation_inject: forall op vl1 vl2 v1 m1 m2, Val.inject_list f vl1 vl2 -> Mem.inject f m1 m2 -> - eval_operation genv (Vptr sp1 Int.zero) op vl1 m1 = Some v1 -> + eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 -> exists v2, - eval_operation genv (Vptr sp2 Int.zero) (shift_stack_operation (Int.repr delta) op) vl2 m2 = Some v2 + eval_operation genv (Vptr sp2 Ptrofs.zero) (shift_stack_operation delta op) vl2 m2 = Some v2 /\ Val.inject f v1 v2. Proof. intros. rewrite eval_shift_stack_operation. simpl. - eapply eval_operation_inj with (sp1 := Vptr sp1 Int.zero) (m1 := m1); eauto. + eapply eval_operation_inj with (sp1 := Vptr sp1 Ptrofs.zero) (m1 := m1); eauto. intros; eapply Mem.valid_pointer_inject_val; eauto. intros; eapply Mem.weak_valid_pointer_inject_val; eauto. intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. intros; eapply Mem.different_pointers_inject; eauto. intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. Qed. End EVAL_INJECT. diff --git a/powerpc/SelectLong.vp b/powerpc/SelectLong.vp new file mode 100644 index 00000000..cc7a38f6 --- /dev/null +++ b/powerpc/SelectLong.vp @@ -0,0 +1,21 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for 64-bit integer operations *) + +Require Import Coqlib. +Require Import Compopts. +Require Import AST Integers Floats. +Require Import Op CminorSel. +Require Import SelectOp SplitLong. + +(** This file is empty because we use the default implementation provided in [SplitLong]. *) diff --git a/powerpc/SelectLongproof.v b/powerpc/SelectLongproof.v new file mode 100644 index 00000000..a82c082c --- /dev/null +++ b/powerpc/SelectLongproof.v @@ -0,0 +1,22 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for 64-bit integer operations *) + +Require Import String Coqlib Maps Integers Floats Errors. +Require Archi. +Require Import AST Values Memory Globalenvs Events. +Require Import Cminor Op CminorSel. +Require Import SelectOp SelectOpproof SplitLong SplitLongproof. +Require Import SelectLong. + +(** This file is empty because we use the default implementation provided in [SplitLong]. *) diff --git a/powerpc/SelectOp.vp b/powerpc/SelectOp.vp index a1fcecc7..79f05295 100644 --- a/powerpc/SelectOp.vp +++ b/powerpc/SelectOp.vp @@ -48,10 +48,10 @@ Open Local Scope cminorsel_scope. (** ** Constants **) -Definition addrsymbol (id: ident) (ofs: int) := +Definition addrsymbol (id: ident) (ofs: ptrofs) := Eop (Oaddrsymbol id ofs) Enil. -Definition addrstack (ofs: int) := +Definition addrstack (ofs: ptrofs) := Eop (Oaddrstack ofs) Enil. (** ** Integer logical negation *) @@ -78,17 +78,17 @@ Nondetfunction 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 (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil + | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) - | Eop (Oaddsymbol s m) (t ::: Enil) => Eop (Oaddsymbol s (Int.add n m)) (t ::: Enil) + | Eop (Oaddsymbol s m) (t ::: Enil) => Eop (Oaddsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) (t ::: Enil) | _ => Eop (Oaddimm n) (e ::: Enil) end. -Nondetfunction addsymbol (s: ident) (ofs: int) (e: expr) := +Nondetfunction addsymbol (s: ident) (ofs: ptrofs) (e: expr) := match e with - | Eop (Ointconst n) Enil => Eop (Oaddrsymbol s (Int.add ofs n)) Enil - | Eop (Oaddimm n) (t ::: Enil) => Eop (Oaddsymbol s (Int.add ofs n)) (t ::: Enil) + | Eop (Ointconst n) Enil => Eop (Oaddrsymbol s (Ptrofs.add ofs (Ptrofs.of_int n))) Enil + | Eop (Oaddimm n) (t ::: Enil) => Eop (Oaddsymbol s (Ptrofs.add ofs (Ptrofs.of_int n))) (t ::: Enil) | _ => Eop (Oaddsymbol s ofs) (e ::: Enil) end. @@ -107,9 +107,9 @@ Nondetfunction add (e1: expr) (e2: expr) := | Eop (Oaddimm n1) (t1:::Enil), t2 => addimm n1 (Eop Oadd (t1:::t2:::Enil)) | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => - Eop Oadd (Eop (Oaddrstack (Int.add n1 n2)) Enil ::: t2 ::: Enil) + Eop Oadd (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int n2))) Enil ::: t2 ::: Enil) | Eop (Oaddsymbol s ofs) (t1:::Enil), Eop (Oaddimm n) (t2:::Enil) => - addsymbol s (Int.add ofs n) (Eop Oadd (t1:::t2:::Enil)) + addsymbol s (Ptrofs.add ofs (Ptrofs.of_int n)) (Eop Oadd (t1:::t2:::Enil)) | Eop (Oaddsymbol s ofs) (t1:::Enil), t2 => addsymbol s ofs (Eop Oadd (t1:::t2:::Enil)) | t1, Eop (Oaddimm n2) (t2:::Enil) => diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v index f93b93e5..e31e847a 100644 --- a/powerpc/SelectOpproof.v +++ b/powerpc/SelectOpproof.v @@ -27,6 +27,7 @@ Require Import CminorSel. Require Import SelectOp. Open Local Scope cminorsel_scope. +Local Transparent Archi.ptr64. (** * Useful lemmas and tactics *) @@ -124,7 +125,7 @@ Qed. Theorem eval_addrstack: forall le ofs, - exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.add sp (Vint ofs)) v. + exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.offset_ptr sp ofs) v. Proof. intros. unfold addrstack. econstructor; split. EvalOp. simpl; eauto. @@ -154,19 +155,26 @@ Proof. TrivialExists. Qed. +Remark shift_symbol_address: + forall id ofs delta, + Genv.symbol_address ge id (Ptrofs.add ofs (Ptrofs.of_int delta)) = Val.add (Genv.symbol_address ge id ofs) (Vint delta). +Proof. + intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id); auto. +Qed. + Theorem eval_addimm: forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)). Proof. red; unfold addimm; intros until x. predSpec Int.eq Int.eq_spec n Int.zero. subst n. intros. exists x; split; auto. - destruct x; simpl; auto. rewrite Int.add_zero. auto. rewrite Int.add_zero. auto. + destruct x; simpl; auto. rewrite Int.add_zero. auto. rewrite Ptrofs.add_zero. auto. case (addimm_match a); intros; InvEval; simpl; TrivialExists; simpl. rewrite Int.add_commut. auto. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. rewrite Int.add_commut; auto. - rewrite Val.add_assoc. rewrite Int.add_commut. auto. + unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. rewrite Ptrofs.add_commut; auto. + destruct sp; simpl; auto. rewrite Ptrofs.add_assoc. do 3 f_equal. apply Ptrofs.add_commut. subst. rewrite Val.add_assoc. rewrite Int.add_commut. auto. - subst. rewrite Int.add_commut. rewrite Genv.shift_symbol_address. rewrite ! Val.add_assoc. f_equal. f_equal. apply Val.add_commut. + subst. rewrite Ptrofs.add_commut. rewrite shift_symbol_address. rewrite ! Val.add_assoc. f_equal. f_equal. apply Val.add_commut. Qed. Theorem eval_addsymbol: @@ -174,8 +182,8 @@ Theorem eval_addsymbol: Proof. red; unfold addsymbol; intros until x. case (addsymbol_match a); intros; InvEval; simpl; TrivialExists; simpl. - rewrite Genv.shift_symbol_address. auto. - rewrite Genv.shift_symbol_address. subst x. rewrite Val.add_assoc. f_equal. f_equal. + rewrite shift_symbol_address. auto. + rewrite shift_symbol_address. subst x. rewrite Val.add_assoc. f_equal. f_equal. apply Val.add_commut. Qed. @@ -199,12 +207,12 @@ Proof. repeat rewrite Val.add_assoc. decEq. apply Val.add_commut. - subst. TrivialExists. econstructor. EvalOp. simpl. reflexivity. econstructor. eauto. constructor. - simpl. repeat rewrite Val.add_assoc. decEq; decEq. - rewrite Val.add_commut. rewrite Val.add_permut. auto. + simpl. rewrite Val.add_permut, Val.add_commut. do 2 f_equal. + destruct sp; simpl; auto. rewrite Ptrofs.add_assoc; auto. - replace (Val.add x y) with - (Val.add (Genv.symbol_address ge s (Int.add ofs n)) (Val.add v1 v0)). + (Val.add (Genv.symbol_address ge s (Ptrofs.add ofs (Ptrofs.of_int n))) (Val.add v1 v0)). apply eval_addsymbol; auto. EvalOp. - subst. rewrite Genv.shift_symbol_address. rewrite ! Val.add_assoc. f_equal. + subst. rewrite shift_symbol_address. rewrite ! Val.add_assoc. f_equal. rewrite Val.add_permut. f_equal. apply Val.add_commut. - subst. rewrite Val.add_assoc. apply eval_addsymbol. EvalOp. - subst. rewrite <- Val.add_assoc. apply eval_addimm. EvalOp. @@ -1000,9 +1008,9 @@ Proof. exists (v1 :: v0 :: nil). split. eauto with evalexpr. simpl. congruence. exists (Vptr b ofs :: nil). split. constructor. EvalOp. simpl; congruence. constructor. - simpl. rewrite Int.add_zero. auto. + simpl. rewrite Ptrofs.add_zero. auto. exists (v :: nil). split. eauto with evalexpr. subst v. simpl. - rewrite Int.add_zero. auto. + rewrite Ptrofs.add_zero. auto. Qed. Theorem eval_builtin_arg: diff --git a/powerpc/ValueAOp.v b/powerpc/ValueAOp.v index fe5a0792..8081f557 100644 --- a/powerpc/ValueAOp.v +++ b/powerpc/ValueAOp.v @@ -156,18 +156,18 @@ Ltac InvHyps := Theorem eval_static_addressing_sound: forall addr vargs vres aargs, - eval_addressing ge (Vptr sp Int.zero) addr vargs = Some vres -> + eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> list_forall2 (vmatch bc) vargs aargs -> vmatch bc vres (eval_static_addressing addr aargs). Proof. unfold eval_addressing, eval_static_addressing; intros; destruct addr; InvHyps; eauto with va. - rewrite Int.add_zero_l; auto with va. + rewrite Ptrofs.add_zero_l; auto with va. Qed. Theorem eval_static_operation_sound: forall op vargs m vres aargs, - eval_operation ge (Vptr sp Int.zero) op vargs m = Some vres -> + eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> list_forall2 (vmatch bc) vargs aargs -> vmatch bc vres (eval_static_operation op aargs). Proof. @@ -175,7 +175,7 @@ Proof. destruct op; InvHyps; eauto with va. destruct (propagate_float_constants tt); constructor. destruct (propagate_float_constants tt); constructor. - rewrite Int.add_zero_l; eauto with va. + rewrite Ptrofs.add_zero_l; eauto with va. fold (Val.sub (Vint i) a1). auto with va. apply floatofwords_sound; auto. apply of_optbool_sound. eapply eval_static_condition_sound; eauto. diff --git a/runtime/Makefile b/runtime/Makefile index c01ef38d..641c9fdc 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -1,11 +1,27 @@ include ../Makefile.config CFLAGS=-O1 -g -Wall + +ifeq ($(ARCH),x86) +ifeq ($(MODEL),64) +ARCH=x86_64 +else +ARCH=x86_32 +endif +endif + +ifeq ($(ARCH),x86_64) +OBJS=i64_dtou.o i64_utod.o i64_utof.o vararg.o +else OBJS=i64_dtos.o i64_dtou.o i64_sar.o i64_sdiv.o i64_shl.o \ i64_shr.o i64_smod.o i64_stod.o i64_stof.o \ i64_udivmod.o i64_udiv.o i64_umod.o i64_utod.o i64_utof.o \ + i64_smulh.o i64_umulh.o \ vararg.o +endif + LIB=libcompcert.a + INCLUDES=include/float.h include/stdarg.h include/stdbool.h \ include/stddef.h include/varargs.h include/stdalign.h \ include/stdnoreturn.h diff --git a/runtime/arm/i64_smulh.S b/runtime/arm/i64_smulh.S new file mode 100644 index 00000000..476f51ce --- /dev/null +++ b/runtime/arm/i64_smulh.S @@ -0,0 +1,77 @@ +@ ***************************************************************** +@ +@ The Compcert verified compiler +@ +@ Xavier Leroy, INRIA Paris +@ +@ Copyright (c) 2016 Institut National de Recherche en Informatique et +@ en Automatique. +@ +@ Redistribution and use in source and binary forms, with or without +@ modification, are permitted provided that the following conditions are met: +@ * Redistributions of source code must retain the above copyright +@ notice, this list of conditions and the following disclaimer. +@ * Redistributions in binary form must reproduce the above copyright +@ notice, this list of conditions and the following disclaimer in the +@ documentation and/or other materials provided with the distribution. +@ * Neither the name of the <organization> nor the +@ names of its contributors may be used to endorse or promote products +@ derived from this software without specific prior written permission. +@ +@ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +@ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +@ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +@ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +@ HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +@ EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +@ PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +@ PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +@ LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +@ NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +@ +@ ********************************************************************* + +@ Helper functions for 64-bit integer arithmetic. ARM version. + +#include "sysdeps.h" + +@@@ Multiply-high signed + +@ Hacker's Delight section 8.3: +@ - compute high 64 bits of the unsigned product X * Y (see i64_umulh.S) +@ - subtract X if Y < 0 +@ - subtract Y if X < 0 + +FUNCTION(__i64_smulh) + push {r4, r5, r6, r7} +@@@ r7:r6 accumulate bits 95-32 of the full product + umull r4, r6, Reg0LO, Reg1LO @ r6 = high half of XL.YL product + umull r4, r5, Reg0LO, Reg1HI @ r5:r4 = product XL.YH + adds r6, r6, r4 + ADC r7, r5, #0 @ no carry out + umull r4, r5, Reg0HI, Reg1LO @ r5:r4 = product XH.YL + adds r6, r6, r4 + adcs r7, r7, r5 @ carry out is possible +@@@ r6:r7 accumulate bits 127-64 of the full product + mov r6, #0 + ADC r6, r6, #0 @ put carry out in bits 127-96 + umull r4, r5, Reg0HI, Reg1HI @ r5:r4 = product XH.YH + adds r7, r7, r4 + ADC r6, r6, r5 +@@@ subtract X if Y < 0 + cmp Reg1HI, #0 + bge 1f + subs r7, r7, Reg0LO + sbcs r6, r6, Reg0HI +@@@ subtract Y if X < 0 +1: cmp Reg0HI, #0 + bge 2f + subs r7, r7, Reg1LO + sbcs r6, r6, Reg1HI +@@@ return result in Reg0 pair +2: mov Reg0LO, r7 + mov Reg0HI, r6 + pop {r4, r5, r6, r7} + bx lr +ENDFUNCTION(__i64_smulh) diff --git a/runtime/arm/i64_umulh.S b/runtime/arm/i64_umulh.S new file mode 100644 index 00000000..c14f0c6b --- /dev/null +++ b/runtime/arm/i64_umulh.S @@ -0,0 +1,61 @@ +@ ***************************************************************** +@ +@ The Compcert verified compiler +@ +@ Xavier Leroy, INRIA Paris +@ +@ Copyright (c) 2016 Institut National de Recherche en Informatique et +@ en Automatique. +@ +@ Redistribution and use in source and binary forms, with or without +@ modification, are permitted provided that the following conditions are met: +@ * Redistributions of source code must retain the above copyright +@ notice, this list of conditions and the following disclaimer. +@ * Redistributions in binary form must reproduce the above copyright +@ notice, this list of conditions and the following disclaimer in the +@ documentation and/or other materials provided with the distribution. +@ * Neither the name of the <organization> nor the +@ names of its contributors may be used to endorse or promote products +@ derived from this software without specific prior written permission. +@ +@ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +@ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +@ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +@ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +@ HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +@ EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +@ PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +@ PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +@ LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +@ NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +@ +@ ********************************************************************* + +@ Helper functions for 64-bit integer arithmetic. ARM version. + +#include "sysdeps.h" + +@@@ Multiply-high unsigned + +@ X * Y = 2^64 XH.YH + 2^32 (XH.YL + XL.YH) + XL.YL + +FUNCTION(__i64_umulh) + push {r4, r5, r6, r7} +@@@ r7:r6 accumulate bits 95-32 of the full product + umull r4, r6, Reg0LO, Reg1LO @ r6 = high half of XL.YL product + umull r4, r5, Reg0LO, Reg1HI @ r5:r4 = product XL.YH + adds r6, r6, r4 + ADC r7, r5, #0 @ no carry out + umull r4, r5, Reg0HI, Reg1LO @ r5:r4 = product XH.YL + adds r6, r6, r4 + adcs r7, r7, r5 @ carry out is possible +@@@ r6:r7 accumulate bits 127-64 of the full product + mov r6, #0 + ADC r6, r6, #0 @ put carry out in bits 127-96 + umull r4, r5, Reg0HI, Reg1HI @ r5:r4 = product XH.YH + adds Reg0LO, r7, r4 + ADC Reg0HI, r6, r5 + pop {r4, r5, r6, r7} + bx lr +ENDFUNCTION(__i64_umulh) diff --git a/runtime/arm/sysdeps.h b/runtime/arm/sysdeps.h index fd4ea61d..ae59f977 100644 --- a/runtime/arm/sysdeps.h +++ b/runtime/arm/sysdeps.h @@ -70,6 +70,7 @@ f: #define THUMB_S(x) x #endif +#define ADC THUMB_S(adc) #define ADD THUMB_S(add) #define AND THUMB_S(and) #define ASR THUMB_S(asr) diff --git a/runtime/c/i64.h b/runtime/c/i64.h index dd584533..a75214fe 100644 --- a/runtime/c/i64.h +++ b/runtime/c/i64.h @@ -41,3 +41,5 @@ extern signed long long __i64_sar(signed long long x, int amount); extern unsigned long long __i64_udivmod(unsigned long long n, unsigned long long d, unsigned long long * rp); +extern unsigned long long __i64_umulh(unsigned long long u, + unsigned long long v); diff --git a/runtime/c/i64_smulh.c b/runtime/c/i64_smulh.c new file mode 100644 index 00000000..b7a42474 --- /dev/null +++ b/runtime/c/i64_smulh.c @@ -0,0 +1,56 @@ +/***************************************************************** + * + * The Compcert verified compiler + * + * Xavier Leroy, INRIA Paris-Rocquencourt + * + * Copyright (c) 2013 Institut National de Recherche en Informatique et + * en Automatique. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * * Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * * Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * * Neither the name of the <organization> nor the + * names of its contributors may be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT + * HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + **********************************************************************/ + +/* Helper functions for 64-bit integer arithmetic. Reference C implementation */ + +#include "i64.h" + +typedef signed long long s64; +typedef unsigned long long u64; + +/* Signed multiply high */ + +/* Hacker's Delight section 8.3: + * - compute high 64 bits of the unsigned product X * Y + * - subtract X if Y < 0 + * - subtract Y if X < 0 + */ + +s64 __i64_smulh(s64 x, s64 y) +{ + s64 t = (s64) __i64_umulh(x, y); + if (y < 0) t = t - x; + if (x < 0) t = t - y; + return t; +} diff --git a/runtime/c/i64_umulh.c b/runtime/c/i64_umulh.c new file mode 100644 index 00000000..d2394d09 --- /dev/null +++ b/runtime/c/i64_umulh.c @@ -0,0 +1,66 @@ +/***************************************************************** + * + * The Compcert verified compiler + * + * Xavier Leroy, INRIA Paris + * + * Copyright (c) 2016 Institut National de Recherche en Informatique et + * en Automatique. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * * Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * * Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * * Neither the name of the <organization> nor the + * names of its contributors may be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT + * HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + **********************************************************************/ + +/* Helper functions for 64-bit integer arithmetic. Reference C implementation */ + +#include "i64.h" + +typedef unsigned long long u64; +typedef unsigned int u32; + +/* Unsigned multiply high */ + +/* Hacker's Delight, algorithm 8.1, specialized to two 32-bit words */ + +u64 __i64_umulh(u64 u, u64 v) +{ + u32 u0 = u, u1 = u >> 32; + u32 v0 = v, v1 = v >> 32; + u32 w1, w2, w3, k; + u64 t; + + t = (u64) u0 * (u64) v0; + k = t >> 32; + + t = (u64) u1 * (u64) v0 + k; + w1 = t; + w2 = t >> 32; + + t = (u64) u0 * (u64) v1 + w1; + k = t >> 32; + + t = (u64) u1 * (u64) v1 + w2 + k; + + return t; +} diff --git a/runtime/powerpc/i64_smul.s b/runtime/powerpc/i64_smul.s new file mode 100644 index 00000000..9eb453d4 --- /dev/null +++ b/runtime/powerpc/i64_smul.s @@ -0,0 +1,76 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris +# +# Copyright (c) 2016 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +# Signed multiply high + +# Reference C implementation in ../c/i64_smul.c + + .balign 16 + .globl __i64_smulh +__i64_smulh: + # u1 in r3; u0 in r4; v1 in r5; v0 in r6 + # First compute unsigned product (see i64_umul.s) + mulhwu r0, r4, r6 # k (in r0) = high((u64) u0 * (u64) v0) + mullw r8, r3, r6 + mulhwu r7, r3, r6 # t (in r8:r7) = (u64) u1 * (u64) v0 + addc r0, r8, r0 # w1 (in r0) = low (t + k) + addze r9, r7 # w2 (in r9) = high (t + k) + mullw r8, r4, r5 + mulhwu r7, r4, r5 # t (in r8:r7) = (u64) u0 * (u64) v1 + addc r0, r8, r0 # tmp (in r0) = low (t + w1) + addze r0, r7 # k (in r0) = high(t + w1) + mullw r8, r3, r5 + mulhwu r7, r3, r5 # t (in r8:r7) = (u64) u1 * (u64) v1 + addc r8, r8, r9 # add w2 + addze r7, r7 + addc r8, r8, r0 # add k + addze r7, r7 + # Here r8:r7 contains the high 64 bits of the unsigned product + srawi r0, r3, 31 # r0 = 0 if U >= 0, -1 if U < 0 + srawi r9, r5, 31 # r9 = 0 if V >= 0, -1 if V < 0 + and r3, r3, r9 + and r4, r4, r9 # r3:r4 = U if V < 0, = 0 if V >= 0 + and r5, r5, r0 + and r6, r6, r0 # r5:r6 = V if U < 0, = 0 if U >= 0 + subfc r8, r4, r8 + subfe r7, r3, r7 + subfc r4, r6, r8 + subfe r3, r5, r7 # result is r8:r7 - r3:r4 - r5:r6 + blr + .type __i64_umulh, @function + .size __i64_umulh, .-__i64_umulh diff --git a/runtime/powerpc/i64_smulh.s b/runtime/powerpc/i64_smulh.s new file mode 100644 index 00000000..4dc97a48 --- /dev/null +++ b/runtime/powerpc/i64_smulh.s @@ -0,0 +1,79 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris +# +# Copyright (c) 2016 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Signed multiply-high + +# Hacker's Delight section 8.3: +# - compute high 64 bits of the unsigned product X * Y (see i64_umulh.S) +# - subtract X if Y < 0 +# - subtract Y if X < 0 + + .balign 16 + .globl __i64_smulh +__i64_smulh: +# r7:r8:r9 accumulate bits 127:32 of the full unsigned product + mulhwu r9, r4, r6 # r9 = high half of XL.YL + mullw r0, r4, r5 # r0 = low half of XL.YH + addc r9, r9, r0 + mulhwu r0, r4, r5 # r0 = high half of XL.YH + addze r8, r0 + mullw r0, r3, r6 # r0 = low half of XH.YL + addc r9, r9, r0 + mulhwu r0, r3, r6 # r0 = high half of XH.YL + adde r8, r8, r0 + li r7, 0 + addze r7, r7 + mullw r0, r3, r5 # r0 = low half of XH.YH + addc r8, r8, r0 + mulhwu r0, r3, r5 # r0 = high half of XH.YH + adde r7, r7, r0 +# Test signs + srawi r0, r3, 31 # r0 = -1 if X < 0, r0 = 0 if X >= 0 + srawi r9, r5, 31 # r9 = -1 if Y < 0, r9 = 0 if Y >= 0 + and r3, r3, r9 # set X = 0 if Y >= 0 + and r4, r4, r9 + and r5, r5, r0 # set Y = 0 if X >= 0 + and r6, r6, r0 + subfc r8, r4, r8 # subtract X + subfe r7, r3, r7 + subfc r4, r6, r8 # subtract Y + subfe r3, r5, r7 + blr + .type __i64_smulh, @function + .size __i64_smulh, .-__i64_smulh + diff --git a/runtime/powerpc/i64_umul.s b/runtime/powerpc/i64_umul.s new file mode 100644 index 00000000..e734b93c --- /dev/null +++ b/runtime/powerpc/i64_umul.s @@ -0,0 +1,64 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris +# +# Copyright (c) 2016 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +# Unsigned multiply high + +# Reference C implementation in ../c/i64_umul.c + + .balign 16 + .globl __i64_umulh +__i64_umulh: + # u1 in r3; u0 in r4; v1 in r5; v0 in r6 + mulhwu r0, r4, r6 # k (in r0) = high((u64) u0 * (u64) v0) + mullw r8, r3, r6 + mulhwu r7, r3, r6 # t (in r8:r7) = (u64) u1 * (u64) v0 + addc r0, r8, r0 # w1 (in r0) = low (t + k) + addze r9, r7 # w2 (in r9) = high (t + k) + mullw r8, r4, r5 + mulhwu r7, r4, r5 # t (in r8:r7) = (u64) u0 * (u64) v1 + addc r0, r8, r0 # tmp (in r0) = low (t + w1) + addze r0, r7 # k (in r0) = high(t + w1) + mullw r8, r3, r5 + mulhwu r7, r3, r5 # t (in r8:r7) = (u64) u1 * (u64) v1 + addc r4, r8, r9 # add w2 + addze r3, r7 + addc r4, r4, r0 # add k + addze r3, r3 + blr + .type __i64_umulh, @function + .size __i64_umulh, .-__i64_umulh diff --git a/runtime/powerpc/i64_umulh.s b/runtime/powerpc/i64_umulh.s new file mode 100644 index 00000000..1c609466 --- /dev/null +++ b/runtime/powerpc/i64_umulh.s @@ -0,0 +1,65 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris +# +# Copyright (c) 2016 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Unsigned multiply-high + +# X * Y = 2^64 XH.YH + 2^32 (XH.YL + XL.YH) + XL.YL + + .balign 16 + .globl __i64_umulh +__i64_umulh: +# r7:r8:r9 accumulate bits 127:32 of the full product + mulhwu r9, r4, r6 # r9 = high half of XL.YL + mullw r0, r4, r5 # r0 = low half of XL.YH + addc r9, r9, r0 + mulhwu r0, r4, r5 # r0 = high half of XL.YH + addze r8, r0 + mullw r0, r3, r6 # r0 = low half of XH.YL + addc r9, r9, r0 + mulhwu r0, r3, r6 # r0 = high half of XH.YL + adde r8, r8, r0 + li r7, 0 + addze r7, r7 + mullw r0, r3, r5 # r0 = low half of XH.YH + addc r4, r8, r0 + mulhwu r0, r3, r5 # r0 = high half of XH.YH + adde r3, r7, r0 + blr + .type __i64_umulh, @function + .size __i64_umulh, .-__i64_umulh + diff --git a/runtime/ia32/i64_dtos.S b/runtime/x86_32/i64_dtos.S index 3cc381bf..3cc381bf 100644 --- a/runtime/ia32/i64_dtos.S +++ b/runtime/x86_32/i64_dtos.S diff --git a/runtime/ia32/i64_dtou.S b/runtime/x86_32/i64_dtou.S index 4903f847..4903f847 100644 --- a/runtime/ia32/i64_dtou.S +++ b/runtime/x86_32/i64_dtou.S diff --git a/runtime/ia32/i64_sar.S b/runtime/x86_32/i64_sar.S index cf2233b1..cf2233b1 100644 --- a/runtime/ia32/i64_sar.S +++ b/runtime/x86_32/i64_sar.S diff --git a/runtime/ia32/i64_sdiv.S b/runtime/x86_32/i64_sdiv.S index f6551c7d..f6551c7d 100644 --- a/runtime/ia32/i64_sdiv.S +++ b/runtime/x86_32/i64_sdiv.S diff --git a/runtime/ia32/i64_shl.S b/runtime/x86_32/i64_shl.S index 1fabebce..1fabebce 100644 --- a/runtime/ia32/i64_shl.S +++ b/runtime/x86_32/i64_shl.S diff --git a/runtime/ia32/i64_shr.S b/runtime/x86_32/i64_shr.S index 34196f09..34196f09 100644 --- a/runtime/ia32/i64_shr.S +++ b/runtime/x86_32/i64_shr.S diff --git a/runtime/ia32/i64_smod.S b/runtime/x86_32/i64_smod.S index 28f47ad4..28f47ad4 100644 --- a/runtime/ia32/i64_smod.S +++ b/runtime/x86_32/i64_smod.S diff --git a/runtime/x86_32/i64_smulh.S b/runtime/x86_32/i64_smulh.S new file mode 100644 index 00000000..cc0f0167 --- /dev/null +++ b/runtime/x86_32/i64_smulh.S @@ -0,0 +1,94 @@ +// ***************************************************************** +// +// The Compcert verified compiler +// +// Xavier Leroy, INRIA Paris +// +// Copyright (c) 2016 Institut National de Recherche en Informatique et +// en Automatique. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the <organization> nor the +// names of its contributors may be used to endorse or promote products +// derived from this software without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// +// ********************************************************************* + +// Helper functions for 64-bit integer arithmetic. IA32 version. + +#include "sysdeps.h" + +// Multiply-high signed + +#define XL 12(%esp) +#define XH 16(%esp) +#define YL 20(%esp) +#define YH 24(%esp) + +// Hacker's Delight section 8.3: +// - compute high 64 bits of the unsigned product X * Y (see i64_umulh.S) +// - subtract X if Y < 0 +// - subtract Y if X < 0 + +FUNCTION(__i64_smulh) + pushl %esi + pushl %edi + movl XL, %eax + mull YL // EDX:EAX = 64-bit product XL.YL + movl %edx, %ecx + xorl %esi, %esi + xorl %edi, %edi // EDI:ESI:ECX accumulatesbits 127:32 of result + movl XH, %eax + mull YL // EDX:EAX = 64-bit product XH.YL + addl %eax, %ecx + adcl %edx, %esi + adcl $0, %edi + movl YH, %eax + mull XL // EDX:EAX = 64-bit product YH.XL + addl %eax, %ecx + adcl %edx, %esi + adcl $0, %edi + movl XH, %eax + mull YH // EDX:EAX = 64-bit product XH.YH + addl %eax, %esi + adcl %edx, %edi +// Here, EDI:ESI is the high 64 bits of the unsigned product X.Y + xorl %eax, %eax + xorl %edx, %edx + cmpl $0, XH + cmovl YL, %eax + cmovl YH, %edx // EDX:EAX = Y if X < 0, = 0 if X >= 0 + subl %eax, %esi + sbbl %edx, %edi // EDI:ESI -= Y if X < 0 + xorl %eax, %eax + xorl %edx, %edx + cmpl $0, YH + cmovl XL, %eax + cmovl XH, %edx // EDX:EAX = X if Y < 0, = 0 if Y >= 0 + subl %eax, %esi + sbbl %edx, %edi // EDI:ESI -= X if Y < 0 +// Now EDI:ESI contains the high 64 bits of the signed product X.Y + movl %esi, %eax + movl %edi, %edx + popl %edi + popl %esi + ret +ENDFUNCTION(__i64_smulh) diff --git a/runtime/ia32/i64_stod.S b/runtime/x86_32/i64_stod.S index d020e2fc..d020e2fc 100644 --- a/runtime/ia32/i64_stod.S +++ b/runtime/x86_32/i64_stod.S diff --git a/runtime/ia32/i64_stof.S b/runtime/x86_32/i64_stof.S index 25b1d4f7..25b1d4f7 100644 --- a/runtime/ia32/i64_stof.S +++ b/runtime/x86_32/i64_stof.S diff --git a/runtime/ia32/i64_udiv.S b/runtime/x86_32/i64_udiv.S index 75305433..75305433 100644 --- a/runtime/ia32/i64_udiv.S +++ b/runtime/x86_32/i64_udiv.S diff --git a/runtime/ia32/i64_udivmod.S b/runtime/x86_32/i64_udivmod.S index dccfc286..dccfc286 100644 --- a/runtime/ia32/i64_udivmod.S +++ b/runtime/x86_32/i64_udivmod.S diff --git a/runtime/ia32/i64_umod.S b/runtime/x86_32/i64_umod.S index a019df28..a019df28 100644 --- a/runtime/ia32/i64_umod.S +++ b/runtime/x86_32/i64_umod.S diff --git a/runtime/x86_32/i64_umulh.S b/runtime/x86_32/i64_umulh.S new file mode 100644 index 00000000..449a0f8b --- /dev/null +++ b/runtime/x86_32/i64_umulh.S @@ -0,0 +1,74 @@ +// ***************************************************************** +// +// The Compcert verified compiler +// +// Xavier Leroy, INRIA Paris +// +// Copyright (c) 2016 Institut National de Recherche en Informatique et +// en Automatique. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the <organization> nor the +// names of its contributors may be used to endorse or promote products +// derived from this software without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// +// ********************************************************************* + +// Helper functions for 64-bit integer arithmetic. IA32 version. + +#include "sysdeps.h" + +// Multiply-high unsigned + +#define XL 12(%esp) +#define XH 16(%esp) +#define YL 20(%esp) +#define YH 24(%esp) + +// X * Y = 2^64 XH.YH + 2^32 (XH.YL + XL.YH) + XL.YL + +FUNCTION(__i64_umulh) + pushl %esi + pushl %edi + movl XL, %eax + mull YL // EDX:EAX = 64-bit product XL.YL + movl %edx, %ecx + xorl %esi, %esi + xorl %edi, %edi // EDI:ESI:ECX accumulate bits 127:32 of result + movl XH, %eax + mull YL // EDX:EAX = 64-bit product XH.YL + addl %eax, %ecx + adcl %edx, %esi + adcl $0, %edi + movl YH, %eax + mull XL // EDX:EAX = 64-bit product YH.XL + addl %eax, %ecx + adcl %edx, %esi + adcl $0, %edi + movl XH, %eax + mull YH // EDX:EAX = 64-bit product XH.YH + addl %esi, %eax + adcl %edi, %edx + popl %edi + popl %esi + ret +ENDFUNCTION(__i64_umulh) + diff --git a/runtime/ia32/i64_utod.S b/runtime/x86_32/i64_utod.S index 428a3b94..428a3b94 100644 --- a/runtime/ia32/i64_utod.S +++ b/runtime/x86_32/i64_utod.S diff --git a/runtime/ia32/i64_utof.S b/runtime/x86_32/i64_utof.S index 0b58f48b..0b58f48b 100644 --- a/runtime/ia32/i64_utof.S +++ b/runtime/x86_32/i64_utof.S diff --git a/runtime/ia32/sysdeps.h b/runtime/x86_32/sysdeps.h index 9d957a88..9d957a88 100644 --- a/runtime/ia32/sysdeps.h +++ b/runtime/x86_32/sysdeps.h diff --git a/runtime/ia32/vararg.S b/runtime/x86_32/vararg.S index 78666c70..78666c70 100644 --- a/runtime/ia32/vararg.S +++ b/runtime/x86_32/vararg.S diff --git a/runtime/x86_64/i64_dtou.S b/runtime/x86_64/i64_dtou.S new file mode 100644 index 00000000..e455ea6f --- /dev/null +++ b/runtime/x86_64/i64_dtou.S @@ -0,0 +1,56 @@ +// ***************************************************************** +// +// The Compcert verified compiler +// +// Xavier Leroy, INRIA Paris +// +// Copyright (c) 2016 Institut National de Recherche en Informatique et +// en Automatique. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the <organization> nor the +// names of its contributors may be used to endorse or promote products +// derived from this software without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// +// ********************************************************************* + +// Helper functions for 64-bit integer arithmetic. x86_64 version. + +#include "sysdeps.h" + +// Conversion float -> unsigned long + +FUNCTION(__i64_dtou) + ucomisd .LC1(%rip), %xmm0 + jnb 1f + cvttsd2siq %xmm0, %rax + ret +1: subsd .LC1(%rip), %xmm0 + cvttsd2siq %xmm0, %rax + addq .LC2(%rip), %rax + ret + + .p2align 3 +.LC1: .quad 0x43e0000000000000 // 2^63 in double precision +.LC2: .quad 0x8000000000000000 // 2^63 as an integer + +ENDFUNCTION(__i64_dtou) + diff --git a/runtime/x86_64/i64_utod.S b/runtime/x86_64/i64_utod.S new file mode 100644 index 00000000..96b77a64 --- /dev/null +++ b/runtime/x86_64/i64_utod.S @@ -0,0 +1,56 @@ +// ***************************************************************** +// +// The Compcert verified compiler +// +// Xavier Leroy, INRIA Paris +// +// Copyright (c) 2016 Institut National de Recherche en Informatique et +// en Automatique. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the <organization> nor the +// names of its contributors may be used to endorse or promote products +// derived from this software without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// +// ********************************************************************* + +// Helper functions for 64-bit integer arithmetic. x86_64 version. + +#include "sysdeps.h" + +// Conversion unsigned long -> double-precision float + +FUNCTION(__i64_utod) + testq %rdi, %rdi + js 1f + pxor %xmm0, %xmm0 // if < 2^63, + cvtsi2sdq %rdi, %xmm0 // convert as if signed + ret +1: // if >= 2^63, use round-to-odd trick + movq %rdi, %rax + shrq %rax + andq $1, %rdi + orq %rdi, %rax // (arg >> 1) | (arg & 1) + pxor %xmm0, %xmm0 + cvtsi2sdq %rax, %xmm0 // convert as if signed + addsd %xmm0, %xmm0 // multiply result by 2.0 + ret +ENDFUNCTION(__i64_utod) diff --git a/runtime/x86_64/i64_utof.S b/runtime/x86_64/i64_utof.S new file mode 100644 index 00000000..d0935341 --- /dev/null +++ b/runtime/x86_64/i64_utof.S @@ -0,0 +1,56 @@ +// ***************************************************************** +// +// The Compcert verified compiler +// +// Xavier Leroy, INRIA Paris +// +// Copyright (c) 2016 Institut National de Recherche en Informatique et +// en Automatique. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the <organization> nor the +// names of its contributors may be used to endorse or promote products +// derived from this software without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// +// ********************************************************************* + +// Helper functions for 64-bit integer arithmetic. x86_64 version. + +#include "sysdeps.h" + +// Conversion unsigned long -> single-precision float + +FUNCTION(__i64_utof) + testq %rdi, %rdi + js 1f + pxor %xmm0, %xmm0 // if < 2^63, + cvtsi2ssq %rdi, %xmm0 // convert as if signed + ret +1: // if >= 2^63, use round-to-odd trick + movq %rdi, %rax + shrq %rax + andq $1, %rdi + orq %rdi, %rax // (arg >> 1) | (arg & 1) + pxor %xmm0, %xmm0 + cvtsi2ssq %rax, %xmm0 // convert as if signed + addss %xmm0, %xmm0 // multiply result by 2.0 + ret +ENDFUNCTION(__i64_utof) diff --git a/runtime/x86_64/sysdeps.h b/runtime/x86_64/sysdeps.h new file mode 100644 index 00000000..e9d456af --- /dev/null +++ b/runtime/x86_64/sysdeps.h @@ -0,0 +1,75 @@ +// ***************************************************************** +// +// The Compcert verified compiler +// +// Xavier Leroy, INRIA Paris +// +// Copyright (c) 2016 Institut National de Recherche en Informatique et +// en Automatique. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the <organization> nor the +// names of its contributors may be used to endorse or promote products +// derived from this software without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// +// ********************************************************************* + +// System dependencies + +#if defined(SYS_linux) || defined(SYS_bsd) + +#define GLOB(x) x +#define FUNCTION(f) \ + .text; \ + .globl f; \ + .align 16; \ +f: + +#define ENDFUNCTION(f) \ + .type f, @function; .size f, . - f + +#endif + +#if defined(SYS_macosx) + +#define GLOB(x) _##x +#define FUNCTION(f) \ + .text; \ + .globl _##f; \ + .align 4; \ +_##f: + +#define ENDFUNCTION(f) + +#endif + +#if defined(SYS_cygwin) + +#define GLOB(x) _##x +#define FUNCTION(f) \ + .text; \ + .globl _##f; \ + .align 16; \ +_##f: + +#define ENDFUNCTION(f) + +#endif diff --git a/runtime/x86_64/vararg.S b/runtime/x86_64/vararg.S new file mode 100644 index 00000000..9c0d787b --- /dev/null +++ b/runtime/x86_64/vararg.S @@ -0,0 +1,148 @@ +// ***************************************************************** +// +// The Compcert verified compiler +// +// Xavier Leroy, INRIA Paris +// +// Copyright (c) 2016 Institut National de Recherche en Informatique et +// en Automatique. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the <organization> nor the +// names of its contributors may be used to endorse or promote products +// derived from this software without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// +// ********************************************************************* + +// Helper functions for variadic functions <stdarg.h>. x86_64 version. + +// typedef struct { +// unsigned int gp_offset; +// unsigned int fp_offset; +// void *overflow_arg_area; +// void *reg_save_area; +// } va_list[1]; + +// The va_start macro initializes the structure as follows: +// - reg_save_area: The element points to the start of the register save area. +// - overflow_arg_area: This pointer is used to fetch arguments passed on +// the stack. It is initialized with the address of the first argument +// passed on the stack, if any, and then always updated to point to the +// start of the next argument on the stack. +// - gp_offset: The element holds the offset in bytes from reg_save_area +// to the place where the next available general purpose argument +// register is saved. In case all argument registers have been +// exhausted, it is set to the value 48 (6 * 8). +// - fp_offset: The element holds the offset in bytes from reg_save_area +// to the place where the next available floating point argument +// register is saved. In case all argument registers have been +// exhausted, it is set to the value 176 (6 * 8 + 8 * 16). + +// unsigned int __compcert_va_int32(va_list ap); +// unsigned long long __compcert_va_int64(va_list ap); +// double __compcert_va_float64(va_list ap); + +#include "sysdeps.h" + +FUNCTION(__compcert_va_int32) + movl 0(%rdi), %edx // edx = gp_offset + cmpl $48, %edx + jae 1f + // next argument is in gp reg area + movq 16(%rdi), %rsi // rsi = reg_save_area + movl 0(%rsi, %rdx, 1), %eax // next integer argument + addl $8, %edx + movl %edx, 0(%rdi) // increment gp_offset by 8 + ret + // next argument is in overflow arg area +1: movq 8(%rdi), %rsi // rsi = overflow_arg_area + movq 0(%rsi), %rax // next integer argument + addq $8, %rsi + movq %rsi, 8(%rdi) // increment overflow_arg_area by 8 + ret +ENDFUNCTION(__compcert_va_int32) + +FUNCTION(__compcert_va_int64) + movl 0(%rdi), %edx // edx = gp_offset + cmpl $48, %edx + jae 1f + // next argument is in gp reg area + movq 16(%rdi), %rsi // rsi = reg_save_area + movq 0(%rsi, %rdx, 1), %rax // next integer argument + addl $8, %edx + movl %edx, 0(%rdi) // increment gp_offset by 8 + ret + // next argument is in overflow arg area +1: movq 8(%rdi), %rsi // rsi = overflow_arg_area + movq 0(%rsi), %rax // next integer argument + addq $8, %rsi + movq %rsi, 8(%rdi) // increment overflow_arg_area by 8 + ret +ENDFUNCTION(__compcert_va_int64) + +FUNCTION(__compcert_va_float64) + movl 4(%rdi), %edx // edx = fp_offset + cmpl $176, %edx + jae 1f + // next argument is in fp reg area + movq 16(%rdi), %rsi // rsi = reg_save_area + movsd 0(%rsi, %rdx, 1), %xmm0 // next floating-point argument + addl $16, %edx + movl %edx, 4(%rdi) // increment fp_offset by 16 + ret + // next argument is in overflow arg area +1: movq 8(%rdi), %rsi // rsi = overflow_arg_area + movsd 0(%rsi), %xmm0 // next floating-point argument + addq $8, %rsi + movq %rsi, 8(%rdi) // increment overflow_arg_area by 8 + ret +ENDFUNCTION(__compcert_va_float64) + +FUNCTION(__compcert_va_composite) + jmp GLOB(__compcert_va_int64) // by-ref convention, FIXME +ENDFUNCTION(__compcert_va_composite) + +// Save integer and FP registers at beginning of vararg function +// r10 points to register save area +// al contains number of FP arguments passed in registers +// The register save area has the following shape: +// 0, 8, ..., 40 -> 6 x 8-byte slots for saving rdi, rsi, rdx, rcx, r8, r9 +// 48, 64, ... 160 -> 8 x 16-byte slots for saving xmm0...xmm7 + +FUNCTION(__compcert_va_saveregs) + movq %rdi, 0(%r10) + movq %rsi, 8(%r10) + movq %rdx, 16(%r10) + movq %rcx, 24(%r10) + movq %r8, 32(%r10) + movq %r9, 40(%r10) + testb %al, %al + je 1f + movaps %xmm0, 48(%r10) + movaps %xmm1, 64(%r10) + movaps %xmm2, 80(%r10) + movaps %xmm3, 96(%r10) + movaps %xmm4, 112(%r10) + movaps %xmm5, 128(%r10) + movaps %xmm6, 144(%r10) + movaps %xmm7, 160(%r10) +1: ret +ENDFUNCTION(__compcert_va_saveregs) diff --git a/test/regression/Makefile b/test/regression/Makefile index 88f50466..5def966b 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -69,22 +69,13 @@ clean: rm -f *.parsed.c *.compcert.c *.light.c *.s *.o *.sdump *~ test: + @echo "----------- Compiled tests -------------" @for i in $(TESTS) $(TESTS_COMP); do \ - if ./$$i.compcert | cmp -s - Results/$$i; \ - then echo "$$i: passed"; \ - else echo "$$i: FAILED"; exit 2; \ - fi; \ + ./Runtest $$i ./$$i.compcert; \ done + @echo "----------- Interpreted tests -------------" @for i in $(TESTS); do \ - if $(CCOMP) -fall -interp -quiet $$i.c > _cinterp.log; then \ - if cmp -s _cinterp.log Results/$$i; \ - then echo "$$i: interpreter passed"; \ - else echo "$$i: interpreter FAILED"; \ - fi; \ - else \ - echo "$$i: interpreter undefined behavior"; \ - fi; \ - rm -f _cinterp.log; \ + ./Runtest $$i $(CCOMP) -fall -interp -quiet $$i.c; \ done @for i in $(TESTS_DIFF); do \ if $(CCOMP) -fall -interp -quiet $$i.c > _cinterp.log; then \ diff --git a/test/regression/Results/builtins-ia32 b/test/regression/Results/builtins-x86 index 6ab71f0d..393ac1fd 100644 --- a/test/regression/Results/builtins-ia32 +++ b/test/regression/Results/builtins-x86 @@ -1,5 +1,6 @@ bswap(12345678) = 78563412 bswap16(1234) = 3412 +bswap64(123456789abcdef0) = f0debc9a78563412 clz(12345678) = 3 clzll(12345678) = 35 clzll(1234567812345678) = 3 diff --git a/test/regression/Results/initializers b/test/regression/Results/initializers-32 index a3c92e86..a3c92e86 100644 --- a/test/regression/Results/initializers +++ b/test/regression/Results/initializers-32 diff --git a/test/regression/Results/initializers-64 b/test/regression/Results/initializers-64 new file mode 100644 index 00000000..63cc0eb7 --- /dev/null +++ b/test/regression/Results/initializers-64 @@ -0,0 +1,30 @@ +x0 = 0 +x1 = 'x' +x2 = 12345 +x3 = 3.14159 +x4 = { 'a', 'b', 'c', 'd' } +x5 = { 1, 2, 3, 0, 0, 0, 0, 0, 0, 0, } +x6 = { 4, 5 } +x7 = { 6, 'u' } +x8 = { 'v', 7 } +x9 = { { 'a', 'b', 0, 0, 0, 0, 0, 0, 0, }, 2.718 } +x10 = { { 'v', 7 }, 2.718 } +x11 = 1.3183101416 +x12 = 1.3183101550 +x13 = { 0, 1 } +x14 ok +x15 ok +x16 ok +x17[7] = { 'H', 'e', 'l', 'l', 'o', '!', 0, } +x18 = "Hello!" +x19 = { "Hello", "world!" } +x20 = { 'H', 'e', 'l', } +x21 = { 'H', 'e', 'l', 'l', 'o', '!', 0, 0, 0, 0, } +x22 ok +x23 = { hd = 16, tl = ok } +x24[6] = { '/', '*', 'B', '*', '/', 0, } +x25[8] = { "/tmp" } +x26[6] = { 'w', 'o', 'r', 'l', 'd', 0, } +x27[4] = { 'a', 'b', 'c', 0, } +x28[2] = { 'a', 'b', } +x29[10] = { 'a', 'b', 'c', 0, 0, 0, 0, 0, 0, 0, } diff --git a/test/regression/Results/int64 b/test/regression/Results/int64 index 307d0887..af444cf6 100644 --- a/test/regression/Results/int64 +++ b/test/regression/Results/int64 @@ -12,6 +12,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = 0 +x /u 5 = 0 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = 0 +x /u 11 = 0 +x %u 11 = 0 +x /s 11 = 0 +x %s 11 = 0 ~x = ffffffffffffffff x & y = 0 x | y = 0 @@ -42,6 +54,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = 0 +x /u 5 = 0 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = 0 +x /u 11 = 0 +x %u 11 = 0 +x /s 11 = 0 +x %s 11 = 0 ~x = ffffffffffffffff x & y = 0 x | y = 1 @@ -72,6 +96,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = 0 +x /u 5 = 0 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = 0 +x /u 11 = 0 +x %u 11 = 0 +x /s 11 = 0 +x %s 11 = 0 ~x = ffffffffffffffff x & y = 0 x | y = ffffffffffffffff @@ -102,6 +138,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = 0 +x /u 5 = 0 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = 0 +x /u 11 = 0 +x %u 11 = 0 +x /s 11 = 0 +x %s 11 = 0 ~x = ffffffffffffffff x & y = 0 x | y = 7fffffff @@ -132,6 +180,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = 0 +x /u 5 = 0 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = 0 +x /u 11 = 0 +x %u 11 = 0 +x /s 11 = 0 +x %s 11 = 0 ~x = ffffffffffffffff x & y = 0 x | y = 80000000 @@ -162,6 +222,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = 0 +x /u 5 = 0 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = 0 +x /u 11 = 0 +x %u 11 = 0 +x /s 11 = 0 +x %s 11 = 0 ~x = ffffffffffffffff x & y = 0 x | y = 7fffffffffffffff @@ -192,6 +264,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = 0 +x /u 5 = 0 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = 0 +x /u 11 = 0 +x %u 11 = 0 +x /s 11 = 0 +x %s 11 = 0 ~x = ffffffffffffffff x & y = 0 x | y = 8000000000000000 @@ -222,6 +306,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = 0 +x /u 5 = 0 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = 0 +x /u 11 = 0 +x %u 11 = 0 +x /s 11 = 0 +x %s 11 = 0 ~x = ffffffffffffffff x & y = 0 x | y = 100000003 @@ -252,6 +348,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = 0 +x /u 5 = 0 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = 0 +x /u 11 = 0 +x %u 11 = 0 +x /s 11 = 0 +x %s 11 = 0 ~x = ffffffffffffffff x & y = 0 x | y = 14057b7ef767814f @@ -282,6 +390,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 8ada4b0819379bb +x %u 3 = 1 +x /s 3 = 8ada4b0819379bb +x %s 3 = 1 +x /u 5 = 534fc69e7587c3d +x %u 5 = 1 +x /s 5 = 534fc69e7587c3d +x %s 5 = 1 +x /u 11 = 25de718dd854fbe +x %u 11 = 8 +x /s 11 = 25de718dd854fbe +x %s 11 = 8 ~x = e5f711ee7b4592cd x & y = 0 x | y = 1a08ee1184ba6d32 @@ -312,6 +432,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 1 +x /s 3 = 0 +x %s 3 = 1 +x /u 5 = 0 +x %u 5 = 1 +x /s 5 = 0 +x %s 5 = 1 +x /u 11 = 0 +x %u 11 = 1 +x /s 11 = 0 +x %s 11 = 1 ~x = fffffffffffffffe x & y = 0 x | y = 1 @@ -342,6 +474,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 1 +x /s 3 = 0 +x %s 3 = 1 +x /u 5 = 0 +x %u 5 = 1 +x /s 5 = 0 +x %s 5 = 1 +x /u 11 = 0 +x %u 11 = 1 +x /s 11 = 0 +x %s 11 = 1 ~x = fffffffffffffffe x & y = 1 x | y = 1 @@ -372,6 +516,18 @@ x /u y2 = 0 x %u y2 = 1 x /s y3 = ffffffffffffffff x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 1 +x /s 3 = 0 +x %s 3 = 1 +x /u 5 = 0 +x %u 5 = 1 +x /s 5 = 0 +x %s 5 = 1 +x /u 11 = 0 +x %u 11 = 1 +x /s 11 = 0 +x %s 11 = 1 ~x = fffffffffffffffe x & y = 1 x | y = ffffffffffffffff @@ -402,6 +558,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 1 +x /s 3 = 0 +x %s 3 = 1 +x /u 5 = 0 +x %u 5 = 1 +x /s 5 = 0 +x %s 5 = 1 +x /u 11 = 0 +x %u 11 = 1 +x /s 11 = 0 +x %s 11 = 1 ~x = fffffffffffffffe x & y = 1 x | y = 7fffffff @@ -432,6 +600,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 1 +x /s 3 = 0 +x %s 3 = 1 +x /u 5 = 0 +x %u 5 = 1 +x /s 5 = 0 +x %s 5 = 1 +x /u 11 = 0 +x %u 11 = 1 +x /s 11 = 0 +x %s 11 = 1 ~x = fffffffffffffffe x & y = 0 x | y = 80000001 @@ -462,6 +642,18 @@ x /u y2 = 0 x %u y2 = 1 x /s y3 = 0 x %s y3 = 1 +x /u 3 = 0 +x %u 3 = 1 +x /s 3 = 0 +x %s 3 = 1 +x /u 5 = 0 +x %u 5 = 1 +x /s 5 = 0 +x %s 5 = 1 +x /u 11 = 0 +x %u 11 = 1 +x /s 11 = 0 +x %s 11 = 1 ~x = fffffffffffffffe x & y = 1 x | y = 7fffffffffffffff @@ -492,6 +684,18 @@ x /u y2 = 0 x %u y2 = 1 x /s y3 = 0 x %s y3 = 1 +x /u 3 = 0 +x %u 3 = 1 +x /s 3 = 0 +x %s 3 = 1 +x /u 5 = 0 +x %u 5 = 1 +x /s 5 = 0 +x %s 5 = 1 +x /u 11 = 0 +x %u 11 = 1 +x /s 11 = 0 +x %s 11 = 1 ~x = fffffffffffffffe x & y = 0 x | y = 8000000000000001 @@ -522,6 +726,18 @@ x /u y2 = 1 x %u y2 = 0 x /s y3 = 1 x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 1 +x /s 3 = 0 +x %s 3 = 1 +x /u 5 = 0 +x %u 5 = 1 +x /s 5 = 0 +x %s 5 = 1 +x /u 11 = 0 +x %u 11 = 1 +x /s 11 = 0 +x %s 11 = 1 ~x = fffffffffffffffe x & y = 1 x | y = 100000003 @@ -552,6 +768,18 @@ x /u y2 = 0 x %u y2 = 1 x /s y3 = 0 x %s y3 = 1 +x /u 3 = 0 +x %u 3 = 1 +x /s 3 = 0 +x %s 3 = 1 +x /u 5 = 0 +x %u 5 = 1 +x /s 5 = 0 +x %s 5 = 1 +x /u 11 = 0 +x %u 11 = 1 +x /s 11 = 0 +x %s 11 = 1 ~x = fffffffffffffffe x & y = 1 x | y = 9af678222e728119 @@ -582,6 +810,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 223cb3a32a60333c +x %u 3 = 0 +x /s 3 = 223cb3a32a60333c +x %s 3 = 0 +x /u 5 = 148ad22eb3068524 +x %u 5 = 0 +x /s 5 = 148ad22eb3068524 +x %s 5 = 0 +x /u 11 = 9565f8997318256 +x %u 11 = 2 +x /s 11 = 9565f8997318256 +x %s 11 = 2 ~x = 9949e51680df664b x & y = 0 x | y = 66b61ae97f2099b5 @@ -612,6 +852,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 5555555555555555 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = ffffffffffffffff +x /u 5 = 3333333333333333 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = ffffffffffffffff +x /u 11 = 1745d1745d1745d1 +x %u 11 = 4 +x /s 11 = 0 +x %s 11 = ffffffffffffffff ~x = 0 x & y = 0 x | y = ffffffffffffffff @@ -642,6 +894,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 5555555555555555 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = ffffffffffffffff +x /u 5 = 3333333333333333 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = ffffffffffffffff +x /u 11 = 1745d1745d1745d1 +x %u 11 = 4 +x /s 11 = 0 +x %s 11 = ffffffffffffffff ~x = 0 x & y = 1 x | y = ffffffffffffffff @@ -672,6 +936,18 @@ x /u y2 = 100000001 x %u y2 = 0 x /s y3 = 1 x %s y3 = 0 +x /u 3 = 5555555555555555 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = ffffffffffffffff +x /u 5 = 3333333333333333 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = ffffffffffffffff +x /u 11 = 1745d1745d1745d1 +x %u 11 = 4 +x /s 11 = 0 +x %s 11 = ffffffffffffffff ~x = 0 x & y = ffffffffffffffff x | y = ffffffffffffffff @@ -702,6 +978,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 5555555555555555 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = ffffffffffffffff +x /u 5 = 3333333333333333 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = ffffffffffffffff +x /u 11 = 1745d1745d1745d1 +x %u 11 = 4 +x /s 11 = 0 +x %s 11 = ffffffffffffffff ~x = 0 x & y = 7fffffff x | y = ffffffffffffffff @@ -732,6 +1020,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 5555555555555555 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = ffffffffffffffff +x /u 5 = 3333333333333333 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = ffffffffffffffff +x /u 11 = 1745d1745d1745d1 +x %u 11 = 4 +x /s 11 = 0 +x %s 11 = ffffffffffffffff ~x = 0 x & y = 80000000 x | y = ffffffffffffffff @@ -762,6 +1062,18 @@ x /u y2 = 200000004 x %u y2 = 3 x /s y3 = 0 x %s y3 = ffffffffffffffff +x /u 3 = 5555555555555555 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = ffffffffffffffff +x /u 5 = 3333333333333333 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = ffffffffffffffff +x /u 11 = 1745d1745d1745d1 +x %u 11 = 4 +x /s 11 = 0 +x %s 11 = ffffffffffffffff ~x = 0 x & y = 7fffffffffffffff x | y = ffffffffffffffff @@ -792,6 +1104,18 @@ x /u y2 = 1ffffffff x %u y2 = 7fffffff x /s y3 = 0 x %s y3 = ffffffffffffffff +x /u 3 = 5555555555555555 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = ffffffffffffffff +x /u 5 = 3333333333333333 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = ffffffffffffffff +x /u 11 = 1745d1745d1745d1 +x %u 11 = 4 +x /s 11 = 0 +x %s 11 = ffffffffffffffff ~x = 0 x & y = 8000000000000000 x | y = ffffffffffffffff @@ -822,6 +1146,18 @@ x /u y2 = ffffffffffffffff x %u y2 = 0 x /s y3 = ffffffffffffffff x %s y3 = 0 +x /u 3 = 5555555555555555 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = ffffffffffffffff +x /u 5 = 3333333333333333 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = ffffffffffffffff +x /u 11 = 1745d1745d1745d1 +x %u 11 = 4 +x /s 11 = 0 +x %s 11 = ffffffffffffffff ~x = 0 x & y = 100000003 x | y = ffffffffffffffff @@ -852,6 +1188,18 @@ x /u y2 = 29b51243c x %u y2 = 2db954e7 x /s y3 = 0 x %s y3 = ffffffffffffffff +x /u 3 = 5555555555555555 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = ffffffffffffffff +x /u 5 = 3333333333333333 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = ffffffffffffffff +x /u 11 = 1745d1745d1745d1 +x %u 11 = 4 +x /s 11 = 0 +x %s 11 = ffffffffffffffff ~x = 0 x & y = 62354cda6226d1f3 x | y = ffffffffffffffff @@ -882,6 +1230,18 @@ x /u y2 = 8f947f37 x %u y2 = 6065753d x /s y3 = 706b80c92f2f09fa x %s y3 = 0 +x /u 3 = 2fdc2a679af05202 +x %u 3 = 0 +x /s 3 = da86d512459afcad +x %s 3 = ffffffffffffffff +x /u 5 = 1cb74ca49029cace +x %u 5 = 0 +x /s 5 = e98419715cf6979b +x %s 5 = ffffffffffffffff +x /u 11 = d0d7fedb5e47374 +x %u 11 = a +x /s 11 = f5c7ae7958cd2da4 +x %s 11 = fffffffffffffffa ~x = 706b80c92f2f09f9 x & y = 8f947f36d0d0f606 x | y = ffffffffffffffff @@ -912,6 +1272,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaa +x %s 3 = 1 +x /u 5 = 19999999 +x %u 5 = 2 +x /s 5 = 19999999 +x %s 5 = 2 +x /u 11 = ba2e8ba +x %u 11 = 1 +x /s 11 = ba2e8ba +x %s 11 = 1 ~x = ffffffff80000000 x & y = 0 x | y = 7fffffff @@ -942,6 +1314,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaa +x %s 3 = 1 +x /u 5 = 19999999 +x %u 5 = 2 +x /s 5 = 19999999 +x %s 5 = 2 +x /u 11 = ba2e8ba +x %u 11 = 1 +x /s 11 = ba2e8ba +x %s 11 = 1 ~x = ffffffff80000000 x & y = 1 x | y = 7fffffff @@ -972,6 +1356,18 @@ x /u y2 = 0 x %u y2 = 7fffffff x /s y3 = ffffffff80000001 x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaa +x %s 3 = 1 +x /u 5 = 19999999 +x %u 5 = 2 +x /s 5 = 19999999 +x %s 5 = 2 +x /u 11 = ba2e8ba +x %u 11 = 1 +x /s 11 = ba2e8ba +x %s 11 = 1 ~x = ffffffff80000000 x & y = 7fffffff x | y = ffffffffffffffff @@ -1002,6 +1398,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaa +x %s 3 = 1 +x /u 5 = 19999999 +x %u 5 = 2 +x /s 5 = 19999999 +x %s 5 = 2 +x /u 11 = ba2e8ba +x %u 11 = 1 +x /s 11 = ba2e8ba +x %s 11 = 1 ~x = ffffffff80000000 x & y = 7fffffff x | y = 7fffffff @@ -1032,6 +1440,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaa +x %s 3 = 1 +x /u 5 = 19999999 +x %u 5 = 2 +x /s 5 = 19999999 +x %s 5 = 2 +x /u 11 = ba2e8ba +x %u 11 = 1 +x /s 11 = ba2e8ba +x %s 11 = 1 ~x = ffffffff80000000 x & y = 0 x | y = ffffffff @@ -1062,6 +1482,18 @@ x /u y2 = 1 x %u y2 = 0 x /s y3 = 1 x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaa +x %s 3 = 1 +x /u 5 = 19999999 +x %u 5 = 2 +x /s 5 = 19999999 +x %s 5 = 2 +x /u 11 = ba2e8ba +x %u 11 = 1 +x /s 11 = ba2e8ba +x %s 11 = 1 ~x = ffffffff80000000 x & y = 7fffffff x | y = 7fffffffffffffff @@ -1092,6 +1524,18 @@ x /u y2 = 0 x %u y2 = 7fffffff x /s y3 = 0 x %s y3 = 7fffffff +x /u 3 = 2aaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaa +x %s 3 = 1 +x /u 5 = 19999999 +x %u 5 = 2 +x /s 5 = 19999999 +x %s 5 = 2 +x /u 11 = ba2e8ba +x %u 11 = 1 +x /s 11 = ba2e8ba +x %s 11 = 1 ~x = ffffffff80000000 x & y = 0 x | y = 800000007fffffff @@ -1122,6 +1566,18 @@ x /u y2 = 7fffffff x %u y2 = 0 x /s y3 = 7fffffff x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaa +x %s 3 = 1 +x /u 5 = 19999999 +x %u 5 = 2 +x /s 5 = 19999999 +x %s 5 = 2 +x /u 11 = ba2e8ba +x %u 11 = 1 +x /s 11 = ba2e8ba +x %s 11 = 1 ~x = ffffffff80000000 x & y = 3 x | y = 17fffffff @@ -1152,6 +1608,18 @@ x /u y2 = 6 x %u y2 = 67c8b5f x /s y3 = 6 x %s y3 = 67c8b5f +x /u 3 = 2aaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaa +x %s 3 = 1 +x /u 5 = 19999999 +x %u 5 = 2 +x /s 5 = 19999999 +x %s 5 = 2 +x /u 11 = ba2e8ba +x %u 11 = 1 +x /s 11 = ba2e8ba +x %s 11 = 1 ~x = ffffffff80000000 x & y = 4fadba5d x | y = 144093707fffffff @@ -1182,6 +1650,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 1e607d2f69822238 +x %u 3 = 0 +x /s 3 = 1e607d2f69822238 +x %s 3 = 0 +x /u 5 = 1239e4b60c1ae154 +x %u 5 = 4 +x /s 5 = 1239e4b60c1ae154 +x %s 5 = 4 +x /u 11 = 848dc52bfaf209a +x %u 11 = a +x /s 11 = 848dc52bfaf209a +x %s 11 = a ~x = a4de8871c3799957 x & y = 3c8666a8 x | y = 5b21778e7fffffff @@ -1212,6 +1692,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 2 +x /s 3 = 2aaaaaaa +x %s 3 = 2 +x /u 5 = 19999999 +x %u 5 = 3 +x /s 5 = 19999999 +x %s 5 = 3 +x /u 11 = ba2e8ba +x %u 11 = 2 +x /s 11 = ba2e8ba +x %s 11 = 2 ~x = ffffffff7fffffff x & y = 0 x | y = 80000000 @@ -1242,6 +1734,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 2 +x /s 3 = 2aaaaaaa +x %s 3 = 2 +x /u 5 = 19999999 +x %u 5 = 3 +x /s 5 = 19999999 +x %s 5 = 3 +x /u 11 = ba2e8ba +x %u 11 = 2 +x /s 11 = ba2e8ba +x %s 11 = 2 ~x = ffffffff7fffffff x & y = 0 x | y = 80000001 @@ -1272,6 +1776,18 @@ x /u y2 = 0 x %u y2 = 80000000 x /s y3 = ffffffff80000000 x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 2 +x /s 3 = 2aaaaaaa +x %s 3 = 2 +x /u 5 = 19999999 +x %u 5 = 3 +x /s 5 = 19999999 +x %s 5 = 3 +x /u 11 = ba2e8ba +x %u 11 = 2 +x /s 11 = ba2e8ba +x %s 11 = 2 ~x = ffffffff7fffffff x & y = 80000000 x | y = ffffffffffffffff @@ -1302,6 +1818,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 2 +x /s 3 = 2aaaaaaa +x %s 3 = 2 +x /u 5 = 19999999 +x %u 5 = 3 +x /s 5 = 19999999 +x %s 5 = 3 +x /u 11 = ba2e8ba +x %u 11 = 2 +x /s 11 = ba2e8ba +x %s 11 = 2 ~x = ffffffff7fffffff x & y = 0 x | y = ffffffff @@ -1332,6 +1860,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 2 +x /s 3 = 2aaaaaaa +x %s 3 = 2 +x /u 5 = 19999999 +x %u 5 = 3 +x /s 5 = 19999999 +x %s 5 = 3 +x /u 11 = ba2e8ba +x %u 11 = 2 +x /s 11 = ba2e8ba +x %s 11 = 2 ~x = ffffffff7fffffff x & y = 80000000 x | y = 80000000 @@ -1362,6 +1902,18 @@ x /u y2 = 1 x %u y2 = 1 x /s y3 = 1 x %s y3 = 1 +x /u 3 = 2aaaaaaa +x %u 3 = 2 +x /s 3 = 2aaaaaaa +x %s 3 = 2 +x /u 5 = 19999999 +x %u 5 = 3 +x /s 5 = 19999999 +x %s 5 = 3 +x /u 11 = ba2e8ba +x %u 11 = 2 +x /s 11 = ba2e8ba +x %s 11 = 2 ~x = ffffffff7fffffff x & y = 80000000 x | y = 7fffffffffffffff @@ -1392,6 +1944,18 @@ x /u y2 = 1 x %u y2 = 0 x /s y3 = ffffffffffffffff x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 2 +x /s 3 = 2aaaaaaa +x %s 3 = 2 +x /u 5 = 19999999 +x %u 5 = 3 +x /s 5 = 19999999 +x %s 5 = 3 +x /u 11 = ba2e8ba +x %u 11 = 2 +x /s 11 = ba2e8ba +x %s 11 = 2 ~x = ffffffff7fffffff x & y = 0 x | y = 8000000080000000 @@ -1422,6 +1986,18 @@ x /u y2 = 80000000 x %u y2 = 0 x /s y3 = 80000000 x %s y3 = 0 +x /u 3 = 2aaaaaaa +x %u 3 = 2 +x /s 3 = 2aaaaaaa +x %s 3 = 2 +x /u 5 = 19999999 +x %u 5 = 3 +x /s 5 = 19999999 +x %s 5 = 3 +x /u 11 = ba2e8ba +x %u 11 = 2 +x /s 11 = ba2e8ba +x %s 11 = 2 ~x = ffffffff7fffffff x & y = 0 x | y = 180000003 @@ -1452,6 +2028,18 @@ x /u y2 = 1 x %u y2 = 467a43f x /s y3 = 1 x %s y3 = 467a43f +x /u 3 = 2aaaaaaa +x %u 3 = 2 +x /s 3 = 2aaaaaaa +x %s 3 = 2 +x /u 5 = 19999999 +x %u 5 = 3 +x /s 5 = 19999999 +x %s 5 = 3 +x /u 11 = ba2e8ba +x %u 11 = 2 +x /s 11 = ba2e8ba +x %s 11 = 2 ~x = ffffffff7fffffff x & y = 80000000 x | y = 7b985bc1e7bce4d7 @@ -1482,6 +2070,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 261ba3127a17215e +x %u 3 = 0 +x /s 3 = 261ba3127a17215e +x %s 3 = 0 +x /u 5 = 16dd61d7e2daad9e +x %u 5 = 4 +x /s 5 = 16dd61d7e2daad9e +x %s 5 = 4 +x /u 11 = a64a0d67e636630 +x %u 11 = a +x /s 11 = a64a0d67e636630 +x %s 11 = a ~x = 8dad16c891ba9be5 x & y = 0 x | y = 7252e937ee45641a @@ -1512,6 +2112,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaaaaaaaaaa +x %s 3 = 1 +x /u 5 = 1999999999999999 +x %u 5 = 2 +x /s 5 = 1999999999999999 +x %s 5 = 2 +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 7 +x /s 11 = ba2e8ba2e8ba2e8 +x %s 11 = 7 ~x = 8000000000000000 x & y = 0 x | y = 7fffffffffffffff @@ -1542,6 +2154,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaaaaaaaaaa +x %s 3 = 1 +x /u 5 = 1999999999999999 +x %u 5 = 2 +x /s 5 = 1999999999999999 +x %s 5 = 2 +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 7 +x /s 11 = ba2e8ba2e8ba2e8 +x %s 11 = 7 ~x = 8000000000000000 x & y = 1 x | y = 7fffffffffffffff @@ -1572,6 +2196,18 @@ x /u y2 = 80000000 x %u y2 = 7fffffff x /s y3 = 8000000000000001 x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaaaaaaaaaa +x %s 3 = 1 +x /u 5 = 1999999999999999 +x %u 5 = 2 +x /s 5 = 1999999999999999 +x %s 5 = 2 +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 7 +x /s 11 = ba2e8ba2e8ba2e8 +x %s 11 = 7 ~x = 8000000000000000 x & y = 7fffffffffffffff x | y = ffffffffffffffff @@ -1602,6 +2238,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaaaaaaaaaa +x %s 3 = 1 +x /u 5 = 1999999999999999 +x %u 5 = 2 +x /s 5 = 1999999999999999 +x %s 5 = 2 +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 7 +x /s 11 = ba2e8ba2e8ba2e8 +x %s 11 = 7 ~x = 8000000000000000 x & y = 7fffffff x | y = 7fffffffffffffff @@ -1632,6 +2280,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaaaaaaaaaa +x %s 3 = 1 +x /u 5 = 1999999999999999 +x %u 5 = 2 +x /s 5 = 1999999999999999 +x %s 5 = 2 +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 7 +x /s 11 = ba2e8ba2e8ba2e8 +x %s 11 = 7 ~x = 8000000000000000 x & y = 80000000 x | y = 7fffffffffffffff @@ -1662,6 +2322,18 @@ x /u y2 = 100000002 x %u y2 = 1 x /s y3 = 100000002 x %s y3 = 1 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaaaaaaaaaa +x %s 3 = 1 +x /u 5 = 1999999999999999 +x %u 5 = 2 +x /s 5 = 1999999999999999 +x %s 5 = 2 +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 7 +x /s 11 = ba2e8ba2e8ba2e8 +x %s 11 = 7 ~x = 8000000000000000 x & y = 7fffffffffffffff x | y = 7fffffffffffffff @@ -1692,6 +2364,18 @@ x /u y2 = ffffffff x %u y2 = 7fffffff x /s y3 = ffffffff00000001 x %s y3 = 7fffffff +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaaaaaaaaaa +x %s 3 = 1 +x /u 5 = 1999999999999999 +x %u 5 = 2 +x /s 5 = 1999999999999999 +x %s 5 = 2 +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 7 +x /s 11 = ba2e8ba2e8ba2e8 +x %s 11 = 7 ~x = 8000000000000000 x & y = 0 x | y = ffffffffffffffff @@ -1722,6 +2406,18 @@ x /u y2 = 7fffffffffffffff x %u y2 = 0 x /s y3 = 7fffffffffffffff x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaaaaaaaaaa +x %s 3 = 1 +x /u 5 = 1999999999999999 +x %u 5 = 2 +x /s 5 = 1999999999999999 +x %s 5 = 2 +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 7 +x /s 11 = ba2e8ba2e8ba2e8 +x %s 11 = 7 ~x = 8000000000000000 x & y = 100000003 x | y = 7fffffffffffffff @@ -1752,6 +2448,18 @@ x /u y2 = ca1d702e x %u y2 = 372ea79b x /s y3 = fffffffea2f0285c x %s y3 = 46eadf37 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaaaaaaaaaa +x %s 3 = 1 +x /u 5 = 1999999999999999 +x %u 5 = 2 +x /s 5 = 1999999999999999 +x %s 5 = 2 +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 7 +x /s 11 = ba2e8ba2e8ba2e8 +x %s 11 = 7 ~x = 8000000000000000 x & y = 2220229ec164ffe1 x | y = ffffffffffffffff @@ -1782,6 +2490,18 @@ x /u y2 = bafa9b4b x %u y2 = 608b627 x /s y3 = bafa9b4b x %s y3 = 608b627 +x /u 3 = 1f29c48c43af5e49 +x %u 3 = 1 +x /s 3 = 1f29c48c43af5e49 +x %s 3 = 1 +x /u 5 = 12b2a920f5693892 +x %u 5 = 2 +x /s 5 = 12b2a920f5693892 +x %s 5 = 2 +x /u 11 = 87fc13d86d2bc9f +x %u 11 = 7 +x /s 11 = 87fc13d86d2bc9f +x %s 11 = 7 ~x = a282b25b34f1e523 x & y = 5d7d4da4cb0e1adc x | y = 7fffffffffffffff @@ -1812,6 +2532,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 2 +x /s 3 = d555555555555556 +x %s 3 = fffffffffffffffe +x /u 5 = 1999999999999999 +x %u 5 = 3 +x /s 5 = e666666666666667 +x %s 5 = fffffffffffffffd +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 8 +x /s 11 = f45d1745d1745d18 +x %s 11 = fffffffffffffff8 ~x = 7fffffffffffffff x & y = 0 x | y = 8000000000000000 @@ -1842,6 +2574,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 2 +x /s 3 = d555555555555556 +x %s 3 = fffffffffffffffe +x /u 5 = 1999999999999999 +x %u 5 = 3 +x /s 5 = e666666666666667 +x %s 5 = fffffffffffffffd +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 8 +x /s 11 = f45d1745d1745d18 +x %s 11 = fffffffffffffff8 ~x = 7fffffffffffffff x & y = 0 x | y = 8000000000000001 @@ -1872,6 +2616,18 @@ x /u y2 = 80000000 x %u y2 = 80000000 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 2 +x /s 3 = d555555555555556 +x %s 3 = fffffffffffffffe +x /u 5 = 1999999999999999 +x %u 5 = 3 +x /s 5 = e666666666666667 +x %s 5 = fffffffffffffffd +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 8 +x /s 11 = f45d1745d1745d18 +x %s 11 = fffffffffffffff8 ~x = 7fffffffffffffff x & y = 8000000000000000 x | y = ffffffffffffffff @@ -1902,6 +2658,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 2 +x /s 3 = d555555555555556 +x %s 3 = fffffffffffffffe +x /u 5 = 1999999999999999 +x %u 5 = 3 +x /s 5 = e666666666666667 +x %s 5 = fffffffffffffffd +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 8 +x /s 11 = f45d1745d1745d18 +x %s 11 = fffffffffffffff8 ~x = 7fffffffffffffff x & y = 0 x | y = 800000007fffffff @@ -1932,6 +2700,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 2 +x /s 3 = d555555555555556 +x %s 3 = fffffffffffffffe +x /u 5 = 1999999999999999 +x %u 5 = 3 +x /s 5 = e666666666666667 +x %s 5 = fffffffffffffffd +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 8 +x /s 11 = f45d1745d1745d18 +x %s 11 = fffffffffffffff8 ~x = 7fffffffffffffff x & y = 0 x | y = 8000000080000000 @@ -1962,6 +2742,18 @@ x /u y2 = 100000002 x %u y2 = 2 x /s y3 = fffffffefffffffe x %s y3 = fffffffffffffffe +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 2 +x /s 3 = d555555555555556 +x %s 3 = fffffffffffffffe +x /u 5 = 1999999999999999 +x %u 5 = 3 +x /s 5 = e666666666666667 +x %s 5 = fffffffffffffffd +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 8 +x /s 11 = f45d1745d1745d18 +x %s 11 = fffffffffffffff8 ~x = 7fffffffffffffff x & y = 0 x | y = ffffffffffffffff @@ -1992,6 +2784,18 @@ x /u y2 = 100000000 x %u y2 = 0 x /s y3 = 100000000 x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 2 +x /s 3 = d555555555555556 +x %s 3 = fffffffffffffffe +x /u 5 = 1999999999999999 +x %u 5 = 3 +x /s 5 = e666666666666667 +x %s 5 = fffffffffffffffd +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 8 +x /s 11 = f45d1745d1745d18 +x %s 11 = fffffffffffffff8 ~x = 7fffffffffffffff x & y = 8000000000000000 x | y = 8000000000000000 @@ -2022,6 +2826,18 @@ x /u y2 = 8000000000000000 x %u y2 = 0 x /s y3 = 8000000000000000 x %s y3 = 0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 2 +x /s 3 = d555555555555556 +x %s 3 = fffffffffffffffe +x /u 5 = 1999999999999999 +x %u 5 = 3 +x /s 5 = e666666666666667 +x %s 5 = fffffffffffffffd +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 8 +x /s 11 = f45d1745d1745d18 +x %s 11 = fffffffffffffff8 ~x = 7fffffffffffffff x & y = 0 x | y = 8000000100000003 @@ -2052,6 +2868,18 @@ x /u y2 = a4795a4ab x %u y2 = 13c1551 x /s y3 = fffffff5b86a5b55 x %s y3 = fffffffffec3eaaf +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 2 +x /s 3 = d555555555555556 +x %s 3 = fffffffffffffffe +x /u 5 = 1999999999999999 +x %u 5 = 3 +x /s 5 = e666666666666667 +x %s 5 = fffffffffffffffd +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 8 +x /s 11 = f45d1745d1745d18 +x %s 11 = fffffffffffffff8 ~x = 7fffffffffffffff x & y = 0 x | y = 8c73aa0d9a415dfb @@ -2082,6 +2910,18 @@ x /u y2 = 31d220f5 x %u y2 = 399b8b6e x /s y3 = ffffffffce2ddf0b x %s y3 = 399b8b6e +x /u 3 = 84db028e8892e7a +x %u 3 = 0 +x /s 3 = 84db028e8892e7a +x %s 3 = 0 +x /u 5 = 4fb69b2251f1be2 +x %u 5 = 4 +x /s 5 = 4fb69b2251f1be2 +x %s 5 = 4 +x /u 11 = 243bbae10df984f +x %u 11 = 9 +x /s 11 = 243bbae10df984f +x %s 11 = 9 ~x = e716ef8546647491 x & y = 0 x | y = 98e9107ab99b8b6e @@ -2112,6 +2952,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 55555556 +x %u 3 = 1 +x /s 3 = 55555556 +x %s 3 = 1 +x /u 5 = 33333333 +x %u 5 = 4 +x /s 5 = 33333333 +x %s 5 = 4 +x /u 11 = 1745d174 +x %u 11 = 7 +x /s 11 = 1745d174 +x %s 11 = 7 ~x = fffffffefffffffc x & y = 0 x | y = 100000003 @@ -2142,6 +2994,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 55555556 +x %u 3 = 1 +x /s 3 = 55555556 +x %s 3 = 1 +x /u 5 = 33333333 +x %u 5 = 4 +x /s 5 = 33333333 +x %s 5 = 4 +x /u 11 = 1745d174 +x %u 11 = 7 +x /s 11 = 1745d174 +x %s 11 = 7 ~x = fffffffefffffffc x & y = 1 x | y = 100000003 @@ -2172,6 +3036,18 @@ x /u y2 = 1 x %u y2 = 4 x /s y3 = fffffffefffffffd x %s y3 = 0 +x /u 3 = 55555556 +x %u 3 = 1 +x /s 3 = 55555556 +x %s 3 = 1 +x /u 5 = 33333333 +x %u 5 = 4 +x /s 5 = 33333333 +x %s 5 = 4 +x /u 11 = 1745d174 +x %u 11 = 7 +x /s 11 = 1745d174 +x %s 11 = 7 ~x = fffffffefffffffc x & y = 100000003 x | y = ffffffffffffffff @@ -2202,6 +3078,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 55555556 +x %u 3 = 1 +x /s 3 = 55555556 +x %s 3 = 1 +x /u 5 = 33333333 +x %u 5 = 4 +x /s 5 = 33333333 +x %s 5 = 4 +x /u 11 = 1745d174 +x %u 11 = 7 +x /s 11 = 1745d174 +x %s 11 = 7 ~x = fffffffefffffffc x & y = 3 x | y = 17fffffff @@ -2232,6 +3120,18 @@ x /u y2 = 0 x %u y2 = 0 x /s y3 = 0 x %s y3 = 0 +x /u 3 = 55555556 +x %u 3 = 1 +x /s 3 = 55555556 +x %s 3 = 1 +x /u 5 = 33333333 +x %u 5 = 4 +x /s 5 = 33333333 +x %s 5 = 4 +x /u 11 = 1745d174 +x %u 11 = 7 +x /s 11 = 1745d174 +x %s 11 = 7 ~x = fffffffefffffffc x & y = 0 x | y = 180000003 @@ -2262,6 +3162,18 @@ x /u y2 = 2 x %u y2 = 5 x /s y3 = 2 x %s y3 = 5 +x /u 3 = 55555556 +x %u 3 = 1 +x /s 3 = 55555556 +x %s 3 = 1 +x /u 5 = 33333333 +x %u 5 = 4 +x /s 5 = 33333333 +x %s 5 = 4 +x /u 11 = 1745d174 +x %u 11 = 7 +x /s 11 = 1745d174 +x %s 11 = 7 ~x = fffffffefffffffc x & y = 100000003 x | y = 7fffffffffffffff @@ -2292,6 +3204,18 @@ x /u y2 = 2 x %u y2 = 3 x /s y3 = fffffffffffffffe x %s y3 = 3 +x /u 3 = 55555556 +x %u 3 = 1 +x /s 3 = 55555556 +x %s 3 = 1 +x /u 5 = 33333333 +x %u 5 = 4 +x /s 5 = 33333333 +x %s 5 = 4 +x /u 11 = 1745d174 +x %u 11 = 7 +x /s 11 = 1745d174 +x %s 11 = 7 ~x = fffffffefffffffc x & y = 0 x | y = 8000000100000003 @@ -2322,6 +3246,18 @@ x /u y2 = 100000003 x %u y2 = 0 x /s y3 = 100000003 x %s y3 = 0 +x /u 3 = 55555556 +x %u 3 = 1 +x /s 3 = 55555556 +x %s 3 = 1 +x /u 5 = 33333333 +x %u 5 = 4 +x /s 5 = 33333333 +x %s 5 = 4 +x /u 11 = 1745d174 +x %u 11 = 7 +x /s 11 = 1745d174 +x %s 11 = 7 ~x = fffffffefffffffc x & y = 100000003 x | y = 100000003 @@ -2352,6 +3288,18 @@ x /u y2 = 1 x %u y2 = 16432d9b x /s y3 = fffffffffffffff5 x %s y3 = b1d0a7b +x /u 3 = 55555556 +x %u 3 = 1 +x /s 3 = 55555556 +x %s 3 = 1 +x /u 5 = 33333333 +x %u 5 = 4 +x /s 5 = 33333333 +x %s 5 = 4 +x /u 11 = 1745d174 +x %u 11 = 7 +x /s 11 = 1745d174 +x %s 11 = 7 ~x = fffffffefffffffc x & y = 1 x | y = e9bcd26990f095a7 @@ -2382,6 +3330,18 @@ x /u y2 = 329cb23ce0f7aa50 x %u y2 = 0 x /s y3 = 329cb23ce0f7aa50 x %s y3 = 0 +x /u 3 = 10dee6144afd38c5 +x %u 3 = 1 +x /s 3 = 10dee6144afd38c5 +x %s 3 = 1 +x /u 5 = a1f56d8f9cb2210 +x %u 5 = 0 +x /s 5 = a1f56d8f9cb2210 +x %s 5 = 0 +x /u 11 = 499e1a8718ae0f0 +x %u 11 = 0 +x /s 11 = 499e1a8718ae0f0 +x %s 11 = 0 ~x = cd634dc31f0855af x & y = 0 x | y = 329cb23de0f7aa53 @@ -2412,6 +3372,18 @@ x /u y2 = 86cb918b x %u y2 = 910b6dd3 x /s y3 = 133e437097 x %s y3 = fffffffffe99a023 +x /u 3 = 2bcb8e3115aa0b1f +x %u 3 = 2 +x /s 3 = d67638dbc054b5cb +x %s 3 = fffffffffffffffe +x /u 5 = 1a46eeea4032d379 +x %u 5 = 2 +x /s 5 = e713bbb70cffa047 +x %s 5 = fffffffffffffffc +x /u 11 = bf1b26a7a45a5f1 +x %u 11 = 4 +x /s 11 = f4abe0f61d2e6020 +x %s 11 = ffffffffffffffff ~x = 7c9d556cbf01dea0 x & y = 8102200000ec0002 x | y = fbe6beb756fea15f @@ -2442,6 +3414,18 @@ x /u y2 = 84c9e8f3 x %u y2 = 27966e44 x /s y3 = 84c9e8f3 x %s y3 = 27966e44 +x /u 3 = 122ad667ce8c5538 +x %u 3 = 1 +x /s 3 = 122ad667ce8c5538 +x %s 3 = 1 +x /u 5 = ae680a4af20ffee +x %u 5 = 3 +x /s 5 = ae680a4af20ffee +x %s 5 = 3 +x /u 11 = 4f4690509c92e83 +x %u 11 = 8 +x /s 11 = 4f4690509c92e83 +x %s 11 = 8 ~x = c97f7cc8945b0056 x & y = 2000820723804900 x | y = 7f92b377ffbeffad @@ -2472,6 +3456,18 @@ x /u y2 = e9932394 x %u y2 = bed9fbb x /s y3 = 142f786e7 x %s y3 = ffffffffe6446d5d +x /u 3 = 3a53921f27b11bab +x %u 3 = 2 +x /s 3 = e4fe3cc9d25bc657 +x %s 3 = fffffffffffffffe +x /u 5 = 22fef145e49d7700 +x %u 5 = 3 +x /s 5 = efcbbe12b16a43ce +x %s 5 = fffffffffffffffd +x /u 11 = fe83f1fc501c1ba +x %u 11 = 5 +x /s 11 = f8a26dab67ea7be9 +x %s 11 = 0 ~x = 510549a288ecacfc x & y = aec2264830121102 x | y = bffff67ff7bbd7d7 @@ -2502,6 +3498,18 @@ x /u y2 = 49889cbcc x %u y2 = d961931 x /s y3 = ffffffff5078c8f7 x %s y3 = fffffffffb32ee6a +x /u 3 = 4a4153351cb255f9 +x %u 3 = 2 +x /s 3 = f4ebfddfc75d00a5 +x %s 3 = fffffffffffffffe +x /u 5 = 2c8d98531137cd2f +x %u 5 = 2 +x /s 5 = f95a651fde0499fd +x %s 5 = fffffffffffffffc +x /u 11 = 14405c82d947e8e7 +x %u 11 = 0 +x /s 11 = fcfa8b0e7c30a316 +x %s 11 = fffffffffffffffb ~x = 213c0660a9e8fe12 x & y = 10409095561000e8 x | y = fefbfbdffe5f6bfd @@ -2532,6 +3540,18 @@ x /u y2 = 111c647a7 x %u y2 = 2a35fbed x /s y3 = 111c647a7 x %s y3 = 2a35fbed +x /u 3 = 295ca3b37973c7a2 +x %u 3 = 1 +x /s 3 = 295ca3b37973c7a2 +x %s 3 = 1 +x /u 5 = 18d12f0548df1161 +x %u 5 = 2 +x /s 5 = 18d12f0548df1161 +x %s 5 = 2 +x /u 11 = b47cf8e09d9c215 +x %u 11 = 0 +x /s 11 = b47cf8e09d9c215 +x %s 11 = 0 ~x = 83ea14e593a4a918 x & y = 740588126c0140e2 x | y = 7c17ef7e7c5f76ef @@ -2562,6 +3582,18 @@ x /u y2 = 67e883b7 x %u y2 = 4d949d8f x /s y3 = 67e883b7 x %s y3 = 4d949d8f +x /u 3 = f0e444b6fdfe025 +x %u 3 = 2 +x /s 3 = f0e444b6fdfe025 +x %s 3 = 2 +x /u 5 = 9088f6076532016 +x %u 5 = 3 +x /s 5 = 9088f6076532016 +x %s 5 = 3 +x /u 11 = 41b29e6073d0e95 +x %u 11 = a +x /s 11 = 41b29e6073d0e95 +x %s 11 = a ~x = d2d5331db0605f8e x & y = 2d02482204938020 x | y = 6f6fecee5fdfe47d @@ -2592,6 +3624,18 @@ x /u y2 = 203527d3 x %u y2 = 339f3657 x /s y3 = ffffffffcf52411e x %s y3 = 47c75183 +x /u 3 = 67605b7f984f059 +x %u 3 = 0 +x /s 3 = 67605b7f984f059 +x %s 3 = 0 +x /u 5 = 3e069d4c8e95d02 +x %u 5 = 1 +x /s 5 = 3e069d4c8e95d02 +x %s 5 = 1 +x /u 11 = 1c318d5158158d2 +x %u 11 = 5 +x /s 11 = 1c318d5158158d2 +x %s 11 = 5 ~x = ec9deed813712ef4 x & y = 12001124448c910a x | y = 9b729dfffd9ff53f @@ -2622,6 +3666,18 @@ x /u y2 = 57ad3b593 x %u y2 = 7501355 x /s y3 = 57ad3b593 x %s y3 = 7501355 +x /u 3 = 18e5589b620ab511 +x %u 3 = 2 +x /s 3 = 18e5589b620ab511 +x %s 3 = 2 +x /u 5 = ef001f6d46cd30a +x %u 5 = 3 +x /s 5 = ef001f6d46cd30a +x %s 5 = 3 +x /u 11 = 6ca2f703202eb90 +x %u 11 = 5 +x /s 11 = 6ca2f703202eb90 +x %s 11 = 5 ~x = b54ff62dd9dfe0ca x & y = 8a0008000200820 x | y = 4fb139f2a6615fb5 @@ -2652,6 +3708,18 @@ x /u y2 = 3affbc857 x %u y2 = 2cd84c77 x /s y3 = fffffffe19aa1e7c x %s y3 = ffffffffe134208f +x /u 3 = 385181e6dae2e1cf +x %u 3 = 2 +x /s 3 = e2fc2c91858d8c7b +x %s 3 = fffffffffffffffe +x /u 5 = 21ca81241cee877c +x %u 5 = 3 +x /s 5 = ee974df0e9bb544a +x %s 5 = fffffffffffffffd +x /u 11 = f5c0c27b00f54db +x %u 11 = 6 +x /s 11 = f8163ab352f80f0b +x %s 11 = fffffffffffffff6 ~x = 570b7a4b6f575a90 x & y = 28d0818000a8a442 x | y = adf5b7fcdcb9a7ff @@ -2682,6 +3750,18 @@ x /u y2 = ed62a033 x %u y2 = 9a9c1784 x /s y3 = 1317fc5dc x %s y3 = ffffffffdaba2cf5 +x /u 3 = 3980e6c0ff575613 +x %u 3 = 0 +x /s 3 = e42b916baa0200be +x %s 3 = ffffffffffffffff +x /u 5 = 22808a73cc679a0b +x %u 5 = 2 +x /s 5 = ef4d5740993466d9 +x %s 5 = fffffffffffffffc +x /u 11 = faeca91ba008bd6 +x %u 11 = 7 +x /s 11 = f868f91d5ce94606 +x %s 11 = fffffffffffffff7 ~x = 537d4bbd01f9fdc6 x & y = a8008042d0040010 x | y = be8bf577febf2e7d @@ -2712,6 +3792,18 @@ x /u y2 = 1457fa721 x %u y2 = 62f7b025 x /s y3 = aca563d9 x %s y3 = fffffffffc51c715 +x /u 3 = 3b2ad00c14d8a806 +x %u 3 = 1 +x /s 3 = e5d57ab6bf8352b1 +x %s 3 = 0 +x /u 5 = 2380166da61b9803 +x %u 5 = 4 +x /s 5 = f04ce33a72e864d1 +x %s 5 = fffffffffffffffe +x /u 11 = 1022f2ec05af73a4 +x %u 11 = 7 +x /s 11 = f8dd2177a8982dd4 +x %s 11 = fffffffffffffff7 ~x = 4e7f8fdbc17607ec x & y = 818040242e888802 x | y = bb9a702e7ec9f9b7 @@ -2742,6 +3834,18 @@ x /u y2 = 401f99d2e x %u y2 = 1b8b48d5 x /s y3 = fffffffc1b6b5e46 x %s y3 = ffffffffebae19b5 +x /u 3 = 2b4968cb1b85047f +x %u 3 = 0 +x /s 3 = d5f41375c62faf2a +x %s 3 = ffffffffffffffff +x /u 5 = 19f8d879dd4fcf7f +x %u 5 = 2 +x /s 5 = e6c5a546aa1c9c4d +x %s 5 = fffffffffffffffc +x /u 11 = bce33da4d52d2ae +x %u 11 = 3 +x /s 11 = f4886265f03b8cdd +x %s 11 = fffffffffffffffe ~x = 7e23c59ead70f282 x & y = 440a40428e0148 x | y = a1ff3eed77ffef7d @@ -2772,6 +3876,18 @@ x /u y2 = 1cdd42781 x %u y2 = 8307e40 x /s y3 = 1cdd42781 x %s y3 = 8307e40 +x /u 3 = 6d86bd5739f6452 +x %u 3 = 1 +x /s 3 = 6d86bd5739f6452 +x %s 3 = 1 +x /u 5 = 41b73e67892d5cb +x %u 5 = 0 +x /s 5 = 41b73e67892d5cb +x %s 5 = 0 +x /u 11 = 1ddeedd1f888fb9 +x %u 11 = 4 +x /s 11 = 1ddeedd1f888fb9 +x %s 11 = 4 ~x = eb76bc7fa521d308 x & y = 200088620b2 x | y = 1feb73b7fadefdff @@ -2802,6 +3918,18 @@ x /u y2 = 1ac3a0a48 x %u y2 = f8ff129 x /s y3 = 1ac3a0a48 x %s y3 = f8ff129 +x /u 3 = 11dcf2a0d0c46c55 +x %u 3 = 2 +x /s 3 = 11dcf2a0d0c46c55 +x %s 3 = 2 +x /u 5 = ab7c4c6e3a90dcd +x %u 5 = 0 +x /s 5 = ab7c4c6e3a90dcd +x %s 5 = 0 +x /u 11 = 4df2ae60a641d8b +x %u 11 = 8 +x /s 11 = 4df2ae60a641d8b +x %s 11 = 8 ~x = ca69281d8db2bafe x & y = 200051a2504d0100 x | y = 359fd7e3fbcd657d @@ -2832,6 +3960,18 @@ x /u y2 = 2464000e3 x %u y2 = d195088 x /s y3 = fffffffdd7d46212 x %s y3 = fffffffffcbb11e9 +x /u 3 = 2bcc4928c5bfa2b3 +x %u 3 = 2 +x /s 3 = d676f3d3706a4d5f +x %s 3 = fffffffffffffffe +x /u 5 = 1a475f1876a62e6b +x %u 5 = 4 +x /s 5 = e7142be54372fb39 +x %s 5 = fffffffffffffffe +x /u 11 = bf1e56835ee7231 +x %u 11 = 0 +x /s 11 = f4ac13f3d8d72c60 +x %s 11 = fffffffffffffffb ~x = 7c9b2485aec117e4 x & y = 14419101012a00a x | y = bbe5fffbd17efb1f @@ -2862,6 +4002,18 @@ x /u y2 = 195403f42 x %u y2 = 67e00199 x /s y3 = ffffffff94c3b859 x %s y3 = ffffffffd787355f +x /u 3 = 437a4bcf93f8f997 +x %u 3 = 0 +x /s 3 = ee24f67a3ea3a442 +x %s 3 = ffffffffffffffff +x /u 5 = 287c93e2f2622f5a +x %u 5 = 3 +x /s 5 = f54960afbf2efc28 +x %s 5 = fffffffffffffffd +x /u 11 = 12672bf2cb43e6fa +x %u 11 = 7 +x /s 11 = fb215a7e6e2ca12a +x %s 11 = fffffffffffffff7 ~x = 35911c914415133a x & y = 4a60e14691c0c8c0 x | y = ffeee7fefffbfef5 @@ -2892,6 +4044,18 @@ x /u y2 = 292cea58 x %u y2 = 301cdf07 x /s y3 = 292cea58 x %s y3 = 301cdf07 +x /u 3 = 4dd7b8dc788047f +x %u 3 = 2 +x /s 3 = 4dd7b8dc788047f +x %s 3 = 2 +x /u 5 = 2eb4a21de1e6919 +x %u 5 = 2 +x /s 5 = 2eb4a21de1e6919 +x %s 5 = 2 +x /u 11 = 153ad55366ae9f4 +x %u 11 = 3 +x /s 11 = 153ad55366ae9f4 +x %s 11 = 3 ~x = f1678d56a967f280 x & y = a98120904980122 x | y = 5ebefbad7fbeedff @@ -2922,6 +4086,18 @@ x /u y2 = ce682040 x %u y2 = 8882909 x /s y3 = 16845c4311 x %s y3 = fffffffffe31f1da +x /u 3 = 4430365b0a64d843 +x %u 3 = 0 +x /s 3 = eedae105b50f82ee +x %s 3 = ffffffffffffffff +x /u 5 = 28e9ba369fd61b5b +x %u 5 = 2 +x /s 5 = f5b687036ca2e829 +x %s 5 = fffffffffffffffc +x /u 11 = 1298c9018e789812 +x %u 11 = 3 +x /s 11 = fb52f78d31615241 +x %s 11 = fffffffffffffffe ~x = 336f5ceee0d17736 x & y = cc902111112e0080 x | y = fdb7bbffdf6ecbed @@ -2952,6 +4128,18 @@ x /u y2 = ff48210c x %u y2 = 6c4e224b x /s y3 = 114ef78ac x %s y3 = ffffffffff84590b +x /u 3 = 524579262dee95b6 +x %u 3 = 1 +x /s 3 = fcf023d0d8994061 +x %s 3 = 0 +x /u 5 = 315ce24a1b8f26a0 +x %u 5 = 3 +x /s 5 = fe29af16e85bf36e +x %s 5 = fffffffffffffffd +x /u 11 = 167009c49829cbbd +x %u 11 = 4 +x /s 11 = ff2a38503b1285ec +x %s 11 = ffffffffffffffff ~x = 92f948d76343edc x & y = f68021120043c122 x | y = f7d27b729befd177 @@ -2982,6 +4170,18 @@ x /u y2 = 27bb1964 x %u y2 = 7672b2b1 x /s y3 = ffffffff68dce4e4 x %s y3 = 1d207631 +x /u 3 = a7ca1b7e214f459 +x %u 3 = 2 +x /s 3 = a7ca1b7e214f459 +x %s 3 = 2 +x /u 5 = 64ac76e5472f902 +x %u 5 = 3 +x /s 5 = 64ac76e5472f902 +x %s 5 = 3 +x /u 11 = 2dc2c1ae09159e9 +x %u 11 = a +x /s 11 = 2dc2c1ae09159e9 +x %s 11 = a ~x = e08a1ad859c122f2 x & y = a340027a42ecd08 x | y = dff7ff6fe6bedf9d @@ -3012,6 +4212,18 @@ x /u y2 = 28349b7ce x %u y2 = 24b397b7 x /s y3 = 28349b7ce x %s y3 = 24b397b7 +x /u 3 = 229daae6f2322257 +x %u 3 = 2 +x /s 3 = 229daae6f2322257 +x %s 3 = 2 +x /u 5 = 14c500242aeae167 +x %u 5 = 4 +x /s 5 = 14c500242aeae167 +x %s 5 = 4 +x /u 11 = 970d184cdb09500 +x %u 11 = 7 +x /s 11 = 970d184cdb09500 +x %s 11 = 7 ~x = 9826ff4b296998f8 x & y = 2151001050060602 x | y = 6fdba6bcde97778f @@ -3042,6 +4254,18 @@ x /u y2 = 12c706881 x %u y2 = 3974fe7b x /s y3 = fffffffefe5ea0d2 x %s y3 = ffffffffe980f385 +x /u 3 = 2df08781ae624f30 +x %u 3 = 1 +x /s 3 = d89b322c590cf9db +x %s 3 = 0 +x /u 5 = 1b90514dcf07c91d +x %u 5 = 0 +x /s 5 = e85d1e1a9bd495ea +x %s 5 = ffffffffffffffff +x /u 11 = c876ac646d4fe53 +x %u 11 = 0 +x /s 11 = f5419951e9bdb882 +x %s 11 = fffffffffffffffb ~x = 762e697af4d9126e x & y = 14094040a262080 x | y = fdfff6978f7fffdd @@ -3072,6 +4296,18 @@ x /u y2 = 2e1d4dc x %u y2 = cb2df2bf x /s y3 = fffffffff2ac0c93 x %s y3 = 2a546e24 +x /u 3 = ca370abf90e10e +x %u 3 = 1 +x /s 3 = ca370abf90e10e +x %s 3 = 1 +x /u 5 = 795439a623ba3b +x %u 5 = 4 +x /s 5 = 795439a623ba3b +x %s 5 = 4 +x /u 11 = 372648bfe1b1be +x %u 11 = 1 +x /s 11 = 372648bfe1b1be +x %s 11 = 1 ~x = fda15adfc14d5cd4 x & y = 25aa0201682800a x | y = d27fb73d7ff7a7ff @@ -3102,6 +4338,18 @@ x /u y2 = 98de5aed x %u y2 = 81b9d719 x /s y3 = ffffffff312686c0 x %s y3 = 67db7555 +x /u 3 = 1d4d2c23df3354c7 +x %u 3 = 0 +x /s 3 = 1d4d2c23df3354c7 +x %s 3 = 0 +x /u 5 = 1194b41585eb9944 +x %u 5 = 1 +x /s 5 = 1194b41585eb9944 +x %s 5 = 1 +x /u 11 = 7fdc638542545aa +x %u 11 = 7 +x /s 11 = 7fdc638542545aa +x %s 11 = 7 ~x = a8187b94626601aa x & y = 1325002814186040 x | y = d7f7d4efdd9fff55 @@ -3132,6 +4380,18 @@ x /u y2 = 2637b00b x %u y2 = 4a30bdb x /s y3 = 2637b00b x %s y3 = 4a30bdb +x /u 3 = 2a81370cf14732f +x %u 3 = 2 +x /s 3 = 2a81370cf14732f +x %s 3 = 2 +x /u 5 = 1980baa15d911e9 +x %u 5 = 2 +x /s 5 = 1980baa15d911e9 +x %s 5 = 2 +x /u 11 = b979aa670593c7 +x %u 11 = 2 +x /s 11 = b979aa670593c7 +x %s 11 = 2 ~x = f807c5ad92c2a670 x & y = 56030102c191002 x | y = 37fa7fde6ffd79ff @@ -3162,6 +4422,18 @@ x /u y2 = 2149e9078 x %u y2 = 3157ec11 x /s y3 = ffffffffbbb6b39e x %s y3 = ffffffff9f7efd07 +x /u 3 = 4ba2da01fefd311d +x %u 3 = 2 +x /s 3 = f64d84aca9a7dbc9 +x %s 3 = fffffffffffffffe +x /u 5 = 2d61b6013297ea45 +x %u 5 = 0 +x /s 5 = fa2e82cdff64b712 +x %s 5 = ffffffffffffffff +x /u 11 = 14a0c717d12dc793 +x %u 11 = 8 +x /s 11 = fd5af5a3741681c3 +x %s 11 = fffffffffffffff8 ~x = 1d1771fa03086ca6 x & y = 600880056cd28250 x | y = efefef87fff79ffd @@ -3192,6 +4464,18 @@ x /u y2 = 178126fd x %u y2 = 75bd3a7 x /s y3 = ffffffffe1f1945e x %s y3 = 5ca580ab +x /u 3 = 465888d92c88f66 +x %u 3 = 1 +x /s 3 = 465888d92c88f66 +x %s 3 = 1 +x /u 5 = 2a351ee8b4522d7 +x %u 5 = 0 +x /s 5 = 2a351ee8b4522d7 +x %s 5 = 0 +x /u 11 = 132f6b23f4df890 +x %u 11 = 3 +x /s 11 = 132f6b23f4df890 +x %s 11 = 3 ~x = f2cf665747a651cc x & y = d20182820412c02 x | y = 8fb8d9fcfc5def77 @@ -3222,6 +4506,18 @@ x /u y2 = 3aa02d06b x %u y2 = 8d30eae x /s y3 = fffffffe83ee35ed x %s y3 = ffffffffdeff9c14 +x /u 3 = 3cba371623852589 +x %u 3 = 2 +x /s 3 = e764e1c0ce2fd035 +x %s 3 = fffffffffffffffe +x /u 5 = 246fbaa6e21cb01f +x %u 5 = 2 +x /s 5 = f13c8773aee97ced +x %s 5 = fffffffffffffffc +x /u 11 = 108fe07a66c738c8 +x %u 11 = 5 +x /s 11 = f94a0f0609aff2f7 +x %s 11 = 0 ~x = 49d15abd95708f62 x & y = 30288500028d2088 x | y = b7bea5cf6adf7ffd @@ -3252,6 +4548,18 @@ x /u y2 = 7cd84df1 x %u y2 = 1c098191 x /s y3 = 7cd84df1 x %s y3 = 1c098191 +x /u 3 = f86ee25fc5c5707 +x %u 3 = 2 +x /s 3 = f86ee25fc5c5707 +x %s 3 = 2 +x /u 5 = 950f549fdd10104 +x %u 5 = 3 +x /s 5 = 950f549fdd10104 +x %s 5 = 3 +x /u 11 = 43c1267735f0076 +x %u 11 = 5 +x /s 11 = 43c1267735f0076 +x %s 11 = 5 ~x = d16b358e0aeafae8 x & y = e84486044000512 x | y = 7f94cff7f517cf5f @@ -3282,6 +4590,18 @@ x /u y2 = 511ed4ac8 x %u y2 = 27f86a1 x /s y3 = 511ed4ac8 x %s y3 = 27f86a1 +x /u 3 = 20945a3de80c88b5 +x %u 3 = 2 +x /s 3 = 20945a3de80c88b5 +x %s 3 = 2 +x /u 5 = 138c362524d45206 +x %u 5 = 3 +x /s 5 = 138c362524d45206 +x %s 5 = 3 +x /u 11 = 8e2a43f6dd4df77 +x %u 11 = 4 +x /s 11 = 8e2a43f6dd4df77 +x %s 11 = 4 ~x = 9e42f14647da65de x & y = 10506b038249800 x | y = 73ff1ff9feaffa3d @@ -3312,6 +4632,18 @@ x /u y2 = 751173e7 x %u y2 = 4f1d5ff0 x /s y3 = ffffffff88c0657c x %s y3 = 3027aaf +x /u 3 = 13b0fe02eb2e5613 +x %u 3 = 2 +x /s 3 = 13b0fe02eb2e5613 +x %s 3 = 2 +x /u 5 = bd0986826b566d8 +x %u 5 = 3 +x /s 5 = bd0986826b566d8 +x %s 5 = 3 +x /u 11 = 55ed0e985f55d4b +x %u 11 = 2 +x /s 11 = 55ed0e985f55d4b +x %s 11 = 2 ~x = c4ed05f73e74fdc4 x & y = 1025008c109022a x | y = bb3efbfdc3cb2abf @@ -3342,6 +4674,18 @@ x /u y2 = a405e4b4 x %u y2 = 4f86312d x /s y3 = a405e4b4 x %s y3 = 4f86312d +x /u 3 = 115e81465ce7714c +x %u 3 = 1 +x /s 3 = 115e81465ce7714c +x %s 3 = 1 +x /u 5 = a6be72a37be10c7 +x %u 5 = 2 +x /s 5 = a6be72a37be10c7 +x %s 5 = 2 +x /u 11 = 4bcaee4a4f94d71 +x %u 11 = a +x /s 11 = 4bcaee4a4f94d71 +x %s 11 = a ~x = cbe47c2ce949ac1a x & y = 1013800210125380 x | y = 755bbff73fffdbf5 @@ -3372,6 +4716,18 @@ x /u y2 = 7c9e1383 x %u y2 = 89a32be1 x /s y3 = fffffffe57830a86 x %s y3 = 83cdb23 +x /u 3 = 201cac35b86dd88a +x %u 3 = 1 +x /s 3 = 201cac35b86dd88a +x %s 3 = 1 +x /u 5 = 134467536ea84eb9 +x %u 5 = 2 +x /s 5 = 134467536ea84eb9 +x %s 5 = 2 +x /u 11 = 8c2006bbdef699a +x %u 11 = 1 +x /s 11 = 8c2006bbdef699a +x %s 11 = 1 ~x = 9fa9fb5ed6b67660 x & y = 404600a000018102 x | y = e5f6dceb2b6d9bdf @@ -3402,6 +4758,18 @@ x /u y2 = 156e6b4cb x %u y2 = caae302 x /s y3 = ffffffff09523710 x %s y3 = ffffffffa5f4f199 +x /u 3 = 31a14ca0c328b5f8 +x %u 3 = 1 +x /s 3 = dc4bf74b6dd360a3 +x %s 3 = 0 +x /u 5 = 1dc72dfa0eb206c8 +x %u 5 = 1 +x /s 5 = ea93fac6db7ed395 +x %s 5 = 0 +x /u 11 = d8914e606ae0315 +x %u 11 = 2 +x /s 11 = f6434371a996bd44 +x %s 11 = fffffffffffffffd ~x = 6b1c1a1db685de16 x & y = 42024c0414a0040 x | y = ffebf7f7697f2fed @@ -3432,6 +4800,18 @@ x /u y2 = 7fac2866 x %u y2 = 15d50693 x /s y3 = 7fac2866 x %s y3 = 15d50693 +x /u 3 = ecb77d397fc3fc1 +x %u 3 = 0 +x /s 3 = ecb77d397fc3fc1 +x %s 3 = 0 +x /u 5 = 8e07b188e642640 +x %u 5 = 3 +x /s 5 = 8e07b188e642640 +x %s 5 = 3 +x /u 11 = 408f2226f44cb91 +x %u 11 = 8 +x /s 11 = 408f2226f44cb91 +x %s 11 = 8 ~x = d39d9885380b40bc x & y = 862024886441d02 x | y = 7cff7f7afffeff57 @@ -3462,6 +4842,18 @@ x /u y2 = 5d8f7413 x %u y2 = 2f76d45d x /s y3 = fffffffcb6a49899 x %s y3 = d7812bd +x /u 3 = 1c10d99a006342b9 +x %u 3 = 2 +x /s 3 = 1c10d99a006342b9 +x %s 3 = 2 +x /u 5 = 10d6e8f6003b8e6f +x %u 5 = 2 +x /s 5 = 10d6e8f6003b8e6f +x %s 5 = 2 +x /u 11 = 7a7812a001b1232 +x %u 11 = 7 +x /s 11 = 7a7812a001b1232 +x %s 11 = 7 ~x = abcd7331fed637d2 x & y = 442084c000290028 x | y = f6739efec53fcc3d @@ -3492,6 +4884,18 @@ x /u y2 = 82583705 x %u y2 = 41aecdc5 x /s y3 = fffffffb038fcf10 x %s y3 = 5628987 +x /u 3 = 276c2afb9a0e57b7 +x %u 3 = 2 +x /s 3 = 276c2afb9a0e57b7 +x %s 3 = 2 +x /u 5 = 17a74cfd5c6f016e +x %u 5 = 1 +x /s 5 = 17a74cfd5c6f016e +x %s 5 = 1 +x /u 11 = ac068d04149bad5 +x %u 11 = 0 +x /s 11 = ac068d04149bad5 +x %s 11 = 0 ~x = 89bb7f0d31d4f8d8 x & y = 604480724a230422 x | y = fe47cdfacf3f1f2f @@ -3522,6 +4926,18 @@ x /u y2 = 43622075f x %u y2 = 748637e x /s y3 = fffffffc38469f85 x %s y3 = ffffffffeb6799d0 +x /u 3 = 2cf82160212b6e3b +x %u 3 = 0 +x /s 3 = d7a2cc0acbd618e6 +x %s 3 = ffffffffffffffff +x /u 5 = 1afb4739ad807556 +x %u 5 = 3 +x /s 5 = e7c814067a4d4224 +x %s 5 = fffffffffffffffd +x /u 11 = c43ac02f1c606ca +x %u 11 = 3 +x /s 11 = f4fdda8e94aec0f9 +x %s 11 = fffffffffffffffe ~x = 79179bdf9c7db54e x & y = 8042001004020 x | y = a6e8f4ad7fe37bfd @@ -3552,6 +4968,18 @@ x /u y2 = 4d288aa25 x %u y2 = 9a2cc6c x /s y3 = ffffffffb9841949 x %s y3 = ffffffffd933c240 +x /u 3 = 50b9779fd98dac6e +x %u 3 = 1 +x /s 3 = fb64224a84385719 +x %s 3 = 0 +x /u 5 = 306f47c64f55010f +x %u 5 = 0 +x /s 5 = fd3c14931c21cddc +x %s 5 = ffffffffffffffff +x /u 11 = 1604095a240f5d92 +x %u 11 = 5 +x /s 11 = febe37e5c6f817c1 +x %s 11 = 0 ~x = dd399207356fab4 x & y = 322464938020044a x | y = f23fefffefeda57f @@ -3582,6 +5010,18 @@ x /u y2 = aebe580f x %u y2 = 47a4b5a3 x /s y3 = aea5798d9 x %s y3 = fffffffffe0cd097 +x /u 3 = 3870ea2956584f27 +x %u 3 = 0 +x /s 3 = e31b94d40102f9d2 +x %s 3 = ffffffffffffffff +x /u 5 = 21dd594c009b62b1 +x %u 5 = 0 +x /s 5 = eeaa2618cd682f7e +x %s 5 = ffffffffffffffff +x /u 11 = f649cf40046a139 +x %u 11 = 2 +x /s 11 = f81ecb7fa32f5b68 +x %s 11 = fffffffffffffffd ~x = 56ad4183fcf7128a x & y = a802280c02084960 x | y = f95fbf7edfdfedf5 @@ -3612,6 +5052,18 @@ x /u y2 = 64f253db1 x %u y2 = 1b1f8b24 x /s y3 = ffffffff34f67dfd x %s y3 = ffffffffe00e78a0 +x /u 3 = 4bcddb50788f348f +x %u 3 = 2 +x /s 3 = f67885fb2339df3b +x %s 3 = fffffffffffffffe +x /u 5 = 2d7b8396aebc52bc +x %u 5 = 3 +x /s 5 = fa4850637b891f8a +x %s 5 = fffffffffffffffd +x /u 11 = 14ac81a1953e5427 +x %u 11 = 2 +x /s 11 = fd66b02d38270e56 +x %s 11 = fffffffffffffffd ~x = 1c966e0e96526250 x & y = 200910f161010802 x | y = e76bf7fb6fad9fbf @@ -3642,6 +5094,18 @@ x /u y2 = 7bb650b1 x %u y2 = b51254f9 x /s y3 = fffffff6f29b761c x %s y3 = 33e2279 +x /u 3 = 2725c483ee5a66d3 +x %u 3 = 0 +x /s 3 = 2725c483ee5a66d3 +x %s 3 = 0 +x /u 5 = 177d0f825bcfd74b +x %u 5 = 2 +x /s 5 = 177d0f825bcfd74b +x %s 5 = 2 +x /u 11 = aad359858473350 +x %u 11 = 9 +x /s 11 = aad359858473350 +x %s 11 = 9 ~x = 8a8eb27434f0cb86 x & y = 710005808a080010 x | y = f777ff8beb8ff5fd @@ -3672,6 +5136,18 @@ x /u y2 = a1fbf096 x %u y2 = 8c67f383 x /s y3 = 4ecae6205 x %s y3 = fffffffff5e0333b +x /u 3 = 315fd6992189fc1b +x %u 3 = 2 +x /s 3 = dc0a8143cc34a6c7 +x %s 3 = fffffffffffffffe +x /u 5 = 1d9fe728adb930dd +x %u 5 = 2 +x /s 5 = ea6cb3f57a85fdab +x %s 5 = fffffffffffffffc +x /u 11 = d773a86da99fef0 +x %u 11 = 3 +x /s 11 = f63169127d82b91f +x %s 11 = fffffffffffffffe ~x = 6be07c349b620bac x & y = 80180008408da042 x | y = fe1f93fbffbff4f7 @@ -3702,6 +5178,18 @@ x /u y2 = 30cdb0a56 x %u y2 = ad1e409 x /s y3 = 30cdb0a56 x %s y3 = ad1e409 +x /u 3 = 2834594c36a7a13f +x %u 3 = 0 +x /s 3 = 2834594c36a7a13f +x %s 3 = 0 +x /u 5 = 181f68c753fe2d8c +x %u 5 = 1 +x /s 5 = 181f68c753fe2d8c +x %s 5 = 1 +x /u 11 = af70114c91671cb +x %u 11 = 4 +x /s 11 = af70114c91671cb +x %s 11 = 4 ~x = 8762f41b5c091c42 x & y = 20880284a1c04088 x | y = 7f9fefeeefffefbd @@ -3732,6 +5220,18 @@ x /u y2 = 3274b0b2 x %u y2 = 9b290b19 x /s y3 = fffffffc3766d779 x %s y3 = 5c46e48 +x /u 3 = ffc62752ea32467 +x %u 3 = 2 +x /s 3 = ffc62752ea32467 +x %s 3 = 2 +x /u 5 = 9976e464f2eaf71 +x %u 5 = 2 +x /s 5 = 9976e464f2eaf71 +x %s 5 = 2 +x /u 11 = 45c1ada23fdf2a7 +x %u 11 = a +x /s 11 = 45c1ada23fdf2a7 +x %s 11 = a ~x = d00ad8a0741692c8 x & y = 2351270701a06c32 x | y = fff727ffcbe9fdff @@ -3762,6 +5262,18 @@ x /u y2 = 68ee956da x %u y2 = 135a2859 x /s y3 = fffffffe50888709 x %s y3 = ffffffffe4ade05d +x /u 3 = 43e30e669be75515 +x %u 3 = 2 +x /s 3 = ee8db9114691ffc1 +x %s 3 = fffffffffffffffe +x /u 5 = 28bb6f0a5d8acca6 +x %u 5 = 3 +x /s 5 = f5883bd72a579974 +x %s 5 = fffffffffffffffd +x /u 11 = 1283be1bfbf945c0 +x %u 11 = 1 +x /s 11 = fb3deca79ee1ffef +x %s 11 = fffffffffffffffc ~x = 3456d4cc2c4a00be x & y = b09080050919e00 x | y = dfadfff7d7fffffd @@ -3792,6 +5304,18 @@ x /u y2 = 16ebd54de x %u y2 = b47cbf9 x /s y3 = 16ebd54de x %s y3 = b47cbf9 +x /u 3 = 184674b358648ec9 +x %u 3 = 0 +x /s 3 = 184674b358648ec9 +x %s 3 = 0 +x /u 5 = e90ac6b9b6f88df +x %u 5 = 0 +x /s 5 = e90ac6b9b6f88df +x %s 5 = 0 +x /u 11 = 69eda025dece11f +x %u 11 = 6 +x /s 11 = 69eda025dece11f +x %s 11 = 6 ~x = b72ca1e5f6d253a4 x & y = d15e1a0124a04a x | y = 7ad7df5f99effe5f @@ -3822,6 +5346,18 @@ x /u y2 = 6ea800f5e x %u y2 = a23e0b1 x /s y3 = fffffffda06520cf x %s y3 = ffffffffe848911b +x /u 3 = 3f87dbe9ca339901 +x %u 3 = 2 +x /s 3 = ea32869474de43ad +x %s 3 = fffffffffffffffe +x /u 5 = 261e50bf7952289a +x %u 5 = 3 +x /s 5 = f2eb1d8c461ef568 +x %s 5 = fffffffffffffffd +x /u 11 = 1153991137255846 +x %u 11 = 3 +x /s 11 = fa0dc79cda0e1275 +x %s 11 = fffffffffffffffe ~x = 41686c42a16534fa x & y = 1a8691b408188800 x | y = bf9fdfff5fbfef35 @@ -3852,6 +5388,18 @@ x /u y2 = c46523b0 x %u y2 = 22e57ccf x /s y3 = ffffffff181acd99 x %s y3 = 84d7ca +x /u 3 = 237216428d33873f +x %u 3 = 2 +x /s 3 = 237216428d33873f +x %s 3 = 2 +x /u 5 = 154473c187ebb78c +x %u 5 = 3 +x /s 5 = 154473c187ebb78c +x %s 5 = 3 +x /u 11 = 9aac040b225536e +x %u 11 = 5 +x /s 11 = 9aac040b225536e +x %s 11 = 5 ~x = 95a9bd3858656a40 x & y = a140085a20894a2 x | y = eade56ffff9a95ff @@ -3882,6 +5430,18 @@ x /u y2 = 9c21e58a x %u y2 = 1d492637 x /s y3 = 9c21e58a x %s y3 = 1d492637 +x /u 3 = 17280248a41a9903 +x %u 3 = 0 +x /s 3 = 17280248a41a9903 +x %s 3 = 0 +x /u 5 = de4ce2b95a98f01 +x %u 5 = 4 +x /s 5 = de4ce2b95a98f01 +x %s 5 = 4 +x /u 11 = 650bacdfe35cca3 +x %u 11 = 8 +x /s 11 = 650bacdfe35cca3 +x %s 11 = 8 ~x = ba87f92613b034f6 x & y = 41600251ec448800 x | y = 75ff4fddef6febed @@ -3912,6 +5472,18 @@ x /u y2 = c4213692 x %u y2 = cc1104f x /s y3 = c4213692 x %s y3 = cc1104f +x /u 3 = 350dbb8fd876f21 +x %u 3 = 0 +x /s 3 = 350dbb8fd876f21 +x %s 3 = 0 +x /u 5 = 1fd50a231b7a913 +x %u 5 = 4 +x /s 5 = 1fd50a231b7a913 +x %s 5 = 4 +x /u 11 = e781be16994cda +x %u 11 = 5 +x /s 11 = e781be16994cda +x %s 11 = 5 ~x = f60d6cd50769b29c x & y = 8f2902aa8960822 x | y = dfbf33af8d67df7 @@ -3942,6 +5514,18 @@ x /u y2 = 18af89756 x %u y2 = 2bc2aae5 x /s y3 = 240bce76 x %s y3 = ffffffffefb31365 +x /u 3 = 50ae5f06a70a966f +x %u 3 = 0 +x /s 3 = fb5909b151b5411a +x %s 3 = ffffffffffffffff +x /u 5 = 30689f6a64398d75 +x %u 5 = 4 +x /s 5 = fd356c3731065a43 +x %s 5 = fffffffffffffffe +x /u 11 = 160102a4b9316ed8 +x %u 11 = 5 +x /s 11 = febb31305c1a2907 +x %s 11 = 0 ~x = df4e2ec0ae03cb2 x & y = 9001101055110048 x | y = feeb5d9ff7bfcbdd @@ -3972,6 +5556,18 @@ x /u y2 = 23f5eca36 x %u y2 = 5804c9f x /s y3 = ffffffffe9ec23f1 x %s y3 = ffffffff93aae1cb +x /u 3 = 522e145f28e067c2 +x %u 3 = 1 +x /s 3 = fcd8bf09d38b126d +x %s 3 = 0 +x /u 5 = 314ed905e5537174 +x %u 5 = 3 +x /s 5 = fe1ba5d2b2203e42 +x %s 5 = fffffffffffffffd +x /u 11 = 1669a8770b25edc0 +x %u 11 = 7 +x /s 11 = ff23d702ae0ea7f0 +x %s 11 = fffffffffffffff7 ~x = 975c2e2855ec8b8 x & y = 6480391c40213142 x | y = ffbb7d3dfafd77cf @@ -4002,6 +5598,18 @@ x /u y2 = 209ed682d x %u y2 = 2780177c x /s y3 = ffffffffa02bad7e x %s y3 = ffffffffefe191e3 +x /u 3 = 481894a813d33d45 +x %u 3 = 2 +x /s 3 = f2c33f52be7de7f1 +x %s 3 = fffffffffffffffe +x /u 5 = 2b41f2cb3f1857f6 +x %u 5 = 3 +x /s 5 = f80ebf980be524c4 +x %s 5 = fffffffffffffffd +x /u 11 = 13a99ce8056827fb +x %u 11 = 8 +x /s 11 = fc63cb73a850e22b +x %s 11 = fffffffffffffff8 ~x = 27b64207c486482e x & y = 480009c812208000 x | y = fa5ffdf9fffbb7dd @@ -4032,6 +5640,18 @@ x /u y2 = 21e776484 x %u y2 = 1226152f x /s y3 = ffffffffc5acab53 x %s y3 = ffffffffdfdae8ae +x /u 3 = 4d0c90b82228a7ce +x %u 3 = 1 +x /s 3 = f7b73b62ccd35279 +x %s 3 = 0 +x /u 5 = 2e3abd3b47b1fe48 +x %u 5 = 3 +x /s 5 = fb078a08147ecb16 +x %s 5 = fffffffffffffffd +x /u 11 = 15036d497dadff38 +x %u 11 = 3 +x /s 11 = fdbd9bd52096b967 +x %s 11 = fffffffffffffffe ~x = 18da4dd799860894 x & y = 650522284059140a x | y = ef35bbaf67fdf77f @@ -4062,6 +5682,18 @@ x /u y2 = 7c0e5692 x %u y2 = 41025c7b x /s y3 = 7c0e5692 x %s y3 = 41025c7b +x /u 3 = f80114c9c91a431 +x %u 3 = 2 +x /s 3 = f80114c9c91a431 +x %s 3 = 2 +x /u 5 = 94cd72df78a95b7 +x %u 5 = 2 +x /s 5 = 94cd72df78a95b7 +x %s 5 = 2 +x /u 11 = 43a33437084cfb0 +x %u 11 = 5 +x /s 11 = 43a33437084cfb0 +x %s 11 = 5 ~x = d17fcc1a2a4b136a x & y = e8012a510040080 x | y = 7ff573e5fdfcee95 @@ -4092,6 +5724,18 @@ x /u y2 = 14d521718 x %u y2 = 4c657d7 x /s y3 = 3b4ec343 x %s y3 = ffffffffcaaf32b0 +x /u 3 = 4fc13fa657807b45 +x %u 3 = 0 +x /s 3 = fa6bea51022b25f0 +x %s 3 = ffffffffffffffff +x /u 5 = 2fda5963ce19e38f +x %u 5 = 4 +x /s 5 = fca726309ae6b05d +x %s 5 = fffffffffffffffe +x /u 11 = 15c0572d5daead41 +x %u 11 = 4 +x /s 11 = fe7a85b900976770 +x %s 11 = ffffffffffffffff ~x = 10bc410cf97e8e30 x & y = a74320f104013182 x | y = ffc3bef7079973ff @@ -4122,6 +5766,18 @@ x /u y2 = 21584e541 x %u y2 = 263b3f29 x /s y3 = fffffffe66636700 x %s y3 = fffffffff6e1d599 +x /u 3 = 3045ac776eb1a1dd +x %u 3 = 2 +x /s 3 = daf05722195c4c89 +x %s 3 = fffffffffffffffe +x /u 5 = 1cf69aae0f37611e +x %u 5 = 3 +x /s 5 = e9c3677adc042dec +x %s 5 = fffffffffffffffd +x /u 11 = d2a464f1e3071f6 +x %u 11 = 7 +x /s 11 = f5e474dac1192c26 +x %s 11 = fffffffffffffff7 ~x = 6f2efa99b3eb1a66 x & y = 5000604004c410 x | y = d5fddf76cf17e5bd @@ -4152,6 +5808,18 @@ x /u y2 = 364afcce3 x %u y2 = f56632d x /s y3 = 364afcce3 x %s y3 = f56632d +x /u 3 = 29903afe3eca437b +x %u 3 = 2 +x /s 3 = 29903afe3eca437b +x %s 3 = 2 +x /u 5 = 18f0236558dfc217 +x %u 5 = 0 +x /s 5 = 18f0236558dfc217 +x %s 5 = 0 +x /u 11 = b55e18b2865b550 +x %u 11 = 3 +x /s 11 = b55e18b2865b550 +x %s 11 = 3 ~x = 834f4f0543a1358c x & y = 24b0b082104e0002 x | y = 7cbef4fabf7feef7 @@ -4182,6 +5850,18 @@ x /u y2 = 2be74f23 x %u y2 = 27781c66 x /s y3 = fffffffbf88ea18f x %s y3 = 1a482a +x /u 3 = e097ab22faf2249 +x %u 3 = 2 +x /s 3 = e097ab22faf2249 +x %s 3 = 2 +x /u 5 = 86c166ae9691492 +x %u 5 = 3 +x /s 5 = 86c166ae9691492 +x %s 5 = 3 +x /u 11 = 3d40a3098a4209f +x %u 11 = 8 +x /s 11 = 3d40a3098a4209f +x %s 11 = 8 ~x = d5e38fe970f29922 x & y = 200c50140d092008 x | y = ff9c769fbf6f7ffd @@ -4212,6 +5892,18 @@ x /u y2 = 1e3f46921 x %u y2 = 59fa719a x /s y3 = ffffffff79b4afc3 x %s y3 = ffffffffe0043b40 +x /u 3 = 42cc27abb2f6771d +x %u 3 = 0 +x /s 3 = ed76d2565da121c8 +x %s 3 = ffffffffffffffff +x /u 5 = 281417cd6b60adde +x %u 5 = 1 +x /s 5 = f4e0e49a382d7aab +x %s 5 = 0 +x /u 11 = 1237adba76a04f07 +x %u 11 = a +x /s 11 = faf1dc4619890937 +x %s 11 = fffffffffffffffa ~x = 379b88fce71c9aa8 x & y = 4800230110416012 x | y = ea64ff1ffeeb7fdf @@ -4242,6 +5934,18 @@ x /u y2 = 225392f08 x %u y2 = 3be1c661 x /s y3 = fffffffe8297e39a x %s y3 = fffffffff93b6ee1 +x /u 3 = 325c4e6498977c20 +x %u 3 = 1 +x /s 3 = dd06f90f434226cb +x %s 3 = 0 +x /u 5 = 1e37623c5b8e1746 +x %u 5 = 3 +x /s 5 = eb042f09285ae414 +x %s 5 = fffffffffffffffd +x /u 11 = dbc156140e37ef1 +x %u 11 = 6 +x /s 11 = f67643ece3cc3921 +x %s 11 = fffffffffffffff6 ~x = 68eb14d236398b9e x & y = 600c90049421440 x | y = d77fefedebff757d @@ -4272,6 +5976,18 @@ x /u y2 = 32bcb4e0b x %u y2 = 13cff1ba x /s y3 = 32bcb4e0b x %s y3 = 13cff1ba +x /u 3 = 22aee1ee38ba4cd3 +x %u 3 = 2 +x /s 3 = 22aee1ee38ba4cd3 +x %s 3 = 2 +x /u 5 = 14cf545bbba2fae5 +x %u 5 = 2 +x /s 5 = 14cf545bbba2fae5 +x %s 5 = 2 +x /u 11 = 975836f83d5b7dc +x %u 11 = 7 +x /s 11 = 975836f83d5b7dc +x %s 11 = 7 ~x = 97f35a3555d11984 x & y = 200ca1c28a04006a x | y = 68cfe7ebefbeefff @@ -4302,6 +6018,18 @@ x /u y2 = 2ed78e4eb x %u y2 = 356cebb8 x /s y3 = ffffffff3a97a9d7 x %s y3 = fffffffff8b9f944 +x /u 3 = 438af87d1c4ac60c +x %u 3 = 1 +x /s 3 = ee35a327c6f570b7 +x %s 3 = 0 +x /u 5 = 28869517ddc676d4 +x %u 5 = 1 +x /s 5 = f55361e4aa9343a1 +x %s 5 = 0 +x /u 11 = 126bb8221efd1ebd +x %u 11 = 6 +x /s 11 = fb25e6adc1e5d8ed +x %s 11 = fffffffffffffff6 ~x = 355f1688ab1fadda x & y = 4020680754004000 x | y = cfb6ed77f7ff5ef5 @@ -4332,6 +6060,18 @@ x /u y2 = 28a1bbf24 x %u y2 = 799b1b7 x /s y3 = fffffffe040371a9 x %s y3 = ffffffffc98b7515 +x /u 3 = 2fe719b1215bbb4a +x %u 3 = 1 +x /s 3 = da91c45bcc0665f5 +x %s 3 = 0 +x /u 5 = 1cbddc371403d6c6 +x %u 5 = 1 +x /s 5 = e98aa903e0d0a393 +x %s 5 = 0 +x /u 11 = d107b5eda8d619f +x %u 11 = a +x /s 11 = f5caa9ea7d761bcf +x %s 11 = fffffffffffffffa ~x = 704ab2ec9becce20 x & y = 894481244032082 x | y = bfb7edbb6f5ff7df @@ -4362,6 +6102,18 @@ x /u y2 = 13ff0e2ae x %u y2 = 476c04b9 x /s y3 = 13ff0e2ae x %s y3 = 476c04b9 +x /u 3 = 1ff4b575c47d2c0d +x %u 3 = 2 +x /s 3 = 1ff4b575c47d2c0d +x %s 3 = 2 +x /u 5 = 132c6ce042b180d5 +x %u 5 = 0 +x /s 5 = 132c6ce042b180d5 +x %s 5 = 0 +x /u 11 = 8b71a3764222349 +x %u 11 = 6 +x /s 11 = 8b71a3764222349 +x %s 11 = 6 ~x = a021df9eb2887bd6 x & y = 4c94000045570000 x | y = 5fff7369fff797ad @@ -4392,6 +6144,18 @@ x /u y2 = 23b3ba758 x %u y2 = 279118f3 x /s y3 = fffffffe9e07f55d x %s y3 = ffffffffd0bd48a5 +x /u 3 = 34af9fbbece823d6 +x %u 3 = 1 +x /s 3 = df5a4a669792ce81 +x %s 3 = 0 +x /u 5 = 1f9c930a5af1af1a +x %u 5 = 1 +x /s 5 = ec695fd727be7be7 +x %s 5 = 0 +x /u 11 = e5e7161cc3f4f97 +x %u 11 = 6 +x /s 11 = f7189fed6f2809c7 +x %s 11 = fffffffffffffff6 ~x = 61f120cc3947947c x & y = 6049232c2206002 x | y = dedfdf77deff6fd7 @@ -4422,6 +6186,18 @@ x /u y2 = 45edad94 x %u y2 = a1dd3be1 x /s y3 = fffffffb12493a09 x %s y3 = d41d9ce +x /u 3 = 1615de9b317844cf +x %u 3 = 0 +x /s 3 = 1615de9b317844cf +x %s 3 = 0 +x /u 5 = d40525d1dae8faf +x %u 5 = 2 +x /s 5 = d40525d1dae8faf +x %s 5 = 2 +x /u 11 = 605f6e481dafb7e +x %u 11 = 3 +x /s 11 = 605f6e481dafb7e +x %s 11 = 3 ~x = bdbe642e6b973192 x & y = 420083418428cc68 x | y = f2cf9bf79decdf7d @@ -4452,6 +6228,18 @@ x /u y2 = 3048d2c3e x %u y2 = 7ddbd3f x /s y3 = fffffffe386a7a90 x %s y3 = fffffffff6bdc2a7 +x /u 3 = 35adadd00d2afd22 +x %u 3 = 1 +x /s 3 = e058587ab7d5a7cd +x %s 3 = 0 +x /u 5 = 203501e33b19cb14 +x %u 5 = 3 +x /s 5 = ed01ceb007e697e2 +x %s 5 = fffffffffffffffd +x /u 11 = ea3bb0a3222ff37 +x %u 11 = a +x /s 11 = f75de995d50bb967 +x %s 11 = fffffffffffffffa ~x = 5ef6f68fd87f0898 x & y = 2108086026801762 x | y = b55db97c77c2f76f @@ -4482,6 +6270,18 @@ x /u y2 = c7279a22 x %u y2 = cb0da98f x /s y3 = 361b5597a x %s y3 = fffffffffb948337 +x /u 3 = 3cb93302689c66fb +x %u 3 = 0 +x /s 3 = e763ddad134711a6 +x %s 3 = ffffffffffffffff +x /u 5 = 246f1e9b0b910a96 +x %u 5 = 3 +x /s 5 = f13beb67d85dd764 +x %s 5 = fffffffffffffffd +x /u 11 = 108f998c4b1361e7 +x %u 11 = 4 +x /s 11 = f949c817edfc1c16 +x %s 11 = ffffffffffffffff ~x = 49d466f8c62acb0e x & y = a22a8801014014a0 x | y = fe2bffa77bff7efd @@ -4512,6 +6312,18 @@ x /u y2 = 9ec1e9af x %u y2 = cf1df113 x /s y3 = 68deaf7ef9 x %s y3 = ffffffffffdef4c3 +x /u 3 = 34b9f12deab9d32e +x %u 3 = 1 +x /s 3 = df649bd895647dd9 +x %s 3 = 0 +x /u 5 = 1fa2c3e859a2b1e8 +x %u 5 = 3 +x /s 5 = ec6f90b5266f7eb6 +x %s 5 = fffffffffffffffd +x /u 11 = e6141c6b4613998 +x %u 11 = 3 +x /s 11 = f71b70525749f3c7 +x %s 11 = fffffffffffffffe ~x = 61d22c763fd28674 x & y = 9e0111084008518a x | y = ff3df789d0bdfbbf @@ -4542,6 +6354,18 @@ x /u y2 = 14b83ddb43 x %u y2 = 7bd891d x /s y3 = fffffffe54d4c750 x %s y3 = fffffffff8ae0935 +x /u 3 = 4ef92cb7884ca93c +x %u 3 = 1 +x /s 3 = f9a3d76232f753e7 +x %s 3 = 0 +x /u 5 = 2f624e07b82dff24 +x %u 5 = 1 +x /s 5 = fc2f1ad484facbf1 +x %s 5 = 0 +x /u 11 = 1589c6609989456d +x %u 11 = 6 +x /s 11 = fe43f4ec3c71ff9d +x %s 11 = fffffffffffffff6 ~x = 131479d9671a044a x & y = 86b040008048b20 x | y = efefbfaebcedfbb5 @@ -4572,6 +6396,18 @@ x /u y2 = 6e847dbc x %u y2 = 63938b7 x /s y3 = ffffffff7fb9c9d5 x %s y3 = 8979c75 +x /u 3 = 13ca0e8122c0474f +x %u 3 = 2 +x /s 3 = 13ca0e8122c0474f +x %s 3 = 2 +x /u 5 = bdfa24d7b402ac9 +x %u 5 = 2 +x /s 5 = bdfa24d7b402ac9 +x %s 5 = 2 +x /u 11 = 565a6dd669187cf +x %u 11 = a +x /s 11 = 565a6dd669187cf +x %s 11 = a ~x = c4a1d47c97bf2a10 x & y = 904228268008542 x | y = bbdeaf93ed49fdff @@ -4602,6 +6438,18 @@ x /u y2 = 9a4aab1a x %u y2 = 8460af0b x /s y3 = 4ce035bf5 x %s y3 = fffffffff8cc5e2a +x /u 3 = 2e915ece37f03793 +x %u 3 = 0 +x /s 3 = d93c0978e29ae23e +x %s 3 = ffffffffffffffff +x /u 5 = 1bf0d27bbb29baf1 +x %u 5 = 4 +x /s 5 = e8bd9f4887f687bf +x %s 5 = fffffffffffffffe +x /u 11 = cb34866c9700f28 +x %u 11 = 1 +x /s 11 = f56d76f26c58c957 +x %s 11 = fffffffffffffffc ~x = 744be395582f5946 x & y = 83800062a7508690 x | y = efffbffbeff7b6fd @@ -4632,6 +6480,18 @@ x /u y2 = 6cd85af3 x %u y2 = 21606d91 x /s y3 = fffffffd4a66f1cd x %s y3 = 6f4d315 +x /u 3 = 1f5c41f0b436badb +x %u 3 = 2 +x /s 3 = 1f5c41f0b436badb +x %s 3 = 2 +x /u 5 = 12d0f45d38eda350 +x %u 5 = 3 +x /s 5 = 12d0f45d38eda350 +x %s 5 = 3 +x /u 11 = 88d8658eb54be99 +x %u 11 = 0 +x /s 11 = 88d8658eb54be99 +x %s 11 = 0 ~x = a1eb3a2de35bcf6c x & y = 5c0485521ca03002 x | y = df56cdf65deff8b7 @@ -4662,6 +6522,18 @@ x /u y2 = 9e37e46d x %u y2 = 276a9058 x /s y3 = fffffffe62f7568d x %s y3 = 3a458b38 +x /u 3 = 2621e032155e5354 +x %u 3 = 1 +x /s 3 = 2621e032155e5354 +x %s 3 = 1 +x /u 5 = 16e1201e0cd231ff +x %u 5 = 2 +x /s 5 = 16e1201e0cd231ff +x %s 5 = 2 +x /u 11 = a66546ac00273d1 +x %u 11 = 2 +x /s 11 = a66546ac00273d1 +x %s 11 = 2 ~x = 8d9a5f69bfe50602 x & y = 3000a010000af1c8 x | y = fb7da79f7a7afdfd @@ -4692,6 +6564,18 @@ x /u y2 = 89be8881 x %u y2 = 3286ec30 x /s y3 = ffffffff318b3773 x %s y3 = 41b7412 +x /u 3 = 1b8a516de883a47d +x %u 3 = 0 +x /s 3 = 1b8a516de883a47d +x %s 3 = 0 +x /u 5 = 108630db8b822f7e +x %u 5 = 1 +x /s 5 = 108630db8b822f7e +x %s 5 = 1 +x /u 11 = 782d063cb0ca139 +x %u 11 = 4 +x /s 11 = 782d063cb0ca139 +x %s 11 = 4 ~x = ad610bb646751288 x & y = 108c644108804832 x | y = db9ff5cfbbeeed7f @@ -4722,6 +6606,18 @@ x /u y2 = fca32bce x %u y2 = 19279bff x /s y3 = 111f23d93 x %s y3 = ffffffffe9244e4c +x /u 3 = 46ec66cc210a532b +x %u 3 = 0 +x /s 3 = f1971176cbb4fdd6 +x %s 3 = ffffffffffffffff +x /u 5 = 2a8dd747470631e6 +x %u 5 = 3 +x /s 5 = f75aa41413d2feb4 +x %s 5 = fffffffffffffffd +x /u 11 = 1357bef1da772df4 +x %u 11 = 5 +x /s 11 = fc11ed7d7d5fe823 +x %s 11 = 0 ~x = 2b3acb9b9ce1067e x & y = d480300441145980 x | y = d7df357767bffbfd @@ -4752,6 +6648,18 @@ x /u y2 = 24340b83f x %u y2 = 41884ad8 x /s y3 = ffffffff68c95c6b x %s y3 = ffffffffb854355c +x /u 3 = 43ab247183879033 +x %u 3 = 2 +x /s 3 = ee55cf1c2e323adf +x %s 3 = fffffffffffffffe +x /u 5 = 2899e2aa821e2352 +x %u 5 = 1 +x /s 5 = f566af774eeaf01f +x %s 5 = 0 +x /u 11 = 12747e4d80f66d25 +x %u 11 = 4 +x /s 11 = fb2eacd923df2754 +x %s 11 = ffffffffffffffff ~x = 34fe92ab75694f64 x & y = 490141548290308a x | y = dbb7fd7debbef19f @@ -4782,6 +6690,18 @@ x /u y2 = f958dab3 x %u y2 = ecb4360b x /s y3 = 16380abc0 x %s y3 = fffffffffebaf8c5 +x /u 3 = 4de81edf94efa317 +x %u 3 = 0 +x /s 3 = f892c98a3f9a4dc2 +x %s 3 = ffffffffffffffff +x /u 5 = 2ebe78ec8c8fc841 +x %u 5 = 0 +x /s 5 = fb8b45b9595c950e +x %s 5 = ffffffffffffffff +x /u 11 = 153f4e3cfa12cf63 +x %u 11 = 4 +x /s 11 = fdf97cc89cfb8992 +x %s 11 = ffffffffffffffff ~x = 1647a361413116ba x & y = e9b0449e2888a940 x | y = effcdcdefeeefd75 @@ -4812,6 +6732,18 @@ x /u y2 = ff8db266 x %u y2 = cc4dce6f x /s y3 = 10cb8d59a x %s y3 = fffffffffdc42d8f +x /u 3 = 524bd3e231be74aa +x %u 3 = 1 +x /s 3 = fcf67e8cdc691f55 +x %s 3 = 0 +x /u 5 = 3160b254843f12cc +x %u 5 = 3 +x /s 5 = fe2d7f21510bdf9a +x %s 5 = fffffffffffffffd +x /u 11 = 1671c56c3c1cab74 +x %u 11 = 3 +x /s 11 = ff2bf3f7df0565a3 +x %s 11 = fffffffffffffffe ~x = 91c84596ac4a200 x & y = f641690005230822 x | y = f7f3fbbe9ffbddff @@ -4842,6 +6774,18 @@ x /u y2 = 13f341cd4 x %u y2 = 3ea81d95 x /s y3 = 13f341cd4 x %s y3 = 3ea81d95 +x /u 3 = 23c2d779fce86f18 +x %u 3 = 1 +x /s 3 = 23c2d779fce86f18 +x %s 3 = 1 +x /u 5 = 1574e7af97bea90e +x %u 5 = 3 +x /s 5 = 1574e7af97bea90e +x %s 5 = 3 +x /u 11 = 9c0c667166defc0 +x %u 11 = 9 +x /s 11 = 9c0c667166defc0 +x %s 11 = 9 ~x = 94b779920946b2b6 x & y = 42080049e2884c00 x | y = 7f4af6fdfeff4f6d @@ -4872,6 +6816,18 @@ x /u y2 = c79a1999e x %u y2 = 8cb3bd5 x /s y3 = fffffffc39559faa x %s y3 = fffffffffec068e9 +x /u 3 = 4181764beb21088b +x %u 3 = 2 +x /s 3 = ec2c20f695cbb337 +x %s 3 = fffffffffffffffe +x /u 5 = 274dad60c0470520 +x %u 5 = 3 +x /s 5 = f41a7a2d8d13d1ee +x %s 5 = fffffffffffffffd +x /u 11 = 11dd7d5a85f1bc83 +x %u 11 = 2 +x /s 11 = fa97abe628da76b2 +x %s 11 = fffffffffffffffd ~x = 3b7b9d1c3e9ce65c x & y = 4802261416119a2 x | y = cfc4f2ebef6bdff7 @@ -4902,6 +6858,18 @@ x /u y2 = 373dc3a72 x %u y2 = f3a74a9 x /s y3 = fffffffca40c567c x %s y3 = ffffffffeb083c95 +x /u 3 = 2b406be27c6ef884 +x %u 3 = 1 +x /s 3 = d5eb168d2719a32f +x %s 3 = 0 +x /u 5 = 19f373ee4aa8fb82 +x %u 5 = 3 +x /s 5 = e6c040bb1775c850 +x %s 5 = fffffffffffffffd +x /u 11 = bcbc0550aa9e6af +x %u 11 = 8 +x /s 11 = f485eee0ad92a0df +x %s 11 = fffffffffffffff8 ~x = 7e3ebc588ab31672 x & y = 181000200488008 x | y = a5d543a7fddeeb9d @@ -4932,6 +6900,18 @@ x /u y2 = 3f82fa73 x %u y2 = 22447773 x /s y3 = 3f82fa73 x %s y3 = 22447773 +x /u 3 = 81b55f36c1b6d2d +x %u 3 = 0 +x /s 3 = 81b55f36c1b6d2d +x %s 3 = 0 +x /u 5 = 4dd33920daa0e4e +x %u 5 = 1 +x /s 5 = 4dd33920daa0e4e +x %s 5 = 1 +x /u 11 = 236002b1d7bd7f5 +x %u 11 = 0 +x /s 11 = 236002b1d7bd7f5 +x %s 11 = 0 ~x = e7adfe25bbadb878 x & y = 2009800400502 x | y = 7a5787dec4ff4f8f @@ -4962,6 +6942,18 @@ x /u y2 = a8d5772 x %u y2 = 2bbf7115 x /s y3 = a8d5772 x %s y3 = 2bbf7115 +x /u 3 = 1955730431eeb5b +x %u 3 = 0 +x /s 3 = 1955730431eeb5b +x %s 3 = 0 +x /u 5 = f334502845c069 +x %u 5 = 4 +x /s 5 = f334502845c069 +x %s 5 = 4 +x /u 11 = 6e8c246f658601 +x %u 11 = 6 +x /s 11 = 6e8c246f658601 +x %s 11 = 6 ~x = fb3ffa6f36a33dee x & y = 50040400000 x | y = 77fd57fee9fdcf5d @@ -4992,6 +6984,18 @@ x /u y2 = a2d45f9b x %u y2 = 7184712 x /s y3 = a2d45f9b x %s y3 = 7184712 +x /u 3 = 187cdc6afb43d939 +x %u 3 = 0 +x /s 3 = 187cdc6afb43d939 +x %s 3 = 0 +x /u 5 = eb1510cfd28b588 +x %u 5 = 3 +x /s 5 = eb1510cfd28b588 +x %s 5 = 3 +x /u 11 = 6adb07a4486de26 +x %u 11 = 9 +x /s 11 = 6adb07a4486de26 +x %s 11 = 9 ~x = b6896abf0e347454 x & y = 4176814080cb830a x | y = 7b7fb5dbf1ffebff @@ -5022,6 +7026,18 @@ x /u y2 = 1056b28b9 x %u y2 = 986cffaf x /s y3 = dab98c69 x %s y3 = fffffffff99e128f +x /u 3 = 4c147aad9bf6b39c +x %u 3 = 1 +x /s 3 = f6bf255846a15e47 +x %s 3 = 0 +x /u 5 = 2da5e334f72d9ef7 +x %u 5 = 2 +x /s 5 = fa72b001c3fa6bc5 +x %s 5 = fffffffffffffffc +x /u 11 = 14bfc45de4b7a559 +x %u 11 = 2 +x /s 11 = fd79f2e987a05f88 +x %s 11 = fffffffffffffffd ~x = 1bc28ff72c1be52a x & y = c400500011c002c0 x | y = ffbf755efbecfbd5 @@ -5052,6 +7068,18 @@ x /u y2 = 1027d221e x %u y2 = e50c5a15 x /s y3 = a31a1d6d x %s y3 = fffffffff9b9f758 +x /u 3 = 53ea3033c7d1435a +x %u 3 = 1 +x /s 3 = fe94dade727bee05 +x %s 3 = 0 +x /u 5 = 3259501f117d8ecf +x %u 5 = 4 +x /s 5 = ff261cebde4a5b9d +x %s 5 = fffffffffffffffe +x /u 11 = 16e2c753f0ad6f75 +x %u 11 = 8 +x /s 11 = ff9cf5df939629a5 +x %s 11 = fffffffffffffff8 ~x = 4416f64a88c35f0 x & y = f912001356324202 x | y = fbfe9ebbd7fbfeff @@ -5082,6 +7110,18 @@ x /u y2 = d967540f x %u y2 = 73d47f08 x /s y3 = 14a5fa443 x %s y3 = ffffffffb843c4bc +x /u 3 = 2fb5882bc358d29d +x %u 3 = 2 +x /s 3 = da6032d66e037d49 +x %s 3 = fffffffffffffffe +x /u 5 = 1ca01e80a8687e5e +x %u 5 = 3 +x /s 5 = e96ceb4d75354b2c +x %s 5 = fffffffffffffffd +x /u 11 = d02f697925e0ae5 +x %u 11 = 2 +x /s 11 = f5bd25233546c514 +x %s 11 = fffffffffffffffd ~x = 70df677cb5f58826 x & y = 880080034a003150 x | y = afa99d9f5a0a7ffd @@ -5112,6 +7152,18 @@ x /u y2 = 1cc9cbb61 x %u y2 = ba5245 x /s y3 = ffffffff8f617990 x %s y3 = fffffffff0d03ed3 +x /u 3 = 44918413ecd20ce6 +x %u 3 = 1 +x /s 3 = ef3c2ebe977cb791 +x %s 3 = 0 +x /u 5 = 29241c0bf47e07bd +x %u 5 = 2 +x /s 5 = f5f0e8d8c14ad48b +x %s 5 = fffffffffffffffc +x /u 11 = 12b35291120abdb3 +x %u 11 = 2 +x /s 11 = fb6d811cb4f377e2 +x %s 11 = fffffffffffffffd ~x = 324b73c43989d94c x & y = 4010882a00060282 x | y = fff7cd3fe7fe3ff7 @@ -5142,6 +7194,18 @@ x /u y2 = 10c2e2273 x %u y2 = 6febbad1 x /s y3 = e4b07a4a x %s y3 = ffffffffb4b2dcf5 +x /u 3 = 3dd259abc52289b4 +x %u 3 = 1 +x /s 3 = e87d04566fcd345f +x %s 3 = 0 +x /u 5 = 2517cf670fe185d2 +x %u 5 = 3 +x /s 5 = f1e49c33dcae52a0 +x %s 5 = fffffffffffffffd +x /u 11 = 10dc47004d096b5f +x %u 11 = 8 +x /s 11 = f996758beff2258f +x %s 11 = fffffffffffffff8 ~x = 4688f2fcb09862e2 x & y = b102050041608008 x | y = b97fad876f779f7d @@ -5172,6 +7236,18 @@ x /u y2 = f5e9880c x %u y2 = 3dce52bf x /s y3 = fffffffefdc6ec2b x %s y3 = 7611c611 +x /u 3 = 29fc78873a7801dd +x %u 3 = 0 +x /s 3 = 29fc78873a7801dd +x %s 3 = 0 +x /u 5 = 1931151defe19ab7 +x %u 5 = 4 +x /s 5 = 1931151defe19ab7 +x %s 5 = 4 +x /u 11 = b7366b0844f4653 +x %u 11 = 6 +x /s 11 = b7366b0844f4653 +x %s 11 = 6 ~x = 820a966a5097fa68 x & y = 12029902c480592 x | y = fff56d97ff7965df @@ -5202,6 +7278,18 @@ x /u y2 = f41ffd27 x %u y2 = 70c5e7 x /s y3 = f41ffd27 x %s y3 = 70c5e7 +x /u 3 = 1c68ebd7642d2f8b +x %u 3 = 0 +x /s 3 = 1c68ebd7642d2f8b +x %s 3 = 0 +x /u 5 = 110bc0b46f4e4fb9 +x %u 5 = 4 +x /s 5 = 110bc0b46f4e4fb9 +x %s 5 = 4 +x /u 11 = 7bf862378696a0e +x %u 11 = 7 +x /s 11 = 7bf862378696a0e +x %s 11 = 7 ~x = aac53c79d378715e x & y = 5120018608820280 x | y = 5d7adbb6feb7febd @@ -5232,6 +7320,18 @@ x /u y2 = 2db65f96 x %u y2 = 5a639c65 x /s y3 = ffffffff897f0ff8 x %s y3 = 1c534bc3 +x /u 3 = afef025a6cf0393 +x %u 3 = 2 +x /s 3 = afef025a6cf0393 +x %s 3 = 2 +x /u 5 = 698f67cfdaf688b +x %u 5 = 4 +x /s 5 = 698f67cfdaf688b +x %s 5 = 4 +x /u 11 = 2ffb5dbb9212f85 +x %u 11 = 4 +x /s 11 = 2ffb5dbb9212f85 +x %s 11 = 4 ~x = df032f8f0b92f544 x & y = 20bcc020c02c082a x | y = b8fcfa71fdfd2bbf @@ -5262,6 +7362,18 @@ x /u y2 = 14171ae1b x %u y2 = 2178d143 x /s y3 = 14171ae1b x %s y3 = 2178d143 +x /u 3 = 129aeb72773a3021 +x %u 3 = 2 +x /s 3 = 129aeb72773a3021 +x %s 3 = 2 +x /u 5 = b29c077e122e9ad +x %u 5 = 4 +x /s 5 = b29c077e122e9ad +x %s 5 = 4 +x /u 11 = 512fa65093e6a37 +x %u 11 = 8 +x /s 11 = 512fa65093e6a37 +x %s 11 = 8 ~x = c82f3da89a516f9a x & y = 2450820665809000 x | y = 3ff3e7d777affe75 @@ -5292,6 +7404,18 @@ x /u y2 = 12e961017 x %u y2 = 22af4b61 x /s y3 = 12e961017 x %s y3 = 22af4b61 +x /u 3 = 296c3b705c8908b5 +x %u 3 = 0 +x /s 3 = 296c3b705c8908b5 +x %s 3 = 0 +x /u 5 = 18da8a1037856b9f +x %u 5 = 4 +x /s 5 = 18da8a1037856b9f +x %s 5 = 4 +x /u 11 = b4c1035eab1025f +x %u 11 = a +x /s 11 = b4c1035eab1025f +x %s 11 = a ~x = 83bb4daeea64e5e0 x & y = 68008250158b1802 x | y = 7d66fff31dbb7bdf @@ -5322,6 +7446,18 @@ x /u y2 = 6e285728ab x %u y2 = c1193 x /s y3 = ffffffb7c1013ab9 x %s y3 = fffffffffed4da77 +x /u 3 = 3388e09be749b778 +x %u 3 = 1 +x /s 3 = de338b4691f46223 +x %s 3 = 0 +x /u 5 = 1eebb9f7245f6e15 +x %u 5 = 0 +x /s 5 = ebb886c3f12c3ae2 +x %s 5 = ffffffffffffffff +x /u 11 = e0e0eb627ce494f +x %u 11 = 4 +x /s 11 = f6c83d41cab7037e +x %s 11 = ffffffffffffffff ~x = 65655e2c4a22d996 x & y = 2008224500040 x | y = 9bffebd3bdff7eed @@ -5352,6 +7488,18 @@ x /u y2 = f00fdea7 x %u y2 = 896e5ed0 x /s y3 = 187a673b8 x %s y3 = fffffffffa8e4fab +x /u 3 = 479b769873df7296 +x %u 3 = 1 +x /s 3 = f24621431e8a1d41 +x %s 3 = 0 +x /u 5 = 2af6e0c1df1fab27 +x %u 5 = 0 +x /s 5 = f7c3ad8eabec77f4 +x %s 5 = ffffffffffffffff +x /u 11 = 13877d6f656b7c57 +x %u 11 = 6 +x /s 11 = fc41abfb08543687 +x %s 11 = fffffffffffffff6 ~x = 292d9c36a461a83c x & y = c41000c118040382 x | y = f7d7ebdddbdfffd7 @@ -5382,6 +7530,18 @@ x /u y2 = 23effdd7 x %u y2 = 272c2ddf x /s y3 = ffffffff8b8269ef x %s y3 = 39a9e8af +x /u 3 = 927a57ae606b18f +x %u 3 = 0 +x /s 3 = 927a57ae606b18f +x %s 3 = 0 +x /u 5 = 57e30168a040422 +x %u 5 = 3 +x /s 5 = 57e30168a040422 +x %s 5 = 3 +x /u 11 = 27f2d21848d763e +x %u 11 = 3 +x /s 11 = 27f2d21848d763e +x %s 11 = 3 ~x = e4890f8f4debeb52 x & y = 324c060920014a8 x | y = dbf6f9f2bff5f6bd diff --git a/test/regression/Results/packedstruct1 b/test/regression/Results/packedstruct1-32 index e4bca769..e4bca769 100644 --- a/test/regression/Results/packedstruct1 +++ b/test/regression/Results/packedstruct1-32 diff --git a/test/regression/Results/packedstruct1-64 b/test/regression/Results/packedstruct1-64 new file mode 100644 index 00000000..c2a8bcd2 --- /dev/null +++ b/test/regression/Results/packedstruct1-64 @@ -0,0 +1,25 @@ +sizeof(struct s1) = 14 +offsetof(x) = 0, offsetof(y) = 2, offsetof(z) = 6 +s1 = {x = 123, y = -456, z = 3.14159} + +sizeof(struct s2) = 16 +&s2 mod 16 = 0 +offsetof(x) = 0, offsetof(y) = 2, offsetof(z) = 6 +s2 = {x = 57, y = -456, z = 3.14159} + +sizeof(struct s3) = 35 +offsetof(s) = 33 +s3 = {x = 123, y = 45678, z = 2147483649, v = -456, w = -1234567, p is ok, t = {111,222,333}, s = {'o','k'}} + +sizeof(struct s4) = 16 +offsetof(x) = 0, offsetof(y) = 4, offsetof(z) = 8 +s4 = {x = 123, y = -456, z = 3.14159} + +sizeof(struct s5) = 14 +offsetof(x) = 0, offsetof(y) = 2, offsetof(z) = 6 +s5 = {x = 123, y = -456, z = 3.14159} + +sizeof(struct s6) = 14 +offsetof(x) = 0, offsetof(y) = 2, offsetof(z) = 6 +s62 = {x = 123, y = -456, z = 3.14159} + diff --git a/test/regression/Results/sizeof1 b/test/regression/Results/sizeof1-32 index a952be52..a952be52 100644 --- a/test/regression/Results/sizeof1 +++ b/test/regression/Results/sizeof1-32 diff --git a/test/regression/Results/sizeof1-64 b/test/regression/Results/sizeof1-64 new file mode 100644 index 00000000..674f6dad --- /dev/null +++ b/test/regression/Results/sizeof1-64 @@ -0,0 +1,3 @@ +sizeof(struct s) = 32, sizeof(tbl) = 32 +sizeof(struct bits1) = 1, sizeof(b1) = 1 +sizeof(struct bits2) = 8, sizeof(b2) = 8 diff --git a/test/regression/Runtest b/test/regression/Runtest new file mode 100755 index 00000000..9051b5b7 --- /dev/null +++ b/test/regression/Runtest @@ -0,0 +1,49 @@ +#!/bin/sh + +# The name of the test +name="$1" +shift + +# The temp file for output +out="test$$.log" +rm -f $out +trap "rm -f $out" 0 INT QUIT + +# The architecture and the bitsize +arch=`sed -n -e 's/^ARCH=//p' ../../Makefile.config` +bits=`sed -n -e 's/^BITSIZE=//p' ../../Makefile.config` + +# The reference output +if test -f "Results/$name-$arch-$bits"; then + ref="Results/$name-$arch-$bits" +elif test -f "Results/$name-$arch"; then + ref="Results/$name-$arch" +elif test -f "Results/$name-$bits"; then + ref="Results/$name-$bits" +elif test -f "Results/$name"; then + ref="Results/$name" +else + ref="" +fi + +# Administer the test +if $* > $out +then + if test -n "$ref"; then + if cmp -s "$out" "$ref"; then + echo "$name: passed" + exit 0 + else + echo "$name: WRONG OUTPUT (diff follows)" + diff -u "$ref" "$out" + exit 2 + fi + else + echo "$name: passed" + exit 0 + fi +else + echo "$name: EXECUTION FAILED (status $?)" + exit 2 +fi + diff --git a/test/regression/alias.c b/test/regression/alias.c index 9887ae2b..925979cb 100644 --- a/test/regression/alias.c +++ b/test/regression/alias.c @@ -69,14 +69,14 @@ int get4(void) return x; } -/* Byte-swapping a pointer */ +/* Byte-swapping a pointer. For 32/64 bit compatibility, we just swap + the two low bytes, but that's in the spirit. */ inline uintptr_t bswap(uintptr_t x) { - return (x >> 24) - | (((x >> 16) & 0xFF) << 8) - | (((x >> 8) & 0xFF) << 16) - | ((x & 0xFF) << 24); + return (x & ~((uintptr_t) 0xFFFF)) + | ((x >> 8) & 0xFF) + | ((x << 8) & 0xFF00); } void NOINLINE set5(uintptr_t x) diff --git a/test/regression/builtins-ia32.c b/test/regression/builtins-x86.c index 9b7ed126..1ba213e7 100644 --- a/test/regression/builtins-ia32.c +++ b/test/regression/builtins-x86.c @@ -8,6 +8,7 @@ int main(int argc, char ** argv) unsigned int y = 0xDEADBEEF; unsigned long long xx = 0x1234567812345678ULL; unsigned long long yy = 0x1234567800000000ULL; + unsigned long long zz = 0x123456789ABCDEF0ULL; unsigned z; double a = 3.14159; double b = 2.718; @@ -16,6 +17,7 @@ int main(int argc, char ** argv) printf("bswap(%x) = %x\n", x, __builtin_bswap(x)); printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s)); + printf("bswap64(%llx) = %llx\n", zz, __builtin_bswap64(zz)); printf("clz(%x) = %d\n", x, __builtin_clz(x)); printf("clzll(%llx) = %d\n", (unsigned long long) x, __builtin_clzll(x)); printf("clzll(%llx) = %d\n", xx, __builtin_clzll(xx)); diff --git a/test/regression/extasm.c b/test/regression/extasm.c index 00a1cd57..c0534047 100644 --- a/test/regression/extasm.c +++ b/test/regression/extasm.c @@ -5,7 +5,9 @@ int clobbers(int x, int z) { int y; asm("TEST0 out:%0 in:%1" : "=r"(y) : "r"(x) : "cc" -#if defined(__i386__) +#if defined(__x86_64__) + , "rax", "rdx", "rbx" +#elif defined(__i386__) , "eax", "edx", "ebx" #elif defined(__arm__) , "r0", "r1", "r4" @@ -16,6 +18,12 @@ int clobbers(int x, int z) return y + z; } +#if defined(__x86_64__) +#define SIXTYFOUR +#else +#undef SIXTYFOUR +#endif + int main() { int x; @@ -44,10 +52,12 @@ int main() asm("FAIL1 in:%0" : : "i"(x)); #endif /* 64-bit output */ +#ifndef SIXTYFOUR asm("TEST10 out: high %R0,lo %Q0" : "=r" (z)); /* 64-bit input */ asm("TEST11 out:%0 in:%1,high %R2,lo %Q2,%3" : "=r"(x) : "r"(y), "r"(z), "r"(f)); +#endif #ifdef FAILURES asm("FAIL2 out:%0" : "=r"(z)); asm("FAIL3 in:%0" : : "r"(z)); diff --git a/test/regression/initializers2.c b/test/regression/initializers2.c index f8d5cafa..82fd9432 100644 --- a/test/regression/initializers2.c +++ b/test/regression/initializers2.c @@ -43,7 +43,7 @@ int main() a2[0], a2[1], a2[2], a2[3], a2[4]); printf("a3 = { %d, %d, %d, %d, %d } (size = %d)\n", a3[0], a3[1], a3[2], a3[3], a3[4], - sizeof(a3) / sizeof(int)); + (int)(sizeof(a3) / sizeof(int))); printf("s1 = { %d, %.2f, %s }\n", s1.a, s1.b, s1.c); diff --git a/test/regression/int64.c b/test/regression/int64.c index 0012216f..d9785e95 100644 --- a/test/regression/int64.c +++ b/test/regression/int64.c @@ -56,6 +56,18 @@ static void test1(u64 x, u64 y) y3 = ((s64)y) >> 32; printf("x /s y3 = %llx\n", safe_sdiv64(x, y3)); printf("x %%s y3 = %llx\n", safe_smod64(x, y3)); + printf("x /u 3 = %llx\n", x / 3); + printf("x %%u 3 = %llx\n", x % 3); + printf("x /s 3 = %llx\n", (s64)x / 3); + printf("x %%s 3 = %llx\n", (s64)x % 3); + printf("x /u 5 = %llx\n", x / 5); + printf("x %%u 5 = %llx\n", x % 5); + printf("x /s 5 = %llx\n", (s64)x / 5); + printf("x %%s 5 = %llx\n", (s64)x % 5); + printf("x /u 11 = %llx\n", x / 11); + printf("x %%u 11 = %llx\n", x % 11); + printf("x /s 11 = %llx\n", (s64)x / 11); + printf("x %%s 11 = %llx\n", (s64)x % 11); printf("~x = %llx\n", ~x); printf("x & y = %llx\n", x & y); printf("x | y = %llx\n", x | y); diff --git a/test/regression/sizeof1.c b/test/regression/sizeof1.c index 139b1bc7..ca494622 100644 --- a/test/regression/sizeof1.c +++ b/test/regression/sizeof1.c @@ -34,10 +34,10 @@ char b2[sizeof(struct bits2)]; /* should be 8 */ int main() { printf("sizeof(struct s) = %d, sizeof(tbl) = %d\n", - sizeof(struct s), sizeof(tbl)); + (int) sizeof(struct s), (int) sizeof(tbl)); printf("sizeof(struct bits1) = %d, sizeof(b1) = %d\n", - sizeof(struct bits1), sizeof(b1)); + (int) sizeof(struct bits1), (int) sizeof(b1)); printf("sizeof(struct bits2) = %d, sizeof(b2) = %d\n", - sizeof(struct bits2), sizeof(b2)); + (int) sizeof(struct bits2), (int) sizeof(b2)); return 0; } diff --git a/test/regression/sizeof2.c b/test/regression/sizeof2.c index 66e38c02..7b2f189e 100644 --- a/test/regression/sizeof2.c +++ b/test/regression/sizeof2.c @@ -3,7 +3,7 @@ int main() { - printf("%d\n", sizeof("abcd")); - printf("%d\n", sizeof(L"abcd") / sizeof(wchar_t)); + printf("%d\n", (int) sizeof("abcd")); + printf("%d\n", (int) (sizeof(L"abcd") / sizeof(wchar_t))); return 0; } @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -12,19 +12,9 @@ (** Abstract syntax and semantics for IA32 assembly language *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Locations. -Require Import Stacklayout. -Require Import Conventions. +Require Import Coqlib Maps. +Require Import AST Integers Floats Values Memory Events Globalenvs Smallstep. +Require Import Locations Stacklayout Conventions. (** * Abstract syntax *) @@ -33,14 +23,14 @@ Require Import Conventions. (** Integer registers. *) Inductive ireg: Type := - | EAX: ireg | EBX: ireg | ECX: ireg | EDX: ireg - | ESI: ireg | EDI: ireg | EBP: ireg | ESP: ireg. + | RAX | RBX | RCX | RDX | RSI | RDI | RBP | RSP + | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15. (** Floating-point registers, i.e. SSE2 registers *) Inductive freg: Type := - | XMM0: freg | XMM1: freg | XMM2: freg | XMM3: freg - | XMM4: freg | XMM5: freg | XMM6: freg | XMM7: freg. + | XMM0 | XMM1 | XMM2 | XMM3 | XMM4 | XMM5 | XMM6 | XMM7 + | XMM8 | XMM9 | XMM10 | XMM11 | XMM12 | XMM13 | XMM14 | XMM15. Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. Proof. decide equality. Defined. @@ -69,7 +59,7 @@ Coercion CR: crbit >-> preg. (** Conventional names for stack pointer ([SP]) and return address ([RA]) *) -Notation SP := ESP (only parsing). +Notation SP := RSP (only parsing). (** ** Instruction set. *) @@ -79,8 +69,8 @@ Definition label := positive. Inductive addrmode: Type := | Addrmode (base: option ireg) - (ofs: option (ireg * int)) - (const: int + ident * int). + (ofs: option (ireg * Z)) + (const: Z + ident * ptrofs). (** Testable conditions (for conditional jumps and more). *) @@ -94,7 +84,15 @@ Inductive testcond: Type := registers, memory references and immediate constants as arguments. Here, we list only the combinations that we actually use. - Naming conventions: + Naming conventions for types: +- [b]: 8 bits +- [w]: 16 bits ("word") +- [l]: 32 bits ("longword") +- [q]: 64 bits ("quadword") +- [d] or [sd]: FP double precision (64 bits) +- [s] or [ss]: FP single precision (32 bits) + + Naming conventions for operands: - [r]: integer register operand - [f]: XMM register operand - [m]: memory operand @@ -109,11 +107,14 @@ Inductive testcond: Type := Inductive instruction: Type := (** Moves *) - | Pmov_rr (rd: ireg) (r1: ireg) (**r [mov] (32-bit int) *) - | Pmov_ri (rd: ireg) (n: int) - | Pmov_ra (rd: ireg) (id: ident) - | Pmov_rm (rd: ireg) (a: addrmode) - | Pmov_mr (a: addrmode) (rs: ireg) + | Pmov_rr (rd: ireg) (r1: ireg) (**r [mov] (integer) *) + | Pmovl_ri (rd: ireg) (n: int) + | Pmovq_ri (rd: ireg) (n: int64) + | Pmov_rs (rd: ireg) (id: ident) + | Pmovl_rm (rd: ireg) (a: addrmode) + | Pmovq_rm (rd: ireg) (a: addrmode) + | Pmovl_mr (a: addrmode) (rs: ireg) + | Pmovq_mr (a: addrmode) (rs: ireg) | Pmovsd_ff (rd: freg) (r1: freg) (**r [movsd] (single 64-bit float) *) | Pmovsd_fi (rd: freg) (n: float) (**r (pseudo-instruction) *) | Pmovsd_fm (rd: freg) (a: addrmode) @@ -125,7 +126,6 @@ Inductive instruction: Type := | Pfstpl_m (a: addrmode) (**r [fstp] double precision *) | Pflds_m (a: addrmode) (**r [fld] simple precision *) | Pfstps_m (a: addrmode) (**r [fstp] simple precision *) - | Pxchg_rr (r1: ireg) (r2: ireg) (**r register-register exchange *) (** Moves with conversion *) | Pmovb_mr (a: addrmode) (rs: ireg) (**r [mov] (8-bit int) *) | Pmovw_mr (a: addrmode) (rs: ireg) (**r [mov] (16-bit int) *) @@ -137,43 +137,81 @@ Inductive instruction: Type := | Pmovzw_rm (rd: ireg) (a: addrmode) | Pmovsw_rr (rd: ireg) (rs: ireg) (**r [movsw] (16-bit sign-extension) *) | Pmovsw_rm (rd: ireg) (a: addrmode) + | Pmovzl_rr (rd: ireg) (rs: ireg) (**r [movzl] (32-bit zero-extension) *) + | Pmovsl_rr (rd: ireg) (rs: ireg) (**r [movsl] (32-bit sign-extension) *) + | Pmovls_rr (rd: ireg) (** 64 to 32 bit conversion (pseudo) *) | Pcvtsd2ss_ff (rd: freg) (r1: freg) (**r conversion to single float *) | Pcvtss2sd_ff (rd: freg) (r1: freg) (**r conversion to double float *) | Pcvttsd2si_rf (rd: ireg) (r1: freg) (**r double to signed int *) | Pcvtsi2sd_fr (rd: freg) (r1: ireg) (**r signed int to double *) | Pcvttss2si_rf (rd: ireg) (r1: freg) (**r single to signed int *) | Pcvtsi2ss_fr (rd: freg) (r1: ireg) (**r signed int to single *) + | Pcvttsd2sl_rf (rd: ireg) (r1: freg) (**r double to signed long *) + | Pcvtsl2sd_fr (rd: freg) (r1: ireg) (**r signed long to double *) + | Pcvttss2sl_rf (rd: ireg) (r1: freg) (**r single to signed long *) + | Pcvtsl2ss_fr (rd: freg) (r1: ireg) (**r signed long to single *) (** Integer arithmetic *) - | Plea (rd: ireg) (a: addrmode) - | Pneg (rd: ireg) - | Psub_rr (rd: ireg) (r1: ireg) - | Pimul_rr (rd: ireg) (r1: ireg) - | Pimul_ri (rd: ireg) (n: int) - | Pimul_r (r1: ireg) - | Pmul_r (r1: ireg) + | Pleal (rd: ireg) (a: addrmode) + | Pleaq (rd: ireg) (a: addrmode) + | Pnegl (rd: ireg) + | Pnegq (rd: ireg) + | Paddl_ri (rd: ireg) (n: int) + | Paddq_ri (rd: ireg) (n: int64) + | Psubl_rr (rd: ireg) (r1: ireg) + | Psubq_rr (rd: ireg) (r1: ireg) + | Pimull_rr (rd: ireg) (r1: ireg) + | Pimulq_rr (rd: ireg) (r1: ireg) + | Pimull_ri (rd: ireg) (n: int) + | Pimulq_ri (rd: ireg) (n: int64) + | Pimull_r (r1: ireg) + | Pimulq_r (r1: ireg) + | Pmull_r (r1: ireg) + | Pmulq_r (r1: ireg) | Pcltd - | Pdiv (r1: ireg) - | Pidiv (r1: ireg) - | Pand_rr (rd: ireg) (r1: ireg) - | Pand_ri (rd: ireg) (n: int) - | Por_rr (rd: ireg) (r1: ireg) - | Por_ri (rd: ireg) (n: int) - | Pxor_r (rd: ireg) (**r [xor] with self = set to zero *) - | Pxor_rr (rd: ireg) (r1: ireg) - | Pxor_ri (rd: ireg) (n: int) - | Pnot (rd: ireg) - | Psal_rcl (rd: ireg) - | Psal_ri (rd: ireg) (n: int) - | Pshr_rcl (rd: ireg) - | Pshr_ri (rd: ireg) (n: int) - | Psar_rcl (rd: ireg) - | Psar_ri (rd: ireg) (n: int) + | Pcqto + | Pdivl (r1: ireg) + | Pdivq (r1: ireg) + | Pidivl (r1: ireg) + | Pidivq (r1: ireg) + | Pandl_rr (rd: ireg) (r1: ireg) + | Pandq_rr (rd: ireg) (r1: ireg) + | Pandl_ri (rd: ireg) (n: int) + | Pandq_ri (rd: ireg) (n: int64) + | Porl_rr (rd: ireg) (r1: ireg) + | Porq_rr (rd: ireg) (r1: ireg) + | Porl_ri (rd: ireg) (n: int) + | Porq_ri (rd: ireg) (n: int64) + | Pxorl_r (rd: ireg) (**r [xor] with self = set to zero *) + | Pxorq_r (rd: ireg) + | Pxorl_rr (rd: ireg) (r1: ireg) + | Pxorq_rr (rd: ireg) (r1: ireg) + | Pxorl_ri (rd: ireg) (n: int) + | Pxorq_ri (rd: ireg) (n: int64) + | Pnotl (rd: ireg) + | Pnotq (rd: ireg) + | Psall_rcl (rd: ireg) + | Psalq_rcl (rd: ireg) + | Psall_ri (rd: ireg) (n: int) + | Psalq_ri (rd: ireg) (n: int) + | Pshrl_rcl (rd: ireg) + | Pshrq_rcl (rd: ireg) + | Pshrl_ri (rd: ireg) (n: int) + | Pshrq_ri (rd: ireg) (n: int) + | Psarl_rcl (rd: ireg) + | Psarq_rcl (rd: ireg) + | Psarl_ri (rd: ireg) (n: int) + | Psarq_ri (rd: ireg) (n: int) | Pshld_ri (rd: ireg) (r1: ireg) (n: int) - | Pror_ri (rd: ireg) (n: int) - | Pcmp_rr (r1 r2: ireg) - | Pcmp_ri (r1: ireg) (n: int) - | Ptest_rr (r1 r2: ireg) - | Ptest_ri (r1: ireg) (n: int) + | Prorl_ri (rd: ireg) (n: int) + | Prorq_ri (rd: ireg) (n: int) + | Pcmpl_rr (r1 r2: ireg) + | Pcmpq_rr (r1 r2: ireg) + | Pcmpl_ri (r1: ireg) (n: int) + | Pcmpq_ri (r1: ireg) (n: int64) + | Ptestl_rr (r1 r2: ireg) + | Ptestq_rr (r1 r2: ireg) + | Ptestl_ri (r1: ireg) (n: int) + | Ptestq_ri (r1: ireg) (n: int64) | Pcmov (c: testcond) (rd: ireg) (r1: ireg) | Psetcc (c: testcond) (rd: ireg) (** Floating-point arithmetic *) @@ -204,24 +242,26 @@ Inductive instruction: Type := | Pcall_r (r: ireg) (sg: signature) | Pret (** Saving and restoring registers *) - | Pmov_rm_a (rd: ireg) (a: addrmode) (**r like [Pmov_rm], using [Many32] chunk *) - | Pmov_mr_a (a: addrmode) (rs: ireg) (**r like [Pmov_mr], using [Many32] chunk *) + | Pmov_rm_a (rd: ireg) (a: addrmode) (**r like [Pmov_rm], using [Many64] chunk *) + | Pmov_mr_a (a: addrmode) (rs: ireg) (**r like [Pmov_mr], using [Many64] chunk *) | Pmovsd_fm_a (rd: freg) (a: addrmode) (**r like [Pmovsd_fm], using [Many64] chunk *) | Pmovsd_mf_a (a: addrmode) (r1: freg) (**r like [Pmovsd_mf], using [Many64] chunk *) (** Pseudo-instructions *) | Plabel(l: label) - | Pallocframe(sz: Z)(ofs_ra ofs_link: int) - | Pfreeframe(sz: Z)(ofs_ra ofs_link: int) + | Pallocframe(sz: Z)(ofs_ra ofs_link: ptrofs) + | Pfreeframe(sz: Z)(ofs_ra ofs_link: ptrofs) | Pbuiltin(ef: external_function)(args: list (builtin_arg preg))(res: builtin_res preg) - (** Instructions not generated by [Asmgen] *) - | Padc_ri (rd: ireg) (n: int) - | Padc_rr (rd: ireg) (r2: ireg) - | Padd_mi (a: addrmode) (n: int) - | Padd_ri (rd: ireg) (n: int) - | Padd_rr (rd: ireg) (r2: ireg) - | Pbsf (rd: ireg) (r1: ireg) - | Pbsr (rd: ireg) (r1: ireg) - | Pbswap (rd: ireg) + (** Instructions not generated by [Asmgen] -- TO CHECK *) + | Padcl_ri (rd: ireg) (n: int) + | Padcl_rr (rd: ireg) (r2: ireg) + | Paddl_mi (a: addrmode) (n: int) + | Paddl_rr (rd: ireg) (r2: ireg) + | Pbsfl (rd: ireg) (r1: ireg) + | Pbsfq (rd: ireg) (r1: ireg) + | Pbsrl (rd: ireg) (r1: ireg) + | Pbsrq (rd: ireg) (r1: ireg) + | Pbswap64 (rd: ireg) + | Pbswap32 (rd: ireg) | Pbswap16 (rd: ireg) | Pcfi_adjust (n: int) | Pfmadd132 (rd: freg) (r2: freg) (r3: freg) @@ -239,15 +279,16 @@ Inductive instruction: Type := | Pmaxsd (rd: freg) (r2: freg) | Pminsd (rd: freg) (r2: freg) | Pmovb_rm (rd: ireg) (a: addrmode) - | Pmovq_mr (a: addrmode) (rs: freg) - | Pmovq_rm (rd: freg) (a: addrmode) + | Pmovsq_mr (a: addrmode) (rs: freg) + | Pmovsq_rm (rd: freg) (a: addrmode) | Pmovsb | Pmovsw | Pmovw_rm (rd: ireg) (ad: addrmode) | Prep_movsl - | Psbb_rr (rd: ireg) (r2: ireg) + | Psbbl_rr (rd: ireg) (r2: ireg) | Psqrtsd (rd: freg) (r1: freg) - | Psub_ri (rd: ireg) (n: int). + | Psubl_ri (rd: ireg) (n: int) + | Psubq_ri (rd: ireg) (n: int64). Definition code := list instruction. Record function : Type := mkfunction { fn_sig: signature; fn_code: code }. @@ -334,22 +375,44 @@ Variable ge: genv. (** Evaluating an addressing mode *) -Definition eval_addrmode (a: addrmode) (rs: regset) : val := - match a with Addrmode base ofs const => - Val.add (match base with - | None => Vzero - | Some r => rs r +Definition eval_addrmode32 (a: addrmode) (rs: regset) : val := + let '(Addrmode base ofs const) := a in + Val.add (match base with + | None => Vint Int.zero + | Some r => rs r + end) + (Val.add (match ofs with + | None => Vint Int.zero + | Some(r, sc) => + if zeq sc 1 + then rs r + else Val.mul (rs r) (Vint (Int.repr sc)) end) - (Val.add (match ofs with - | None => Vzero - | Some(r, sc) => - if Int.eq sc Int.one then rs r else Val.mul (rs r) (Vint sc) - end) - (match const with - | inl ofs => Vint ofs - | inr(id, ofs) => Genv.symbol_address ge id ofs - end)) - end. + (match const with + | inl ofs => Vint (Int.repr ofs) + | inr(id, ofs) => Genv.symbol_address ge id ofs + end)). + +Definition eval_addrmode64 (a: addrmode) (rs: regset) : val := + let '(Addrmode base ofs const) := a in + Val.addl (match base with + | None => Vlong Int64.zero + | Some r => rs r + end) + (Val.addl (match ofs with + | None => Vlong Int64.zero + | Some(r, sc) => + if zeq sc 1 + then rs r + else Val.mull (rs r) (Vlong (Int64.repr sc)) + end) + (match const with + | inl ofs => Vlong (Int64.repr ofs) + | inr(id, ofs) => Genv.symbol_address ge id ofs + end)). + +Definition eval_addrmode (a: addrmode) (rs: regset) : val := + if Archi.ptr64 then eval_addrmode64 a rs else eval_addrmode32 a rs. (** Performing a comparison *) @@ -368,6 +431,13 @@ Definition compare_ints (x y: val) (rs: regset) (m: mem): regset := #OF <- (Val.sub_overflow x y) #PF <- Vundef. +Definition compare_longs (x y: val) (rs: regset) (m: mem): regset := + rs #ZF <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq x y)) + #CF <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt x y)) + #SF <- (Val.negativel (Val.subl x y)) + #OF <- (Val.subl_overflow x y) + #PF <- Vundef. + (** Floating-point comparison between x and y: - ZF = 1 if x=y or unordered, 0 if x<>y - CF = 1 if x<y or unordered, 0 if x>=y @@ -481,7 +551,7 @@ Inductive outcome: Type := to [Vundef] in addition to incrementing the [PC]. *) Definition nextinstr (rs: regset) := - rs#PC <- (Val.add rs#PC Vone). + rs#PC <- (Val.offset_ptr rs#PC Ptrofs.one). Definition nextinstr_nf (rs: regset) : regset := nextinstr (undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs). @@ -491,7 +561,7 @@ Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := | None => Stuck | Some pos => match rs#PC with - | Vptr b ofs => Next (rs#PC <- (Vptr b (Int.repr pos))) m + | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m | _ => Stuck end end. @@ -537,14 +607,20 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** Moves *) | Pmov_rr rd r1 => Next (nextinstr (rs#rd <- (rs r1))) m - | Pmov_ri rd n => + | Pmovl_ri rd n => Next (nextinstr_nf (rs#rd <- (Vint n))) m - | Pmov_ra rd id => - Next (nextinstr_nf (rs#rd <- (Genv.symbol_address ge id Int.zero))) m - | Pmov_rm rd a => + | Pmovq_ri rd n => + Next (nextinstr_nf (rs#rd <- (Vlong n))) m + | Pmov_rs rd id => + Next (nextinstr_nf (rs#rd <- (Genv.symbol_address ge id Ptrofs.zero))) m + | Pmovl_rm rd a => exec_load Mint32 m a rs rd - | Pmov_mr a r1 => + | Pmovq_rm rd a => + exec_load Mint64 m a rs rd + | Pmovl_mr a r1 => exec_store Mint32 m a rs r1 nil + | Pmovq_mr a r1 => + exec_store Mint64 m a rs r1 nil | Pmovsd_ff rd r1 => Next (nextinstr (rs#rd <- (rs r1))) m | Pmovsd_fi rd n => @@ -567,8 +643,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out exec_load Mfloat32 m a rs ST0 | Pfstps_m a => exec_store Mfloat32 m a rs ST0 (ST0 :: nil) - | Pxchg_rr r1 r2 => - Next (nextinstr (rs#r1 <- (rs r2) #r2 <- (rs r1))) m (** Moves with conversion *) | Pmovb_mr a r1 => exec_store Mint8unsigned m a rs r1 nil @@ -590,6 +664,12 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m | Pmovsw_rm rd a => exec_load Mint16signed m a rs rd + | Pmovzl_rr rd r1 => + Next (nextinstr (rs#rd <- (Val.longofintu rs#r1))) m + | Pmovsl_rr rd r1 => + Next (nextinstr (rs#rd <- (Val.longofint rs#r1))) m + | Pmovls_rr rd => + Next (nextinstr (rs#rd <- (Val.loword rs#rd))) m | Pcvtsd2ss_ff rd r1 => Next (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m | Pcvtss2sd_ff rd r1 => @@ -602,85 +682,171 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#rd <- (Val.maketotal (Val.intofsingle rs#r1)))) m | Pcvtsi2ss_fr rd r1 => Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleofint rs#r1)))) m + | Pcvttsd2sl_rf rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.longoffloat rs#r1)))) m + | Pcvtsl2sd_fr rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatoflong rs#r1)))) m + | Pcvttss2sl_rf rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.longofsingle rs#r1)))) m + | Pcvtsl2ss_fr rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleoflong rs#r1)))) m (** Integer arithmetic *) - | Plea rd a => - Next (nextinstr (rs#rd <- (eval_addrmode a rs))) m - | Pneg rd => + | Pleal rd a => + Next (nextinstr (rs#rd <- (eval_addrmode32 a rs))) m + | Pleaq rd a => + Next (nextinstr (rs#rd <- (eval_addrmode64 a rs))) m + | Pnegl rd => Next (nextinstr_nf (rs#rd <- (Val.neg rs#rd))) m - | Psub_rr rd r1 => + | Pnegq rd => + Next (nextinstr_nf (rs#rd <- (Val.negl rs#rd))) m + | Paddl_ri rd n => + Next (nextinstr_nf (rs#rd <- (Val.add rs#rd (Vint n)))) m + | Paddq_ri rd n => + Next (nextinstr_nf (rs#rd <- (Val.addl rs#rd (Vlong n)))) m + | Psubl_rr rd r1 => Next (nextinstr_nf (rs#rd <- (Val.sub rs#rd rs#r1))) m - | Pimul_rr rd r1 => + | Psubq_rr rd r1 => + Next (nextinstr_nf (rs#rd <- (Val.subl rs#rd rs#r1))) m + | Pimull_rr rd r1 => Next (nextinstr_nf (rs#rd <- (Val.mul rs#rd rs#r1))) m - | Pimul_ri rd n => + | Pimulq_rr rd r1 => + Next (nextinstr_nf (rs#rd <- (Val.mull rs#rd rs#r1))) m + | Pimull_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.mul rs#rd (Vint n)))) m - | Pimul_r r1 => - Next (nextinstr_nf (rs#EAX <- (Val.mul rs#EAX rs#r1) - #EDX <- (Val.mulhs rs#EAX rs#r1))) m - | Pmul_r r1 => - Next (nextinstr_nf (rs#EAX <- (Val.mul rs#EAX rs#r1) - #EDX <- (Val.mulhu rs#EAX rs#r1))) m + | Pimulq_ri rd n => + Next (nextinstr_nf (rs#rd <- (Val.mull rs#rd (Vlong n)))) m + | Pimull_r r1 => + Next (nextinstr_nf (rs#RAX <- (Val.mul rs#RAX rs#r1) + #RDX <- (Val.mulhs rs#RAX rs#r1))) m + | Pimulq_r r1 => + Next (nextinstr_nf (rs#RAX <- (Val.mull rs#RAX rs#r1) + #RDX <- (Val.mullhs rs#RAX rs#r1))) m + | Pmull_r r1 => + Next (nextinstr_nf (rs#RAX <- (Val.mul rs#RAX rs#r1) + #RDX <- (Val.mulhu rs#RAX rs#r1))) m + | Pmulq_r r1 => + Next (nextinstr_nf (rs#RAX <- (Val.mull rs#RAX rs#r1) + #RDX <- (Val.mullhu rs#RAX rs#r1))) m | Pcltd => - Next (nextinstr_nf (rs#EDX <- (Val.shr rs#EAX (Vint (Int.repr 31))))) m - | Pdiv r1 => - match rs#EDX, rs#EAX, rs#r1 with + Next (nextinstr_nf (rs#RDX <- (Val.shr rs#RAX (Vint (Int.repr 31))))) m + | Pcqto => + Next (nextinstr_nf (rs#RDX <- (Val.shrl rs#RAX (Vint (Int.repr 63))))) m + | Pdivl r1 => + match rs#RDX, rs#RAX, rs#r1 with | Vint nh, Vint nl, Vint d => match Int.divmodu2 nh nl d with - | Some(q, r) => Next (nextinstr_nf (rs#EAX <- (Vint q) #EDX <- (Vint r))) m + | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vint q) #RDX <- (Vint r))) m | None => Stuck end | _, _, _ => Stuck end - | Pidiv r1 => - match rs#EDX, rs#EAX, rs#r1 with + | Pdivq r1 => + match rs#RDX, rs#RAX, rs#r1 with + | Vlong nh, Vlong nl, Vlong d => + match Int64.divmodu2 nh nl d with + | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vlong q) #RDX <- (Vlong r))) m + | None => Stuck + end + | _, _, _ => Stuck + end + | Pidivl r1 => + match rs#RDX, rs#RAX, rs#r1 with | Vint nh, Vint nl, Vint d => match Int.divmods2 nh nl d with - | Some(q, r) => Next (nextinstr_nf (rs#EAX <- (Vint q) #EDX <- (Vint r))) m + | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vint q) #RDX <- (Vint r))) m + | None => Stuck + end + | _, _, _ => Stuck + end + | Pidivq r1 => + match rs#RDX, rs#RAX, rs#r1 with + | Vlong nh, Vlong nl, Vlong d => + match Int64.divmods2 nh nl d with + | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vlong q) #RDX <- (Vlong r))) m | None => Stuck end | _, _, _ => Stuck end - | Pand_rr rd r1 => + | Pandl_rr rd r1 => Next (nextinstr_nf (rs#rd <- (Val.and rs#rd rs#r1))) m - | Pand_ri rd n => + | Pandq_rr rd r1 => + Next (nextinstr_nf (rs#rd <- (Val.andl rs#rd rs#r1))) m + | Pandl_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.and rs#rd (Vint n)))) m - | Por_rr rd r1 => + | Pandq_ri rd n => + Next (nextinstr_nf (rs#rd <- (Val.andl rs#rd (Vlong n)))) m + | Porl_rr rd r1 => Next (nextinstr_nf (rs#rd <- (Val.or rs#rd rs#r1))) m - | Por_ri rd n => + | Porq_rr rd r1 => + Next (nextinstr_nf (rs#rd <- (Val.orl rs#rd rs#r1))) m + | Porl_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.or rs#rd (Vint n)))) m - | Pxor_r rd => + | Porq_ri rd n => + Next (nextinstr_nf (rs#rd <- (Val.orl rs#rd (Vlong n)))) m + | Pxorl_r rd => Next (nextinstr_nf (rs#rd <- Vzero)) m - | Pxor_rr rd r1 => + | Pxorq_r rd => + Next (nextinstr_nf (rs#rd <- (Vlong Int64.zero))) m + | Pxorl_rr rd r1 => Next (nextinstr_nf (rs#rd <- (Val.xor rs#rd rs#r1))) m - | Pxor_ri rd n => + | Pxorq_rr rd r1 => + Next (nextinstr_nf (rs#rd <- (Val.xorl rs#rd rs#r1))) m + | Pxorl_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.xor rs#rd (Vint n)))) m - | Pnot rd => + | Pxorq_ri rd n => + Next (nextinstr_nf (rs#rd <- (Val.xorl rs#rd (Vlong n)))) m + | Pnotl rd => Next (nextinstr_nf (rs#rd <- (Val.notint rs#rd))) m - | Psal_rcl rd => - Next (nextinstr_nf (rs#rd <- (Val.shl rs#rd rs#ECX))) m - | Psal_ri rd n => + | Pnotq rd => + Next (nextinstr_nf (rs#rd <- (Val.notl rs#rd))) m + | Psall_rcl rd => + Next (nextinstr_nf (rs#rd <- (Val.shl rs#rd rs#RCX))) m + | Psalq_rcl rd => + Next (nextinstr_nf (rs#rd <- (Val.shll rs#rd rs#RCX))) m + | Psall_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.shl rs#rd (Vint n)))) m - | Pshr_rcl rd => - Next (nextinstr_nf (rs#rd <- (Val.shru rs#rd rs#ECX))) m - | Pshr_ri rd n => + | Psalq_ri rd n => + Next (nextinstr_nf (rs#rd <- (Val.shll rs#rd (Vint n)))) m + | Pshrl_rcl rd => + Next (nextinstr_nf (rs#rd <- (Val.shru rs#rd rs#RCX))) m + | Pshrq_rcl rd => + Next (nextinstr_nf (rs#rd <- (Val.shrlu rs#rd rs#RCX))) m + | Pshrl_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.shru rs#rd (Vint n)))) m - | Psar_rcl rd => - Next (nextinstr_nf (rs#rd <- (Val.shr rs#rd rs#ECX))) m - | Psar_ri rd n => + | Pshrq_ri rd n => + Next (nextinstr_nf (rs#rd <- (Val.shrlu rs#rd (Vint n)))) m + | Psarl_rcl rd => + Next (nextinstr_nf (rs#rd <- (Val.shr rs#rd rs#RCX))) m + | Psarq_rcl rd => + Next (nextinstr_nf (rs#rd <- (Val.shrl rs#rd rs#RCX))) m + | Psarl_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.shr rs#rd (Vint n)))) m + | Psarq_ri rd n => + Next (nextinstr_nf (rs#rd <- (Val.shrl rs#rd (Vint n)))) m | Pshld_ri rd r1 n => Next (nextinstr_nf (rs#rd <- (Val.or (Val.shl rs#rd (Vint n)) (Val.shru rs#r1 (Vint (Int.sub Int.iwordsize n)))))) m - | Pror_ri rd n => + | Prorl_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.ror rs#rd (Vint n)))) m - | Pcmp_rr r1 r2 => + | Prorq_ri rd n => + Next (nextinstr_nf (rs#rd <- (Val.rorl rs#rd (Vint n)))) m + | Pcmpl_rr r1 r2 => Next (nextinstr (compare_ints (rs r1) (rs r2) rs m)) m - | Pcmp_ri r1 n => + | Pcmpq_rr r1 r2 => + Next (nextinstr (compare_longs (rs r1) (rs r2) rs m)) m + | Pcmpl_ri r1 n => Next (nextinstr (compare_ints (rs r1) (Vint n) rs m)) m - | Ptest_rr r1 r2 => + | Pcmpq_ri r1 n => + Next (nextinstr (compare_longs (rs r1) (Vlong n) rs m)) m + | Ptestl_rr r1 r2 => Next (nextinstr (compare_ints (Val.and (rs r1) (rs r2)) Vzero rs m)) m - | Ptest_ri r1 n => + | Ptestq_rr r1 r2 => + Next (nextinstr (compare_longs (Val.andl (rs r1) (rs r2)) (Vlong Int64.zero) rs m)) m + | Ptestl_ri r1 n => Next (nextinstr (compare_ints (Val.and (rs r1) (Vint n)) Vzero rs m)) m + | Ptestq_ri r1 n => + Next (nextinstr (compare_longs (Val.andl (rs r1) (Vlong n)) (Vlong Int64.zero) rs m)) m | Pcmov c rd r1 => match eval_testcond c rs with | Some true => Next (nextinstr (rs#rd <- (rs#r1))) m @@ -727,7 +893,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pjmp_l lbl => goto_label f lbl rs m | Pjmp_s id sg => - Next (rs#PC <- (Genv.symbol_address ge id Int.zero)) m + Next (rs#PC <- (Genv.symbol_address ge id Ptrofs.zero)) m | Pjmp_r r sg => Next (rs#PC <- (rs r)) m | Pjcc cond lbl => @@ -747,21 +913,21 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Vint n => match list_nth_z tbl (Int.unsigned n) with | None => Stuck - | Some lbl => goto_label f lbl rs m + | Some lbl => goto_label f lbl (rs #RAX <- Vundef #RDX <- Vundef) m end | _ => Stuck end | Pcall_s id sg => - Next (rs#RA <- (Val.add rs#PC Vone) #PC <- (Genv.symbol_address ge id Int.zero)) m + Next (rs#RA <- (Val.offset_ptr rs#PC Ptrofs.one) #PC <- (Genv.symbol_address ge id Ptrofs.zero)) m | Pcall_r r sg => - Next (rs#RA <- (Val.add rs#PC Vone) #PC <- (rs r)) m + Next (rs#RA <- (Val.offset_ptr rs#PC Ptrofs.one) #PC <- (rs r)) m | Pret => Next (rs#PC <- (rs#RA)) m (** Saving and restoring registers *) | Pmov_rm_a rd a => - exec_load Many32 m a rs rd + exec_load (if Archi.ptr64 then Many64 else Many32) m a rs rd | Pmov_mr_a a r1 => - exec_store Many32 m a rs r1 nil + exec_store (if Archi.ptr64 then Many64 else Many32) m a rs r1 nil | Pmovsd_fm_a rd a => exec_load Many64 m a rs rd | Pmovsd_mf_a a r1 => @@ -771,27 +937,27 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr rs) m | Pallocframe sz ofs_ra ofs_link => let (m1, stk) := Mem.alloc m 0 sz in - let sp := Vptr stk Int.zero in - match Mem.storev Mint32 m1 (Val.add sp (Vint ofs_link)) rs#ESP with + let sp := Vptr stk Ptrofs.zero in + match Mem.storev Mptr m1 (Val.offset_ptr sp ofs_link) rs#RSP with | None => Stuck | Some m2 => - match Mem.storev Mint32 m2 (Val.add sp (Vint ofs_ra)) rs#RA with + match Mem.storev Mptr m2 (Val.offset_ptr sp ofs_ra) rs#RA with | None => Stuck - | Some m3 => Next (nextinstr (rs #EDX <- (rs#ESP) #ESP <- sp)) m3 + | Some m3 => Next (nextinstr (rs #RAX <- (rs#RSP) #RSP <- sp)) m3 end end | Pfreeframe sz ofs_ra ofs_link => - match Mem.loadv Mint32 m (Val.add rs#ESP (Vint ofs_ra)) with + match Mem.loadv Mptr m (Val.offset_ptr rs#RSP ofs_ra) with | None => Stuck | Some ra => - match Mem.loadv Mint32 m (Val.add rs#ESP (Vint ofs_link)) with + match Mem.loadv Mptr m (Val.offset_ptr rs#RSP ofs_link) with | None => Stuck | Some sp => - match rs#ESP with + match rs#RSP with | Vptr stk ofs => match Mem.free m stk 0 sz with | None => Stuck - | Some m' => Next (nextinstr (rs#ESP <- sp #RA <- ra)) m' + | Some m' => Next (nextinstr (rs#RSP <- sp #RA <- ra)) m' end | _ => Stuck end @@ -801,14 +967,16 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Stuck (**r treated specially below *) (** The following instructions and directives are not generated directly by [Asmgen], so we do not model them. *) - | Padc_ri _ _ - | Padc_rr _ _ - | Padd_mi _ _ - | Padd_ri _ _ - | Padd_rr _ _ - | Pbsf _ _ - | Pbsr _ _ - | Pbswap _ + | Padcl_ri _ _ + | Padcl_rr _ _ + | Paddl_mi _ _ + | Paddl_rr _ _ + | Pbsfl _ _ + | Pbsfq _ _ + | Pbsrl _ _ + | Pbsrq _ _ + | Pbswap64 _ + | Pbswap32 _ | Pbswap16 _ | Pcfi_adjust _ | Pfmadd132 _ _ _ @@ -826,15 +994,16 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pmaxsd _ _ | Pminsd _ _ | Pmovb_rm _ _ - | Pmovq_rm _ _ - | Pmovq_mr _ _ + | Pmovsq_rm _ _ + | Pmovsq_mr _ _ | Pmovsb | Pmovsw | Pmovw_rm _ _ | Prep_movsl - | Psbb_rr _ _ + | Psbbl_rr _ _ | Psqrtsd _ _ - | Psub_ri _ _ => Stuck + | Psubl_ri _ _ + | Psubq_ri _ _ => Stuck end. (** Translation of the LTL/Linear/Mach view of machine registers @@ -842,13 +1011,21 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Definition preg_of (r: mreg) : preg := match r with - | AX => IR EAX - | BX => IR EBX - | CX => IR ECX - | DX => IR EDX - | SI => IR ESI - | DI => IR EDI - | BP => IR EBP + | AX => IR RAX + | BX => IR RBX + | CX => IR RCX + | DX => IR RDX + | SI => IR RSI + | DI => IR RDI + | BP => IR RBP + | Machregs.R8 => IR R8 + | Machregs.R9 => IR R9 + | Machregs.R10 => IR R10 + | Machregs.R11 => IR R11 + | Machregs.R12 => IR R12 + | Machregs.R13 => IR R13 + | Machregs.R14 => IR R14 + | Machregs.R15 => IR R15 | X0 => FR XMM0 | X1 => FR XMM1 | X2 => FR XMM2 @@ -857,6 +1034,14 @@ Definition preg_of (r: mreg) : preg := | X5 => FR XMM5 | X6 => FR XMM6 | X7 => FR XMM7 + | X8 => FR XMM8 + | X9 => FR XMM9 + | X10 => FR XMM10 + | X11 => FR XMM11 + | X12 => FR XMM12 + | X13 => FR XMM13 + | X14 => FR XMM14 + | X15 => FR XMM15 | FP0 => ST0 end. @@ -870,7 +1055,7 @@ Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := | extcall_arg_stack: forall ofs ty bofs v, bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> Mem.loadv (chunk_of_type ty) m - (Val.add (rs (IR ESP)) (Vint (Int.repr bofs))) = Some v -> + (Val.offset_ptr (rs (IR RSP)) (Ptrofs.repr bofs)) = Some v -> extcall_arg rs m (S Outgoing ofs ty) v. Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := @@ -899,15 +1084,15 @@ Inductive step: state -> trace -> state -> Prop := forall b ofs f i rs m rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Int.unsigned ofs) f.(fn_code) = Some i -> + find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some i -> exec_instr f i rs m = Next rs' m' -> step (State rs m) E0 (State rs' m') | exec_step_builtin: forall b ofs f ef args res rs m vargs t vres rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Int.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> - eval_builtin_args ge rs (rs ESP) m args vargs -> + find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> + eval_builtin_args ge rs (rs RSP) m args vargs -> external_call ef ge vargs m t vres m' -> rs' = nextinstr_nf (set_res res vres @@ -915,7 +1100,7 @@ Inductive step: state -> trace -> state -> Prop := step (State rs m) t (State rs' m') | exec_step_external: forall b ef args res rs m t rs' m', - rs PC = Vptr b Int.zero -> + rs PC = Vptr b Ptrofs.zero -> Genv.find_funct_ptr ge b = Some (External ef) -> extcall_arguments rs m (ef_sig ef) args -> external_call ef ge args m t res m' -> @@ -932,15 +1117,15 @@ Inductive initial_state (p: program): state -> Prop := let ge := Genv.globalenv p in let rs0 := (Pregmap.init Vundef) - # PC <- (Genv.symbol_address ge p.(prog_main) Int.zero) - # RA <- Vzero - # ESP <- Vzero in + # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) + # RA <- Vnullptr + # RSP <- Vnullptr in initial_state p (State rs0 m0). Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m r, - rs#PC = Vzero -> - rs#EAX = Vint r -> + rs#PC = Vnullptr -> + rs#RAX = Vint r -> final_state (State rs m) r. Definition semantics (p: program) := @@ -998,7 +1183,9 @@ Ltac Equalities := - (* initial states *) inv H; inv H0. f_equal. congruence. - (* final no step *) - inv H. unfold Vzero in H0. red; intros; red; intros. inv H; congruence. + assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). + { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } + inv H. red; intros; red; intros. inv H; rewrite H0 in *; eelim NOTNULL; eauto. - (* final states *) inv H; inv H0. congruence. Qed. diff --git a/ia32/AsmToJSON.ml b/x86/AsmToJSON.ml index 3214491f..3214491f 100644 --- a/ia32/AsmToJSON.ml +++ b/x86/AsmToJSON.ml diff --git a/ia32/AsmToJSON.mli b/x86/AsmToJSON.mli index 20bcba5e..20bcba5e 100644 --- a/ia32/AsmToJSON.mli +++ b/x86/AsmToJSON.mli diff --git a/ia32/Asmexpand.ml b/x86/Asmexpand.ml index 6a64221e..0436bc86 100644 --- a/ia32/Asmexpand.ml +++ b/x86/Asmexpand.ml @@ -19,38 +19,60 @@ open Asmexpandaux open AST open Camlcoq open Datatypes -open Integers exception Error of string (* Useful constants and helper functions *) -let _0 = Int.zero -let _1 = Int.one +let _0 = Integers.Int.zero +let _1 = Integers.Int.one let _2 = coqint_of_camlint 2l let _4 = coqint_of_camlint 4l let _8 = coqint_of_camlint 8l + +let _0z = Z.zero +let _1z = Z.one +let _2z = Z.of_sint 2 +let _4z = Z.of_sint 4 +let _8z = Z.of_sint 8 +let _16z = Z.of_sint 16 -let stack_alignment () = - if Configuration.system = "macosx" then 16 - else 8 +let stack_alignment () = 16 + +(* Pseudo instructions for 32/64 bit compatibility *) + +let _Plea (r, addr) = + if Archi.ptr64 then Pleaq (r, addr) else Pleal (r, addr) (* SP adjustment to allocate or free a stack frame *) -let int32_align n a = - if n >= 0l - then Int32.logand (Int32.add n (Int32.of_int (a-1))) (Int32.of_int (-a)) - else Int32.logand n (Int32.of_int (-a)) +let align n a = + if n >= 0 then (n + a - 1) land (-a) else n land (-a) -let sp_adjustment sz = - let sz = camlint_of_coqint sz in +let sp_adjustment_32 sz = + let sz = Z.to_int sz in (* Preserve proper alignment of the stack *) - let sz = int32_align sz (stack_alignment ()) in + let sz = align sz (stack_alignment ()) in (* The top 4 bytes have already been allocated by the "call" instruction. *) - let sz = Int32.sub sz 4l in - sz - - + sz - 4 + +let sp_adjustment_64 sz = + let sz = Z.to_int sz in + if is_current_function_variadic() then begin + (* If variadic, add room for register save area, which must be 16-aligned *) + let ofs = align (sz - 8) 16 in + let sz = ofs + 176 (* save area *) + 8 (* return address *) in + (* Preserve proper alignment of the stack *) + let sz = align sz 16 in + (* The top 8 bytes have already been allocated by the "call" instruction. *) + (sz - 8, ofs) + end else begin + (* Preserve proper alignment of the stack *) + let sz = align sz 16 in + (* The top 8 bytes have already been allocated by the "call" instruction. *) + (sz - 8, -1) + end + (* Built-ins. They come in two flavors: - annotation statements: take their arguments in registers or stack locations; generate no code; @@ -69,25 +91,25 @@ let expand_annot_val txt targ args res = | _, _ -> raise (Error "ill-formed __builtin_annot_intval") -(* Translate a builtin argument into an addressing mode *) - -let addressing_of_builtin_arg = function - | BA (IR r) -> Addrmode(Some r, None, Coq_inl Integers.Int.zero) - | BA_addrstack ofs -> Addrmode(Some ESP, None, Coq_inl ofs) - | BA_addrglobal(id, ofs) -> Addrmode(None, None, Coq_inr(id, ofs)) - | _ -> assert false - (* Operations on addressing modes *) let offset_addressing (Addrmode(base, ofs, cst)) delta = Addrmode(base, ofs, match cst with - | Coq_inl n -> Coq_inl(Int.add n delta) - | Coq_inr(id, n) -> Coq_inr(id, Int.add n delta)) + | Coq_inl n -> Coq_inl(Z.add n delta) + | Coq_inr(id, n) -> Coq_inr(id, Integers.Ptrofs.add n delta)) let linear_addr reg ofs = Addrmode(Some reg, None, Coq_inl ofs) let global_addr id ofs = Addrmode(None, None, Coq_inr(id, ofs)) +(* Translate a builtin argument into an addressing mode *) + +let addressing_of_builtin_arg = function + | BA (IR r) -> linear_addr r Z.zero + | BA_addrstack ofs -> linear_addr RSP (Integers.Ptrofs.unsigned ofs) + | BA_addrglobal(id, ofs) -> global_addr id ofs + | _ -> assert false + (* Handling of memcpy *) (* Unaligned memory accesses are quite fast on IA32, so use large @@ -95,29 +117,34 @@ let global_addr id ofs = Addrmode(None, None, Coq_inr(id, ofs)) let expand_builtin_memcpy_small sz al src dst = let rec copy src dst sz = - if sz >= 8 && !Clflags.option_ffpu then begin - emit (Pmovq_rm (XMM7, src)); - emit (Pmovq_mr (dst, XMM7)); - copy (offset_addressing src _8) (offset_addressing dst _8) (sz - 8) + if sz >= 8 && Archi.ptr64 then begin + emit (Pmovq_rm (RCX, src)); + emit (Pmovq_mr (dst, RCX)); + copy (offset_addressing src _8z) (offset_addressing dst _8z) (sz - 8) + end else if sz >= 8 && !Clflags.option_ffpu then begin + emit (Pmovsq_rm (XMM7, src)); + emit (Pmovsq_mr (dst, XMM7)); + copy (offset_addressing src _8z) (offset_addressing dst _8z) (sz - 8) end else if sz >= 4 then begin - emit (Pmov_rm (ECX, src)); - emit (Pmov_mr (dst, ECX)); - copy (offset_addressing src _4) (offset_addressing dst _4) (sz - 4) + emit (Pmovl_rm (RCX, src)); + emit (Pmovl_mr (dst, RCX)); + copy (offset_addressing src _4z) (offset_addressing dst _4z) (sz - 4) end else if sz >= 2 then begin - emit (Pmovw_rm (ECX, src)); - emit (Pmovw_mr (dst, ECX)); - copy (offset_addressing src _2) (offset_addressing dst _2) (sz - 2) + emit (Pmovw_rm (RCX, src)); + emit (Pmovw_mr (dst, RCX)); + copy (offset_addressing src _2z) (offset_addressing dst _2z) (sz - 2) end else if sz >= 1 then begin - emit (Pmovb_rm (ECX, src)); - emit (Pmovb_mr (dst, ECX)); - copy (offset_addressing src _1) (offset_addressing dst _1) (sz - 1) + emit (Pmovb_rm (RCX, src)); + emit (Pmovb_mr (dst, RCX)); + copy (offset_addressing src _1z) (offset_addressing dst _1z) (sz - 1) end in copy (addressing_of_builtin_arg src) (addressing_of_builtin_arg dst) sz let expand_builtin_memcpy_big sz al src dst = - if src <> BA (IR ESI) then emit (Plea (ESI, addressing_of_builtin_arg src)); - if dst <> BA (IR EDI) then emit (Plea (EDI, addressing_of_builtin_arg dst)); - emit (Pmov_ri (ECX,coqint_of_camlint (Int32.of_int (sz / 4)))); + if src <> BA (IR RSI) then emit (_Plea (RSI, addressing_of_builtin_arg src)); + if dst <> BA (IR RDI) then emit (_Plea (RDI, addressing_of_builtin_arg dst)); + (* TODO: movsq? *) + emit (Pmovl_ri (RCX,coqint_of_camlint (Int32.of_int (sz / 4)))); emit Prep_movsl; if sz mod 4 >= 2 then emit Pmovsw; if sz mod 2 >= 1 then emit Pmovsb @@ -141,15 +168,17 @@ let expand_builtin_vload_common chunk addr res = | Mint16signed, BR(IR res) -> emit (Pmovsw_rm (res,addr)) | Mint32, BR(IR res) -> - emit (Pmov_rm (res,addr)) + emit (Pmovl_rm (res,addr)) + | Mint64, BR(IR res) -> + emit (Pmovq_rm (res,addr)) | Mint64, BR_splitlong(BR(IR res1), BR(IR res2)) -> - let addr' = offset_addressing addr _4 in + let addr' = offset_addressing addr _4z in if not (Asmgen.addressing_mentions addr res2) then begin - emit (Pmov_rm (res2,addr)); - emit (Pmov_rm (res1,addr')) + emit (Pmovl_rm (res2,addr)); + emit (Pmovl_rm (res1,addr')) end else begin - emit (Pmov_rm (res1,addr')); - emit (Pmov_rm (res2,addr)) + emit (Pmovl_rm (res1,addr')); + emit (Pmovl_rm (res2,addr)) end | Mfloat32, BR(FR res) -> emit (Pmovss_fm (res,addr)) @@ -168,20 +197,22 @@ let expand_builtin_vload chunk args res = let expand_builtin_vstore_common chunk addr src tmp = match chunk, src with | (Mint8signed | Mint8unsigned), BA(IR src) -> - if Asmgen.low_ireg src then + if Archi.ptr64 || Asmgen.low_ireg src then emit (Pmovb_mr (addr,src)) else begin - emit (Pmov_rr (tmp,src)); - emit (Pmovb_mr (addr,tmp)) - end + emit (Pmov_rr (tmp,src)); + emit (Pmovb_mr (addr,tmp)) + end | (Mint16signed | Mint16unsigned), BA(IR src) -> emit (Pmovw_mr (addr,src)) | Mint32, BA(IR src) -> - emit (Pmov_mr (addr,src)) + emit (Pmovl_mr (addr,src)) + | Mint64, BA(IR src) -> + emit (Pmovq_mr (addr,src)) | Mint64, BA_splitlong(BA(IR src1), BA(IR src2)) -> - let addr' = offset_addressing addr _4 in - emit (Pmov_mr (addr,src2)); - emit (Pmov_mr (addr',src1)) + let addr' = offset_addressing addr _4z in + emit (Pmovl_mr (addr,src2)); + emit (Pmovl_mr (addr',src1)) | Mfloat32, BA(FR src) -> emit (Pmovss_mf (addr,src)) | Mfloat64, BA(FR src) -> @@ -194,20 +225,65 @@ let expand_builtin_vstore chunk args = | [addr; src] -> let addr = addressing_of_builtin_arg addr in expand_builtin_vstore_common chunk addr src - (if Asmgen.addressing_mentions addr EAX then ECX else EAX) + (if Asmgen.addressing_mentions addr RAX then RCX else RAX) | _ -> assert false (* Handling of varargs *) -let expand_builtin_va_start r = +let rec next_arg_locations ir fr ofs = function + | [] -> + (ir, fr, ofs) + | (Tint | Tlong | Tany32 | Tany64) :: l -> + if ir < 6 + then next_arg_locations (ir + 1) fr ofs l + else next_arg_locations ir fr (ofs + 8) l + | (Tfloat | Tsingle) :: l -> + if fr < 8 + then next_arg_locations ir (fr + 1) ofs l + else next_arg_locations ir fr (ofs + 8) l + +let current_function_stacksize = ref 0L + +let expand_builtin_va_start_32 r = if not (is_current_function_variadic ()) then invalid_arg "Fatal error: va_start used in non-vararg function"; - let ofs = coqint_of_camlint + let ofs = Int32.(add (add !PrintAsmaux.current_function_stacksize 4l) (mul 4l (Z.to_int32 (Conventions1.size_arguments (get_current_function_sig ()))))) in - emit (Pmov_mr (linear_addr r _0, ESP)); - emit (Padd_mi (linear_addr r _0, ofs)) + emit (Pleal (RAX, linear_addr RSP (Z.of_uint32 ofs))); + emit (Pmovl_mr (linear_addr r _0z, RAX)) + +let expand_builtin_va_start_64 r = + if not (is_current_function_variadic ()) then + invalid_arg "Fatal error: va_start used in non-vararg function"; + let (ir, fr, ofs) = + next_arg_locations 0 0 0 (get_current_function_args ()) in + (* [r] points to the following struct: + struct { + unsigned int gp_offset; + unsigned int fp_offset; + void *overflow_arg_area; + void *reg_save_area; + } + gp_offset is initialized to ir * 8 + fp_offset is initialized to 6 * 8 + fr * 16 + overflow_arg_area is initialized to sp + current stacksize + ofs + reg_save_area is initialized to + sp + current stacksize - 16 - save area size (6 * 8 + 8 * 16) *) + let gp_offset = Int32.of_int (ir * 8) + and fp_offset = Int32.of_int (6 * 8 + fr * 16) + and overflow_arg_area = Int64.(add !current_function_stacksize (of_int ofs)) + and reg_save_area = Int64.(sub !current_function_stacksize 192L) in + assert (r <> RAX); + emit (Pmovl_ri (RAX, coqint_of_camlint gp_offset)); + emit (Pmovl_mr (linear_addr r _0z, RAX)); + emit (Pmovl_ri (RAX, coqint_of_camlint fp_offset)); + emit (Pmovl_mr (linear_addr r _4z, RAX)); + emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 overflow_arg_area))); + emit (Pmovq_mr (linear_addr r _8z, RAX)); + emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 reg_save_area))); + emit (Pmovq_mr (linear_addr r _16z, RAX)) (* FMA operations *) @@ -239,38 +315,52 @@ let expand_builtin_inline name args res = | ("__builtin_bswap"| "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> if a1 <> res then emit (Pmov_rr (res,a1)); - emit (Pbswap res) + emit (Pbswap32 res) + | "__builtin_bswap64", [BA(IR a1)], BR(IR res) -> + if a1 <> res then + emit (Pmov_rr (res,a1)); + emit (Pbswap64 res) + | "__builtin_bswap64", [BA_splitlong(BA(IR ah), BA(IR al))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> + assert (ah = RAX && al = RDX && rh = RDX && rl = RAX); + emit (Pbswap32 RAX); + emit (Pbswap32 RDX) | "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> if a1 <> res then emit (Pmov_rr (res,a1)); emit (Pbswap16 res) | ("__builtin_clz"|"__builtin_clzl"), [BA(IR a1)], BR(IR res) -> - emit (Pbsr (res,a1)); - emit (Pxor_ri(res,coqint_of_camlint 31l)) + emit (Pbsrl (res,a1)); + emit (Pxorl_ri(res,coqint_of_camlint 31l)) + | "__builtin_clzll", [BA(IR a1)], BR(IR res) -> + emit (Pbsrq (res,a1)); + emit (Pxorl_ri(res,coqint_of_camlint 63l)) | "__builtin_clzll", [BA_splitlong(BA (IR ah), BA (IR al))], BR(IR res) -> let lbl1 = new_label() in let lbl2 = new_label() in - emit (Ptest_rr(ah, ah)); + emit (Ptestl_rr(ah, ah)); emit (Pjcc(Cond_e, lbl1)); - emit (Pbsr(res, ah)); - emit (Pxor_ri(res, coqint_of_camlint 31l)); + emit (Pbsrl(res, ah)); + emit (Pxorl_ri(res, coqint_of_camlint 31l)); emit (Pjmp_l lbl2); emit (Plabel lbl1); - emit (Pbsr(res, al)); - emit (Pxor_ri(res, coqint_of_camlint 63l)); + emit (Pbsrl(res, al)); + emit (Pxorl_ri(res, coqint_of_camlint 63l)); emit (Plabel lbl2) | ("__builtin_ctz" | "__builtin_ctzl"), [BA(IR a1)], BR(IR res) -> - emit (Pbsf (res,a1)) + emit (Pbsfl (res,a1)) + | "__builtin_ctzll", [BA(IR a1)], BR(IR res) -> + emit (Pbsfq (res,a1)) | "__builtin_ctzll", [BA_splitlong(BA (IR ah), BA (IR al))], BR(IR res) -> let lbl1 = new_label() in let lbl2 = new_label() in - emit (Ptest_rr(al, al)); + emit (Ptestl_rr(al, al)); emit (Pjcc(Cond_e, lbl1)); - emit (Pbsf(res, al)); + emit (Pbsfl(res, al)); emit (Pjmp_l lbl2); emit (Plabel lbl1); - emit (Pbsf(res, ah)); - emit (Padd_ri(res, coqint_of_camlint 32l)); + emit (Pbsfl(res, ah)); + emit (Paddl_ri(res, coqint_of_camlint 32l)); emit (Plabel lbl2) (* Float arithmetic *) | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> @@ -320,75 +410,120 @@ let expand_builtin_inline name args res = (* 64-bit integer arithmetic *) | "__builtin_negl", [BA_splitlong(BA(IR ah), BA(IR al))], BR_splitlong(BR(IR rh), BR(IR rl)) -> - assert (ah = EDX && al = EAX && rh = EDX && rl = EAX); - emit (Pneg EAX); - emit (Padc_ri (EDX,_0)); - emit (Pneg EDX) + assert (ah = RDX && al = RAX && rh = RDX && rl = RAX); + emit (Pnegl RAX); + emit (Padcl_ri (RDX,_0)); + emit (Pnegl RDX) | "__builtin_addl", [BA_splitlong(BA(IR ah), BA(IR al)); BA_splitlong(BA(IR bh), BA(IR bl))], BR_splitlong(BR(IR rh), BR(IR rl)) -> - assert (ah = EDX && al = EAX && bh = ECX && bl = EBX && rh = EDX && rl = EAX); - emit (Padd_rr (EAX,EBX)); - emit (Padc_rr (EDX,ECX)) + assert (ah = RDX && al = RAX && bh = RCX && bl = RBX && rh = RDX && rl = RAX); + emit (Paddl_rr (RAX,RBX)); + emit (Padcl_rr (RDX,RCX)) | "__builtin_subl", [BA_splitlong(BA(IR ah), BA(IR al)); BA_splitlong(BA(IR bh), BA(IR bl))], BR_splitlong(BR(IR rh), BR(IR rl)) -> - assert (ah = EDX && al = EAX && bh = ECX && bl = EBX && rh = EDX && rl = EAX); - emit (Psub_rr (EAX,EBX)); - emit (Psbb_rr (EDX,ECX)) + assert (ah = RDX && al = RAX && bh = RCX && bl = RBX && rh = RDX && rl = RAX); + emit (Psubl_rr (RAX,RBX)); + emit (Psbbl_rr (RDX,RCX)) | "__builtin_mull", [BA(IR a); BA(IR b)], BR_splitlong(BR(IR rh), BR(IR rl)) -> - assert (a = EAX && b = EDX && rh = EDX && rl = EAX); - emit (Pmul_r EDX) + assert (a = RAX && b = RDX && rh = RDX && rl = RAX); + emit (Pmull_r RDX) (* Memory accesses *) | "__builtin_read16_reversed", [BA(IR a1)], BR(IR res) -> emit (Pmovzw_rm (res, linear_addr a1 _0)); emit (Pbswap16 res) | "__builtin_read32_reversed", [BA(IR a1)], BR(IR res) -> - emit (Pmov_rm (res, linear_addr a1 _0)); - emit (Pbswap res) + emit (Pmovl_rm (res, linear_addr a1 _0)); + emit (Pbswap32 res) | "__builtin_write16_reversed", [BA(IR a1); BA(IR a2)], _ -> - let tmp = if a1 = ECX then EDX else ECX in + let tmp = if a1 = RCX then RDX else RCX in if a2 <> tmp then emit (Pmov_rr (tmp,a2)); emit (Pbswap16 tmp); - emit (Pmovw_mr (linear_addr a1 _0, tmp)) + emit (Pmovw_mr (linear_addr a1 _0z, tmp)) | "__builtin_write32_reversed", [BA(IR a1); BA(IR a2)], _ -> - let tmp = if a1 = ECX then EDX else ECX in + let tmp = if a1 = RCX then RDX else RCX in if a2 <> tmp then emit (Pmov_rr (tmp,a2)); - emit (Pbswap tmp); - emit (Pmov_mr (linear_addr a1 _0, tmp)) + emit (Pbswap32 tmp); + emit (Pmovl_mr (linear_addr a1 _0z, tmp)) (* Vararg stuff *) | "__builtin_va_start", [BA(IR a)], _ -> - expand_builtin_va_start a + assert (a = RDX); + if Archi.ptr64 + then expand_builtin_va_start_64 a + else expand_builtin_va_start_32 a (* Synchronization *) | "__builtin_membar", [], _ -> () (* no operation *) | "__builtin_nop", [], _ -> - emit (Pxchg_rr (EAX,EAX)) + emit (Pmov_rr (RAX,RAX)) (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) +(* Calls to variadic functions for x86-64: register AL must contain + the number of XMM registers used for parameter passing. To be on + the safe side. do the same if the called function is + unprototyped. *) + +let set_al sg = + if Archi.ptr64 && (sg.sig_cc.cc_vararg || sg.sig_cc.cc_unproto) then begin + let (ir, fr, ofs) = next_arg_locations 0 0 0 sg.sig_args in + emit (Pmovl_ri (RAX, coqint_of_camlint (Int32.of_int fr))) + end + (* Expansion of instructions *) let expand_instruction instr = match instr with | Pallocframe (sz, ofs_ra, ofs_link) -> - let sz = sp_adjustment sz in - let addr = linear_addr ESP (coqint_of_camlint (Int32.add sz 4l)) in - let addr' = linear_addr ESP ofs_link in - let sz' = coqint_of_camlint sz in - emit (Psub_ri (ESP,sz')); - emit (Pcfi_adjust sz'); - emit (Plea (EDX,addr)); - emit (Pmov_mr (addr',EDX)); - PrintAsmaux.current_function_stacksize := sz + if Archi.ptr64 then begin + let (sz, save_regs) = sp_adjustment_64 sz in + (* Allocate frame *) + let sz' = Z.of_uint sz in + emit (Psubq_ri (RSP, sz')); + emit (Pcfi_adjust sz'); + if save_regs >= 0 then begin + (* Save the registers *) + emit (Pleaq (R10, linear_addr RSP (Z.of_uint save_regs))); + emit (Pcall_s (intern_string "__compcert_va_saveregs", + {sig_args = []; sig_res = None; sig_cc = cc_default})) + end; + (* Stack chaining *) + let fullsz = sz + 8 in + let addr1 = linear_addr RSP (Z.of_uint fullsz) in + let addr2 = linear_addr RSP ofs_link in + emit (Pleaq (RAX, addr1)); + emit (Pmovq_mr (addr2, RAX)); + current_function_stacksize := Int64.of_int fullsz + end else begin + let sz = sp_adjustment_32 sz in + (* Allocate frame *) + let sz' = Z.of_uint sz in + emit (Psubl_ri (RSP, sz')); + emit (Pcfi_adjust sz'); + (* Stack chaining *) + let addr1 = linear_addr RSP (Z.of_uint (sz + 4)) in + let addr2 = linear_addr RSP ofs_link in + emit (Pleal (RAX,addr1)); + emit (Pmovl_mr (addr2,RAX)); + PrintAsmaux.current_function_stacksize := Int32.of_int sz + end | Pfreeframe(sz, ofs_ra, ofs_link) -> - let sz = sp_adjustment sz in - emit (Padd_ri (ESP,coqint_of_camlint sz)) + if Archi.ptr64 then begin + let (sz, _) = sp_adjustment_64 sz in + emit (Paddq_ri (RSP, Z.of_uint sz)) + end else begin + let sz = sp_adjustment_32 sz in + emit (Paddl_ri (RSP, Z.of_uint sz)) + end + | Pjmp_s(_, sg) | Pjmp_r(_, sg) | Pcall_s(_, sg) | Pcall_r(_, sg) -> + set_al sg; + emit instr | Pbuiltin (ef,args, res) -> begin match ef with @@ -399,10 +534,7 @@ let expand_instruction instr = | EF_vstore chunk -> expand_builtin_vstore chunk args | EF_memcpy(sz, al) -> - expand_builtin_memcpy - (Int32.to_int (camlint_of_coqint sz)) - (Int32.to_int (camlint_of_coqint al)) - args + expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args | EF_annot_val(txt, targ) -> expand_annot_val txt targ args res | EF_annot _ | EF_debug _ | EF_inline_asm _ -> @@ -412,17 +544,39 @@ let expand_instruction instr = end | _ -> emit instr -let int_reg_to_dwarf = function - | EAX -> 0 - | EBX -> 3 - | ECX -> 1 - | EDX -> 2 - | ESI -> 6 - | EDI -> 7 - | EBP -> 5 - | ESP -> 4 - -let float_reg_to_dwarf = function +let int_reg_to_dwarf_32 = function + | RAX -> 0 + | RBX -> 3 + | RCX -> 1 + | RDX -> 2 + | RSI -> 6 + | RDI -> 7 + | RBP -> 5 + | RSP -> 4 + | _ -> assert false + +let int_reg_to_dwarf_64 = function + | RAX -> 0 + | RDX -> 1 + | RCX -> 2 + | RBX -> 3 + | RSI -> 4 + | RDI -> 5 + | RBP -> 6 + | RSP -> 7 + | R8 -> 8 + | R9 -> 9 + | R10 -> 10 + | R11 -> 11 + | R12 -> 12 + | R13 -> 13 + | R14 -> 14 + | R15 -> 15 + +let int_reg_to_dwarf = + if Archi.ptr64 then int_reg_to_dwarf_64 else int_reg_to_dwarf_32 + +let float_reg_to_dwarf_32 = function | XMM0 -> 21 | XMM1 -> 22 | XMM2 -> 23 @@ -431,6 +585,28 @@ let float_reg_to_dwarf = function | XMM5 -> 26 | XMM6 -> 27 | XMM7 -> 28 + | _ -> assert false + +let float_reg_to_dwarf_64 = function + | XMM0 -> 17 + | XMM1 -> 18 + | XMM2 -> 19 + | XMM3 -> 20 + | XMM4 -> 21 + | XMM5 -> 22 + | XMM6 -> 23 + | XMM7 -> 24 + | XMM8 -> 25 + | XMM9 -> 26 + | XMM10 -> 27 + | XMM11 -> 28 + | XMM12 -> 29 + | XMM13 -> 30 + | XMM14 -> 31 + | XMM15 -> 32 + +let float_reg_to_dwarf = + if Archi.ptr64 then float_reg_to_dwarf_64 else float_reg_to_dwarf_32 let preg_to_dwarf = function | IR r -> int_reg_to_dwarf r diff --git a/ia32/Asmgen.v b/x86/Asmgen.v index 1d718c26..bb26d507 100644 --- a/ia32/Asmgen.v +++ b/x86/Asmgen.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -10,10 +10,10 @@ (* *) (* *********************************************************************) -(** Translation from Mach to IA32 Asm. *) +(** Translation from Mach to IA32 assembly language *) Require Import Coqlib Errors. -Require Import Integers Floats AST Memdata. +Require Import AST Integers Floats Memdata. Require Import Op Locations Mach Asm. Open Local Scope string_scope. @@ -37,7 +37,7 @@ Definition ireg_of (r: mreg) : res ireg := Definition freg_of (r: mreg) : res freg := match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end. -(** Smart constructors for various operations. *) +(** Smart constructors for some operations. *) Definition mk_mov (rd rs: preg) (k: code) : res code := match rd, rs with @@ -48,22 +48,26 @@ Definition mk_mov (rd rs: preg) (k: code) : res code := Definition mk_shrximm (n: int) (k: code) : res code := let p := Int.sub (Int.shl Int.one n) Int.one in - OK (Ptest_rr EAX EAX :: - Plea ECX (Addrmode (Some EAX) None (inl _ p)) :: - Pcmov Cond_l EAX ECX :: - Psar_ri EAX n :: k). + OK (Ptestl_rr RAX RAX :: + Pleal RCX (Addrmode (Some RAX) None (inl _ (Int.unsigned p))) :: + Pcmov Cond_l RAX RCX :: + Psarl_ri RAX n :: k). + +Definition mk_shrxlimm (n: int) (k: code) : res code := + OK (if Int.eq n Int.zero then Pmov_rr RAX RAX :: k else + Pcqto :: + Pshrq_ri RDX (Int.sub (Int.repr 64) n) :: + Pleaq RAX (Addrmode (Some RAX) (Some(RDX, 1)) (inl _ 0)) :: + Psarq_ri RAX n :: k). Definition low_ireg (r: ireg) : bool := - match r with - | EAX | EBX | ECX | EDX => true - | ESI | EDI | EBP | ESP => false - end. + match r with RAX | RBX | RCX | RDX => true | _ => false end. Definition mk_intconv (mk: ireg -> ireg -> instruction) (rd rs: ireg) (k: code) := - if low_ireg rs then + if Archi.ptr64 || low_ireg rs then OK (mk rd rs :: k) else - OK (Pmov_rr EAX rs :: mk rd EAX :: k). + OK (Pmov_rr RAX rs :: mk rd RAX :: k). Definition addressing_mentions (addr: addrmode) (r: ireg) : bool := match addr with Addrmode base displ const => @@ -71,39 +75,44 @@ Definition addressing_mentions (addr: addrmode) (r: ireg) : bool := || match displ with Some(r', sc) => ireg_eq r r' | None => false end end. -Definition mk_smallstore (sto: addrmode -> ireg ->instruction) - (addr: addrmode) (rs: ireg) (k: code) := - if low_ireg rs then - OK (sto addr rs :: k) - else if addressing_mentions addr EAX then - OK (Plea ECX addr :: Pmov_rr EAX rs :: - sto (Addrmode (Some ECX) None (inl _ Int.zero)) EAX :: k) +Definition mk_storebyte (addr: addrmode) (rs: ireg) (k: code) := + if Archi.ptr64 || low_ireg rs then + OK (Pmovb_mr addr rs :: k) + else if addressing_mentions addr RAX then + OK (Pleal RCX addr :: Pmov_rr RAX rs :: + Pmovb_mr (Addrmode (Some RCX) None (inl _ 0)) RAX :: k) else - OK (Pmov_rr EAX rs :: sto addr EAX :: k). + OK (Pmov_rr RAX rs :: Pmovb_mr addr RAX :: k). (** Accessing slots in the stack frame. *) -Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) := +Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := + let a := Addrmode (Some base) None (inl _ (Ptrofs.unsigned ofs)) in match ty, preg_of dst with - | Tint, IR r => OK (Pmov_rm r (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tsingle, FR r => OK (Pmovss_fm r (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tsingle, ST0 => OK (Pflds_m (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tfloat, FR r => OK (Pmovsd_fm r (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tfloat, ST0 => OK (Pfldl_m (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tany32, IR r => OK (Pmov_rm_a r (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tany64, FR r => OK (Pmovsd_fm_a r (Addrmode (Some base) None (inl _ ofs)) :: k) + | Tint, IR r => OK (Pmovl_rm r a :: k) + | Tlong, IR r => OK (Pmovq_rm r a :: k) + | Tsingle, FR r => OK (Pmovss_fm r a :: k) + | Tsingle, ST0 => OK (Pflds_m a :: k) + | Tfloat, FR r => OK (Pmovsd_fm r a :: k) + | Tfloat, ST0 => OK (Pfldl_m a :: k) + | Tany32, IR r => if Archi.ptr64 then Error (msg "Asmgen.loadind1") else OK (Pmov_rm_a r a :: k) + | Tany64, IR r => if Archi.ptr64 then OK (Pmov_rm_a r a :: k) else Error (msg "Asmgen.loadind2") + | Tany64, FR r => OK (Pmovsd_fm_a r a :: k) | _, _ => Error (msg "Asmgen.loadind") end. -Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) := +Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) := + let a := Addrmode (Some base) None (inl _ (Ptrofs.unsigned ofs)) in match ty, preg_of src with - | Tint, IR r => OK (Pmov_mr (Addrmode (Some base) None (inl _ ofs)) r :: k) - | Tsingle, FR r => OK (Pmovss_mf (Addrmode (Some base) None (inl _ ofs)) r :: k) - | Tsingle, ST0 => OK (Pfstps_m (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tfloat, FR r => OK (Pmovsd_mf (Addrmode (Some base) None (inl _ ofs)) r :: k) - | Tfloat, ST0 => OK (Pfstpl_m (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tany32, IR r => OK (Pmov_mr_a (Addrmode (Some base) None (inl _ ofs)) r :: k) - | Tany64, FR r => OK (Pmovsd_mf_a (Addrmode (Some base) None (inl _ ofs)) r :: k) + | Tint, IR r => OK (Pmovl_mr a r :: k) + | Tlong, IR r => OK (Pmovq_mr a r :: k) + | Tsingle, FR r => OK (Pmovss_mf a r :: k) + | Tsingle, ST0 => OK (Pfstps_m a :: k) + | Tfloat, FR r => OK (Pmovsd_mf a r :: k) + | Tfloat, ST0 => OK (Pfstpl_m a :: k) + | Tany32, IR r => if Archi.ptr64 then Error (msg "Asmgen.storeind1") else OK (Pmov_mr_a a r :: k) + | Tany64, IR r => if Archi.ptr64 then OK (Pmov_mr_a a r :: k) else Error (msg "Asmgen.storeind2") + | Tany64, FR r => OK (Pmovsd_mf_a a r :: k) | _, _ => Error (msg "Asmgen.storeind") end. @@ -115,7 +124,7 @@ Definition transl_addressing (a: addressing) (args: list mreg): res addrmode := do r1 <- ireg_of a1; OK(Addrmode (Some r1) None (inl _ n)) | Aindexed2 n, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK(Addrmode (Some r1) (Some(r2, Int.one)) (inl _ n)) + OK(Addrmode (Some r1) (Some(r2, 1)) (inl _ n)) | Ascaled sc n, a1 :: nil => do r1 <- ireg_of a1; OK(Addrmode None (Some(r1, sc)) (inl _ n)) | Aindexed2scaled sc n, a1 :: a2 :: nil => @@ -128,11 +137,30 @@ Definition transl_addressing (a: addressing) (args: list mreg): res addrmode := | Abasedscaled sc id ofs, a1 :: nil => do r1 <- ireg_of a1; OK(Addrmode None (Some(r1, sc)) (inr _ (id, ofs))) | Ainstack n, nil => - OK(Addrmode (Some ESP) None (inl _ n)) + OK(Addrmode (Some RSP) None (inl _ (Ptrofs.signed n))) | _, _ => Error(msg "Asmgen.transl_addressing") end. +Definition normalize_addrmode_32 (a: addrmode) := + match a with + | Addrmode base ofs (inl n) => + Addrmode base ofs (inl _ (Int.signed (Int.repr n))) + | Addrmode base ofs (inr _) => + a + end. + +Definition normalize_addrmode_64 (a: addrmode) := + match a with + | Addrmode base ofs (inl n) => + let n' := Int.signed (Int.repr n) in + if zeq n' n + then (a, None) + else (Addrmode base ofs (inl _ 0), Some (Int64.repr n)) + | Addrmode base ofs (inr _) => + (a, None) + end. + (** Floating-point comparison. We swap the operands in some cases to simplify the handling of the unordered case. *) @@ -156,14 +184,23 @@ Definition transl_cond (cond: condition) (args: list mreg) (k: code) : res code := match cond, args with | Ccomp c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmp_rr r1 r2 :: k) + do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpl_rr r1 r2 :: k) | Ccompu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmp_rr r1 r2 :: k) + do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpl_rr r1 r2 :: k) | Ccompimm c n, a1 :: nil => do r1 <- ireg_of a1; - OK (if Int.eq_dec n Int.zero then Ptest_rr r1 r1 :: k else Pcmp_ri r1 n :: k) + OK (if Int.eq_dec n Int.zero then Ptestl_rr r1 r1 :: k else Pcmpl_ri r1 n :: k) | Ccompuimm c n, a1 :: nil => - do r1 <- ireg_of a1; OK (Pcmp_ri r1 n :: k) + do r1 <- ireg_of a1; OK (Pcmpl_ri r1 n :: k) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpq_rr r1 r2 :: k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpq_rr r1 r2 :: k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int64.eq_dec n Int64.zero then Ptestq_rr r1 r1 :: k else Pcmpq_ri r1 n :: k) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; OK (Pcmpq_ri r1 n :: k) | Ccompf cmp, a1 :: a2 :: nil => do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp cmp r1 r2 :: k) | Cnotcompf cmp, a1 :: a2 :: nil => @@ -173,9 +210,9 @@ Definition transl_cond | Cnotcompfs cmp, a1 :: a2 :: nil => do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp32 cmp r1 r2 :: k) | Cmaskzero n, a1 :: nil => - do r1 <- ireg_of a1; OK (Ptest_ri r1 n :: k) + do r1 <- ireg_of a1; OK (Ptestl_ri r1 n :: k) | Cmasknotzero n, a1 :: nil => - do r1 <- ireg_of a1; OK (Ptest_ri r1 n :: k) + do r1 <- ireg_of a1; OK (Ptestl_ri r1 n :: k) | _, _ => Error(msg "Asmgen.transl_cond") end. @@ -213,6 +250,10 @@ Definition testcond_for_condition (cond: condition) : extcond := | Ccompu c => Cond_base(testcond_for_unsigned_comparison c) | Ccompimm c n => Cond_base(testcond_for_signed_comparison c) | Ccompuimm c n => Cond_base(testcond_for_unsigned_comparison c) + | Ccompl c => Cond_base(testcond_for_signed_comparison c) + | Ccomplu c => Cond_base(testcond_for_unsigned_comparison c) + | Ccomplimm c n => Cond_base(testcond_for_signed_comparison c) + | Ccompluimm c n => Cond_base(testcond_for_unsigned_comparison c) | Ccompf c | Ccompfs c => match c with | Ceq => Cond_and Cond_np Cond_e @@ -242,19 +283,19 @@ Definition mk_setcc_base (cond: extcond) (rd: ireg) (k: code) := | Cond_base c => Psetcc c rd :: k | Cond_and c1 c2 => - if ireg_eq rd EAX - then Psetcc c1 EAX :: Psetcc c2 ECX :: Pand_rr EAX ECX :: k - else Psetcc c1 EAX :: Psetcc c2 rd :: Pand_rr rd EAX :: k + if ireg_eq rd RAX + then Psetcc c1 RAX :: Psetcc c2 RCX :: Pandl_rr RAX RCX :: k + else Psetcc c1 RAX :: Psetcc c2 rd :: Pandl_rr rd RAX :: k | Cond_or c1 c2 => - if ireg_eq rd EAX - then Psetcc c1 EAX :: Psetcc c2 ECX :: Por_rr EAX ECX :: k - else Psetcc c1 EAX :: Psetcc c2 rd :: Por_rr rd EAX :: k + if ireg_eq rd RAX + then Psetcc c1 RAX :: Psetcc c2 RCX :: Porl_rr RAX RCX :: k + else Psetcc c1 RAX :: Psetcc c2 rd :: Porl_rr rd RAX :: k end. Definition mk_setcc (cond: extcond) (rd: ireg) (k: code) := - if low_ireg rd + if Archi.ptr64 || low_ireg rd then mk_setcc_base cond rd k - else mk_setcc_base cond EAX (Pmov_rr rd EAX :: k). + else mk_setcc_base cond RAX (Pmov_rr rd RAX :: k). Definition mk_jcc (cond: extcond) (lbl: label) (k: code) := match cond with @@ -273,7 +314,10 @@ Definition transl_op mk_mov (preg_of res) (preg_of a1) k | Ointconst n, nil => do r <- ireg_of res; - OK ((if Int.eq_dec n Int.zero then Pxor_r r else Pmov_ri r n) :: k) + OK ((if Int.eq_dec n Int.zero then Pxorl_r r else Pmovl_ri r n) :: k) + | Olongconst n, nil => + do r <- ireg_of res; + OK ((if Int64.eq_dec n Int64.zero then Pxorq_r r else Pmovq_ri r n) :: k) | Ofloatconst f, nil => do r <- freg_of res; OK ((if Float.eq_dec f Float.zero then Pxorpd_f r else Pmovsd_fi r f) :: k) @@ -282,110 +326,217 @@ Definition transl_op OK ((if Float32.eq_dec f Float32.zero then Pxorps_f r else Pmovss_fi r f) :: k) | Oindirectsymbol id, nil => do r <- ireg_of res; - OK (Pmov_ra r id :: k) + OK (Pmov_rs r id :: k) | Ocast8signed, a1 :: nil => do r1 <- ireg_of a1; do r <- ireg_of res; mk_intconv Pmovsb_rr r r1 k | Ocast8unsigned, a1 :: nil => do r1 <- ireg_of a1; do r <- ireg_of res; mk_intconv Pmovzb_rr r r1 k | Ocast16signed, a1 :: nil => - do r1 <- ireg_of a1; do r <- ireg_of res; mk_intconv Pmovsw_rr r r1 k + do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pmovsw_rr r r1 :: k) | Ocast16unsigned, a1 :: nil => - do r1 <- ireg_of a1; do r <- ireg_of res; mk_intconv Pmovzw_rr r r1 k + do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pmovzw_rr r r1 :: k) | Oneg, a1 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pneg r :: k) + do r <- ireg_of res; OK (Pnegl r :: k) | Osub, a1 :: a2 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Psub_rr r r2 :: k) + do r <- ireg_of res; do r2 <- ireg_of a2; OK (Psubl_rr r r2 :: k) | Omul, a1 :: a2 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pimul_rr r r2 :: k) + do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pimull_rr r r2 :: k) | Omulimm n, a1 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pimul_ri r n :: k) + do r <- ireg_of res; OK (Pimull_ri r n :: k) | Omulhs, a1 :: a2 :: nil => assertion (mreg_eq a1 AX); assertion (mreg_eq res DX); - do r2 <- ireg_of a2; OK (Pimul_r r2 :: k) + do r2 <- ireg_of a2; OK (Pimull_r r2 :: k) | Omulhu, a1 :: a2 :: nil => assertion (mreg_eq a1 AX); assertion (mreg_eq res DX); - do r2 <- ireg_of a2; OK (Pmul_r r2 :: k) + do r2 <- ireg_of a2; OK (Pmull_r r2 :: k) | Odiv, a1 :: a2 :: nil => assertion (mreg_eq a1 AX); assertion (mreg_eq a2 CX); assertion (mreg_eq res AX); - OK(Pcltd :: Pidiv ECX :: k) + OK(Pcltd :: Pidivl RCX :: k) | Odivu, a1 :: a2 :: nil => assertion (mreg_eq a1 AX); assertion (mreg_eq a2 CX); assertion (mreg_eq res AX); - OK(Pxor_r EDX :: Pdiv ECX :: k) + OK(Pxorl_r RDX :: Pdivl RCX :: k) | Omod, a1 :: a2 :: nil => assertion (mreg_eq a1 AX); assertion (mreg_eq a2 CX); assertion (mreg_eq res DX); - OK(Pcltd :: Pidiv ECX :: k) + OK(Pcltd :: Pidivl RCX :: k) | Omodu, a1 :: a2 :: nil => assertion (mreg_eq a1 AX); assertion (mreg_eq a2 CX); assertion (mreg_eq res DX); - OK(Pxor_r EDX :: Pdiv ECX :: k) + OK(Pxorl_r RDX :: Pdivl RCX :: k) | Oand, a1 :: a2 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pand_rr r r2 :: k) + do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pandl_rr r r2 :: k) | Oandimm n, a1 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pand_ri r n :: k) + do r <- ireg_of res; OK (Pandl_ri r n :: k) | Oor, a1 :: a2 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Por_rr r r2 :: k) + do r <- ireg_of res; do r2 <- ireg_of a2; OK (Porl_rr r r2 :: k) | Oorimm n, a1 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Por_ri r n :: k) + do r <- ireg_of res; OK (Porl_ri r n :: k) | Oxor, a1 :: a2 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pxor_rr r r2 :: k) + do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pxorl_rr r r2 :: k) | Oxorimm n, a1 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pxor_ri r n :: k) + do r <- ireg_of res; OK (Pxorl_ri r n :: k) | Onot, a1 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pnot r :: k) + do r <- ireg_of res; OK (Pnotl r :: k) | Oshl, a1 :: a2 :: nil => assertion (mreg_eq a1 res); assertion (mreg_eq a2 CX); - do r <- ireg_of res; OK (Psal_rcl r :: k) + do r <- ireg_of res; OK (Psall_rcl r :: k) | Oshlimm n, a1 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Psal_ri r n :: k) + do r <- ireg_of res; OK (Psall_ri r n :: k) | Oshr, a1 :: a2 :: nil => assertion (mreg_eq a1 res); assertion (mreg_eq a2 CX); - do r <- ireg_of res; OK (Psar_rcl r :: k) + do r <- ireg_of res; OK (Psarl_rcl r :: k) | Oshrimm n, a1 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Psar_ri r n :: k) + do r <- ireg_of res; OK (Psarl_ri r n :: k) | Oshru, a1 :: a2 :: nil => assertion (mreg_eq a1 res); assertion (mreg_eq a2 CX); - do r <- ireg_of res; OK (Pshr_rcl r :: k) + do r <- ireg_of res; OK (Pshrl_rcl r :: k) | Oshruimm n, a1 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pshr_ri r n :: k) + do r <- ireg_of res; OK (Pshrl_ri r n :: k) | Oshrximm n, a1 :: nil => assertion (mreg_eq a1 AX); assertion (mreg_eq res AX); mk_shrximm n k | Ororimm n, a1 :: nil => assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pror_ri r n :: k) + do r <- ireg_of res; OK (Prorl_ri r n :: k) | Oshldimm n, a1 :: a2 :: nil => assertion (mreg_eq a1 res); do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pshld_ri r r2 n :: k) | Olea addr, _ => do am <- transl_addressing addr args; do r <- ireg_of res; - OK (Plea r am :: k) + OK (Pleal r (normalize_addrmode_32 am) :: k) +(* 64-bit integer operations *) + | Olowlong, a1 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; OK (Pmovls_rr r :: k) + | Ocast32signed, a1 :: nil => + do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pmovsl_rr r r1 :: k) + | Ocast32unsigned, a1 :: nil => + do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pmovzl_rr r r1 :: k) + | Onegl, a1 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; OK (Pnegq r :: k) + | Oaddlimm n, a1 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; OK (Paddq_ri r n :: k) + | Osubl, a1 :: a2 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; do r2 <- ireg_of a2; OK (Psubq_rr r r2 :: k) + | Omull, a1 :: a2 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pimulq_rr r r2 :: k) + | Omullimm n, a1 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; OK (Pimulq_ri r n :: k) + | Omullhs, a1 :: a2 :: nil => + assertion (mreg_eq a1 AX); + assertion (mreg_eq res DX); + do r2 <- ireg_of a2; OK (Pimulq_r r2 :: k) + | Omullhu, a1 :: a2 :: nil => + assertion (mreg_eq a1 AX); + assertion (mreg_eq res DX); + do r2 <- ireg_of a2; OK (Pmulq_r r2 :: k) + | Odivl, a1 :: a2 :: nil => + assertion (mreg_eq a1 AX); + assertion (mreg_eq a2 CX); + assertion (mreg_eq res AX); + OK(Pcqto :: Pidivq RCX :: k) + | Odivlu, a1 :: a2 :: nil => + assertion (mreg_eq a1 AX); + assertion (mreg_eq a2 CX); + assertion (mreg_eq res AX); + OK(Pxorq_r RDX :: Pdivq RCX :: k) + | Omodl, a1 :: a2 :: nil => + assertion (mreg_eq a1 AX); + assertion (mreg_eq a2 CX); + assertion (mreg_eq res DX); + OK(Pcqto :: Pidivq RCX :: k) + | Omodlu, a1 :: a2 :: nil => + assertion (mreg_eq a1 AX); + assertion (mreg_eq a2 CX); + assertion (mreg_eq res DX); + OK(Pxorq_r RDX :: Pdivq RCX :: k) + | Oandl, a1 :: a2 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pandq_rr r r2 :: k) + | Oandlimm n, a1 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; OK (Pandq_ri r n :: k) + | Oorl, a1 :: a2 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; do r2 <- ireg_of a2; OK (Porq_rr r r2 :: k) + | Oorlimm n, a1 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; OK (Porq_ri r n :: k) + | Oxorl, a1 :: a2 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pxorq_rr r r2 :: k) + | Oxorlimm n, a1 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; OK (Pxorq_ri r n :: k) + | Onotl, a1 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; OK (Pnotq r :: k) + | Oshll, a1 :: a2 :: nil => + assertion (mreg_eq a1 res); + assertion (mreg_eq a2 CX); + do r <- ireg_of res; OK (Psalq_rcl r :: k) + | Oshllimm n, a1 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; OK (Psalq_ri r n :: k) + | Oshrl, a1 :: a2 :: nil => + assertion (mreg_eq a1 res); + assertion (mreg_eq a2 CX); + do r <- ireg_of res; OK (Psarq_rcl r :: k) + | Oshrlimm n, a1 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; OK (Psarq_ri r n :: k) + | Oshrxlimm n, a1 :: nil => + assertion (mreg_eq a1 AX); + assertion (mreg_eq res AX); + mk_shrxlimm n k + | Oshrlu, a1 :: a2 :: nil => + assertion (mreg_eq a1 res); + assertion (mreg_eq a2 CX); + do r <- ireg_of res; OK (Pshrq_rcl r :: k) + | Oshrluimm n, a1 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; OK (Pshrq_ri r n :: k) + | Ororlimm n, a1 :: nil => + assertion (mreg_eq a1 res); + do r <- ireg_of res; OK (Prorq_ri r n :: k) + | Oleal addr, _ => + do am <- transl_addressing addr args; do r <- ireg_of res; + OK (match normalize_addrmode_64 am with + | (am', None) => Pleaq r am' :: k + | (am', Some delta) => Pleaq r am' :: Paddq_ri r delta :: k + end) +(**) | Onegf, a1 :: nil => assertion (mreg_eq a1 res); do r <- freg_of res; OK (Pnegd r :: k) @@ -434,6 +585,14 @@ Definition transl_op do r <- ireg_of res; do r1 <- freg_of a1; OK (Pcvttss2si_rf r r1 :: k) | Osingleofint, a1 :: nil => do r <- freg_of res; do r1 <- ireg_of a1; OK (Pcvtsi2ss_fr r r1 :: k) + | Olongoffloat, a1 :: nil => + do r <- ireg_of res; do r1 <- freg_of a1; OK (Pcvttsd2sl_rf r r1 :: k) + | Ofloatoflong, a1 :: nil => + do r <- freg_of res; do r1 <- ireg_of a1; OK (Pcvtsl2sd_fr r r1 :: k) + | Olongofsingle, a1 :: nil => + do r <- ireg_of res; do r1 <- freg_of a1; OK (Pcvttss2sl_rf r r1 :: k) + | Osingleoflong, a1 :: nil => + do r <- freg_of res; do r1 <- ireg_of a1; OK (Pcvtsl2ss_fr r r1 :: k) | Ocmp c, args => do r <- ireg_of res; transl_cond c args (mk_setcc (testcond_for_condition c) r k) @@ -457,7 +616,9 @@ Definition transl_load (chunk: memory_chunk) | Mint16signed => do r <- ireg_of dest; OK(Pmovsw_rm r am :: k) | Mint32 => - do r <- ireg_of dest; OK(Pmov_rm r am :: k) + do r <- ireg_of dest; OK(Pmovl_rm r am :: k) + | Mint64 => + do r <- ireg_of dest; OK(Pmovq_rm r am :: k) | Mfloat32 => do r <- freg_of dest; OK(Pmovss_fm r am :: k) | Mfloat64 => @@ -472,11 +633,13 @@ Definition transl_store (chunk: memory_chunk) do am <- transl_addressing addr args; match chunk with | Mint8unsigned | Mint8signed => - do r <- ireg_of src; mk_smallstore Pmovb_mr am r k + do r <- ireg_of src; mk_storebyte am r k | Mint16unsigned | Mint16signed => do r <- ireg_of src; OK(Pmovw_mr am r :: k) | Mint32 => - do r <- ireg_of src; OK(Pmov_mr am r :: k) + do r <- ireg_of src; OK(Pmovl_mr am r :: k) + | Mint64 => + do r <- ireg_of src; OK(Pmovq_mr am r :: k) | Mfloat32 => do r <- freg_of src; OK(Pmovss_mf am r :: k) | Mfloat64 => @@ -488,18 +651,18 @@ Definition transl_store (chunk: memory_chunk) (** Translation of a Mach instruction. *) Definition transl_instr (f: Mach.function) (i: Mach.instruction) - (edx_is_parent: bool) (k: code) := + (ax_is_parent: bool) (k: code) := match i with | Mgetstack ofs ty dst => - loadind ESP ofs ty dst k + loadind RSP ofs ty dst k | Msetstack src ofs ty => - storeind src ESP ofs ty k + storeind src RSP ofs ty k | Mgetparam ofs ty dst => - if edx_is_parent then - loadind EDX ofs ty dst k + if ax_is_parent then + loadind RAX ofs ty dst k else - (do k1 <- loadind EDX ofs ty dst k; - loadind ESP f.(fn_link_ofs) Tint DX k1) + (do k1 <- loadind RAX ofs ty dst k; + loadind RSP f.(fn_link_ofs) Tptr AX k1) | Mop op args res => transl_op op args res k | Mload chunk addr args dst => @@ -537,35 +700,35 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool := match i with | Msetstack src ofs ty => before - | Mgetparam ofs ty dst => negb (mreg_eq dst DX) + | Mgetparam ofs ty dst => negb (mreg_eq dst AX) | _ => false end. (** This is the naive definition that we no longer use because it is not tail-recursive. It is kept as specification. *) -Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (it1p: bool) := +Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (axp: bool) := match il with | nil => OK nil | i1 :: il' => - do k <- transl_code f il' (it1_is_parent it1p i1); - transl_instr f i1 it1p k + do k <- transl_code f il' (it1_is_parent axp i1); + transl_instr f i1 axp k end. (** This is an equivalent definition in continuation-passing style that runs in constant stack space. *) Fixpoint transl_code_rec (f: Mach.function) (il: list Mach.instruction) - (it1p: bool) (k: code -> res code) := + (axp: bool) (k: code -> res code) := match il with | nil => k nil | i1 :: il' => - transl_code_rec f il' (it1_is_parent it1p i1) - (fun c1 => do c2 <- transl_instr f i1 it1p c1; k c2) + transl_code_rec f il' (it1_is_parent axp i1) + (fun c1 => do c2 <- transl_instr f i1 axp c1; k c2) end. -Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (it1p: bool) := - transl_code_rec f il it1p (fun c => OK c). +Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (axp: bool) := + transl_code_rec f il axp (fun c => OK c). (** Translation of a whole function. Note that we must check that the generated code contains less than [2^32] instructions, @@ -579,7 +742,7 @@ Definition transl_function (f: Mach.function) := Definition transf_function (f: Mach.function) : res Asm.function := do tf <- transl_function f; - if zlt Int.max_unsigned (list_length_z tf.(fn_code)) + if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) then Error (msg "code size exceeded") else OK tf. diff --git a/ia32/Asmgenproof.v b/x86/Asmgenproof.v index c498b601..e56dc429 100644 --- a/ia32/Asmgenproof.v +++ b/x86/Asmgenproof.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -10,7 +10,7 @@ (* *) (* *********************************************************************) -(** Correctness proof for x86 generation: main proof. *) +(** Correctness proof for x86-64 generation: main proof. *) Require Import Coqlib Errors. Require Import Integers Floats AST Linking. @@ -64,9 +64,9 @@ Qed. Lemma transf_function_no_overflow: forall f tf, - transf_function f = OK tf -> list_length_z (fn_code tf) <= Int.max_unsigned. + transf_function f = OK tf -> list_length_z (fn_code tf) <= Ptrofs.max_unsigned. Proof. - intros. monadInv H. destruct (zlt Int.max_unsigned (list_length_z (fn_code x))); monadInv EQ0. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); monadInv EQ0. omega. Qed. @@ -132,6 +132,13 @@ Proof. Qed. Hint Resolve mk_shrximm_label: labels. +Remark mk_shrxlimm_label: + forall n k c, mk_shrxlimm n k = OK c -> tail_nolabel k c. +Proof. + intros. monadInv H. destruct (Int.eq n Int.zero); TailNoLabel. +Qed. +Hint Resolve mk_shrxlimm_label: labels. + Remark mk_intconv_label: forall f r1 r2 k c, mk_intconv f r1 r2 k = OK c -> (forall r r', nolabel (f r r')) -> @@ -141,14 +148,12 @@ Proof. Qed. Hint Resolve mk_intconv_label: labels. -Remark mk_smallstore_label: - forall f addr r k c, mk_smallstore f addr r k = OK c -> - (forall r addr, nolabel (f r addr)) -> - tail_nolabel k c. +Remark mk_storebyte_label: + forall addr r k c, mk_storebyte addr r k = OK c -> tail_nolabel k c. Proof. - unfold mk_smallstore; intros. TailNoLabel. + unfold mk_storebyte; intros. TailNoLabel. Qed. -Hint Resolve mk_smallstore_label: labels. +Hint Resolve mk_storebyte_label: labels. Remark loadind_label: forall base ofs ty dst k c, @@ -170,14 +175,14 @@ Remark mk_setcc_base_label: forall xc rd k, tail_nolabel k (mk_setcc_base xc rd k). Proof. - intros. destruct xc; simpl; destruct (ireg_eq rd EAX); TailNoLabel. + intros. destruct xc; simpl; destruct (ireg_eq rd RAX); TailNoLabel. Qed. Remark mk_setcc_label: forall xc rd k, tail_nolabel k (mk_setcc xc rd k). Proof. - intros. unfold mk_setcc. destruct (low_ireg rd). + intros. unfold mk_setcc. destruct (Archi.ptr64 || low_ireg rd). apply mk_setcc_base_label. eapply tail_nolabel_trans. apply mk_setcc_base_label. TailNoLabel. Qed. @@ -196,7 +201,8 @@ Remark transl_cond_label: Proof. unfold transl_cond; intros. destruct cond; TailNoLabel. - destruct (Int.eq_dec i Int.zero); TailNoLabel. + destruct (Int.eq_dec n Int.zero); TailNoLabel. + destruct (Int64.eq_dec n Int64.zero); TailNoLabel. destruct c0; simpl; TailNoLabel. destruct c0; simpl; TailNoLabel. destruct c0; simpl; TailNoLabel. @@ -209,9 +215,11 @@ Remark transl_op_label: tail_nolabel k c. Proof. unfold transl_op; intros. destruct op; TailNoLabel. - destruct (Int.eq_dec i Int.zero); TailNoLabel. - destruct (Float.eq_dec f Float.zero); TailNoLabel. - destruct (Float32.eq_dec f Float32.zero); TailNoLabel. + destruct (Int.eq_dec n Int.zero); TailNoLabel. + destruct (Int64.eq_dec n Int64.zero); TailNoLabel. + destruct (Float.eq_dec n Float.zero); TailNoLabel. + destruct (Float32.eq_dec n Float32.zero); TailNoLabel. + destruct (normalize_addrmode_64 x) as [am' [delta|]]; TailNoLabel. eapply tail_nolabel_trans. eapply transl_cond_label; eauto. eapply mk_setcc_label. Qed. @@ -285,7 +293,7 @@ Lemma transl_find_label: | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc end. Proof. - intros. monadInv H. destruct (zlt Int.max_unsigned (list_length_z (fn_code x))); inv EQ0. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0. monadInv EQ. simpl. eapply transl_code_label; eauto. rewrite transl_code'_transl_code in EQ0; eauto. Qed. @@ -309,10 +317,10 @@ Proof. intros [tc [A B]]. exploit label_pos_code_tail; eauto. instantiate (1 := 0). intros [pos' [P [Q R]]]. - exists tc; exists (rs#PC <- (Vptr b (Int.repr pos'))). + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). split. unfold goto_label. rewrite P. rewrite H1. auto. split. rewrite Pregmap.gss. constructor; auto. - rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in Q. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. auto. omega. generalize (transf_function_no_overflow _ _ H0). omega. intros. apply Pregmap.gso; auto. @@ -328,7 +336,7 @@ Proof. - intros. exploit transl_instr_label; eauto. destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor. - intros. monadInv H0. - destruct (zlt Int.max_unsigned (list_length_z (fn_code x))); inv EQ0. + destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0. monadInv EQ. rewrite transl_code'_transl_code in EQ0. exists x; exists true; split; auto. unfold fn_code. repeat constructor. - exact transf_function_no_overflow. @@ -360,7 +368,7 @@ Inductive match_states: Mach.state -> Asm.state -> Prop := (MEXT: Mem.extends m m') (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) (AG: agree ms sp rs) - (DXP: ep = true -> rs#EDX = parent_sp s), + (AXP: ep = true -> rs#RAX = parent_sp s), match_states (Mach.State s fb sp c ms m) (Asm.State rs m') | match_states_call: @@ -368,7 +376,7 @@ Inductive match_states: Mach.state -> Asm.state -> Prop := (STACKS: match_stack ge s) (MEXT: Mem.extends m m') (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Int.zero) + (ATPC: rs PC = Vptr fb Ptrofs.zero) (ATLR: rs RA = parent_ra s), match_states (Mach.Callstate s fb ms m) (Asm.State rs m') @@ -391,7 +399,7 @@ Lemma exec_straight_steps: exists rs2, exec_straight tge tf c rs1 m1' k rs2 m2' /\ agree ms2 sp rs2 - /\ (it1_is_parent ep i = true -> rs2#EDX = parent_sp s)) -> + /\ (it1_is_parent ep i = true -> rs2#RAX = parent_sp s)) -> exists st', plus step tge (State rs1 m1') E0 st' /\ match_states (Mach.State s fb sp c ms2 m2) st'. @@ -503,19 +511,19 @@ Local Transparent destroyed_by_setstack. intros [v' [C D]]. Opaque loadind. left; eapply exec_straight_steps; eauto; intros. - assert (DIFF: negb (mreg_eq dst DX) = true -> IR EDX <> preg_of dst). - intros. change (IR EDX) with (preg_of DX). red; intros. - unfold proj_sumbool in H1. destruct (mreg_eq dst DX); try discriminate. + assert (DIFF: negb (mreg_eq dst AX) = true -> IR RAX <> preg_of dst). + intros. change (IR RAX) with (preg_of AX). red; intros. + unfold proj_sumbool in H1. destruct (mreg_eq dst AX); try discriminate. elim n. eapply preg_of_injective; eauto. destruct ep; simpl in TR. -(* EDX contains parent *) +(* RAX contains parent *) exploit loadind_correct. eexact TR. - instantiate (2 := rs0). rewrite DXP; eauto. + instantiate (2 := rs0). rewrite AXP; eauto. intros [rs1 [P [Q R]]]. exists rs1; split. eauto. split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto. simpl; intros. rewrite R; auto. -(* EDX does not contain parent *) +(* RAX does not contain parent *) monadInv TR. exploit loadind_correct. eexact EQ0. eauto. intros [rs1 [P [Q R]]]. simpl in Q. exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. @@ -565,17 +573,17 @@ Opaque loadind. - (* Mcall *) assert (f0 = f) by congruence. subst f0. inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Int.max_unsigned). + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). eapply transf_function_no_overflow; eauto. destruct ros as [rf|fid]; simpl in H; monadInv H5. + (* Indirect call *) - assert (rs rf = Vptr f' Int.zero). + assert (rs rf = Vptr f' Ptrofs.zero). destruct (rs rf); try discriminate. - revert H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Int.zero). + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Int.add ofs Int.one)) fb f c false tf x). + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). econstructor; eauto. exploit return_address_offset_correct; eauto. intros; subst ra. left; econstructor; split. @@ -589,7 +597,7 @@ Opaque loadind. Simplifs. rewrite <- H2. auto. + (* Direct call *) generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Int.add ofs Int.one)) fb f c false tf x). + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). econstructor; eauto. exploit return_address_offset_correct; eauto. intros; subst ra. left; econstructor; split. @@ -605,7 +613,7 @@ Opaque loadind. - (* Mtailcall *) assert (f0 = f) by congruence. subst f0. inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Int.max_unsigned). + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). eapply transf_function_no_overflow; eauto. rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *. exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]]. @@ -615,18 +623,19 @@ Opaque loadind. exploit Mem.free_parallel_extends; eauto. intros [m2' [E F]]. destruct ros as [rf|fid]; simpl in H; monadInv H7. + (* Indirect call *) - assert (rs rf = Vptr f' Int.zero). + assert (rs rf = Vptr f' Ptrofs.zero). destruct (rs rf); try discriminate. - revert H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Int.zero). + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. generalize (code_tail_next_int _ _ _ _ NOOV H8). intro CT1. left; econstructor; split. eapply plus_left. eapply exec_step_internal. eauto. eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto. + simpl. replace (chunk_of_type Tptr) with Mptr in * by (unfold Tptr, Mptr; destruct Archi.ptr64; auto). + rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto. apply star_one. eapply exec_step_internal. - transitivity (Val.add rs0#PC Vone). auto. rewrite <- H4. simpl. eauto. + transitivity (Val.offset_ptr rs0#PC Ptrofs.one). auto. rewrite <- H4. simpl. eauto. eapply functions_transl; eauto. eapply find_instr_tail; eauto. simpl. eauto. traceEq. econstructor; eauto. @@ -639,9 +648,10 @@ Opaque loadind. left; econstructor; split. eapply plus_left. eapply exec_step_internal. eauto. eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto. + simpl. replace (chunk_of_type Tptr) with Mptr in * by (unfold Tptr, Mptr; destruct Archi.ptr64; auto). + rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto. apply star_one. eapply exec_step_internal. - transitivity (Val.add rs0#PC Vone). auto. rewrite <- H4. simpl. eauto. + transitivity (Val.offset_ptr rs0#PC Ptrofs.one). auto. rewrite <- H4. simpl. eauto. eapply functions_transl; eauto. eapply find_instr_tail; eauto. simpl. eauto. traceEq. econstructor; eauto. @@ -769,24 +779,27 @@ Opaque loadind. inv AT. monadInv H6. exploit functions_transl; eauto. intro FN. generalize (transf_function_no_overflow _ _ H5); intro NOOV. - exploit find_label_goto_label; eauto. + set (rs1 := rs0 #RAX <- Vundef #RDX <- Vundef). + exploit (find_label_goto_label f tf lbl rs1); eauto. intros [tc' [rs' [A [B C]]]]. exploit ireg_val; eauto. rewrite H. intros LD; inv LD. left; econstructor; split. apply plus_one. econstructor; eauto. eapply find_instr_tail; eauto. - simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eauto. + simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A. econstructor; eauto. Transparent destroyed_by_jumptable. - simpl. eapply agree_exten; eauto. intros. rewrite C; auto with asmgen. + apply agree_undef_regs with rs0; auto. + simpl; intros. destruct H8. rewrite C by auto with asmgen. unfold rs1; Simplifs. congruence. - (* Mreturn *) assert (f0 = f) by congruence. subst f0. inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Int.max_unsigned). + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). eapply transf_function_no_overflow; eauto. rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *. + replace (chunk_of_type Tptr) with Mptr in * by (unfold Tptr, Mptr; destruct Archi.ptr64; auto). exploit Mem.loadv_extends. eauto. eexact H0. auto. simpl. intros [parent' [A B]]. exploit lessdef_parent_sp; eauto. intros. subst parent'. clear B. exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [ra' [C D]]. @@ -799,7 +812,7 @@ Transparent destroyed_by_jumptable. eapply functions_transl; eauto. eapply find_instr_tail; eauto. simpl. rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto. apply star_one. eapply exec_step_internal. - transitivity (Val.add rs0#PC Vone). auto. rewrite <- H3. simpl. eauto. + transitivity (Val.offset_ptr rs0#PC Ptrofs.one). auto. rewrite <- H3. simpl. eauto. eapply functions_transl; eauto. eapply find_instr_tail; eauto. simpl. eauto. traceEq. constructor; auto. @@ -809,7 +822,7 @@ Transparent destroyed_by_jumptable. - (* internal function *) exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Int.max_unsigned (list_length_z (fn_code x0))); inv EQ1. + destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x0))); inv EQ1. monadInv EQ0. rewrite transl_code'_transl_code in EQ1. unfold store_stack in *. exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl. @@ -820,9 +833,11 @@ Transparent destroyed_by_jumptable. intros [m3' [P Q]]. left; econstructor; split. apply plus_one. econstructor; eauto. - simpl. rewrite Int.unsigned_zero. simpl. eauto. - simpl. rewrite C. simpl in F. rewrite (sp_val _ _ _ AG) in F. rewrite F. - simpl in P. rewrite ATLR. rewrite P. eauto. + simpl. rewrite Ptrofs.unsigned_zero. simpl. eauto. + simpl. rewrite C. simpl in F, P. + replace (chunk_of_type Tptr) with Mptr in F, P by (unfold Tptr, Mptr; destruct Archi.ptr64; auto). + rewrite (sp_val _ _ _ AG) in F. rewrite F. + rewrite ATLR. rewrite P. eauto. econstructor; eauto. unfold nextinstr. rewrite Pregmap.gss. repeat rewrite Pregmap.gso; auto with asmgen. rewrite ATPC. simpl. constructor; eauto. @@ -863,12 +878,14 @@ Proof. econstructor; split. econstructor. eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Int.zero) - with (Vptr fb Int.zero). + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). econstructor; eauto. constructor. apply Mem.extends_refl. - split. auto. simpl. unfold Vzero; congruence. intros. rewrite Regmap.gi. auto. + split. reflexivity. simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + intros. rewrite Regmap.gi. auto. unfold Genv.symbol_address. rewrite (match_program_main TRANSF). rewrite symbols_preserved. @@ -880,7 +897,9 @@ Lemma transf_final_states: match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r. Proof. intros. inv H0. inv H. constructor. auto. - compute in H1. inv H1. + assert (r0 = AX). + { unfold loc_result in H1; destruct Archi.ptr64; compute in H1; congruence. } + subst r0. generalize (preg_val _ _ _ AX AG). rewrite H2. intros LD; inv LD. auto. Qed. diff --git a/ia32/Asmgenproof1.v b/x86/Asmgenproof1.v index 9703d419..401be7d7 100644 --- a/ia32/Asmgenproof1.v +++ b/x86/Asmgenproof1.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -10,27 +10,16 @@ (* *) (* *********************************************************************) -(** Correctness proof for IA32 generation: auxiliary results. *) +(** Correctness proof for x86-64 generation: auxiliary results. *) Require Import Coqlib. -Require Import AST. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Op. -Require Import Locations. -Require Import Mach. -Require Import Asm. -Require Import Asmgen. -Require Import Asmgenproof0. -Require Import Conventions. +Require Import AST Errors Integers Floats Values Memory Globalenvs. +Require Import Op Locations Conventions Mach Asm. +Require Import Asmgen Asmgenproof0. Open Local Scope error_monad_scope. -(** * Correspondence between Mach registers and IA32 registers *) +(** * Correspondence between Mach registers and x86 registers *) Lemma agree_nextinstr_nf: forall ms sp rs, @@ -63,7 +52,7 @@ Qed. Lemma nextinstr_nf_set_preg: forall rs m v, - (nextinstr_nf (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone. + (nextinstr_nf (rs#(preg_of m) <- v))#PC = Val.offset_ptr rs#PC Ptrofs.one. Proof. intros. unfold nextinstr_nf. transitivity (nextinstr (rs#(preg_of m) <- v) PC). auto. @@ -92,7 +81,7 @@ Ltac Simplif := Ltac Simplifs := repeat Simplif. -(** * Correctness of IA32 constructor functions *) +(** * Correctness of x86-64 constructor functions *) Section CONSTRUCTORS. @@ -114,7 +103,7 @@ Proof. (* mov *) econstructor. split. apply exec_straight_one. simpl. eauto. auto. split. Simplifs. intros; Simplifs. -(* movd *) +(* movsd *) econstructor. split. apply exec_straight_one. simpl. eauto. auto. split. Simplifs. intros; Simplifs. Qed. @@ -152,7 +141,7 @@ Proof. || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone) eqn:OK; try (intuition discriminate). intros _. - InvBooleans. + InvBooleans. exists (Int.shr i (Int.repr 31)), i, i0, (Int.divs i i0), (Int.mods i i0); intuition auto. rewrite Int.shr_lt_zero. apply Int.divmods2_divs_mods. red; intros; subst i0; rewrite Int.eq_true in H; discriminate. @@ -161,16 +150,56 @@ Proof. discriminate. Qed. +Lemma divlu_modlu_exists: + forall v1 v2, + Val.divlu v1 v2 <> None \/ Val.modlu v1 v2 <> None -> + exists n d q r, + v1 = Vlong n /\ v2 = Vlong d + /\ Int64.divmodu2 Int64.zero n d = Some(q, r) + /\ Val.divlu v1 v2 = Some (Vlong q) /\ Val.modlu v1 v2 = Some (Vlong r). +Proof. + intros v1 v2; unfold Val.divlu, Val.modlu. + destruct v1; try (intuition discriminate). + destruct v2; try (intuition discriminate). + predSpec Int64.eq Int64.eq_spec i0 Int64.zero ; try (intuition discriminate). + intros _. exists i, i0, (Int64.divu i i0), (Int64.modu i i0); intuition auto. + apply Int64.divmodu2_divu_modu; auto. +Qed. + +Lemma divls_modls_exists: + forall v1 v2, + Val.divls v1 v2 <> None \/ Val.modls v1 v2 <> None -> + exists nh nl d q r, + Val.shrl v1 (Vint (Int.repr 63)) = Vlong nh /\ v1 = Vlong nl /\ v2 = Vlong d + /\ Int64.divmods2 nh nl d = Some(q, r) + /\ Val.divls v1 v2 = Some (Vlong q) /\ Val.modls v1 v2 = Some (Vlong r). +Proof. + intros v1 v2; unfold Val.divls, Val.modls. + destruct v1; try (intuition discriminate). + destruct v2; try (intuition discriminate). + destruct (Int64.eq i0 Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone) eqn:OK; + try (intuition discriminate). + intros _. + InvBooleans. + exists (Int64.shr i (Int64.repr 63)), i, i0, (Int64.divs i i0), (Int64.mods i i0); intuition auto. + rewrite Int64.shr_lt_zero. apply Int64.divmods2_divs_mods. + red; intros; subst i0; rewrite Int64.eq_true in H; discriminate. + revert H0. predSpec Int64.eq Int64.eq_spec i (Int64.repr Int64.min_signed); auto. + predSpec Int64.eq Int64.eq_spec i0 Int64.mone; auto. + discriminate. +Qed. + (** Smart constructor for [shrx] *) Lemma mk_shrximm_correct: forall n k c (rs1: regset) v m, mk_shrximm n k = OK c -> - Val.shrx (rs1#EAX) (Vint n) = Some v -> + Val.shrx (rs1#RAX) (Vint n) = Some v -> exists rs2, exec_straight ge fn c rs1 m k rs2 m - /\ rs2#EAX = v - /\ forall r, data_preg r = true -> r <> EAX -> r <> ECX -> rs2#r = rs1#r. + /\ rs2#RAX = v + /\ forall r, data_preg r = true -> r <> RAX -> r <> RCX -> rs2#r = rs1#r. Proof. unfold mk_shrximm; intros. inv H. exploit Val.shrx_shr; eauto. intros [x [y [A [B C]]]]. @@ -178,16 +207,16 @@ Proof. set (tnm1 := Int.sub (Int.shl Int.one n) Int.one). set (x' := Int.add x tnm1). set (rs2 := nextinstr (compare_ints (Vint x) (Vint Int.zero) rs1 m)). - set (rs3 := nextinstr (rs2#ECX <- (Vint x'))). - set (rs4 := nextinstr (if Int.lt x Int.zero then rs3#EAX <- (Vint x') else rs3)). - set (rs5 := nextinstr_nf (rs4#EAX <- (Val.shr rs4#EAX (Vint n)))). - assert (rs3#EAX = Vint x). unfold rs3. Simplifs. - assert (rs3#ECX = Vint x'). unfold rs3. Simplifs. + set (rs3 := nextinstr (rs2#RCX <- (Vint x'))). + set (rs4 := nextinstr (if Int.lt x Int.zero then rs3#RAX <- (Vint x') else rs3)). + set (rs5 := nextinstr_nf (rs4#RAX <- (Val.shr rs4#RAX (Vint n)))). + assert (rs3#RAX = Vint x). unfold rs3. Simplifs. + assert (rs3#RCX = Vint x'). unfold rs3. Simplifs. exists rs5. split. apply exec_straight_step with rs2 m. simpl. rewrite A. simpl. rewrite Int.and_idem. auto. auto. apply exec_straight_step with rs3 m. simpl. - change (rs2 EAX) with (rs1 EAX). rewrite A. simpl. - rewrite (Int.add_commut Int.zero tnm1). rewrite Int.add_zero. auto. auto. + change (rs2 RAX) with (rs1 RAX). rewrite A. simpl. + rewrite Int.repr_unsigned. rewrite Int.add_zero_l. auto. auto. apply exec_straight_step with rs4 m. simpl. rewrite Int.lt_sub_overflow. unfold rs4. destruct (Int.lt x Int.zero); simpl; auto. unfold rs4. destruct (Int.lt x Int.zero); simpl; auto. @@ -200,6 +229,45 @@ Proof. unfold compare_ints. Simplifs. Qed. +(** Smart constructor for [shrxl] *) + +Lemma mk_shrxlimm_correct: + forall n k c (rs1: regset) v m, + mk_shrxlimm n k = OK c -> + Val.shrxl (rs1#RAX) (Vint n) = Some v -> + exists rs2, + exec_straight ge fn c rs1 m k rs2 m + /\ rs2#RAX = v + /\ forall r, data_preg r = true -> r <> RAX -> r <> RDX -> rs2#r = rs1#r. +Proof. + unfold mk_shrxlimm; intros. exploit Val.shrxl_shrl_2; eauto. intros EQ. + destruct (Int.eq n Int.zero); inv H. +- econstructor; split. apply exec_straight_one. simpl; reflexivity. auto. + split. Simplifs. intros; Simplifs. +- set (v1 := Val.shrl (rs1 RAX) (Vint (Int.repr 63))) in *. + set (v2 := Val.shrlu v1 (Vint (Int.sub (Int.repr 64) n))) in *. + set (v3 := Val.addl (rs1 RAX) v2) in *. + set (v4 := Val.shrl v3 (Vint n)) in *. + set (rs2 := nextinstr_nf (rs1#RDX <- v1)). + set (rs3 := nextinstr_nf (rs2#RDX <- v2)). + set (rs4 := nextinstr (rs3#RAX <- v3)). + set (rs5 := nextinstr_nf (rs4#RAX <- v4)). + assert (X: forall v1 v2, + Val.addl v1 (Val.addl v2 (Vlong Int64.zero)) = Val.addl v1 v2). + { intros. unfold Val.addl; destruct Archi.ptr64 eqn:SF, v0; auto; destruct v5; auto. + rewrite Int64.add_zero; auto. + rewrite Ptrofs.add_zero; auto. + rewrite Int64.add_zero; auto. + rewrite Int64.add_zero; auto. } + exists rs5; split. + eapply exec_straight_trans with (rs2 := rs3). + eapply exec_straight_two with (rs2 := rs2); reflexivity. + eapply exec_straight_two with (rs2 := rs4). + simpl. rewrite X. reflexivity. reflexivity. reflexivity. reflexivity. + split. unfold rs5; Simplifs. + intros. unfold rs5; Simplifs. unfold rs4; Simplifs. unfold rs3; Simplifs. unfold rs2; Simplifs. +Qed. + (** Smart constructor for integer conversions *) Lemma mk_intconv_correct: @@ -210,9 +278,9 @@ Lemma mk_intconv_correct: exists rs2, exec_straight ge fn c rs1 m k rs2 m /\ rs2#rd = sem rs1#rs - /\ forall r, data_preg r = true -> r <> rd -> r <> EAX -> rs2#r = rs1#r. + /\ forall r, data_preg r = true -> r <> rd -> r <> RAX -> rs2#r = rs1#r. Proof. - unfold mk_intconv; intros. destruct (low_ireg rs); monadInv H. + unfold mk_intconv; intros. destruct (Archi.ptr64 || low_ireg rs); monadInv H. econstructor. split. apply exec_straight_one. rewrite H0. eauto. auto. split. Simplifs. intros. Simplifs. econstructor. split. eapply exec_straight_two. @@ -226,149 +294,210 @@ Lemma addressing_mentions_correct: forall a r (rs1 rs2: regset), (forall (r': ireg), r' <> r -> rs1 r' = rs2 r') -> addressing_mentions a r = false -> - eval_addrmode ge a rs1 = eval_addrmode ge a rs2. + eval_addrmode32 ge a rs1 = eval_addrmode32 ge a rs2. Proof. - intros until rs2; intro AG. unfold addressing_mentions, eval_addrmode. + intros until rs2; intro AG. unfold addressing_mentions, eval_addrmode32. destruct a. intros. destruct (orb_false_elim _ _ H). unfold proj_sumbool in *. decEq. destruct base; auto. apply AG. destruct (ireg_eq r i); congruence. decEq. destruct ofs as [[r' sc] | ]; auto. rewrite AG; auto. destruct (ireg_eq r r'); congruence. Qed. -Lemma mk_smallstore_correct: - forall chunk sto addr r k c rs1 m1 m2, - mk_smallstore sto addr r k = OK c -> - Mem.storev chunk m1 (eval_addrmode ge addr rs1) (rs1 r) = Some m2 -> - (forall c r addr rs m, - exec_instr ge c (sto addr r) rs m = exec_store ge chunk m addr rs r nil) -> +Lemma mk_storebyte_correct: + forall addr r k c rs1 m1 m2, + mk_storebyte addr r k = OK c -> + Mem.storev Mint8unsigned m1 (eval_addrmode ge addr rs1) (rs1 r) = Some m2 -> exists rs2, exec_straight ge fn c rs1 m1 k rs2 m2 - /\ forall r, data_preg r = true -> r <> EAX /\ r <> ECX -> rs2#r = rs1#r. + /\ forall r, data_preg r = true -> preg_notin r (if Archi.ptr64 then nil else AX :: CX :: nil) -> rs2#r = rs1#r. Proof. - unfold mk_smallstore; intros. - remember (low_ireg r) as low. destruct low. + unfold mk_storebyte; intros. + destruct (Archi.ptr64 || low_ireg r) eqn:E. (* low reg *) - monadInv H. econstructor; split. apply exec_straight_one. rewrite H1. - unfold exec_store. rewrite H0. eauto. auto. + monadInv H. econstructor; split. apply exec_straight_one. + simpl. unfold exec_store. rewrite H0. eauto. auto. intros; Simplifs. (* high reg *) - remember (addressing_mentions addr EAX) as mentions. destruct mentions; monadInv H. -(* EAX is mentioned. *) - assert (r <> ECX). red; intros; subst r; discriminate. - set (rs2 := nextinstr (rs1#ECX <- (eval_addrmode ge addr rs1))). - set (rs3 := nextinstr (rs2#EAX <- (rs1 r))). + InvBooleans. rewrite H1; simpl. destruct (addressing_mentions addr RAX) eqn:E; monadInv H. +(* RAX is mentioned. *) + assert (r <> RCX). { red; intros; subst r; discriminate H2. } + set (rs2 := nextinstr (rs1#RCX <- (eval_addrmode32 ge addr rs1))). + set (rs3 := nextinstr (rs2#RAX <- (rs1 r))). econstructor; split. apply exec_straight_three with rs2 m1 rs3 m1. simpl. auto. simpl. replace (rs2 r) with (rs1 r). auto. symmetry. unfold rs2; Simplifs. - rewrite H1. unfold exec_store. simpl. rewrite Int.add_zero. - change (rs3 EAX) with (rs1 r). - change (rs3 ECX) with (eval_addrmode ge addr rs1). - replace (Val.add (eval_addrmode ge addr rs1) (Vint Int.zero)) + simpl. unfold exec_store. unfold eval_addrmode; rewrite H1; simpl. rewrite Int.add_zero. + change (rs3 RAX) with (rs1 r). + change (rs3 RCX) with (eval_addrmode32 ge addr rs1). + replace (Val.add (eval_addrmode32 ge addr rs1) (Vint Int.zero)) with (eval_addrmode ge addr rs1). rewrite H0. eauto. - destruct (eval_addrmode ge addr rs1); simpl in H0; try discriminate. - simpl. rewrite Int.add_zero; auto. + unfold eval_addrmode in *; rewrite H1 in *. + destruct (eval_addrmode32 ge addr rs1); simpl in H0; try discriminate H0. + simpl. rewrite H1. rewrite Ptrofs.add_zero; auto. auto. auto. auto. - intros. destruct H3. Simplifs. unfold rs3; Simplifs. unfold rs2; Simplifs. -(* EAX is not mentioned *) - set (rs2 := nextinstr (rs1#EAX <- (rs1 r))). + intros. destruct H4. Simplifs. unfold rs3; Simplifs. unfold rs2; Simplifs. +(* RAX is not mentioned *) + set (rs2 := nextinstr (rs1#RAX <- (rs1 r))). econstructor; split. apply exec_straight_two with rs2 m1. simpl. auto. - rewrite H1. unfold exec_store. - rewrite (addressing_mentions_correct addr EAX rs2 rs1); auto. - change (rs2 EAX) with (rs1 r). rewrite H0. eauto. + simpl. unfold exec_store. unfold eval_addrmode in *; rewrite H1 in *. + rewrite (addressing_mentions_correct addr RAX rs2 rs1); auto. + change (rs2 RAX) with (rs1 r). rewrite H0. eauto. intros. unfold rs2; Simplifs. auto. auto. - intros. destruct H2. simpl. Simplifs. unfold rs2; Simplifs. + intros. destruct H3. simpl. Simplifs. unfold rs2; Simplifs. Qed. (** Accessing slots in the stack frame *) +Remark eval_addrmode_indexed: + forall (base: ireg) ofs (rs: regset), + match rs#base with Vptr _ _ => True | _ => False end -> + eval_addrmode ge (Addrmode (Some base) None (inl _ (Ptrofs.unsigned ofs))) rs = Val.offset_ptr rs#base ofs. +Proof. + intros. destruct (rs#base) eqn:BASE; try contradiction. + intros; unfold eval_addrmode; destruct Archi.ptr64 eqn:SF; simpl; rewrite BASE; simpl; rewrite SF; simpl. +- apply f_equal. apply f_equal. rewrite Int64.add_zero_l. rewrite <- (Ptrofs.repr_unsigned ofs) at 2. auto with ptrofs. +- apply f_equal. apply f_equal. rewrite Int.add_zero_l. rewrite <- (Ptrofs.repr_unsigned ofs) at 2. auto with ptrofs. +Qed. + +Ltac loadind_correct_solve := + match goal with + | H: Error _ = OK _ |- _ => discriminate H + | H: OK _ = OK _ |- _ => inv H + | H: match ?x with _ => _ end = OK _ |- _ => destruct x eqn:?; loadind_correct_solve + | _ => idtac + end. + Lemma loadind_correct: forall (base: ireg) ofs ty dst k (rs: regset) c m v, loadind base ofs ty dst k = OK c -> - Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v -> + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> exists rs', exec_straight ge fn c rs m k rs' m /\ rs'#(preg_of dst) = v /\ forall r, data_preg r = true -> r <> preg_of dst -> rs'#r = rs#r. Proof. unfold loadind; intros. - set (addr := Addrmode (Some base) None (inl (ident * int) ofs)) in *. - assert (eval_addrmode ge addr rs = Val.add rs#base (Vint ofs)). - unfold addr. simpl. rewrite Int.add_commut; rewrite Int.add_zero; auto. + set (addr := Addrmode (Some base) None (inl (ident * ptrofs) (Ptrofs.unsigned ofs))) in *. + assert (eval_addrmode ge addr rs = Val.offset_ptr rs#base ofs). + { apply eval_addrmode_indexed. destruct (rs base); auto || discriminate. } + rewrite <- H1 in H0. exists (nextinstr_nf (rs#(preg_of dst) <- v)); split. -- destruct ty; try discriminate; destruct (preg_of dst); inv H; simpl in H0; - apply exec_straight_one; auto; simpl; unfold exec_load; rewrite H1, H0; auto. +- loadind_correct_solve; apply exec_straight_one; auto; simpl in *; unfold exec_load; rewrite ?Heqb, ?H0; auto. - intuition Simplifs. Qed. Lemma storeind_correct: forall (base: ireg) ofs ty src k (rs: regset) c m m', storeind src base ofs ty k = OK c -> - Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' -> + Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) (rs#(preg_of src)) = Some m' -> exists rs', exec_straight ge fn c rs m k rs' m' /\ forall r, data_preg r = true -> preg_notin r (destroyed_by_setstack ty) -> rs'#r = rs#r. Proof. -Local Transparent destroyed_by_setstack. unfold storeind; intros. - set (addr := Addrmode (Some base) None (inl (ident * int) ofs)) in *. - assert (eval_addrmode ge addr rs = Val.add rs#base (Vint ofs)). - unfold addr. simpl. rewrite Int.add_commut; rewrite Int.add_zero; auto. - destruct ty; try discriminate; destruct (preg_of src); inv H; simpl in H0; + set (addr := Addrmode (Some base) None (inl (ident * ptrofs) (Ptrofs.unsigned ofs))) in *. + assert (eval_addrmode ge addr rs = Val.offset_ptr rs#base ofs). + { apply eval_addrmode_indexed. destruct (rs base); auto || discriminate. } + rewrite <- H1 in H0. + loadind_correct_solve; simpl in H0; (econstructor; split; - [apply exec_straight_one; [simpl; unfold exec_store; rewrite H1, H0; eauto|auto] + [apply exec_straight_one; [simpl; unfold exec_store; rewrite ?Heqb, H0;eauto|auto] |simpl; intros; unfold undef_regs; repeat Simplifs]). Qed. (** Translation of addressing modes *) -Lemma transl_addressing_mode_correct: +Lemma transl_addressing_mode_32_correct: forall addr args am (rs: regset) v, transl_addressing addr args = OK am -> - eval_addressing ge (rs ESP) addr (List.map rs (List.map preg_of args)) = Some v -> - Val.lessdef v (eval_addrmode ge am rs). + eval_addressing32 ge (rs RSP) addr (List.map rs (List.map preg_of args)) = Some v -> + Val.lessdef v (eval_addrmode32 ge am rs). +Proof. + assert (A: forall id ofs, Archi.ptr64 = false -> + Val.add (Vint Int.zero) (Genv.symbol_address ge id ofs) = Genv.symbol_address ge id ofs). + { intros. unfold Val.add; rewrite H. unfold Genv.symbol_address. + destruct (Genv.find_symbol ge id); auto. rewrite Ptrofs.add_zero; auto. } + assert (C: forall v i, + Val.lessdef (Val.mul v (Vint (Int.repr i))) + (if zeq i 1 then v else Val.mul v (Vint (Int.repr i)))). + { intros. destruct (zeq i 1); subst; auto. + destruct v; simpl; auto. rewrite Int.mul_one; auto. } + unfold transl_addressing; intros. + destruct addr; repeat (destruct args; try discriminate H); simpl in H0; FuncInv; + monadInv H; try (erewrite ! ireg_of_eq by eauto); unfold eval_addrmode32. +- simpl; rewrite Int.add_zero_l; auto. +- rewrite Val.add_assoc. apply Val.add_lessdef; auto. +- rewrite Val.add_permut. apply Val.add_lessdef; auto. simpl; rewrite Int.add_zero_l; auto. +- apply Val.add_lessdef; auto. apply Val.add_lessdef; auto. +- rewrite ! A by auto. auto. +- rewrite Val.add_commut. rewrite A by auto. auto. +- rewrite Val.add_permut. rewrite Val.add_commut. apply Val.add_lessdef; auto. rewrite A; auto. +- simpl. unfold Val.add; rewrite Heqb. + destruct (rs RSP); simpl; auto. + rewrite Int.add_zero_l. apply Val.lessdef_same; f_equal; f_equal. + symmetry. transitivity (Ptrofs.repr (Ptrofs.signed i)). auto with ptrofs. auto with ints. +Qed. + +Lemma transl_addressing_mode_64_correct: + forall addr args am (rs: regset) v, + transl_addressing addr args = OK am -> + eval_addressing64 ge (rs RSP) addr (List.map rs (List.map preg_of args)) = Some v -> + Val.lessdef v (eval_addrmode64 ge am rs). Proof. - assert (A: forall n, Int.add Int.zero n = n). - intros. rewrite Int.add_commut. apply Int.add_zero. - assert (B: forall n i, (if Int.eq i Int.one then Vint n else Vint (Int.mul n i)) = Vint (Int.mul n i)). - intros. predSpec Int.eq Int.eq_spec i Int.one. - subst i. rewrite Int.mul_one. auto. auto. + assert (A: forall id ofs, Archi.ptr64 = true -> + Val.addl (Vlong Int64.zero) (Genv.symbol_address ge id ofs) = Genv.symbol_address ge id ofs). + { intros. unfold Val.addl; rewrite H. unfold Genv.symbol_address. + destruct (Genv.find_symbol ge id); auto. rewrite Ptrofs.add_zero; auto. } assert (C: forall v i, - Val.lessdef (Val.mul v (Vint i)) - (if Int.eq i Int.one then v else Val.mul v (Vint i))). - intros. predSpec Int.eq Int.eq_spec i Int.one. - subst i. destruct v; simpl; auto. rewrite Int.mul_one; auto. - destruct v; simpl; auto. + Val.lessdef (Val.mull v (Vlong (Int64.repr i))) + (if zeq i 1 then v else Val.mull v (Vlong (Int64.repr i)))). + { intros. destruct (zeq i 1); subst; auto. + destruct v; simpl; auto. rewrite Int64.mul_one; auto. } unfold transl_addressing; intros. - destruct addr; repeat (destruct args; try discriminate); simpl in H0; inv H0. -(* indexed *) - monadInv H. rewrite (ireg_of_eq _ _ EQ). simpl. rewrite A; auto. -(* indexed2 *) - monadInv H. rewrite (ireg_of_eq _ _ EQ); rewrite (ireg_of_eq _ _ EQ1). simpl. - rewrite Val.add_assoc; auto. -(* scaled *) - monadInv H. rewrite (ireg_of_eq _ _ EQ). unfold eval_addrmode. - rewrite Val.add_permut. simpl. rewrite A. apply Val.add_lessdef; auto. -(* indexed2scaled *) - monadInv H. rewrite (ireg_of_eq _ _ EQ); rewrite (ireg_of_eq _ _ EQ1); simpl. - apply Val.add_lessdef; auto. apply Val.add_lessdef; auto. -(* global *) - inv H. simpl. unfold Genv.symbol_address. - destruct (Genv.find_symbol ge i); simpl; auto. repeat rewrite Int.add_zero. auto. -(* based *) - monadInv H. rewrite (ireg_of_eq _ _ EQ). simpl. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); simpl; auto. - rewrite Int.add_zero. rewrite Val.add_commut. auto. -(* basedscaled *) - monadInv H. rewrite (ireg_of_eq _ _ EQ). unfold eval_addrmode. - rewrite (Val.add_commut Vzero). rewrite Val.add_assoc. rewrite Val.add_permut. - apply Val.add_lessdef; auto. destruct (rs x); simpl; auto. rewrite B. simpl. - rewrite Int.add_zero. auto. -(* instack *) - inv H; simpl. rewrite A; auto. + destruct addr; repeat (destruct args; try discriminate H); simpl in H0; FuncInv; + monadInv H; try (erewrite ! ireg_of_eq by eauto); unfold eval_addrmode64. +- simpl; rewrite Int64.add_zero_l; auto. +- rewrite Val.addl_assoc. apply Val.addl_lessdef; auto. +- rewrite Val.addl_permut. apply Val.addl_lessdef; auto. simpl; rewrite Int64.add_zero_l; auto. +- apply Val.addl_lessdef; auto. apply Val.addl_lessdef; auto. +- rewrite ! A by auto. auto. +- unfold Val.addl; rewrite Heqb. destruct (rs RSP); auto. simpl. + rewrite Int64.add_zero_l. apply Val.lessdef_same; f_equal; f_equal. + symmetry. transitivity (Ptrofs.repr (Ptrofs.signed i)). auto with ptrofs. auto with ints. +Qed. + +Lemma transl_addressing_mode_correct: + forall addr args am (rs: regset) v, + transl_addressing addr args = OK am -> + eval_addressing ge (rs RSP) addr (List.map rs (List.map preg_of args)) = Some v -> + Val.lessdef v (eval_addrmode ge am rs). +Proof. + unfold eval_addressing, eval_addrmode; intros. destruct Archi.ptr64. + eapply transl_addressing_mode_64_correct; eauto. + eapply transl_addressing_mode_32_correct; eauto. +Qed. + +Lemma normalize_addrmode_32_correct: + forall am rs, eval_addrmode32 ge (normalize_addrmode_32 am) rs = eval_addrmode32 ge am rs. +Proof. + intros; destruct am as [base ofs [n|r]]; simpl; auto. rewrite Int.repr_signed. auto. +Qed. + +Lemma normalize_addrmode_64_correct: + forall am rs, + eval_addrmode64 ge am rs = + match normalize_addrmode_64 am with + | (am', None) => eval_addrmode64 ge am' rs + | (am', Some delta) => Val.addl (eval_addrmode64 ge am' rs) (Vlong delta) + end. +Proof. + intros; destruct am as [base ofs [n|r]]; simpl; auto. + destruct (zeq (Int.signed (Int.repr n)) n); simpl; auto. + rewrite ! Val.addl_assoc. apply f_equal. apply f_equal. simpl. rewrite Int64.add_zero_l; auto. Qed. (** Processor conditions and comparisons *) @@ -390,53 +519,7 @@ Proof. intros. Simplifs. Qed. -Lemma int_signed_eq: - forall x y, Int.eq x y = zeq (Int.signed x) (Int.signed y). -Proof. - intros. unfold Int.eq. unfold proj_sumbool. - destruct (zeq (Int.unsigned x) (Int.unsigned y)); - destruct (zeq (Int.signed x) (Int.signed y)); auto. - elim n. unfold Int.signed. rewrite e; auto. - elim n. apply Int.eqm_small_eq; auto with ints. - eapply Int.eqm_trans. apply Int.eqm_sym. apply Int.eqm_signed_unsigned. - rewrite e. apply Int.eqm_signed_unsigned. -Qed. - -Lemma int_not_lt: - forall x y, negb (Int.lt y x) = (Int.lt x y || Int.eq x y). -Proof. - intros. unfold Int.lt. rewrite int_signed_eq. unfold proj_sumbool. - destruct (zlt (Int.signed y) (Int.signed x)). - rewrite zlt_false. rewrite zeq_false. auto. omega. omega. - destruct (zeq (Int.signed x) (Int.signed y)). - rewrite zlt_false. auto. omega. - rewrite zlt_true. auto. omega. -Qed. - -Lemma int_lt_not: - forall x y, Int.lt y x = negb (Int.lt x y) && negb (Int.eq x y). -Proof. - intros. rewrite <- negb_orb. rewrite <- int_not_lt. rewrite negb_involutive. auto. -Qed. - -Lemma int_not_ltu: - forall x y, negb (Int.ltu y x) = (Int.ltu x y || Int.eq x y). -Proof. - intros. unfold Int.ltu, Int.eq. - destruct (zlt (Int.unsigned y) (Int.unsigned x)). - rewrite zlt_false. rewrite zeq_false. auto. omega. omega. - destruct (zeq (Int.unsigned x) (Int.unsigned y)). - rewrite zlt_false. auto. omega. - rewrite zlt_true. auto. omega. -Qed. - -Lemma int_ltu_not: - forall x y, Int.ltu y x = negb (Int.ltu x y) && negb (Int.eq x y). -Proof. - intros. rewrite <- negb_orb. rewrite <- int_not_ltu. rewrite negb_involutive. auto. -Qed. - -Lemma testcond_for_signed_comparison_correct: +Lemma testcond_for_signed_comparison_32_correct: forall c v1 v2 rs m b, Val.cmp_bool c v1 v2 = Some b -> eval_testcond (testcond_for_signed_comparison c) @@ -453,12 +536,12 @@ Proof. destruct (Int.eq i i0); auto. destruct (Int.eq i i0); auto. destruct (Int.lt i i0); auto. - rewrite int_not_lt. destruct (Int.lt i i0); simpl; destruct (Int.eq i i0); auto. - rewrite (int_lt_not i i0). destruct (Int.lt i i0); destruct (Int.eq i i0); reflexivity. + rewrite Int.not_lt. destruct (Int.lt i i0); simpl; destruct (Int.eq i i0); auto. + rewrite (Int.lt_not i i0). destruct (Int.lt i i0); destruct (Int.eq i i0); reflexivity. destruct (Int.lt i i0); reflexivity. Qed. -Lemma testcond_for_unsigned_comparison_correct: +Lemma testcond_for_unsigned_comparison_32_correct: forall c v1 v2 rs m b, Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 = Some b -> eval_testcond (testcond_for_unsigned_comparison c) @@ -468,44 +551,145 @@ Proof. set (rs' := nextinstr (compare_ints v1 v2 rs m)). intros [A [B [C [D E]]]]. unfold eval_testcond. rewrite A; rewrite B. unfold Val.cmpu, Val.cmp. - destruct v1; destruct v2; simpl in H; inv H. -(* int int *) + destruct v1; destruct v2; simpl in H; FuncInv; subst. +- (* int int *) destruct c; simpl; auto. destruct (Int.eq i i0); reflexivity. destruct (Int.eq i i0); auto. destruct (Int.ltu i i0); auto. - rewrite int_not_ltu. destruct (Int.ltu i i0); simpl; destruct (Int.eq i i0); auto. - rewrite (int_ltu_not i i0). destruct (Int.ltu i i0); destruct (Int.eq i i0); reflexivity. + rewrite Int.not_ltu. destruct (Int.ltu i i0); simpl; destruct (Int.eq i i0); auto. + rewrite (Int.ltu_not i i0). destruct (Int.ltu i i0); destruct (Int.eq i i0); reflexivity. destruct (Int.ltu i i0); reflexivity. -(* int ptr *) +- (* int ptr *) + unfold Val.cmpu_bool; rewrite Heqb1. destruct (Int.eq i Int.zero && - (Mem.valid_pointer m b0 (Int.unsigned i0) || Mem.valid_pointer m b0 (Int.unsigned i0 - 1))) eqn:?; try discriminate. - destruct c; simpl in *; inv H1. - rewrite Heqb1; reflexivity. - rewrite Heqb1; reflexivity. -(* ptr int *) + (Mem.valid_pointer m b0 (Ptrofs.unsigned i0) || Mem.valid_pointer m b0 (Ptrofs.unsigned i0 - 1))); try discriminate H. + destruct c; simpl in *; inv H; reflexivity. +- (* ptr int *) + unfold Val.cmpu_bool; rewrite Heqb1. destruct (Int.eq i0 Int.zero && - (Mem.valid_pointer m b0 (Int.unsigned i) || Mem.valid_pointer m b0 (Int.unsigned i - 1))) eqn:?; try discriminate. - destruct c; simpl in *; inv H1. - rewrite Heqb1; reflexivity. - rewrite Heqb1; reflexivity. -(* ptr ptr *) - simpl. - fold (Mem.weak_valid_pointer m b0 (Int.unsigned i)) in *. - fold (Mem.weak_valid_pointer m b1 (Int.unsigned i0)) in *. + (Mem.valid_pointer m b0 (Ptrofs.unsigned i) || Mem.valid_pointer m b0 (Ptrofs.unsigned i - 1))); try discriminate H. + destruct c; simpl in *; inv H; reflexivity. +- (* ptr ptr *) + unfold Val.cmpu_bool; rewrite Heqb2. + fold (Mem.weak_valid_pointer m b0 (Ptrofs.unsigned i)) in *. + fold (Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i0)) in *. destruct (eq_block b0 b1). - destruct (Mem.weak_valid_pointer m b0 (Int.unsigned i) && - Mem.weak_valid_pointer m b1 (Int.unsigned i0)); inversion H1. + destruct (Mem.weak_valid_pointer m b0 (Ptrofs.unsigned i) && + Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i0)); inv H. destruct c; simpl; auto. - destruct (Int.eq i i0); reflexivity. - destruct (Int.eq i i0); auto. - destruct (Int.ltu i i0); auto. - rewrite int_not_ltu. destruct (Int.ltu i i0); simpl; destruct (Int.eq i i0); auto. - rewrite (int_ltu_not i i0). destruct (Int.ltu i i0); destruct (Int.eq i i0); reflexivity. - destruct (Int.ltu i i0); reflexivity. - destruct (Mem.valid_pointer m b0 (Int.unsigned i) && - Mem.valid_pointer m b1 (Int.unsigned i0)); try discriminate. - destruct c; simpl in *; inv H1; reflexivity. + destruct (Ptrofs.eq i i0); auto. + destruct (Ptrofs.eq i i0); auto. + destruct (Ptrofs.ltu i i0); auto. + rewrite Ptrofs.not_ltu. destruct (Ptrofs.ltu i i0); simpl; destruct (Ptrofs.eq i i0); auto. + rewrite (Ptrofs.ltu_not i i0). destruct (Ptrofs.ltu i i0); destruct (Ptrofs.eq i i0); reflexivity. + destruct (Ptrofs.ltu i i0); reflexivity. + destruct (Mem.valid_pointer m b0 (Ptrofs.unsigned i) && + Mem.valid_pointer m b1 (Ptrofs.unsigned i0)); try discriminate H. + destruct c; simpl in *; inv H; reflexivity. +Qed. + +Lemma compare_longs_spec: + forall rs v1 v2 m, + let rs' := nextinstr (compare_longs v1 v2 rs m) in + rs'#ZF = Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq v1 v2) + /\ rs'#CF = Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 v2) + /\ rs'#SF = Val.negativel (Val.subl v1 v2) + /\ rs'#OF = Val.subl_overflow v1 v2 + /\ (forall r, data_preg r = true -> rs'#r = rs#r). +Proof. + intros. unfold rs'; unfold compare_longs. + split. auto. + split. auto. + split. auto. + split. auto. + intros. Simplifs. +Qed. + +Lemma int64_sub_overflow: + forall x y, + Int.xor (Int.repr (Int64.unsigned (Int64.sub_overflow x y Int64.zero))) + (Int.repr (Int64.unsigned (Int64.negative (Int64.sub x y)))) = + (if Int64.lt x y then Int.one else Int.zero). +Proof. + intros. + transitivity (Int.repr (Int64.unsigned (if Int64.lt x y then Int64.one else Int64.zero))). + rewrite <- (Int64.lt_sub_overflow x y). + unfold Int64.sub_overflow, Int64.negative. + set (s := Int64.signed x - Int64.signed y - Int64.signed Int64.zero). + destruct (zle Int64.min_signed s && zle s Int64.max_signed); + destruct (Int64.lt (Int64.sub x y) Int64.zero); + auto. + destruct (Int64.lt x y); auto. +Qed. + +Lemma testcond_for_signed_comparison_64_correct: + forall c v1 v2 rs m b, + Val.cmpl_bool c v1 v2 = Some b -> + eval_testcond (testcond_for_signed_comparison c) + (nextinstr (compare_longs v1 v2 rs m)) = Some b. +Proof. + intros. generalize (compare_longs_spec rs v1 v2 m). + set (rs' := nextinstr (compare_longs v1 v2 rs m)). + intros [A [B [C [D E]]]]. + destruct v1; destruct v2; simpl in H; inv H. + unfold eval_testcond. rewrite A; rewrite B; rewrite C; rewrite D. + simpl; rewrite int64_sub_overflow. + destruct c; simpl. + destruct (Int64.eq i i0); auto. + destruct (Int64.eq i i0); auto. + destruct (Int64.lt i i0); auto. + rewrite Int64.not_lt. destruct (Int64.lt i i0); simpl; destruct (Int64.eq i i0); auto. + rewrite (Int64.lt_not i i0). destruct (Int64.lt i i0); destruct (Int64.eq i i0); reflexivity. + destruct (Int64.lt i i0); reflexivity. +Qed. + +Lemma testcond_for_unsigned_comparison_64_correct: + forall c v1 v2 rs m b, + Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 = Some b -> + eval_testcond (testcond_for_unsigned_comparison c) + (nextinstr (compare_longs v1 v2 rs m)) = Some b. +Proof. + intros. generalize (compare_longs_spec rs v1 v2 m). + set (rs' := nextinstr (compare_longs v1 v2 rs m)). + intros [A [B [C [D E]]]]. + unfold eval_testcond. rewrite A; rewrite B. + destruct v1; destruct v2; simpl in H; FuncInv; subst. +- (* int int *) + destruct c; simpl; auto. + destruct (Int64.eq i i0); reflexivity. + destruct (Int64.eq i i0); auto. + destruct (Int64.ltu i i0); auto. + rewrite Int64.not_ltu. destruct (Int64.ltu i i0); simpl; destruct (Int64.eq i i0); auto. + rewrite (Int64.ltu_not i i0). destruct (Int64.ltu i i0); destruct (Int64.eq i i0); reflexivity. + destruct (Int64.ltu i i0); reflexivity. +- (* int ptr *) + unfold Val.cmplu; simpl; destruct Archi.ptr64; try discriminate. + destruct (Int64.eq i Int64.zero && + (Mem.valid_pointer m b0 (Ptrofs.unsigned i0) || Mem.valid_pointer m b0 (Ptrofs.unsigned i0 - 1))) eqn:?; try discriminate H. + destruct c; simpl in *; inv H; auto. +- (* ptr int *) + unfold Val.cmplu; simpl; destruct Archi.ptr64; try discriminate. + destruct (Int64.eq i0 Int64.zero && + (Mem.valid_pointer m b0 (Ptrofs.unsigned i) || Mem.valid_pointer m b0 (Ptrofs.unsigned i - 1))) eqn:?; try discriminate H. + destruct c; simpl in *; inv H; auto. +- (* ptr ptr *) + unfold Val.cmplu; simpl; destruct Archi.ptr64; try discriminate H. + fold (Mem.weak_valid_pointer m b0 (Ptrofs.unsigned i)) in *. + fold (Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i0)) in *. + destruct (eq_block b0 b1). + destruct (Mem.weak_valid_pointer m b0 (Ptrofs.unsigned i) && + Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i0)); inv H. + destruct c; simpl; auto. + destruct (Ptrofs.eq i i0); auto. + destruct (Ptrofs.eq i i0); auto. + destruct (Ptrofs.ltu i i0); auto. + rewrite Ptrofs.not_ltu. destruct (Ptrofs.ltu i i0); simpl; destruct (Ptrofs.eq i i0); auto. + rewrite (Ptrofs.ltu_not i i0). destruct (Ptrofs.ltu i i0); destruct (Ptrofs.eq i i0); reflexivity. + destruct (Ptrofs.ltu i i0); reflexivity. + destruct (Mem.valid_pointer m b0 (Ptrofs.unsigned i) && + Mem.valid_pointer m b1 (Ptrofs.unsigned i0)); try discriminate H. + destruct c; simpl in *; inv H; reflexivity. Qed. Lemma compare_floats_spec: @@ -793,35 +977,63 @@ Lemma transl_cond_correct: Proof. unfold transl_cond; intros. destruct cond; repeat (destruct args; try discriminate); monadInv H. -(* comp *) +- (* comp *) simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). econstructor. split. apply exec_straight_one. simpl. eauto. auto. split. destruct (Val.cmp_bool c0 (rs x) (rs x0)) eqn:?; auto. - eapply testcond_for_signed_comparison_correct; eauto. + eapply testcond_for_signed_comparison_32_correct; eauto. intros. unfold compare_ints. Simplifs. -(* compu *) +- (* compu *) simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). econstructor. split. apply exec_straight_one. simpl. eauto. auto. split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto. - eapply testcond_for_unsigned_comparison_correct; eauto. + eapply testcond_for_unsigned_comparison_32_correct; eauto. intros. unfold compare_ints. Simplifs. -(* compimm *) - simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int.eq_dec i Int.zero). +- (* compimm *) + simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int.eq_dec n Int.zero). econstructor; split. apply exec_straight_one. simpl; eauto. auto. split. destruct (rs x); simpl; auto. subst. rewrite Int.and_idem. - eapply testcond_for_signed_comparison_correct; eauto. + eapply testcond_for_signed_comparison_32_correct; eauto. intros. unfold compare_ints. Simplifs. econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. destruct (Val.cmp_bool c0 (rs x) (Vint i)) eqn:?; auto. - eapply testcond_for_signed_comparison_correct; eauto. + split. destruct (Val.cmp_bool c0 (rs x) (Vint n)) eqn:?; auto. + eapply testcond_for_signed_comparison_32_correct; eauto. intros. unfold compare_ints. Simplifs. -(* compuimm *) +- (* compuimm *) simpl. rewrite (ireg_of_eq _ _ EQ). econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (Vint i)) eqn:?; auto. - eapply testcond_for_unsigned_comparison_correct; eauto. + split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (Vint n)) eqn:?; auto. + eapply testcond_for_unsigned_comparison_32_correct; eauto. intros. unfold compare_ints. Simplifs. -(* compf *) +- (* compl *) + simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). + econstructor. split. apply exec_straight_one. simpl. eauto. auto. + split. destruct (Val.cmpl_bool c0 (rs x) (rs x0)) eqn:?; auto. + eapply testcond_for_signed_comparison_64_correct; eauto. + intros. unfold compare_longs. Simplifs. +- (* complu *) + simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). + econstructor. split. apply exec_straight_one. simpl. eauto. auto. + split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto. + eapply testcond_for_unsigned_comparison_64_correct; eauto. + intros. unfold compare_longs. Simplifs. +- (* compimm *) + simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int64.eq_dec n Int64.zero). + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split. destruct (rs x); simpl; auto. subst. rewrite Int64.and_idem. + eapply testcond_for_signed_comparison_64_correct; eauto. + intros. unfold compare_longs. Simplifs. + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split. destruct (Val.cmpl_bool c0 (rs x) (Vlong n)) eqn:?; auto. + eapply testcond_for_signed_comparison_64_correct; eauto. + intros. unfold compare_longs. Simplifs. +- (* compuimm *) + simpl. rewrite (ireg_of_eq _ _ EQ). + econstructor. split. apply exec_straight_one. simpl. eauto. auto. + split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (Vlong n)) eqn:?; auto. + eapply testcond_for_unsigned_comparison_64_correct; eauto. + intros. unfold compare_longs. Simplifs. +- (* compf *) simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)). split. apply exec_straight_one. @@ -830,7 +1042,7 @@ Proof. split. destruct (rs x); destruct (rs x0); simpl; auto. repeat rewrite swap_floats_commut. apply testcond_for_float_comparison_correct. intros. Simplifs. apply compare_floats_inv; auto with asmgen. -(* notcompf *) +- (* notcompf *) simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)). split. apply exec_straight_one. @@ -839,7 +1051,7 @@ Proof. split. destruct (rs x); destruct (rs x0); simpl; auto. repeat rewrite swap_floats_commut. apply testcond_for_neg_float_comparison_correct. intros. Simplifs. apply compare_floats_inv; auto with asmgen. -(* compfs *) +- (* compfs *) simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). exists (nextinstr (compare_floats32 (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)). split. apply exec_straight_one. @@ -848,7 +1060,7 @@ Proof. split. destruct (rs x); destruct (rs x0); simpl; auto. repeat rewrite swap_floats_commut. apply testcond_for_float32_comparison_correct. intros. Simplifs. apply compare_floats32_inv; auto with asmgen. -(* notcompfs *) +- (* notcompfs *) simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). exists (nextinstr (compare_floats32 (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)). split. apply exec_straight_one. @@ -857,19 +1069,19 @@ Proof. split. destruct (rs x); destruct (rs x0); simpl; auto. repeat rewrite swap_floats_commut. apply testcond_for_neg_float32_comparison_correct. intros. Simplifs. apply compare_floats32_inv; auto with asmgen. -(* maskzero *) +- (* maskzero *) simpl. rewrite (ireg_of_eq _ _ EQ). econstructor. split. apply exec_straight_one. simpl; eauto. auto. split. destruct (rs x); simpl; auto. - generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero m). - intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto. + generalize (compare_ints_spec rs (Vint (Int.and i n)) Vzero m). + intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i n) Int.zero); auto. intros. unfold compare_ints. Simplifs. -(* masknotzero *) +- (* masknotzero *) simpl. rewrite (ireg_of_eq _ _ EQ). econstructor. split. apply exec_straight_one. simpl; eauto. auto. split. destruct (rs x); simpl; auto. - generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero m). - intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto. + generalize (compare_ints_spec rs (Vint (Int.and i n)) Vzero m). + intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i n) Int.zero); auto. intros. unfold compare_ints. Simplifs. Qed. @@ -890,7 +1102,7 @@ Lemma mk_setcc_base_correct: exists rs2, exec_straight ge fn (mk_setcc_base cond rd k) rs1 m k rs2 m /\ rs2#rd = Val.of_optbool(eval_extcond cond rs1) - /\ forall r, data_preg r = true -> r <> EAX /\ r <> ECX -> r <> rd -> rs2#r = rs1#r. + /\ forall r, data_preg r = true -> r <> RAX /\ r <> RCX -> r <> rd -> rs2#r = rs1#r. Proof. intros. destruct cond; simpl in *. - (* base *) @@ -913,7 +1125,7 @@ Proof. destruct b; auto. auto. rewrite H; clear H. - destruct (ireg_eq rd EAX). + destruct (ireg_eq rd RAX). subst rd. econstructor; split. eapply exec_straight_three. simpl; eauto. @@ -947,7 +1159,7 @@ Proof. auto. } rewrite H; clear H. - destruct (ireg_eq rd EAX). + destruct (ireg_eq rd RAX). subst rd. econstructor; split. eapply exec_straight_three. simpl; eauto. @@ -970,9 +1182,9 @@ Lemma mk_setcc_correct: exists rs2, exec_straight ge fn (mk_setcc cond rd k) rs1 m k rs2 m /\ rs2#rd = Val.of_optbool(eval_extcond cond rs1) - /\ forall r, data_preg r = true -> r <> EAX /\ r <> ECX -> r <> rd -> rs2#r = rs1#r. + /\ forall r, data_preg r = true -> r <> RAX /\ r <> RCX -> r <> rd -> rs2#r = rs1#r. Proof. - intros. unfold mk_setcc. destruct (low_ireg rd). + intros. unfold mk_setcc. destruct (Archi.ptr64 || low_ireg rd). - apply mk_setcc_base_correct. - exploit mk_setcc_base_correct. intros [rs2 [A [B C]]]. econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. @@ -1002,7 +1214,7 @@ Ltac TranslOp := Lemma transl_op_correct: forall op args res k c (rs: regset) m v, transl_op op args res k = OK c -> - eval_operation ge (rs#ESP) op (map rs (map preg_of args)) m = Some v -> + eval_operation ge (rs#RSP) op (map rs (map preg_of args)) m = Some v -> exists rs', exec_straight ge fn c rs m k rs' m /\ Val.lessdef v rs'#(preg_of res) @@ -1028,76 +1240,137 @@ Transparent destroyed_by_op. exploit mk_mov_correct; eauto. intros [rs2 [A [B C]]]. apply SAME. exists rs2. eauto. (* intconst *) - apply SAME. destruct (Int.eq_dec i Int.zero). subst i. TranslOp. TranslOp. + apply SAME. destruct (Int.eq_dec n Int.zero). subst n. TranslOp. TranslOp. +(* longconst *) + apply SAME. destruct (Int64.eq_dec n Int64.zero). subst n. TranslOp. TranslOp. (* floatconst *) - apply SAME. destruct (Float.eq_dec f Float.zero). subst f. TranslOp. TranslOp. + apply SAME. destruct (Float.eq_dec n Float.zero). subst n. TranslOp. TranslOp. (* singleconst *) - apply SAME. destruct (Float32.eq_dec f Float32.zero). subst f. TranslOp. TranslOp. + apply SAME. destruct (Float32.eq_dec n Float32.zero). subst n. TranslOp. TranslOp. (* cast8signed *) apply SAME. eapply mk_intconv_correct; eauto. (* cast8unsigned *) apply SAME. eapply mk_intconv_correct; eauto. -(* cast16signed *) - apply SAME. eapply mk_intconv_correct; eauto. -(* cast16unsigned *) - apply SAME. eapply mk_intconv_correct; eauto. (* mulhs *) apply SAME. TranslOp. destruct H1. Simplifs. (* mulhu *) apply SAME. TranslOp. destruct H1. Simplifs. (* div *) apply SAME. - exploit (divs_mods_exists (rs EAX) (rs ECX)). left; congruence. + exploit (divs_mods_exists (rs RAX) (rs RCX)). left; congruence. intros (nh & nl & d & q & r & A & B & C & D & E & F). - set (rs1 := nextinstr_nf (rs#EDX <- (Vint nh))). + set (rs1 := nextinstr_nf (rs#RDX <- (Vint nh))). econstructor; split. eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity. - simpl. change (rs1 EAX) with (rs EAX); rewrite B. - change (rs1 ECX) with (rs ECX); rewrite C. + simpl. change (rs1 RAX) with (rs RAX); rewrite B. + change (rs1 RCX) with (rs RCX); rewrite C. rewrite D. reflexivity. auto. auto. split. change (Vint q = v). congruence. simpl; intros. destruct H2. unfold rs1; Simplifs. (* divu *) apply SAME. - exploit (divu_modu_exists (rs EAX) (rs ECX)). left; congruence. + exploit (divu_modu_exists (rs RAX) (rs RCX)). left; congruence. intros (n & d & q & r & B & C & D & E & F). - set (rs1 := nextinstr_nf (rs#EDX <- Vzero)). + set (rs1 := nextinstr_nf (rs#RDX <- Vzero)). econstructor; split. eapply exec_straight_two with (rs2 := rs1). reflexivity. - simpl. change (rs1 EAX) with (rs EAX); rewrite B. - change (rs1 ECX) with (rs ECX); rewrite C. + simpl. change (rs1 RAX) with (rs RAX); rewrite B. + change (rs1 RCX) with (rs RCX); rewrite C. rewrite D. reflexivity. auto. auto. split. change (Vint q = v). congruence. simpl; intros. destruct H2. unfold rs1; Simplifs. (* mod *) apply SAME. - exploit (divs_mods_exists (rs EAX) (rs ECX)). right; congruence. + exploit (divs_mods_exists (rs RAX) (rs RCX)). right; congruence. intros (nh & nl & d & q & r & A & B & C & D & E & F). - set (rs1 := nextinstr_nf (rs#EDX <- (Vint nh))). + set (rs1 := nextinstr_nf (rs#RDX <- (Vint nh))). econstructor; split. eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity. - simpl. change (rs1 EAX) with (rs EAX); rewrite B. - change (rs1 ECX) with (rs ECX); rewrite C. + simpl. change (rs1 RAX) with (rs RAX); rewrite B. + change (rs1 RCX) with (rs RCX); rewrite C. rewrite D. reflexivity. auto. auto. split. change (Vint r = v). congruence. simpl; intros. destruct H2. unfold rs1; Simplifs. (* modu *) apply SAME. - exploit (divu_modu_exists (rs EAX) (rs ECX)). right; congruence. + exploit (divu_modu_exists (rs RAX) (rs RCX)). right; congruence. intros (n & d & q & r & B & C & D & E & F). - set (rs1 := nextinstr_nf (rs#EDX <- Vzero)). + set (rs1 := nextinstr_nf (rs#RDX <- Vzero)). econstructor; split. eapply exec_straight_two with (rs2 := rs1). reflexivity. - simpl. change (rs1 EAX) with (rs EAX); rewrite B. - change (rs1 ECX) with (rs ECX); rewrite C. + simpl. change (rs1 RAX) with (rs RAX); rewrite B. + change (rs1 RCX) with (rs RCX); rewrite C. rewrite D. reflexivity. auto. auto. split. change (Vint r = v). congruence. simpl; intros. destruct H2. unfold rs1; Simplifs. (* shrximm *) apply SAME. eapply mk_shrximm_correct; eauto. (* lea *) - exploit transl_addressing_mode_correct; eauto. intros EA. - TranslOp. rewrite nextinstr_inv; auto with asmgen. rewrite Pregmap.gss; auto. + exploit transl_addressing_mode_32_correct; eauto. intros EA. + TranslOp. rewrite nextinstr_inv; auto with asmgen. rewrite Pregmap.gss. rewrite normalize_addrmode_32_correct; auto. +(* mullhs *) + apply SAME. TranslOp. destruct H1. Simplifs. +(* mullhu *) + apply SAME. TranslOp. destruct H1. Simplifs. +(* divl *) + apply SAME. + exploit (divls_modls_exists (rs RAX) (rs RCX)). left; congruence. + intros (nh & nl & d & q & r & A & B & C & D & E & F). + set (rs1 := nextinstr_nf (rs#RDX <- (Vlong nh))). + econstructor; split. + eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity. + simpl. change (rs1 RAX) with (rs RAX); rewrite B. + change (rs1 RCX) with (rs RCX); rewrite C. + rewrite D. reflexivity. auto. auto. + split. change (Vlong q = v). congruence. + simpl; intros. destruct H2. unfold rs1; Simplifs. +(* divlu *) + apply SAME. + exploit (divlu_modlu_exists (rs RAX) (rs RCX)). left; congruence. + intros (n & d & q & r & B & C & D & E & F). + set (rs1 := nextinstr_nf (rs#RDX <- (Vlong Int64.zero))). + econstructor; split. + eapply exec_straight_two with (rs2 := rs1). reflexivity. + simpl. change (rs1 RAX) with (rs RAX); rewrite B. + change (rs1 RCX) with (rs RCX); rewrite C. + rewrite D. reflexivity. auto. auto. + split. change (Vlong q = v). congruence. + simpl; intros. destruct H2. unfold rs1; Simplifs. +(* modl *) + apply SAME. + exploit (divls_modls_exists (rs RAX) (rs RCX)). right; congruence. + intros (nh & nl & d & q & r & A & B & C & D & E & F). + set (rs1 := nextinstr_nf (rs#RDX <- (Vlong nh))). + econstructor; split. + eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity. + simpl. change (rs1 RAX) with (rs RAX); rewrite B. + change (rs1 RCX) with (rs RCX); rewrite C. + rewrite D. reflexivity. auto. auto. + split. change (Vlong r = v). congruence. + simpl; intros. destruct H2. unfold rs1; Simplifs. +(* modlu *) + apply SAME. + exploit (divlu_modlu_exists (rs RAX) (rs RCX)). right; congruence. + intros (n & d & q & r & B & C & D & E & F). + set (rs1 := nextinstr_nf (rs#RDX <- (Vlong Int64.zero))). + econstructor; split. + eapply exec_straight_two with (rs2 := rs1). reflexivity. + simpl. change (rs1 RAX) with (rs RAX); rewrite B. + change (rs1 RCX) with (rs RCX); rewrite C. + rewrite D. reflexivity. auto. auto. + split. change (Vlong r = v). congruence. + simpl; intros. destruct H2. unfold rs1; Simplifs. +(* shrxlimm *) + apply SAME. eapply mk_shrxlimm_correct; eauto. +(* leal *) + exploit transl_addressing_mode_64_correct; eauto. intros EA. + generalize (normalize_addrmode_64_correct x rs). destruct (normalize_addrmode_64 x) as [am' [delta|]]; intros EV. + econstructor; split. eapply exec_straight_two. + simpl. reflexivity. simpl. reflexivity. auto. auto. + split. rewrite nextinstr_nf_inv by auto. rewrite Pregmap.gss. rewrite nextinstr_inv by auto with asmgen. + rewrite Pregmap.gss. rewrite <- EV; auto. + intros; Simplifs. + TranslOp. rewrite nextinstr_inv; auto with asmgen. rewrite Pregmap.gss; auto. rewrite <- EV; auto. (* intoffloat *) apply SAME. TranslOp. rewrite H0; auto. (* floatofint *) @@ -1106,12 +1379,20 @@ Transparent destroyed_by_op. apply SAME. TranslOp. rewrite H0; auto. (* singleofint *) apply SAME. TranslOp. rewrite H0; auto. +(* longoffloat *) + apply SAME. TranslOp. rewrite H0; auto. +(* floatoflong *) + apply SAME. TranslOp. rewrite H0; auto. +(* longofsingle *) + apply SAME. TranslOp. rewrite H0; auto. +(* singleoflong *) + apply SAME. TranslOp. rewrite H0; auto. (* condition *) exploit transl_cond_correct; eauto. intros [rs2 [P [Q R]]]. exploit mk_setcc_correct; eauto. intros [rs3 [S [T U]]]. exists rs3. split. eapply exec_straight_trans. eexact P. eexact S. - split. rewrite T. destruct (eval_condition c0 rs ## (preg_of ## args) m). + split. rewrite T. destruct (eval_condition cond rs ## (preg_of ## args) m). rewrite Q. auto. simpl; auto. intros. transitivity (rs2 r); auto. @@ -1122,7 +1403,7 @@ Qed. Lemma transl_load_correct: forall chunk addr args dest k c (rs: regset) m a v, transl_load chunk addr args dest k = OK c -> - eval_addressing ge (rs#ESP) addr (map rs (map preg_of args)) = Some a -> + eval_addressing ge (rs#RSP) addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists rs', exec_straight ge fn c rs m k rs' m @@ -1135,8 +1416,8 @@ Proof. set (rs2 := nextinstr_nf (rs#(preg_of dest) <- v)). assert (exec_load ge chunk m x rs (preg_of dest) = Next rs2 m). unfold exec_load. rewrite EA'. rewrite H1. auto. - assert (rs2 PC = Val.add (rs PC) Vone). - transitivity (Val.add ((rs#(preg_of dest) <- v) PC) Vone). + assert (rs2 PC = Val.offset_ptr (rs PC) Ptrofs.one). + transitivity (Val.offset_ptr ((rs#(preg_of dest) <- v) PC) Ptrofs.one). auto. decEq. apply Pregmap.gso; auto with asmgen. exists rs2. split. destruct chunk; ArgsInv; apply exec_straight_one; auto. @@ -1147,7 +1428,7 @@ Qed. Lemma transl_store_correct: forall chunk addr args src k c (rs: regset) m a m', transl_store chunk addr args src k = OK c -> - eval_addressing ge (rs#ESP) addr (map rs (map preg_of args)) = Some a -> + eval_addressing ge (rs#RSP) addr (map rs (map preg_of args)) = Some a -> Mem.storev chunk m a (rs (preg_of src)) = Some m' -> exists rs', exec_straight ge fn c rs m k rs' m' @@ -1158,11 +1439,10 @@ Proof. assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto. rewrite <- EA' in H1. destruct chunk; ArgsInv. (* int8signed *) - eapply mk_smallstore_correct; eauto. - intros. simpl. unfold exec_store. - destruct (eval_addrmode ge addr0 rs0); simpl; auto. rewrite Mem.store_signed_unsigned_8; auto. + eapply mk_storebyte_correct; eauto. + destruct (eval_addrmode ge x rs); simpl; auto. rewrite <- Mem.store_signed_unsigned_8; auto. (* int8unsigned *) - eapply mk_smallstore_correct; eauto. + eapply mk_storebyte_correct; eauto. (* int16signed *) econstructor; split. apply exec_straight_one. simpl. unfold exec_store. @@ -1180,6 +1460,10 @@ Proof. econstructor; split. apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto. intros. Simplifs. +(* int64 *) + econstructor; split. + apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto. + intros. Simplifs. (* float32 *) econstructor; split. apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto. @@ -1191,5 +1475,3 @@ Proof. Qed. End CONSTRUCTORS. - - diff --git a/ia32/CBuiltins.ml b/x86/CBuiltins.ml index 79a839f3..09303223 100644 --- a/ia32/CBuiltins.ml +++ b/x86/CBuiltins.ml @@ -17,14 +17,24 @@ open C +let (va_list_type, va_list_scalar, size_va_list) = + if Archi.ptr64 then + (* Actually a struct passed by reference; equivalent to 3 64-bit words *) + (TArray(TInt(IULong, []), Some 3L, []), false, 3*8) + else + (* Just a pointer *) + (TPtr(TVoid [], []), true, 4) + let builtins = { Builtins.typedefs = [ - "__builtin_va_list", TPtr(TVoid [], []) + "__builtin_va_list", va_list_type; ]; Builtins.functions = [ (* Integer arithmetic *) "__builtin_bswap", (TInt(IUInt, []), [TInt(IUInt, [])], false); + "__builtin_bswap64", + (TInt(IULongLong, []), [TInt(IULongLong, [])], false); "__builtin_bswap32", (TInt(IUInt, []), [TInt(IUInt, [])], false); "__builtin_bswap16", @@ -79,9 +89,6 @@ let builtins = { ] } -let size_va_list = 4 -let va_list_scalar = true - (* Expand memory references inside extended asm statements. Used in C2C. *) let asm_mem_argument arg = Printf.sprintf "0(%s)" arg diff --git a/ia32/CombineOp.v b/x86/CombineOp.v index cdd16071..34c1c9cc 100644 --- a/ia32/CombineOp.v +++ b/x86/CombineOp.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -14,10 +14,8 @@ during the [CSE] phase. *) Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Op. -Require Import CSEdomain. +Require Import AST Integers. +Require Import Op CSEdomain. Definition valnum := positive. @@ -72,23 +70,43 @@ Function combine_cond (cond: condition) (args: list valnum) : option(condition * | _, _ => None end. -Function combine_addr (addr: addressing) (args: list valnum) : option(addressing * list valnum) := +Function combine_addr_32 (addr: addressing) (args: list valnum) : option(addressing * list valnum) := match addr, args with | Aindexed n, x::nil => match get x with - | Some(Op (Olea a) ys) => Some(offset_addressing_total a n, ys) + | Some(Op (Olea a) ys) => + match offset_addressing a n with Some a' => Some (a', ys) | None => None end | _ => None end | _, _ => None end. +Function combine_addr_64 (addr: addressing) (args: list valnum) : option(addressing * list valnum) := + match addr, args with + | Aindexed n, x::nil => + match get x with + | Some(Op (Oleal a) ys) => + match offset_addressing a n with Some a' => Some (a', ys) | None => None end + | _ => None + end + | _, _ => None + end. + +Definition combine_addr (addr: addressing) (args: list valnum) : option(addressing * list valnum) := + if Archi.ptr64 then combine_addr_64 addr args else combine_addr_32 addr args. + Function combine_op (op: operation) (args: list valnum) : option(operation * list valnum) := match op, args with | Olea addr, _ => - match combine_addr addr args with + match combine_addr_32 addr args with | Some(addr', args') => Some(Olea addr', args') | None => None end + | Oleal addr, _ => + match combine_addr_64 addr args with + | Some(addr', args') => Some(Oleal addr', args') + | None => None + end | Oandimm n, x :: nil => match get x with | Some(Op (Oandimm m) ys) => Some(Oandimm (Int.and m n), ys) @@ -104,6 +122,21 @@ Function combine_op (op: operation) (args: list valnum) : option(operation * lis | Some(Op (Oxorimm m) ys) => Some(Oxorimm (Int.xor m n), ys) | _ => None end + | Oandlimm n, x :: nil => + match get x with + | Some(Op (Oandlimm m) ys) => Some(Oandlimm (Int64.and m n), ys) + | _ => None + end + | Oorlimm n, x :: nil => + match get x with + | Some(Op (Oorlimm m) ys) => Some(Oorlimm (Int64.or m n), ys) + | _ => None + end + | Oxorlimm n, x :: nil => + match get x with + | Some(Op (Oxorlimm m) ys) => Some(Oxorlimm (Int64.xor m n), ys) + | _ => None + end | Ocmp cond, _ => match combine_cond cond args with | Some(cond', args') => Some(Ocmp cond', args') diff --git a/ia32/CombineOpproof.v b/x86/CombineOpproof.v index 8f600054..f59e582b 100644 --- a/ia32/CombineOpproof.v +++ b/x86/CombineOpproof.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -14,12 +14,8 @@ during the [CSE] phase. *) Require Import Coqlib. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Op. -Require Import RTL. -Require Import CSEdomain. +Require Import Integers Values Memory. +Require Import Op RTL CSEdomain. Require Import CombineOp. Section COMBINE. @@ -122,14 +118,36 @@ Proof. simpl; eapply combine_compimm_eq_1_sound; eauto. Qed. +Theorem combine_addr_32_sound: + forall addr args addr' args', + combine_addr_32 get addr args = Some(addr', args') -> + eval_addressing32 ge sp addr' (map valu args') = eval_addressing32 ge sp addr (map valu args). +Proof. + intros. functional inversion H; subst. + (* indexed - lea *) + UseGetSound. simpl. unfold offset_addressing in H7. destruct (addressing_valid (offset_addressing_total a n)); inv H7. + eapply eval_offset_addressing_total_32; eauto. +Qed. + +Theorem combine_addr_64_sound: + forall addr args addr' args', + combine_addr_64 get addr args = Some(addr', args') -> + eval_addressing64 ge sp addr' (map valu args') = eval_addressing64 ge sp addr (map valu args). +Proof. + intros. functional inversion H; subst. + (* indexed - leal *) + UseGetSound. simpl. unfold offset_addressing in H7. destruct (addressing_valid (offset_addressing_total a n)); inv H7. + eapply eval_offset_addressing_total_64; eauto. +Qed. + Theorem combine_addr_sound: forall addr args addr' args', combine_addr get addr args = Some(addr', args') -> eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args). Proof. - intros. functional inversion H; subst. - (* indexed - lea *) - UseGetSound. simpl. eapply eval_offset_addressing_total; eauto. + unfold combine_addr, eval_addressing; intros; destruct Archi.ptr64. + apply combine_addr_64_sound; auto. + apply combine_addr_32_sound; auto. Qed. Theorem combine_op_sound: @@ -139,13 +157,21 @@ Theorem combine_op_sound: Proof. intros. functional inversion H; subst. (* lea-lea *) - simpl. eapply combine_addr_sound; eauto. + simpl. eapply combine_addr_32_sound; eauto. +(* leal-leal *) + simpl. eapply combine_addr_64_sound; eauto. (* andimm - andimm *) UseGetSound; simpl. rewrite <- H0. rewrite Val.and_assoc. auto. (* orimm - orimm *) UseGetSound; simpl. rewrite <- H0. rewrite Val.or_assoc. auto. (* xorimm - xorimm *) UseGetSound; simpl. rewrite <- H0. rewrite Val.xor_assoc. auto. +(* andimm - andimm *) + UseGetSound; simpl. rewrite <- H0. rewrite Val.andl_assoc. auto. +(* orimm - orimm *) + UseGetSound; simpl. rewrite <- H0. rewrite Val.orl_assoc. auto. +(* xorimm - xorimm *) + UseGetSound; simpl. rewrite <- H0. rewrite Val.xorl_assoc. auto. (* cmp *) simpl. decEq; decEq. eapply combine_cond_sound; eauto. Qed. diff --git a/x86/ConstpropOp.vp b/x86/ConstpropOp.vp new file mode 100644 index 00000000..0bf143d2 --- /dev/null +++ b/x86/ConstpropOp.vp @@ -0,0 +1,404 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Strength reduction for operators and conditions. + This is the machine-dependent part of [Constprop]. *) + +Require Import Coqlib Compopts. +Require Import AST Integers Floats. +Require Import Op Registers. +Require Import ValueDomain. + +(** * Converting known values to constants *) + +Parameter symbol_is_external: ident -> bool. (**r See [SelectOp] *) + +Definition Olea_ptr (a: addressing) := if Archi.ptr64 then Oleal a else Olea a. + +Definition const_for_result (a: aval) : option operation := + match a with + | I n => Some(Ointconst n) + | L n => if Archi.ptr64 then Some(Olongconst n) else None + | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None + | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None + | Ptr(Gl id ofs) => + if symbol_is_external id then + if Ptrofs.eq ofs Ptrofs.zero then Some (Oindirectsymbol id) else None + else + Some (Olea_ptr (Aglobal id ofs)) + | Ptr(Stk ofs) => Some(Olea_ptr (Ainstack ofs)) + | _ => None + end. + +(** * 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. *) + +Nondetfunction cond_strength_reduction + (cond: condition) (args: list reg) (vl: list aval) := + match cond, args, vl with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompimm c n2, r1 :: nil) + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompuimm c n2, r1 :: nil) + | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ccomplimm (swap_comparison c) n1, r2 :: nil) + | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccomplimm c n2, r1 :: nil) + | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ccompluimm (swap_comparison c) n1, r2 :: nil) + | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccompluimm c n2, r1 :: nil) + | _, _, _ => + (cond, args) + end. + +Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) := + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args'). + +Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := + match c, args, vl with + | Ccompimm Ceq n, r1 :: nil, v1 :: nil => + if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) + else if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) + else make_cmp_base c args vl + | Ccompimm Cne n, r1 :: nil, v1 :: nil => + if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) + else if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) + else make_cmp_base c args vl + | _, _, _ => + make_cmp_base c args vl + end. + +(** For addressing modes, we need to distinguish +- reductions that produce pointers (i.e. that produce [Aglobal], [Ainstack], [Abased] and [Abasedscaled] addressing modes), which are valid only if the pointer size is right; +- other reductions (producing [Aindexed] or [Aindexed2] modes), which are valid independently of the pointer size. +*) + +Nondetfunction addr_strength_reduction_32_generic + (addr: addressing) (args: list reg) (vl: list aval) := + match addr, args, vl with + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Aindexed (Int.signed n1 + ofs), r2 :: nil) + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Aindexed (Int.signed n2 + ofs), r1 :: nil) + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Aindexed (Int.signed n2 * sc + ofs), r1 :: nil) + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ascaled sc (Int.signed n1 + ofs), r2 :: nil) + | _, _ => + (addr, args) + end. + +Nondetfunction addr_strength_reduction_32 + (addr: addressing) (args: list reg) (vl: list aval) := + + if Archi.ptr64 then addr_strength_reduction_32_generic addr args vl else + + match addr, args, vl with + + | Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil => + (Aglobal symb (Ptrofs.add n (Ptrofs.repr ofs)), nil) + | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil => + (Ainstack (Ptrofs.add n (Ptrofs.repr ofs)), nil) + + | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil => + (Aglobal symb (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int n2)) (Ptrofs.repr ofs)), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Gl symb n2) :: nil => + (Aglobal symb (Ptrofs.add (Ptrofs.add n2 (Ptrofs.of_int n1)) (Ptrofs.repr ofs)), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil => + (Ainstack (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int n2)) (Ptrofs.repr ofs)), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Stk n2) :: nil => + (Ainstack (Ptrofs.add (Ptrofs.add (Ptrofs.of_int n1) n2) (Ptrofs.repr ofs)), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil => + (Abased symb (Ptrofs.add n1 (Ptrofs.repr ofs)), r2 :: nil) + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil => + (Abased symb (Ptrofs.add n2 (Ptrofs.repr ofs)), r1 :: nil) + + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil => + (Aglobal symb (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int (Int.mul n2 (Int.repr sc)))) (Ptrofs.repr ofs)), nil) + + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil => + (Abasedscaled sc symb (Ptrofs.add n1 (Ptrofs.repr ofs)), r2 :: nil) + + | Abased id ofs, r1 :: nil, I n1 :: nil => + (Aglobal id (Ptrofs.add ofs (Ptrofs.of_int n1)), nil) + + | Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil => + (Aglobal id (Ptrofs.add ofs (Ptrofs.of_int (Int.mul n1 (Int.repr sc)))), nil) + + | _, _ => + addr_strength_reduction_32_generic addr args vl + end. + +Nondetfunction addr_strength_reduction_64_generic + (addr: addressing) (args: list reg) (vl: list aval) := + match addr, args, vl with + | Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Aindexed (Int64.signed n1 + ofs), r2 :: nil) + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Aindexed (Int64.signed n2 + ofs), r1 :: nil) + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Aindexed (Int64.signed n2 * sc + ofs), r1 :: nil) + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ascaled sc (Int64.signed n1 + ofs), r2 :: nil) + | _, _ => + (addr, args) + end. + +Nondetfunction addr_strength_reduction_64 + (addr: addressing) (args: list reg) (vl: list aval) := + + if negb Archi.ptr64 then addr_strength_reduction_64_generic addr args vl else + + match addr, args, vl with + + | Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil => + (Aglobal symb (Ptrofs.add n (Ptrofs.repr ofs)), nil) + | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil => + (Ainstack (Ptrofs.add n (Ptrofs.repr ofs)), nil) + + | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: L n2 :: nil => + (Aglobal symb (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int64 n2)) (Ptrofs.repr ofs)), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: Ptr(Gl symb n2) :: nil => + (Aglobal symb (Ptrofs.add (Ptrofs.add n2 (Ptrofs.of_int64 n1)) (Ptrofs.repr ofs)), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: L n2 :: nil => + (Ainstack (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int64 n2)) (Ptrofs.repr ofs)), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: Ptr(Stk n2) :: nil => + (Ainstack (Ptrofs.add (Ptrofs.add (Ptrofs.of_int64 n1) n2) (Ptrofs.repr ofs)), nil) + + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: L n2 :: nil => + (Aglobal symb (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int64 (Int64.mul n2 (Int64.repr sc)))) (Ptrofs.repr ofs)), nil) + + | _, _ => + addr_strength_reduction_64_generic addr args vl + end. + +Definition addr_strength_reduction + (addr: addressing) (args: list reg) (vl: list aval) := + if Archi.ptr64 + then addr_strength_reduction_64 addr args vl + else addr_strength_reduction_32 addr args vl. + +Definition make_addimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Olea (Aindexed (Int.signed n)), r :: nil). + +Definition make_shlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshlimm n, r1 :: nil) + else (Oshl, r1 :: r2 :: nil). + +Definition make_shrimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshrimm n, r1 :: nil) + else (Oshr, r1 :: r2 :: nil). + +Definition make_shruimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshruimm n, r1 :: nil) + else (Oshru, r1 :: r2 :: 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 => (Oshlimm l, r :: nil) + | None => (Omulimm n, r :: nil) + end. + +Definition make_andimm (n: int) (r: reg) (a: aval) := + if Int.eq n Int.zero then (Ointconst Int.zero, nil) + else if Int.eq n Int.mone then (Omove, r :: nil) + else if match a with Uns _ m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero + | _ => false end + 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 make_divimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => if Int.ltu l (Int.repr 31) + then (Oshrximm l, r1 :: nil) + else (Odiv, r1 :: r2 :: nil) + | None => (Odiv, r1 :: r2 :: nil) + end. + +Definition make_divuimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => (Oshruimm l, r1 :: nil) + | None => (Odivu, r1 :: r2 :: nil) + end. + +Definition make_moduimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) + | None => (Omodu, r1 :: r2 :: nil) + end. + +Definition make_addlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero + then (Omove, r :: nil) + else (Oleal (Aindexed (Int64.signed n)), r :: nil). + +Definition make_shllimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshllimm n, r1 :: nil) + else (Oshll, r1 :: r2 :: nil). + +Definition make_shrlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshrlimm n, r1 :: nil) + else (Oshrl, r1 :: r2 :: nil). + +Definition make_shrluimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshrluimm n, r1 :: nil) + else (Oshrlu, r1 :: r2 :: nil). + +Definition make_mullimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then + (Olongconst Int64.zero, nil) + else if Int64.eq n Int64.one then + (Omove, r :: nil) + else + match Int64.is_power2' n with + | Some l => (Oshllimm l, r :: nil) + | None => (Omullimm n, r :: nil) + end. + +Definition make_andlimm (n: int64) (r: reg) (a: aval) := + if Int64.eq n Int64.zero then (Olongconst Int64.zero, nil) + else if Int64.eq n Int64.mone then (Omove, r :: nil) + else (Oandlimm n, r :: nil). + +Definition make_orlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then (Omove, r :: nil) + else if Int64.eq n Int64.mone then (Olongconst Int64.mone, nil) + else (Oorlimm n, r :: nil). + +Definition make_xorlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then (Omove, r :: nil) + else if Int64.eq n Int64.mone then (Onotl, r :: nil) + else (Oxorlimm n, r :: nil). + +Definition make_divlimm n (r1 r2: reg) := + match Int64.is_power2' n with + | Some l => if Int.ltu l (Int.repr 63) + then (Oshrxlimm l, r1 :: nil) + else (Odivl, r1 :: r2 :: nil) + | None => (Odivl, r1 :: r2 :: nil) + end. + +Definition make_divluimm n (r1 r2: reg) := + match Int64.is_power2' n with + | Some l => (Oshrluimm l, r1 :: nil) + | None => (Odivlu, r1 :: r2 :: nil) + end. + +Definition make_modluimm n (r1 r2: reg) := + match Int64.is_power2 n with + | Some l => (Oandlimm (Int64.sub n Int64.one), r1 :: nil) + | None => (Omodlu, r1 :: r2 :: nil) + end. + +Definition make_mulfimm (n: float) (r r1 r2: reg) := + if Float.eq_dec n (Float.of_int (Int.repr 2)) + then (Oaddf, r :: r :: nil) + else (Omulf, r1 :: r2 :: nil). + +Definition make_mulfsimm (n: float32) (r r1 r2: reg) := + if Float32.eq_dec n (Float32.of_int (Int.repr 2)) + then (Oaddfs, r :: r :: nil) + else (Omulfs, r1 :: r2 :: nil). + +Definition make_cast8signed (r: reg) (a: aval) := + if vincl a (Sgn Ptop 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil). +Definition make_cast8unsigned (r: reg) (a: aval) := + if vincl a (Uns Ptop 8) then (Omove, r :: nil) else (Ocast8unsigned, r :: nil). +Definition make_cast16signed (r: reg) (a: aval) := + if vincl a (Sgn Ptop 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil). +Definition make_cast16unsigned (r: reg) (a: aval) := + if vincl a (Uns Ptop 16) then (Omove, r :: nil) else (Ocast16unsigned, r :: nil). + +Nondetfunction op_strength_reduction + (op: operation) (args: list reg) (vl: list aval) := + match op, args, vl with + | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1 + | Ocast8unsigned, r1 :: nil, v1 :: nil => make_cast8unsigned r1 v1 + | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1 + | Ocast16unsigned, r1 :: nil, v1 :: nil => make_cast16unsigned r1 v1 + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 + | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2 + | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1 + | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1 + | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 + | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 + | Olea addr, args, vl => + let (addr', args') := addr_strength_reduction_32 addr args vl in + (Olea addr', args') + | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg n2) r1 + | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_mullimm n1 r2 + | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_mullimm n2 r1 + | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divlimm n2 r1 r2 + | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divluimm n2 r1 r2 + | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_modluimm n2 r1 r2 + | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_andlimm n1 r2 v2 + | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm n2 r1 v1 + | Oandlimm n, r1 :: nil, v1 :: nil => make_andlimm n r1 v1 + | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_orlimm n1 r2 + | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm n2 r1 + | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_xorlimm n1 r2 + | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm n2 r1 + | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shllimm n2 r1 r2 + | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2 + | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2 + | Oleal addr, args, vl => + let (addr', args') := addr_strength_reduction_64 addr args vl in + (Oleal addr', args') + | Ocmp c, args, vl => make_cmp c args vl + | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 + | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 + | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 + | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2 + | _, _, _ => (op, args) + end. diff --git a/x86/ConstpropOpproof.v b/x86/ConstpropOpproof.v new file mode 100644 index 00000000..4f582f86 --- /dev/null +++ b/x86/ConstpropOpproof.v @@ -0,0 +1,883 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for operator strength reduction. *) + +Require Import Coqlib Compopts. +Require Import Integers Floats Values Memory Globalenvs Events. +Require Import Op Registers RTL ValueDomain. +Require Import ConstpropOp. + +Section STRENGTH_REDUCTION. + +Variable bc: block_classification. +Variable ge: genv. +Hypothesis GENV: genv_match bc ge. +Variable sp: block. +Hypothesis STACK: bc sp = BCstack. +Variable ae: AE.t. +Variable e: regset. +Variable m: mem. +Hypothesis MATCH: ematch bc e ae. + +Lemma match_G: + forall r id ofs, + AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef e#r (Genv.symbol_address ge id ofs). +Proof. + intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH. +Qed. + +Lemma match_S: + forall r ofs, + AE.get r ae = Ptr(Stk ofs) -> Val.lessdef e#r (Vptr sp ofs). +Proof. + intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH. +Qed. + +Ltac InvApproxRegs := + match goal with + | [ H: _ :: _ = _ :: _ |- _ ] => + injection H; clear H; intros; InvApproxRegs + | [ H: ?v = AE.get ?r ae |- _ ] => + generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs + | _ => idtac + end. + +Ltac SimplVM := + match goal with + | [ H: vmatch _ ?v (I ?n) |- _ ] => + let E := fresh in + assert (E: v = Vint n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (L ?n) |- _ ] => + let E := fresh in + assert (E: v = Vlong n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (F ?n) |- _ ] => + let E := fresh in + assert (E: v = Vfloat n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (FS ?n) |- _ ] => + let E := fresh in + assert (E: v = Vsingle n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] => + let E := fresh in + assert (E: Val.lessdef v (Genv.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto); + clear H; SimplVM + | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] => + let E := fresh in + assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto); + clear H; SimplVM + | _ => idtac + end. + +Lemma eval_Olea_ptr: + forall a el, + eval_operation ge (Vptr sp Ptrofs.zero) (Olea_ptr a) el m = eval_addressing ge (Vptr sp Ptrofs.zero) a el. +Proof. + unfold Olea_ptr, eval_addressing; intros. destruct Archi.ptr64; auto. +Qed. + +Lemma const_for_result_correct: + forall a op v, + const_for_result a = Some op -> + vmatch bc v a -> + exists v', eval_operation ge (Vptr sp Ptrofs.zero) op nil m = Some v' /\ Val.lessdef v v'. +Proof. + unfold const_for_result. generalize Archi.ptr64; intros ptr64; intros. + destruct a; inv H; SimplVM. +- (* integer *) + exists (Vint n); auto. +- (* long *) + destruct ptr64; inv H2. exists (Vlong n); auto. +- (* float *) + destruct (Compopts.generate_float_constants tt); inv H2. exists (Vfloat f); auto. +- (* single *) + destruct (Compopts.generate_float_constants tt); inv H2. exists (Vsingle f); auto. +- (* pointer *) + destruct p; try discriminate; SimplVM. + + (* global *) + destruct (symbol_is_external id). + * revert H2; predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero; intros EQ; inv EQ. + exists (Genv.symbol_address ge id Ptrofs.zero); auto. + * inv H2. exists (Genv.symbol_address ge id ofs); split. + rewrite eval_Olea_ptr. apply eval_addressing_Aglobal. + auto. + + (* stack *) + inv H2. exists (Vptr sp ofs); split. + rewrite eval_Olea_ptr. rewrite eval_addressing_Ainstack. + simpl. rewrite Ptrofs.add_zero_l; auto. + auto. +Qed. + +Lemma cond_strength_reduction_correct: + forall cond args vl, + vl = map (fun r => AE.get r ae) args -> + let (cond', args') := cond_strength_reduction cond args vl in + eval_condition cond' e##args' m = eval_condition cond e##args m. +Proof. + intros until vl. unfold cond_strength_reduction. + case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVM. +- apply Val.swap_cmp_bool. +- auto. +- apply Val.swap_cmpu_bool. +- auto. +- apply Val.swap_cmpl_bool. +- auto. +- apply Val.swap_cmplu_bool. +- auto. +- auto. +Qed. + +Lemma addr_strength_reduction_32_generic_correct: + forall addr args vl res, + vl = map (fun r => AE.get r ae) args -> + eval_addressing32 ge (Vptr sp Ptrofs.zero) addr e##args = Some res -> + let (addr', args') := addr_strength_reduction_32_generic addr args vl in + exists res', eval_addressing32 ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'. +Proof. +Local Opaque Val.add. + assert (A: forall x y, Int.repr (Int.signed x + y) = Int.add x (Int.repr y)). + { intros; apply Int.eqm_samerepr; auto using Int.eqm_signed_unsigned with ints. } + assert (B: forall x y z, Int.repr (Int.signed x * y + z) = Int.add (Int.mul x (Int.repr y)) (Int.repr z)). + { intros; apply Int.eqm_samerepr; apply Int.eqm_add; auto with ints. + unfold Int.mul; auto using Int.eqm_signed_unsigned with ints. } + intros until res; intros VL EA. + unfold addr_strength_reduction_32_generic; destruct (addr_strength_reduction_32_generic_match addr args vl); + simpl in *; InvApproxRegs; SimplVM; try (inv EA). +- econstructor; split; eauto. rewrite A, Val.add_assoc, Val.add_permut. auto. +- econstructor; split; eauto. rewrite A, Val.add_assoc. auto. +- Local Transparent Val.add. + econstructor; split; eauto. simpl. rewrite B. auto. +- econstructor; split; eauto. rewrite A, Val.add_permut. auto. +- exists res; auto. +Qed. + +Lemma addr_strength_reduction_32_correct: + forall addr args vl res, + vl = map (fun r => AE.get r ae) args -> + eval_addressing32 ge (Vptr sp Ptrofs.zero) addr e##args = Some res -> + let (addr', args') := addr_strength_reduction_32 addr args vl in + exists res', eval_addressing32 ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'. +Proof. + intros until res; intros VL EA. unfold addr_strength_reduction_32. + destruct Archi.ptr64 eqn:SF. apply addr_strength_reduction_32_generic_correct; auto. + assert (A: forall n, Ptrofs.of_int (Int.repr n) = Ptrofs.repr n) by auto with ptrofs. + assert (B: forall symb ofs n, + Genv.symbol_address ge symb (Ptrofs.add ofs (Ptrofs.repr n)) = + Val.add (Genv.symbol_address ge symb ofs) (Vint (Int.repr n))). + { intros. rewrite <- A. apply Genv.shift_symbol_address_32; auto. } +Local Opaque Val.add. + destruct (addr_strength_reduction_32_match addr args vl); + simpl in *; InvApproxRegs; SimplVM; FuncInv; subst; rewrite ?SF. +- econstructor; split; eauto. rewrite B. apply Val.add_lessdef; auto. +- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. +Local Transparent Val.add. + inv H0; auto. rewrite H2. simpl; rewrite SF, A. auto. +- econstructor; split; eauto. + unfold Ptrofs.add at 2. rewrite B. + fold (Ptrofs.add n1 (Ptrofs.of_int n2)). + rewrite Genv.shift_symbol_address_32 by auto. + rewrite ! Val.add_assoc. apply Val.add_lessdef; auto. +- econstructor; split; eauto. + unfold Ptrofs.add at 2. rewrite B. + fold (Ptrofs.add n2 (Ptrofs.of_int n1)). + rewrite Genv.shift_symbol_address_32 by auto. + rewrite ! Val.add_assoc. rewrite Val.add_permut. apply Val.add_lessdef; auto. +- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. rewrite Val.add_assoc. + eapply Val.lessdef_trans. apply Val.add_lessdef; eauto. + simpl. rewrite SF. rewrite Ptrofs.add_assoc. apply Val.lessdef_same; do 3 f_equal. auto with ptrofs. +- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. rewrite Val.add_assoc, Val.add_permut. + eapply Val.lessdef_trans. apply Val.add_lessdef; eauto. + simpl. rewrite SF. rewrite <- (Ptrofs.add_commut n2). rewrite Ptrofs.add_assoc. + apply Val.lessdef_same; do 3 f_equal. auto with ptrofs. +- econstructor; split; eauto. rewrite B. rewrite ! Val.add_assoc. rewrite (Val.add_commut (Vint (Int.repr ofs))). + apply Val.add_lessdef; auto. +- econstructor; split; eauto. rewrite B. rewrite (Val.add_commut e#r1). rewrite ! Val.add_assoc. + rewrite (Val.add_commut (Vint (Int.repr ofs))). apply Val.add_lessdef; auto. +- econstructor; split; eauto. rewrite B. rewrite Genv.shift_symbol_address_32 by auto. + rewrite ! Val.add_assoc. apply Val.add_lessdef; auto. +- econstructor; split; eauto. rewrite B. rewrite ! Val.add_assoc. + rewrite (Val.add_commut (Vint (Int.repr ofs))). apply Val.add_lessdef; auto. +- econstructor; split; eauto. + rewrite Genv.shift_symbol_address_32 by auto. auto. +- econstructor; split; eauto. + rewrite Genv.shift_symbol_address_32 by auto. auto. +- apply addr_strength_reduction_32_generic_correct; auto. +Qed. + +Lemma addr_strength_reduction_64_generic_correct: + forall addr args vl res, + vl = map (fun r => AE.get r ae) args -> + eval_addressing64 ge (Vptr sp Ptrofs.zero) addr e##args = Some res -> + let (addr', args') := addr_strength_reduction_64_generic addr args vl in + exists res', eval_addressing64 ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'. +Proof. +Local Opaque Val.addl. + assert (A: forall x y, Int64.repr (Int64.signed x + y) = Int64.add x (Int64.repr y)). + { intros; apply Int64.eqm_samerepr; auto using Int64.eqm_signed_unsigned with ints. } + assert (B: forall x y z, Int64.repr (Int64.signed x * y + z) = Int64.add (Int64.mul x (Int64.repr y)) (Int64.repr z)). + { intros; apply Int64.eqm_samerepr; apply Int64.eqm_add; auto with ints. + unfold Int64.mul; auto using Int64.eqm_signed_unsigned with ints. } + intros until res; intros VL EA. + unfold addr_strength_reduction_64_generic; destruct (addr_strength_reduction_64_generic_match addr args vl); + simpl in *; InvApproxRegs; SimplVM; try (inv EA). +- econstructor; split; eauto. rewrite A, Val.addl_assoc, Val.addl_permut. auto. +- econstructor; split; eauto. rewrite A, Val.addl_assoc. auto. +- Local Transparent Val.addl. + econstructor; split; eauto. simpl. rewrite B. auto. +- econstructor; split; eauto. rewrite A, Val.addl_permut. auto. +- exists res; auto. +Qed. + +Lemma addr_strength_reduction_64_correct: + forall addr args vl res, + vl = map (fun r => AE.get r ae) args -> + eval_addressing64 ge (Vptr sp Ptrofs.zero) addr e##args = Some res -> + let (addr', args') := addr_strength_reduction_64 addr args vl in + exists res', eval_addressing64 ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'. +Proof. + intros until res; intros VL EA. unfold addr_strength_reduction_64. + destruct (negb Archi.ptr64) eqn:SF. apply addr_strength_reduction_64_generic_correct; auto. + rewrite negb_false_iff in SF. + assert (A: forall n, Ptrofs.of_int64 (Int64.repr n) = Ptrofs.repr n) by auto with ptrofs. + assert (B: forall symb ofs n, + Genv.symbol_address ge symb (Ptrofs.add ofs (Ptrofs.repr n)) = + Val.addl (Genv.symbol_address ge symb ofs) (Vlong (Int64.repr n))). + { intros. rewrite <- A. apply Genv.shift_symbol_address_64; auto. } +Local Opaque Val.addl. + destruct (addr_strength_reduction_64_match addr args vl); + simpl in *; InvApproxRegs; SimplVM; FuncInv; subst; rewrite ?SF. +- econstructor; split; eauto. rewrite B. apply Val.addl_lessdef; auto. +- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. +Local Transparent Val.addl. + inv H0; auto. rewrite H2. simpl; rewrite SF, A. auto. +- econstructor; split; eauto. + unfold Ptrofs.add at 2. rewrite B. + fold (Ptrofs.add n1 (Ptrofs.of_int64 n2)). + rewrite Genv.shift_symbol_address_64 by auto. + rewrite ! Val.addl_assoc. apply Val.addl_lessdef; auto. +- econstructor; split; eauto. + unfold Ptrofs.add at 2. rewrite B. + fold (Ptrofs.add n2 (Ptrofs.of_int64 n1)). + rewrite Genv.shift_symbol_address_64 by auto. + rewrite ! Val.addl_assoc. rewrite Val.addl_permut. apply Val.addl_lessdef; auto. +- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. rewrite Val.addl_assoc. + eapply Val.lessdef_trans. apply Val.addl_lessdef; eauto. + simpl. rewrite SF. rewrite Ptrofs.add_assoc. apply Val.lessdef_same; do 3 f_equal. auto with ptrofs. +- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. rewrite Val.addl_assoc, Val.addl_permut. + eapply Val.lessdef_trans. apply Val.addl_lessdef; eauto. + simpl. rewrite SF. rewrite <- (Ptrofs.add_commut n2). rewrite Ptrofs.add_assoc. + apply Val.lessdef_same; do 3 f_equal. auto with ptrofs. +- econstructor; split; eauto. rewrite B. rewrite Genv.shift_symbol_address_64 by auto. + rewrite ! Val.addl_assoc. apply Val.addl_lessdef; auto. +- apply addr_strength_reduction_64_generic_correct; auto. +Qed. + +Lemma addr_strength_reduction_correct: + forall addr args vl res, + vl = map (fun r => AE.get r ae) args -> + eval_addressing ge (Vptr sp Ptrofs.zero) addr e##args = Some res -> + let (addr', args') := addr_strength_reduction addr args vl in + exists res', eval_addressing ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'. +Proof. + unfold eval_addressing, addr_strength_reduction. destruct Archi.ptr64. + apply addr_strength_reduction_64_correct. + apply addr_strength_reduction_32_correct. +Qed. + +Lemma make_cmp_base_correct: + forall c args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_cmp_base c args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v + /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. +Proof. + intros. unfold make_cmp_base. + generalize (cond_strength_reduction_correct c args vl H). + destruct (cond_strength_reduction c args vl) as [c' args']. intros EQ. + econstructor; split. simpl; eauto. rewrite EQ. auto. +Qed. + +Lemma make_cmp_correct: + forall c args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_cmp c args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v + /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. +Proof. + intros c args vl. + assert (Y: forall r, vincl (AE.get r ae) (Uns Ptop 1) = true -> + e#r = Vundef \/ e#r = Vint Int.zero \/ e#r = Vint Int.one). + { intros. apply vmatch_Uns_1 with bc Ptop. eapply vmatch_ge. eapply vincl_ge; eauto. apply MATCH. } + unfold make_cmp. case (make_cmp_match c args vl); intros. +- destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. + simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. + destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. + simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. + apply make_cmp_base_correct; auto. +- destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. + simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. + destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. + simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. + apply make_cmp_base_correct; auto. +- apply make_cmp_base_correct; auto. +Qed. + +Lemma make_addimm_correct: + forall n r, + let (op, args) := make_addimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.add e#r (Vint n)) v. +Proof. + intros. unfold make_addimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst. exists (e#r); split; auto. + destruct (e#r); simpl; auto; rewrite ?Int.add_zero, ?Ptrofs.add_zero; auto. + exists (Val.add e#r (Vint n)); split; auto. simpl. rewrite Int.repr_signed; auto. +Qed. + +Lemma make_shlimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shlimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shl e#r1 (Vint n)) v. +Proof. + intros; unfold make_shlimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shl_zero. auto. + destruct (Int.ltu n Int.iwordsize). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shrimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shrimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shr e#r1 (Vint n)) v. +Proof. + intros; unfold make_shrimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shr_zero. auto. + destruct (Int.ltu n Int.iwordsize). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shruimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shruimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shru e#r1 (Vint n)) v. +Proof. + intros; unfold make_shruimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shru_zero. auto. + destruct (Int.ltu n Int.iwordsize). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_mulimm_correct: + forall n r1, + let (op, args) := make_mulimm n r1 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mul e#r1 (Vint n)) v. +Proof. + intros; unfold make_mulimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (Vint Int.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_zero; auto. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_one; auto. + destruct (Int.is_power2 n) eqn:?; intros. + rewrite (Val.mul_pow2 e#r1 _ _ Heqo). econstructor; split. simpl; eauto. auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_divimm_correct: + forall n r1 r2 v, + Val.divs e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_divimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divimm. + destruct (Int.is_power2 n) eqn:?. + destruct (Int.ltu i (Int.repr 31)) eqn:?. + exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divuimm_correct: + forall n r1 r2 v, + Val.divu e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_divuimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divuimm. + destruct (Int.is_power2 n) eqn:?. + econstructor; split. simpl; eauto. + rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto. + exists v; auto. +Qed. + +Lemma make_moduimm_correct: + forall n r1 r2 v, + Val.modu e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_moduimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_moduimm. + destruct (Int.is_power2 n) eqn:?. + exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence. + exists v; auto. +Qed. + +Lemma make_andimm_correct: + forall n r x, + vmatch bc e#r x -> + let (op, args) := make_andimm n r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.and e#r (Vint n)) v. +Proof. + intros; unfold make_andimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (Vint Int.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_mone; auto. + destruct (match x with Uns _ k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero + | _ => false end) eqn:UNS. + destruct x; try congruence. + exists (e#r); split; auto. + inv H; auto. simpl. replace (Int.and i n) with i; auto. + generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ. + Int.bit_solve. destruct (zlt i0 n0). + replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). + rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. + rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. + rewrite Int.bits_not by auto. apply negb_involutive. + rewrite H6 by auto. auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_orimm_correct: + forall n r, + let (op, args) := make_orimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.or e#r (Vint n)) v. +Proof. + intros; unfold make_orimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Vint Int.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_mone; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_xorimm_correct: + forall n r, + let (op, args) := make_xorimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xor e#r (Vint n)) v. +Proof. + intros; unfold make_xorimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.xor_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Val.notint e#r); split; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_addlimm_correct: + forall n r, + let (op, args) := make_addlimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.addl e#r (Vlong n)) v. +Proof. + intros. unfold make_addlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst. exists (e#r); split; auto. + destruct (e#r); simpl; auto; rewrite ? Int64.add_zero, ? Ptrofs.add_zero; auto. + exists (Val.addl e#r (Vlong n)); split; auto. simpl. rewrite Int64.repr_signed; auto. +Qed. + +Lemma make_shllimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shllimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shll e#r1 (Vint n)) v. +Proof. + intros; unfold make_shllimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. + unfold Int64.shl'. rewrite Z.shiftl_0_r, Int64.repr_unsigned. auto. + destruct (Int.ltu n Int64.iwordsize'). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shrlimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shrlimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrl e#r1 (Vint n)) v. +Proof. + intros; unfold make_shrlimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. + unfold Int64.shr'. rewrite Z.shiftr_0_r, Int64.repr_signed. auto. + destruct (Int.ltu n Int64.iwordsize'). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shrluimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shrluimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrlu e#r1 (Vint n)) v. +Proof. + intros; unfold make_shrluimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. + unfold Int64.shru'. rewrite Z.shiftr_0_r, Int64.repr_unsigned. auto. + destruct (Int.ltu n Int64.iwordsize'). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_mullimm_correct: + forall n r1, + let (op, args) := make_mullimm n r1 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mull e#r1 (Vlong n)) v. +Proof. + intros; unfold make_mullimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. subst. + exists (Vlong Int64.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.one; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_one; auto. + destruct (Int64.is_power2' n) eqn:?; intros. + exists (Val.shll e#r1 (Vint i)); split; auto. + destruct (e#r1); simpl; auto. + erewrite Int64.is_power2'_range by eauto. + erewrite Int64.mul_pow2' by eauto. auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_divlimm_correct: + forall n r1 r2 v, + Val.divls e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_divlimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divlimm. + destruct (Int64.is_power2' n) eqn:?. destruct (Int.ltu i (Int.repr 63)) eqn:?. + rewrite H0 in H. econstructor; split. simpl; eauto. eapply Val.divls_pow2; eauto. auto. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divluimm_correct: + forall n r1 r2 v, + Val.divlu e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_divluimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divluimm. + destruct (Int64.is_power2' n) eqn:?. + econstructor; split. simpl; eauto. + rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. + simpl. + erewrite Int64.is_power2'_range by eauto. + erewrite Int64.divu_pow2' by eauto. auto. + exists v; auto. +Qed. + +Lemma make_modluimm_correct: + forall n r1 r2 v, + Val.modlu e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_modluimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_modluimm. + destruct (Int64.is_power2 n) eqn:?. + exists v; split; auto. simpl. decEq. + rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. + simpl. erewrite Int64.modu_and by eauto. auto. + exists v; auto. +Qed. + +Lemma make_andlimm_correct: + forall n r x, + let (op, args) := make_andlimm n r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.andl e#r (Vlong n)) v. +Proof. + intros; unfold make_andlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst n. exists (Vlong Int64.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_mone; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_orlimm_correct: + forall n r, + let (op, args) := make_orlimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.orl e#r (Vlong n)) v. +Proof. + intros; unfold make_orlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. + subst n. exists (Vlong Int64.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_mone; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_xorlimm_correct: + forall n r, + let (op, args) := make_xorlimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xorl e#r (Vlong n)) v. +Proof. + intros; unfold make_xorlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.xor_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. + subst n. exists (Val.notl e#r); split; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_mulfimm_correct: + forall n r1 r2, + e#r2 = Vfloat n -> + let (op, args) := make_mulfimm n r1 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. +Proof. + intros; unfold make_mulfimm. + destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r1); simpl; auto. rewrite Float.mul2_add; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_mulfimm_correct_2: + forall n r1 r2, + e#r1 = Vfloat n -> + let (op, args) := make_mulfimm n r2 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. +Proof. + intros; unfold make_mulfimm. + destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r2); simpl; auto. rewrite Float.mul2_add; auto. + rewrite Float.mul_commut; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_mulfsimm_correct: + forall n r1 r2, + e#r2 = Vsingle n -> + let (op, args) := make_mulfsimm n r1 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. +Proof. + intros; unfold make_mulfsimm. + destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r1); simpl; auto. rewrite Float32.mul2_add; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_mulfsimm_correct_2: + forall n r1 r2, + e#r1 = Vsingle n -> + let (op, args) := make_mulfsimm n r2 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. +Proof. + intros; unfold make_mulfsimm. + destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r2); simpl; auto. rewrite Float32.mul2_add; auto. + rewrite Float32.mul_commut; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_cast8signed_correct: + forall r x, + vmatch bc e#r x -> + let (op, args) := make_cast8signed r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 8 e#r) v. +Proof. + intros; unfold make_cast8signed. destruct (vincl x (Sgn Ptop 8)) eqn:INCL. + exists e#r; split; auto. + assert (V: vmatch bc e#r (Sgn Ptop 8)). + { eapply vmatch_ge; eauto. apply vincl_ge; auto. } + inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto. + econstructor; split; simpl; eauto. +Qed. + +Lemma make_cast8unsigned_correct: + forall r x, + vmatch bc e#r x -> + let (op, args) := make_cast8unsigned r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext 8 e#r) v. +Proof. + intros; unfold make_cast8unsigned. destruct (vincl x (Uns Ptop 8)) eqn:INCL. + exists e#r; split; auto. + assert (V: vmatch bc e#r (Uns Ptop 8)). + { eapply vmatch_ge; eauto. apply vincl_ge; auto. } + inv V; simpl; auto. rewrite is_uns_zero_ext in H4 by auto. rewrite H4; auto. + econstructor; split; simpl; eauto. +Qed. + +Lemma make_cast16signed_correct: + forall r x, + vmatch bc e#r x -> + let (op, args) := make_cast16signed r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 16 e#r) v. +Proof. + intros; unfold make_cast16signed. destruct (vincl x (Sgn Ptop 16)) eqn:INCL. + exists e#r; split; auto. + assert (V: vmatch bc e#r (Sgn Ptop 16)). + { eapply vmatch_ge; eauto. apply vincl_ge; auto. } + inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto. + econstructor; split; simpl; eauto. +Qed. + +Lemma make_cast16unsigned_correct: + forall r x, + vmatch bc e#r x -> + let (op, args) := make_cast16unsigned r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext 16 e#r) v. +Proof. + intros; unfold make_cast16unsigned. destruct (vincl x (Uns Ptop 16)) eqn:INCL. + exists e#r; split; auto. + assert (V: vmatch bc e#r (Uns Ptop 16)). + { eapply vmatch_ge; eauto. apply vincl_ge; auto. } + inv V; simpl; auto. rewrite is_uns_zero_ext in H4 by auto. rewrite H4; auto. + econstructor; split; simpl; eauto. +Qed. + +Lemma op_strength_reduction_correct: + forall op args vl v, + vl = map (fun r => AE.get r ae) args -> + eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v -> + let (op', args') := op_strength_reduction op args vl in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some w /\ Val.lessdef v w. +Proof. + intros until v; unfold op_strength_reduction; + case (op_strength_reduction_match op args vl); simpl; intros. +(* cast8signed *) + InvApproxRegs; SimplVM; inv H0. apply make_cast8signed_correct; auto. +(* cast8unsigned *) + InvApproxRegs; SimplVM; inv H0. apply make_cast8unsigned_correct; auto. +(* cast16signed *) + InvApproxRegs; SimplVM; inv H0. apply make_cast16signed_correct; auto. +(* cast16unsigned *) + InvApproxRegs; SimplVM; inv H0. apply make_cast16unsigned_correct; auto. +(* sub *) + InvApproxRegs; SimplVM; inv H0. rewrite Val.sub_add_opp. apply make_addimm_correct; auto. +(* mul *) + rewrite Val.mul_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. + InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. +(* divs *) + assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divimm_correct; auto. +(* divu *) + assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divuimm_correct; auto. +(* modu *) + assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_moduimm_correct; auto. +(* and *) + rewrite Val.and_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. + InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. + inv H; inv H0. apply make_andimm_correct; auto. +(* or *) + rewrite Val.or_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. + InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. +(* xor *) + rewrite Val.xor_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. + InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. +(* shl *) + InvApproxRegs; SimplVM; inv H0. apply make_shlimm_correct; auto. +(* shr *) + InvApproxRegs; SimplVM; inv H0. apply make_shrimm_correct; auto. +(* shru *) + InvApproxRegs; SimplVM; inv H0. apply make_shruimm_correct; auto. +(* lea *) + exploit addr_strength_reduction_32_correct; eauto. + destruct (addr_strength_reduction_32 addr args0 vl0) as [addr' args']. + auto. +(* subl *) + InvApproxRegs; SimplVM; inv H0. + replace (Val.subl e#r1 (Vlong n2)) with (Val.addl e#r1 (Vlong (Int64.neg n2))). + apply make_addlimm_correct; auto. + unfold Val.addl, Val.subl. destruct Archi.ptr64 eqn:SF, e#r1; auto. + rewrite Int64.sub_add_opp; auto. + rewrite Ptrofs.sub_add_opp. do 2 f_equal. auto with ptrofs. + rewrite Int64.sub_add_opp; auto. +(* mull *) + rewrite Val.mull_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. + InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. +(* divl *) + assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divlimm_correct; auto. +(* divlu *) + assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divluimm_correct; auto. +(* modlu *) + assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_modluimm_correct; auto. +(* andl *) + rewrite Val.andl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. + InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. + inv H; inv H0. apply make_andlimm_correct; auto. +(* orl *) + rewrite Val.orl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. + InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. +(* xorl *) + rewrite Val.xorl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. + InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. +(* shll *) + InvApproxRegs; SimplVM; inv H0. apply make_shllimm_correct; auto. +(* shrl *) + InvApproxRegs; SimplVM; inv H0. apply make_shrlimm_correct; auto. +(* shrlu *) + InvApproxRegs; SimplVM; inv H0. apply make_shrluimm_correct; auto. +(* leal *) + exploit addr_strength_reduction_64_correct; eauto. + destruct (addr_strength_reduction_64 addr args0 vl0) as [addr' args']. + auto. +(* cond *) + inv H0. apply make_cmp_correct; auto. +(* mulf *) + InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto. + InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2). + rewrite <- H2. apply make_mulfimm_correct_2; auto. +(* mulfs *) + InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfsimm_correct; auto. + InvApproxRegs; SimplVM; inv H0. fold (Val.mulfs (Vsingle n1) e#r2). + rewrite <- H2. apply make_mulfsimm_correct_2; auto. +(* default *) + exists v; auto. +Qed. + +End STRENGTH_REDUCTION. diff --git a/x86/Conventions1.v b/x86/Conventions1.v new file mode 100644 index 00000000..dbc8b064 --- /dev/null +++ b/x86/Conventions1.v @@ -0,0 +1,473 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Function calling conventions and other conventions regarding the use of + machine registers and stack slots. *) + +Require Import Coqlib Decidableplus. +Require Import AST Machregs Locations. + +(** * Classification of machine registers *) + +(** Machine registers (type [mreg] in module [Locations]) are divided in + the following groups: +- 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 x86-32 and x86-64 application binary interfaces (ABI) + in our choice of callee- and caller-save registers. +*) + +Definition is_callee_save (r: mreg) : bool := + match r with + | AX | CX | DX => false + | BX | BP => true + | SI | DI => negb Archi.ptr64 (**r callee-save in 32 bits but not in 64 bits *) + | R8 | R9 | R10 | R11 => false + | R12 | R13 | R14 | R15 => true + | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 => false + | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 => false + | FP0 => false + end. + +Definition int_caller_save_regs := + if Archi.ptr64 + then AX :: CX :: DX :: SI :: DI :: R8 :: R9 :: R10 :: R11 :: nil + else AX :: CX :: DX :: nil. + +Definition float_caller_save_regs := + if Archi.ptr64 + then X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: + X8 :: X9 :: X10 :: X11 :: X12 :: X13 :: X14 :: X15 :: nil + else X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: nil. + +Definition int_callee_save_regs := + if Archi.ptr64 + then BX :: BP :: R12 :: R13 :: R14 :: R15 :: nil + else BX :: SI :: DI :: BP :: nil. + +Definition float_callee_save_regs : list mreg := nil. + +Definition destroyed_at_call := + List.filter (fun r => negb (is_callee_save r)) all_mregs. + +Definition dummy_int_reg := AX. (**r Used in [Regalloc]. *) +Definition dummy_float_reg := X0. (**r Used in [Regalloc]. *) + +Definition is_float_reg (r: mreg) := + match r with + | AX | BX | CX | DX | SI | DI | BP + | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 => false + | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 + | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 | FP0 => true + end. + +(** * 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 compiler, we + implement the standard x86-32 and x86-64 conventions. *) + +(** ** Location of function result *) + +(** In 32 bit mode, the result value of a function is passed back to the + caller in registers [AX] or [DX:AX] or [FP0], depending on the type + of the returned value. We treat a function without result as a + function with one integer result. *) + +Definition loc_result_32 (s: signature) : rpair mreg := + match s.(sig_res) with + | None => One AX + | Some (Tint | Tany32) => One AX + | Some (Tfloat | Tsingle) => One FP0 + | Some Tany64 => One X0 + | Some Tlong => Twolong DX AX + end. + +(** In 64 bit mode, he result value of a function is passed back to + the caller in registers [AX] or [X0]. *) + +Definition loc_result_64 (s: signature) : rpair mreg := + match s.(sig_res) with + | None => One AX + | Some (Tint | Tlong | Tany32 | Tany64) => One AX + | Some (Tfloat | Tsingle) => One X0 + end. + +Definition loc_result := + if Archi.ptr64 then loc_result_64 else loc_result_32. + +(** The result registers have types compatible with that given in the signature. *) + +Lemma loc_result_type: + forall sig, + subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true. +Proof. + intros. unfold proj_sig_res, loc_result, loc_result_32, loc_result_64, mreg_type; + destruct Archi.ptr64; destruct (sig_res sig) as [[]|]; auto. +Qed. + +(** The result locations are caller-save registers *) + +Lemma loc_result_caller_save: + forall (s: signature), + forall_rpair (fun r => is_callee_save r = false) (loc_result s). +Proof. + intros. unfold loc_result, loc_result_32, loc_result_64, is_callee_save; + destruct Archi.ptr64; destruct (sig_res s) as [[]|]; simpl; auto. +Qed. + +(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) + +Lemma loc_result_pair: + forall sg, + match loc_result sg with + | One _ => True + | Twolong r1 r2 => + r1 <> r2 /\ sg.(sig_res) = Some Tlong + /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true + /\ Archi.splitlong = true + end. +Proof. + intros. change Archi.splitlong with (negb Archi.ptr64). + unfold loc_result, loc_result_32, loc_result_64, mreg_type; + destruct Archi.ptr64; destruct (sig_res sg) as [[]|]; auto. + split; auto. congruence. +Qed. + +(** The location of the result depends only on the result part of the signature *) + +Lemma loc_result_exten: + forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2. +Proof. + intros. unfold loc_result, loc_result_32, loc_result_64. + destruct Archi.ptr64; rewrite H; auto. +Qed. + +(** ** Location of function arguments *) + +(** In the x86-32 ABI, all arguments are passed on stack. (Snif.) *) + +Fixpoint loc_arguments_32 + (tyl: list typ) (ofs: Z) {struct tyl} : list (rpair loc) := + match tyl with + | nil => nil + | ty :: tys => + match ty with + | Tlong => Twolong (S Outgoing (ofs + 1) Tint) (S Outgoing ofs Tint) + | _ => One (S Outgoing ofs ty) + end + :: loc_arguments_32 tys (ofs + typesize ty) + end. + +(** In the x86-64 ABI: +- The first 6 integer arguments are passed in registers [DI], [SI], [DX], [CX], [R8], [R9]. +- The first 8 floating-point arguments are passed in registers [X0] to [X7]. +- Extra arguments are passed on the stack, in [Outgoing] slots. + Consecutive stack slots are separated by 8 bytes, even if only 4 bytes + of data is used in a slot. +*) + +Definition int_param_regs := DI :: SI :: DX :: CX :: R8 :: R9 :: nil. +Definition float_param_regs := X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: nil. + +Fixpoint loc_arguments_64 + (tyl: list typ) (ir fr ofs: Z) {struct tyl} : list (rpair loc) := + match tyl with + | nil => nil + | (Tint | Tlong | Tany32 | Tany64) as ty :: tys => + match list_nth_z int_param_regs ir with + | None => + One (S Outgoing ofs ty) :: loc_arguments_64 tys ir fr (ofs + 2) + | Some ireg => + One (R ireg) :: loc_arguments_64 tys (ir + 1) fr ofs + end + | (Tfloat | Tsingle) as ty :: tys => + match list_nth_z float_param_regs fr with + | None => + One (S Outgoing ofs ty) :: loc_arguments_64 tys ir fr (ofs + 2) + | Some freg => + One (R freg) :: loc_arguments_64 tys ir (fr + 1) ofs + end + end. + +(** [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 (rpair loc) := + if Archi.ptr64 + then loc_arguments_64 s.(sig_args) 0 0 0 + else loc_arguments_32 s.(sig_args) 0. + +(** [size_arguments s] returns the number of [Outgoing] slots used + to call a function with signature [s]. *) + +Fixpoint size_arguments_32 + (tyl: list typ) (ofs: Z) {struct tyl} : Z := + match tyl with + | nil => ofs + | ty :: tys => size_arguments_32 tys (ofs + typesize ty) + end. + +Fixpoint size_arguments_64 (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z := + match tyl with + | nil => ofs + | (Tint | Tlong | Tany32 | Tany64) :: tys => + match list_nth_z int_param_regs ir with + | None => size_arguments_64 tys ir fr (ofs + 2) + | Some ireg => size_arguments_64 tys (ir + 1) fr ofs + end + | (Tfloat | Tsingle) :: tys => + match list_nth_z float_param_regs fr with + | None => size_arguments_64 tys ir fr (ofs + 2) + | Some freg => size_arguments_64 tys ir (fr + 1) ofs + end + end. + +Definition size_arguments (s: signature) : Z := + if Archi.ptr64 + then size_arguments_64 s.(sig_args) 0 0 0 + else size_arguments_32 s.(sig_args) 0. + +(** Argument locations are either caller-save registers or [Outgoing] + stack slots at nonnegative offsets. *) + +Definition loc_argument_acceptable (l: loc) : Prop := + match l with + | R r => is_callee_save r = false + | S Outgoing ofs ty => ofs >= 0 /\ (typealign ty | ofs) + | _ => False + end. + +Definition loc_argument_32_charact (ofs: Z) (l: loc) : Prop := + match l with + | S Outgoing ofs' ty => ofs' >= ofs /\ typealign ty = 1 + | _ => False + end. + +Definition loc_argument_64_charact (ofs: Z) (l: loc) : Prop := + match l with + | R r => In r int_param_regs \/ In r float_param_regs + | S Outgoing ofs' ty => ofs' >= ofs /\ (2 | ofs') + | _ => False + end. + +Remark loc_arguments_32_charact: + forall tyl ofs p, + In p (loc_arguments_32 tyl ofs) -> forall_rpair (loc_argument_32_charact ofs) p. +Proof. + assert (X: forall ofs1 ofs2 l, loc_argument_32_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_32_charact ofs1 l). + { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } + induction tyl as [ | ty tyl]; simpl loc_arguments_32; intros. +- contradiction. +- destruct H. ++ destruct ty; subst p; simpl; omega. ++ apply IHtyl in H. generalize (typesize_pos ty); intros. destruct p; simpl in *. +* eapply X; eauto; omega. +* destruct H; split; eapply X; eauto; omega. +Qed. + +Remark loc_arguments_64_charact: + forall tyl ir fr ofs p, + In p (loc_arguments_64 tyl ir fr ofs) -> (2 | ofs) -> forall_rpair (loc_argument_64_charact ofs) p. +Proof. + assert (X: forall ofs1 ofs2 l, loc_argument_64_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_64_charact ofs1 l). + { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } + assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_64_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_64_charact ofs1) p). + { destruct p; simpl; intuition eauto. } + assert (Z: forall ofs, (2 | ofs) -> (2 | ofs + 2)). + { intros. apply Z.divide_add_r; auto. apply Zdivide_refl. } +Opaque list_nth_z. + induction tyl; simpl loc_arguments_64; intros. + elim H. + assert (A: forall ty, In p + match list_nth_z int_param_regs ir with + | Some ireg => One (R ireg) :: loc_arguments_64 tyl (ir + 1) fr ofs + | None => One (S Outgoing ofs ty) :: loc_arguments_64 tyl ir fr (ofs + 2) + end -> + forall_rpair (loc_argument_64_charact ofs) p). + { intros. destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H1. + subst. left. eapply list_nth_z_in; eauto. + eapply IHtyl; eauto. + subst. split. omega. assumption. + eapply Y; eauto. omega. } + assert (B: forall ty, In p + match list_nth_z float_param_regs fr with + | Some ireg => One (R ireg) :: loc_arguments_64 tyl ir (fr + 1) ofs + | None => One (S Outgoing ofs ty) :: loc_arguments_64 tyl ir fr (ofs + 2) + end -> + forall_rpair (loc_argument_64_charact ofs) p). + { intros. destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H1. + subst. right. eapply list_nth_z_in; eauto. + eapply IHtyl; eauto. + subst. split. omega. assumption. + eapply Y; eauto. omega. } + destruct a; eauto. +Qed. + +Lemma loc_arguments_acceptable: + forall (s: signature) (p: rpair loc), + In p (loc_arguments s) -> forall_rpair loc_argument_acceptable p. +Proof. + unfold loc_arguments; intros. destruct Archi.ptr64 eqn:SF. +- (* 64 bits *) + assert (A: forall r, In r int_param_regs -> is_callee_save r = false) by (unfold is_callee_save; rewrite SF; decide_goal). + assert (B: forall r, In r float_param_regs -> is_callee_save r = false) by decide_goal. + assert (X: forall l, loc_argument_64_charact 0 l -> loc_argument_acceptable l). + { unfold loc_argument_64_charact, loc_argument_acceptable. + destruct l as [r | [] ofs ty]; auto. intros [C|C]; auto. + intros [C D]. split; auto. apply Zdivide_trans with 2; auto. + exists (2 / typealign ty); destruct ty; reflexivity. + } + exploit loc_arguments_64_charact; eauto using Zdivide_0. + unfold forall_rpair; destruct p; intuition auto. +- (* 32 bits *) + assert (X: forall l, loc_argument_32_charact 0 l -> loc_argument_acceptable l). + { destruct l as [r | [] ofs ty]; simpl; intuition auto. rewrite H2; apply Z.divide_1_l. } + exploit loc_arguments_32_charact; eauto. + unfold forall_rpair; destruct p; intuition auto. +Qed. + +Hint Resolve loc_arguments_acceptable: locs. + +(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) + +Remark size_arguments_32_above: + forall tyl ofs0, ofs0 <= size_arguments_32 tyl ofs0. +Proof. + induction tyl; simpl; intros. + omega. + apply Zle_trans with (ofs0 + typesize a); auto. + generalize (typesize_pos a); omega. +Qed. + +Remark size_arguments_64_above: + forall tyl ir fr ofs0, + ofs0 <= size_arguments_64 tyl ir fr ofs0. +Proof. + induction tyl; simpl; intros. + omega. + assert (A: ofs0 <= + match list_nth_z int_param_regs ir with + | Some _ => size_arguments_64 tyl (ir + 1) fr ofs0 + | None => size_arguments_64 tyl ir fr (ofs0 + 2) + end). + { destruct (list_nth_z int_param_regs ir); eauto. + apply Zle_trans with (ofs0 + 2); auto. omega. } + assert (B: ofs0 <= + match list_nth_z float_param_regs fr with + | Some _ => size_arguments_64 tyl ir (fr + 1) ofs0 + | None => size_arguments_64 tyl ir fr (ofs0 + 2) + end). + { destruct (list_nth_z float_param_regs fr); eauto. + apply Zle_trans with (ofs0 + 2); auto. omega. } + destruct a; auto. +Qed. + +Lemma size_arguments_above: + forall s, size_arguments s >= 0. +Proof. + intros; unfold size_arguments. apply Zle_ge. + destruct Archi.ptr64; [apply size_arguments_64_above|apply size_arguments_32_above]. +Qed. + +Lemma loc_arguments_32_bounded: + forall ofs ty tyl ofs0, + In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_32 tyl ofs0)) -> + ofs + typesize ty <= size_arguments_32 tyl ofs0. +Proof. + induction tyl as [ | t l]; simpl; intros x IN. +- contradiction. +- rewrite in_app_iff in IN; destruct IN as [IN|IN]. ++ apply Zle_trans with (x + typesize t); [|apply size_arguments_32_above]. + Ltac decomp := + match goal with + | [ H: _ \/ _ |- _ ] => destruct H; decomp + | [ H: S _ _ _ = S _ _ _ |- _ ] => inv H + | [ H: False |- _ ] => contradiction + end. + destruct t; simpl in IN; decomp; simpl; omega. ++ apply IHl; auto. +Qed. + +Lemma loc_arguments_64_bounded: + forall ofs ty tyl ir fr ofs0, + In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_64 tyl ir fr ofs0)) -> + ofs + typesize ty <= size_arguments_64 tyl ir fr ofs0. +Proof. + induction tyl; simpl; intros. + contradiction. + assert (T: forall ty0, typesize ty0 <= 2). + { destruct ty0; simpl; omega. } + assert (A: forall ty0, + In (S Outgoing ofs ty) (regs_of_rpairs + match list_nth_z int_param_regs ir with + | Some ireg => + One (R ireg) :: loc_arguments_64 tyl (ir + 1) fr ofs0 + | None => One (S Outgoing ofs0 ty0) :: loc_arguments_64 tyl ir fr (ofs0 + 2) + end) -> + ofs + typesize ty <= + match list_nth_z int_param_regs ir with + | Some _ => size_arguments_64 tyl (ir + 1) fr ofs0 + | None => size_arguments_64 tyl ir fr (ofs0 + 2) + end). + { intros. destruct (list_nth_z int_param_regs ir); simpl in H0; destruct H0. + - discriminate. + - eapply IHtyl; eauto. + - inv H0. apply Zle_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_64_above. + - eapply IHtyl; eauto. } + assert (B: forall ty0, + In (S Outgoing ofs ty) (regs_of_rpairs + match list_nth_z float_param_regs fr with + | Some ireg => + One (R ireg) :: loc_arguments_64 tyl ir (fr + 1) ofs0 + | None => One (S Outgoing ofs0 ty0) :: loc_arguments_64 tyl ir fr (ofs0 + 2) + end) -> + ofs + typesize ty <= + match list_nth_z float_param_regs fr with + | Some _ => size_arguments_64 tyl ir (fr + 1) ofs0 + | None => size_arguments_64 tyl ir fr (ofs0 + 2) + end). + { intros. destruct (list_nth_z float_param_regs fr); simpl in H0; destruct H0. + - discriminate. + - eapply IHtyl; eauto. + - inv H0. apply Zle_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_64_above. + - eapply IHtyl; eauto. } + destruct a; eauto. +Qed. + +Lemma loc_arguments_bounded: + forall (s: signature) (ofs: Z) (ty: typ), + In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) -> + ofs + typesize ty <= size_arguments s. +Proof. + unfold loc_arguments, size_arguments; intros. + destruct Archi.ptr64; eauto using loc_arguments_32_bounded, loc_arguments_64_bounded. +Qed. + +Lemma loc_arguments_main: + loc_arguments signature_main = nil. +Proof. + unfold loc_arguments; destruct Archi.ptr64; reflexivity. +Qed. diff --git a/ia32/Machregs.v b/x86/Machregs.v index 3a6ae674..741081a6 100644 --- a/ia32/Machregs.v +++ b/x86/Machregs.v @@ -31,12 +31,13 @@ Require Import Op. Inductive mreg: Type := (** Allocatable integer regs *) - | AX: mreg | BX: mreg | CX: mreg | DX: mreg | SI: mreg | DI: mreg | BP: mreg + | AX | BX | CX | DX | SI | DI | BP + | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 (**r only in 64-bit mode *) (** Allocatable float regs *) - | X0: mreg | X1: mreg | X2: mreg | X3: mreg - | X4: mreg | X5: mreg | X6: mreg | X7: mreg + | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 + | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 (**r only in 64-bit mode *) (** Special float reg *) - | FP0: mreg (**r top of x87 FP stack *). + | FP0. Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. Proof. decide equality. Defined. @@ -44,7 +45,9 @@ Global Opaque mreg_eq. Definition all_mregs := AX :: BX :: CX :: DX :: SI :: DI :: BP + :: R8 :: R9 :: R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 + :: X8 :: X9 :: X10 :: X11 :: X12 :: X13 :: X14 :: X15 :: FP0 :: nil. Lemma all_mregs_complete: @@ -55,7 +58,7 @@ Proof. Qed. Instance Decidable_eq_mreg : forall (x y: mreg), Decidable (eq x y) := Decidable_eq mreg_eq. - + Instance Finite_mreg : Finite mreg := { Finite_elements := all_mregs; Finite_elements_spec := all_mregs_complete @@ -63,8 +66,11 @@ Instance Finite_mreg : Finite mreg := { Definition mreg_type (r: mreg): typ := match r with - | AX | BX | CX | DX | SI | DI | BP => Tany32 - | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 | FP0 => Tany64 + | AX | BX | CX | DX | SI | DI | BP => if Archi.ptr64 then Tany64 else Tany32 + | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 => Tany64 + | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 => Tany64 + | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 => Tany64 + | FP0 => Tany64 end. Local Open Scope positive_scope. @@ -75,9 +81,10 @@ Module IndexedMreg <: INDEXED_TYPE. Definition index (r: mreg): positive := match r with | AX => 1 | BX => 2 | CX => 3 | DX => 4 | SI => 5 | DI => 6 | BP => 7 - | X0 => 8 | X1 => 9 | X2 => 10 | X3 => 11 - | X4 => 12 | X5 => 13 | X6 => 14 | X7 => 15 - | FP0 => 16 + | R8 => 8 | R9 => 9 | R10 => 10 | R11 => 11 | R12 => 12 | R13 => 13 | R14 => 14 | R15 => 15 + | X0 => 16 | X1 => 17 | X2 => 18 | X3 => 19 | X4 => 20 | X5 => 21 | X6 => 22 | X7 => 23 + | X8 => 24 | X9 => 25 | X10 => 26 | X11 => 27 | X12 => 28 | X13 => 29 | X14 => 30 | X15 => 31 + | FP0 => 32 end. Lemma index_inj: forall r1 r2, index r1 = index r2 -> r1 = r2. @@ -94,10 +101,16 @@ Definition is_stack_reg (r: mreg) : bool := Local Open Scope string_scope. Definition register_names := + ("RAX", AX) :: ("RBX", BX) :: ("RCX", CX) :: ("RDX", DX) :: + ("RSI", SI) :: ("RDI", DI) :: ("RBP", BP) :: ("EAX", AX) :: ("EBX", BX) :: ("ECX", CX) :: ("EDX", DX) :: ("ESI", SI) :: ("EDI", DI) :: ("EBP", BP) :: + ("R8", R8) :: ("R9", R9) :: ("R10", R10) :: ("R11", R11) :: + ("R12", R12) :: ("R13", R13) :: ("R14", R14) :: ("R15", R15) :: ("XMM0", X0) :: ("XMM1", X1) :: ("XMM2", X2) :: ("XMM3", X3) :: ("XMM4", X4) :: ("XMM5", X5) :: ("XMM6", X6) :: ("XMM7", X7) :: + ("XMM8", X8) :: ("XMM9", X9) :: ("XMM10", X10) :: ("XMM11", X11) :: + ("XMM12", X12) :: ("XMM13", X13) :: ("XMM14", X14) :: ("XMM15", X15) :: ("ST0", FP0) :: nil. Definition register_by_name (s: string) : option mreg := @@ -112,7 +125,7 @@ Definition register_by_name (s: string) : option mreg := Definition destroyed_by_op (op: operation): list mreg := match op with - | Ocast8signed | Ocast8unsigned | Ocast16signed | Ocast16unsigned => AX :: nil + | Ocast8signed | Ocast8unsigned => AX :: nil | Omulhs => AX :: DX :: nil | Omulhu => AX :: DX :: nil | Odiv => AX :: DX :: nil @@ -120,6 +133,13 @@ Definition destroyed_by_op (op: operation): list mreg := | Omod => AX :: DX :: nil | Omodu => AX :: DX :: nil | Oshrximm _ => CX :: nil + | Omullhs => AX :: DX :: nil + | Omullhu => AX :: DX :: nil + | Odivl => AX :: DX :: nil + | Odivlu => AX :: DX :: nil + | Omodl => AX :: DX :: nil + | Omodlu => AX :: DX :: nil + | Oshrxlimm _ => DX :: nil | Ocmp _ => AX :: CX :: nil | _ => nil end. @@ -129,15 +149,15 @@ Definition destroyed_by_load (chunk: memory_chunk) (addr: addressing): list mreg Definition destroyed_by_store (chunk: memory_chunk) (addr: addressing): list mreg := match chunk with - | Mint8signed | Mint8unsigned => AX :: CX :: nil + | Mint8signed | Mint8unsigned => if Archi.ptr64 then nil else AX :: CX :: nil | _ => nil - end. + end. Definition destroyed_by_cond (cond: condition): list mreg := nil. Definition destroyed_by_jumptable: list mreg := - nil. + AX :: DX :: nil. Fixpoint destroyed_by_clobber (cl: list string): list mreg := match cl with @@ -153,21 +173,21 @@ Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with | EF_memcpy sz al => if zle sz 32 then CX :: X7 :: nil else CX :: SI :: DI :: nil - | EF_vstore (Mint8unsigned|Mint8signed) => AX :: CX :: nil + | EF_vstore (Mint8unsigned|Mint8signed) => + if Archi.ptr64 then nil else AX :: CX :: nil | EF_builtin name sg => - if string_dec name "__builtin_write16_reversed" - || string_dec name "__builtin_write32_reversed" - then CX :: DX :: nil else nil + if string_dec name "__builtin_va_start" then AX :: nil + else if string_dec name "__builtin_write16_reversed" + || string_dec name "__builtin_write32_reversed" + then CX :: DX :: nil + else nil | EF_inline_asm txt sg clob => destroyed_by_clobber clob | _ => nil end. Definition destroyed_at_function_entry: list mreg := (* must include [destroyed_by_setstack ty] *) - DX :: FP0 :: nil. - -Definition destroyed_at_indirect_call: list mreg := - nil. + AX :: FP0 :: nil. Definition destroyed_by_setstack (ty: typ): list mreg := match ty with @@ -175,8 +195,11 @@ Definition destroyed_by_setstack (ty: typ): list mreg := | _ => nil end. +Definition destroyed_at_indirect_call: list mreg := + nil. + Definition temp_for_parent_frame: mreg := - DX. + AX. Definition mregs_for_operation (op: operation): list (option mreg) * option mreg := match op with @@ -190,6 +213,16 @@ Definition mregs_for_operation (op: operation): list (option mreg) * option mreg | Oshr => (None :: Some CX :: nil, None) | Oshru => (None :: Some CX :: nil, None) | Oshrximm _ => (Some AX :: nil, Some AX) + | Omullhs => (Some AX :: None :: nil, Some DX) + | Omullhu => (Some AX :: None :: nil, Some DX) + | Odivl => (Some AX :: Some CX :: nil, Some AX) + | Odivlu => (Some AX :: Some CX :: nil, Some AX) + | Omodl => (Some AX :: Some CX :: nil, Some DX) + | Omodlu => (Some AX :: Some CX :: nil, Some DX) + | Oshll => (None :: Some CX :: nil, None) + | Oshrl => (None :: Some CX :: nil, None) + | Oshrlu => (None :: Some CX :: nil, None) + | Oshrxlimm _ => (Some AX :: nil, Some AX) | _ => (nil, None) end. @@ -205,6 +238,10 @@ Definition mregs_for_builtin (ef: external_function): list (option mreg) * list (Some DX :: Some AX :: Some CX :: Some BX :: nil, Some DX :: Some AX :: nil) else if string_dec name "__builtin_mull" then (Some AX :: Some DX :: nil, Some DX :: Some AX :: nil) + else if string_dec name "__builtin_va_start" then + (Some DX :: nil, nil) + else if (negb Archi.ptr64) && string_dec name "__builtin_bswap64" then + (Some AX :: Some DX :: nil, Some DX :: Some AX :: nil) else (nil, nil) | _ => (nil, nil) @@ -213,7 +250,6 @@ Definition mregs_for_builtin (ef: external_function): list (option mreg) * list Global Opaque destroyed_by_op destroyed_by_load destroyed_by_store destroyed_by_cond destroyed_by_jumptable destroyed_by_builtin - destroyed_at_indirect_call destroyed_by_setstack destroyed_at_function_entry temp_for_parent_frame mregs_for_operation mregs_for_builtin. @@ -225,6 +261,7 @@ Definition two_address_op (op: operation) : bool := match op with | Omove => false | Ointconst _ => false + | Olongconst _ => false | Ofloatconst _ => false | Osingleconst _ => false | Oindirectsymbol _ => false @@ -259,6 +296,38 @@ Definition two_address_op (op: operation) : bool := | Ororimm _ => true | Oshldimm _ => true | Olea addr => false + | Omakelong => true + | Olowlong => true + | Ohighlong => true + | Ocast32signed => false + | Ocast32unsigned => false + | Onegl => true + | Oaddlimm _ => true + | Osubl => true + | Omull => true + | Omullimm _ => true + | Omullhs => false + | Omullhu => false + | Odivl => false + | Odivlu => false + | Omodl => false + | Omodlu => false + | Oandl => true + | Oandlimm _ => true + | Oorl => true + | Oorlimm _ => true + | Oxorl => true + | Oxorlimm _ => true + | Onotl => true + | Oshll => true + | Oshllimm _ => true + | Oshrl => true + | Oshrlimm _ => true + | Oshrxlimm _ => false + | Oshrlu => true + | Oshrluimm _ => true + | Ororlimm _ => true + | Oleal addr => false | Onegf => true | Oabsf => true | Oaddf => true @@ -277,9 +346,10 @@ Definition two_address_op (op: operation) : bool := | Ofloatofint => false | Ointofsingle => false | Osingleofint => false - | Omakelong => false - | Olowlong => false - | Ohighlong => false + | Olongoffloat => false + | Ofloatoflong => false + | Olongofsingle => false + | Osingleoflong => false | Ocmp c => false end. diff --git a/ia32/Machregsaux.ml b/x86/Machregsaux.ml index 473e0602..473e0602 100644 --- a/ia32/Machregsaux.ml +++ b/x86/Machregsaux.ml diff --git a/ia32/Machregsaux.mli b/x86/Machregsaux.mli index 9404568d..9404568d 100644 --- a/ia32/Machregsaux.mli +++ b/x86/Machregsaux.mli diff --git a/ia32/NeedOp.v b/x86/NeedOp.v index 07eec160..09013cdd 100644 --- a/ia32/NeedOp.v +++ b/x86/NeedOp.v @@ -1,15 +1,20 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Neededness analysis for x86_64 operators *) + Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Op. -Require Import NeedDomain. -Require Import RTL. - -(** Neededness analysis for IA32 operators *) +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Op NeedDomain RTL. Definition op1 (nv: nval) := nv :: nil. Definition op2 (nv: nval) := nv :: nv :: nil. @@ -20,7 +25,7 @@ Definition needs_of_condition (cond: condition): list nval := | _ => nil end. -Definition needs_of_addressing (addr: addressing) (nv: nval): list nval := +Definition needs_of_addressing_32 (addr: addressing) (nv: nval): list nval := match addr with | Aindexed n => op1 (modarith nv) | Aindexed2 n => op2 (modarith nv) @@ -32,10 +37,26 @@ Definition needs_of_addressing (addr: addressing) (nv: nval): list nval := | Ainstack ofs => nil end. +Definition needs_of_addressing_64 (addr: addressing) (nv: nval): list nval := + match addr with + | Aindexed n => op1 (default nv) + | Aindexed2 n => op2 (default nv) + | Ascaled sc ofs => op1 (default nv) + | Aindexed2scaled sc ofs => op2 (default nv) + | Aglobal s ofs => nil + | Abased s ofs => op1 (default nv) + | Abasedscaled sc s ofs => op1 (default nv) + | Ainstack ofs => nil + end. + +Definition needs_of_addressing (addr: addressing) (nv: nval): list nval := + if Archi.ptr64 then needs_of_addressing_64 addr nv else needs_of_addressing_32 addr nv. + Definition needs_of_operation (op: operation) (nv: nval): list nval := match op with | Omove => op1 nv | Ointconst n => nil + | Olongconst n => nil | Ofloatconst n => nil | Osingleconst n => nil | Oindirectsymbol id => nil @@ -64,15 +85,40 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oshruimm n => op1 (shruimm nv n) | Ororimm n => op1 (ror nv n) | Oshldimm n => op1 (default nv) - | Olea addr => needs_of_addressing addr nv + | Olea addr => needs_of_addressing_32 addr nv + | Omakelong => op2 (default nv) + | Olowlong | Ohighlong => op1 (default nv) + | Ocast32signed => op1 (default nv) + | Ocast32unsigned => op1 (default nv) + | Onegl => op1 (default nv) + | Oaddlimm _ => op1 (default nv) + | Osubl => op2 (default nv) + | Omull => op2 (default nv) + | Omullimm _ => op1 (default nv) + | Omullhs | Omullhu | Odivl | Odivlu | Omodl | Omodlu => op2 (default nv) + | Oandl => op2 (default nv) + | Oandlimm _ => op1 (default nv) + | Oorl => op2 (default nv) + | Oorlimm _ => op1 (default nv) + | Oxorl => op2 (default nv) + | Oxorlimm _ => op1 (default nv) + | Onotl => op1 (default nv) + | Oshll => op2 (default nv) + | Oshllimm _ => op1 (default nv) + | Oshrl => op2 (default nv) + | Oshrlimm _ => op1 (default nv) + | Oshrxlimm n => op1 (default nv) + | Oshrlu => op2 (default nv) + | Oshrluimm _ => op1 (default nv) + | Ororlimm _ => op1 (default nv) + | Oleal addr => needs_of_addressing_64 addr nv | Onegf | Oabsf => op1 (default nv) | Oaddf | Osubf | Omulf | Odivf => op2 (default nv) | Onegfs | Oabsfs => op1 (default nv) | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv) | Osingleoffloat | Ofloatofsingle => op1 (default nv) | Ointoffloat | Ofloatofint | Ointofsingle | Osingleofint => op1 (default nv) - | Omakelong => op2 (default nv) - | Olowlong | Ohighlong => op1 (default nv) + | Olongoffloat | Ofloatoflong | Olongofsingle | Osingleoflong => op1 (default nv) | Ocmp c => needs_of_condition c end. @@ -117,19 +163,19 @@ Proof. try (eapply default_needs_of_condition_sound; eauto; fail); simpl in *; FuncInv; InvAgree. - eapply maskzero_sound; eauto. -- destruct (Val.maskzero_bool v i) as [b'|] eqn:MZ; try discriminate. +- destruct (Val.maskzero_bool v n) as [b'|] eqn:MZ; try discriminate. erewrite maskzero_sound; eauto. Qed. -Lemma needs_of_addressing_sound: - forall (ge: genv) sp addr args v nv args', - eval_addressing ge (Vptr sp Int.zero) addr args = Some v -> - vagree_list args args' (needs_of_addressing addr nv) -> +Lemma needs_of_addressing_32_sound: + forall sp addr args v nv args', + eval_addressing32 ge (Vptr sp Ptrofs.zero) addr args = Some v -> + vagree_list args args' (needs_of_addressing_32 addr nv) -> exists v', - eval_addressing ge (Vptr sp Int.zero) addr args' = Some v' + eval_addressing32 ge (Vptr sp Ptrofs.zero) addr args' = Some v' /\ vagree v v' nv. Proof. - unfold needs_of_addressing; intros. + unfold needs_of_addressing_32; intros. destruct addr; simpl in *; FuncInv; InvAgree; TrivialExists; auto using add_sound, mul_sound with na. apply add_sound; auto with na. apply add_sound; rewrite modarith_idem; auto. @@ -137,13 +183,23 @@ Proof. apply mul_sound; rewrite modarith_idem; auto with na. Qed. +(* +Lemma needs_of_addressing_64_sound: + forall sp addr args v nv args', + eval_addressing64 ge (Vptr sp Ptrofs.zero) addr args = Some v -> + vagree_list args args' (needs_of_addressing_64 addr nv) -> + exists v', + eval_addressing64 ge (Vptr sp Ptrofs.zero) addr args' = Some v' + /\ vagree v v' nv. +*) + Lemma needs_of_operation_sound: forall op args v nv args', - eval_operation ge (Vptr sp Int.zero) op args m = Some v -> + eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v -> vagree_list args args' (needs_of_operation op nv) -> nv <> Nothing -> exists v', - eval_operation ge (Vptr sp Int.zero) op args' m' = Some v' + eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v' /\ vagree v v' nv. Proof. unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail); @@ -166,8 +222,12 @@ Proof. - apply shrimm_sound; auto. - apply shruimm_sound; auto. - apply ror_sound; auto. -- eapply needs_of_addressing_sound; eauto. -- destruct (eval_condition c args m) as [b|] eqn:EC; simpl in H2. +- eapply needs_of_addressing_32_sound; eauto. +- change (eval_addressing64 ge (Vptr sp Ptrofs.zero) a args') + with (eval_operation ge (Vptr sp Ptrofs.zero) (Oleal a) args' m'). + eapply default_needs_of_operation_sound; eauto. + destruct a; simpl in H0; auto. +- destruct (eval_condition cond args m) as [b|] eqn:EC; simpl in H2. erewrite needs_of_condition_sound by eauto. subst v; simpl. auto with na. subst v; auto with na. @@ -176,7 +236,7 @@ Qed. Lemma operation_is_redundant_sound: forall op nv arg1 args v arg1' args', operation_is_redundant op nv = true -> - eval_operation ge (Vptr sp Int.zero) op (arg1 :: args) m = Some v -> + eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m = Some v -> vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) -> vagree v arg1' nv. Proof. diff --git a/x86/Op.v b/x86/Op.v new file mode 100644 index 00000000..0de3e061 --- /dev/null +++ b/x86/Op.v @@ -0,0 +1,1452 @@ +(* *********************************************************************) +(* *) +(* 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 X86-64-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 Memory. +Require Import Globalenvs. +Require Import Events. + +Set Implicit Arguments. + +(** Conditions (boolean-valued operators). *) + +Inductive condition : Type := + | Ccomp (c: comparison) (**r signed integer comparison *) + | Ccompu (c: comparison) (**r unsigned integer comparison *) + | Ccompimm (c: comparison) (n: int) (**r signed integer comparison with a constant *) + | Ccompuimm (c: comparison) (n: int) (**r unsigned integer comparison with a constant *) + | Ccompl (c: comparison) (**r signed 64-bit integer comparison *) + | Ccomplu (c: comparison) (**r unsigned 64-bit integer comparison *) + | Ccomplimm (c: comparison) (n: int64) (**r signed 64-bit integer comparison with a constant *) + | Ccompluimm (c: comparison) (n: int64) (**r unsigned 64-bit integer comparison with a constant *) + | Ccompf (c: comparison) (**r 64-bit floating-point comparison *) + | Cnotcompf (c: comparison) (**r negation of a floating-point comparison *) + | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) + | Cnotcompfs (c: comparison) (**r negation of a floating-point comparison *) + | Cmaskzero (n: int) (**r test [(arg & constant) == 0] *) + | Cmasknotzero (n: int). (**r test [(arg & constant) != 0] *) + +(** Addressing modes. [r1], [r2], etc, are the arguments to the + addressing. *) + +Inductive addressing: Type := + | Aindexed: Z -> addressing (**r Address is [r1 + offset] *) + | Aindexed2: Z -> addressing (**r Address is [r1 + r2 + offset] *) + | Ascaled: Z -> Z -> addressing (**r Address is [r1 * scale + offset] *) + | Aindexed2scaled: Z -> Z -> addressing + (**r Address is [r1 + r2 * scale + offset] *) + | Aglobal: ident -> ptrofs -> addressing (**r Address is [symbol + offset] *) + | Abased: ident -> ptrofs -> addressing (**r Address is [symbol + offset + r1] *) + | Abasedscaled: Z -> ident -> ptrofs -> addressing (**r Address is [symbol + offset + r1 * scale] *) + | Ainstack: ptrofs -> addressing. (**r Address is [stack_pointer + offset] *) + +(** Arithmetic and logical operations. In the descriptions, [rd] is the + result of the operation and [r1], [r2], etc, are the arguments. *) + +Inductive operation : Type := + | Omove (**r [rd = r1] *) + | Ointconst (n: int) (**r [rd] is set to the given integer constant *) + | Olongconst (n: int64) (**r [rd] is set to the given integer constant *) + | Ofloatconst (n: float) (**r [rd] is set to the given float constant *) + | Osingleconst (n: float32)(**r [rd] is set to the given float constant *) + | Oindirectsymbol (id: ident) (**r [rd] is set to the address of the symbol *) +(*c 32-bit integer arithmetic: *) + | Ocast8signed (**r [rd] is 8-bit sign extension of [r1] *) + | Ocast8unsigned (**r [rd] is 8-bit zero extension of [r1] *) + | Ocast16signed (**r [rd] is 16-bit sign extension of [r1] *) + | Ocast16unsigned (**r [rd] is 16-bit zero extension of [r1] *) + | Oneg (**r [rd = - r1] *) + | Osub (**r [rd = r1 - r2] *) + | Omul (**r [rd = r1 * r2] *) + | Omulimm (n: int) (**r [rd = r1 * n] *) + | Omulhs (**r [rd = high part of r1 * r2, signed] *) + | Omulhu (**r [rd = high part of r1 * r2, unsigned] *) + | Odiv (**r [rd = r1 / r2] (signed) *) + | Odivu (**r [rd = r1 / r2] (unsigned) *) + | Omod (**r [rd = r1 % r2] (signed) *) + | Omodu (**r [rd = r1 % r2] (unsigned) *) + | Oand (**r [rd = r1 & r2] *) + | Oandimm (n: int) (**r [rd = r1 & n] *) + | Oor (**r [rd = r1 | r2] *) + | Oorimm (n: int) (**r [rd = r1 | n] *) + | Oxor (**r [rd = r1 ^ r2] *) + | Oxorimm (n: int) (**r [rd = r1 ^ n] *) + | Onot (**r [rd = ~r1] *) + | Oshl (**r [rd = r1 << r2] *) + | Oshlimm (n: int) (**r [rd = r1 << n] *) + | Oshr (**r [rd = r1 >> r2] (signed) *) + | Oshrimm (n: int) (**r [rd = r1 >> n] (signed) *) + | Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *) + | Oshru (**r [rd = r1 >> r2] (unsigned) *) + | Oshruimm (n: int) (**r [rd = r1 >> n] (unsigned) *) + | Ororimm (n: int) (**r rotate right immediate *) + | Oshldimm (n: int) (**r [rd = r1 << n | r2 >> (32-n)] *) + | Olea (a: addressing) (**r effective address *) +(*c 64-bit integer arithmetic: *) + | Omakelong (**r [rd = r1 << 32 | r2] *) + | Olowlong (**r [rd = low-word(r1)] *) + | Ohighlong (**r [rd = high-word(r1)] *) + | Ocast32signed (**r [rd] is 32-bit sign extension of [r1] *) + | Ocast32unsigned (**r [rd] is 32-bit zero extension of [r1] *) + | Onegl (**r [rd = - r1] *) + | Oaddlimm (n: int64) (**r [rd = r1 + n] *) + | Osubl (**r [rd = r1 - r2] *) + | Omull (**r [rd = r1 * r2] *) + | Omullimm (n: int64) (**r [rd = r1 * n] *) + | Omullhs (**r [rd = high part of r1 * r2, signed] *) + | Omullhu (**r [rd = high part of r1 * r2, unsigned] *) + | Odivl (**r [rd = r1 / r2] (signed) *) + | Odivlu (**r [rd = r1 / r2] (unsigned) *) + | Omodl (**r [rd = r1 % r2] (signed) *) + | Omodlu (**r [rd = r1 % r2] (unsigned) *) + | Oandl (**r [rd = r1 & r2] *) + | Oandlimm (n: int64) (**r [rd = r1 & n] *) + | Oorl (**r [rd = r1 | r2] *) + | Oorlimm (n: int64) (**r [rd = r1 | n] *) + | Oxorl (**r [rd = r1 ^ r2] *) + | Oxorlimm (n: int64) (**r [rd = r1 ^ n] *) + | Onotl (**r [rd = ~r1] *) + | Oshll (**r [rd = r1 << r2] *) + | Oshllimm (n: int) (**r [rd = r1 << n] *) + | Oshrl (**r [rd = r1 >> r2] (signed) *) + | Oshrlimm (n: int) (**r [rd = r1 >> n] (signed) *) + | Oshrxlimm (n: int) (**r [rd = r1 / 2^n] (signed) *) + | Oshrlu (**r [rd = r1 >> r2] (unsigned) *) + | Oshrluimm (n: int) (**r [rd = r1 >> n] (unsigned) *) + | Ororlimm (n: int) (**r rotate right immediate *) + | Oleal (a: addressing) (**r effective address *) +(*c Floating-point arithmetic: *) + | Onegf (**r [rd = - r1] *) + | Oabsf (**r [rd = abs(r1)] *) + | Oaddf (**r [rd = r1 + r2] *) + | Osubf (**r [rd = r1 - r2] *) + | Omulf (**r [rd = r1 * r2] *) + | Odivf (**r [rd = r1 / r2] *) + | Onegfs (**r [rd = - r1] *) + | Oabsfs (**r [rd = abs(r1)] *) + | Oaddfs (**r [rd = r1 + r2] *) + | Osubfs (**r [rd = r1 - r2] *) + | Omulfs (**r [rd = r1 * r2] *) + | Odivfs (**r [rd = r1 / r2] *) + | Osingleoffloat (**r [rd] is [r1] truncated to single-precision float *) + | Ofloatofsingle (**r [rd] is [r1] extended to double-precision float *) +(*c Conversions between int and float: *) + | Ointoffloat (**r [rd = signed_int_of_float64(r1)] *) + | Ofloatofint (**r [rd = float64_of_signed_int(r1)] *) + | Ointofsingle (**r [rd = signed_int_of_float32(r1)] *) + | Osingleofint (**r [rd = float32_of_signed_int(r1)] *) + | Olongoffloat (**r [rd = signed_long_of_float64(r1)] *) + | Ofloatoflong (**r [rd = float64_of_signed_long(r1)] *) + | Olongofsingle (**r [rd = signed_long_of_float32(r1)] *) + | Osingleoflong (**r [rd = float32_of_signed_long(r1)] *) +(*c Boolean tests: *) + | Ocmp (cond: condition). (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + +(** Comparison functions (used in modules [CSE] and [Allocation]). *) + +Definition eq_condition (x y: condition) : {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec Int64.eq_dec; intro. + assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. + decide equality. +Defined. + +Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. +Proof. + generalize ident_eq Ptrofs.eq_dec zeq; intros. + decide equality. +Defined. + +Definition eq_operation (x y: operation): {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec Int64.eq_dec Float.eq_dec Float32.eq_dec; intros. + decide equality. + apply ident_eq. + apply eq_addressing. + apply eq_addressing. + apply eq_condition. +Defined. + +Global Opaque eq_condition eq_addressing eq_operation. + +(** In addressing modes, offsets are 32-bit signed integers, even in 64-bit mode. + The following function checks that an addressing mode is valid, i.e. that + the offsets are in range. *) + +Definition offset_in_range (n: Z) : bool := zle Int.min_signed n && zle n Int.max_signed. + +Definition addressing_valid (a: addressing) : bool := + match a with + | Aindexed n => offset_in_range n + | Aindexed2 n => offset_in_range n + | Ascaled sc ofs => offset_in_range ofs + | Aindexed2scaled sc ofs => offset_in_range ofs + | Aglobal s ofs => true + | Abased s ofs => true + | Abasedscaled sc s ofs => true + | Ainstack ofs => offset_in_range (Ptrofs.signed ofs) + end. + +(** * Evaluation functions *) + +(** Evaluation of conditions, operators and addressing modes applied + to lists of values. Return [None] when the computation can trigger an + error, e.g. integer division by zero. [eval_condition] returns a boolean, + [eval_operation] and [eval_addressing] return a value. *) + +Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := + match cond, vl with + | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 + | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 + | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n) + | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n) + | Ccompl c, v1 :: v2 :: nil => Val.cmpl_bool c v1 v2 + | Ccomplu c, v1 :: v2 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 + | Ccomplimm c n, v1 :: nil => Val.cmpl_bool c v1 (Vlong n) + | Ccompluimm c n, v1 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong n) + | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2 + | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2) + | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2 + | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) + | Cmaskzero n, v1 :: nil => Val.maskzero_bool v1 n + | Cmasknotzero n, v1 :: nil => option_map negb (Val.maskzero_bool v1 n) + | _, _ => None + end. + +Definition eval_addressing32 + (F V: Type) (genv: Genv.t F V) (sp: val) + (addr: addressing) (vl: list val) : option val := + match addr, vl with + | Aindexed n, v1::nil => + Some (Val.add v1 (Vint (Int.repr n))) + | Aindexed2 n, v1::v2::nil => + Some (Val.add (Val.add v1 v2) (Vint (Int.repr n))) + | Ascaled sc ofs, v1::nil => + Some (Val.add (Val.mul v1 (Vint (Int.repr sc))) (Vint (Int.repr ofs))) + | Aindexed2scaled sc ofs, v1::v2::nil => + Some(Val.add v1 (Val.add (Val.mul v2 (Vint (Int.repr sc))) (Vint (Int.repr ofs)))) + | Aglobal s ofs, nil => + if Archi.ptr64 then None else Some (Genv.symbol_address genv s ofs) + | Abased s ofs, v1::nil => + if Archi.ptr64 then None else Some (Val.add (Genv.symbol_address genv s ofs) v1) + | Abasedscaled sc s ofs, v1::nil => + if Archi.ptr64 then None else Some (Val.add (Genv.symbol_address genv s ofs) (Val.mul v1 (Vint (Int.repr sc)))) + | Ainstack ofs, nil => + if Archi.ptr64 then None else Some(Val.offset_ptr sp ofs) + | _, _ => None + end. + +Definition eval_addressing64 + (F V: Type) (genv: Genv.t F V) (sp: val) + (addr: addressing) (vl: list val) : option val := + match addr, vl with + | Aindexed n, v1::nil => + Some (Val.addl v1 (Vlong (Int64.repr n))) + | Aindexed2 n, v1::v2::nil => + Some (Val.addl (Val.addl v1 v2) (Vlong (Int64.repr n))) + | Ascaled sc ofs, v1::nil => + Some (Val.addl (Val.mull v1 (Vlong (Int64.repr sc))) (Vlong (Int64.repr ofs))) + | Aindexed2scaled sc ofs, v1::v2::nil => + Some(Val.addl v1 (Val.addl (Val.mull v2 (Vlong (Int64.repr sc))) (Vlong (Int64.repr ofs)))) + | Aglobal s ofs, nil => + if Archi.ptr64 then Some (Genv.symbol_address genv s ofs) else None + | Ainstack ofs, nil => + if Archi.ptr64 then Some(Val.offset_ptr sp ofs) else None + | _, _ => None + end. + +Definition eval_addressing + (F V: Type) (genv: Genv.t F V) (sp: val) + (addr: addressing) (vl: list val) : option val := + if Archi.ptr64 + then eval_addressing64 genv sp addr vl + else eval_addressing32 genv sp addr vl. + +Definition eval_operation + (F V: Type) (genv: Genv.t F V) (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) + | Olongconst n, nil => Some (Vlong n) + | Ofloatconst n, nil => Some (Vfloat n) + | Osingleconst n, nil => Some (Vsingle n) + | Oindirectsymbol id, nil => Some (Genv.symbol_address genv id Ptrofs.zero) + | 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) + | Oneg, v1::nil => Some (Val.neg v1) + | Osub, v1::v2::nil => Some (Val.sub v1 v2) + | Omul, v1::v2::nil => Some (Val.mul v1 v2) + | Omulimm n, v1::nil => Some (Val.mul v1 (Vint n)) + | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2) + | Omulhu, v1::v2::nil => Some (Val.mulhu v1 v2) + | Odiv, v1::v2::nil => Val.divs v1 v2 + | Odivu, v1::v2::nil => Val.divu v1 v2 + | Omod, v1::v2::nil => Val.mods v1 v2 + | Omodu, v1::v2::nil => Val.modu v1 v2 + | Oand, v1::v2::nil => Some(Val.and v1 v2) + | Oandimm n, v1::nil => Some (Val.and v1 (Vint n)) + | Oor, v1::v2::nil => Some(Val.or v1 v2) + | Oorimm n, v1::nil => Some (Val.or v1 (Vint n)) + | Oxor, v1::v2::nil => Some(Val.xor v1 v2) + | Oxorimm n, v1::nil => Some (Val.xor v1 (Vint n)) + | Onot, v1::nil => Some(Val.notint v1) + | Oshl, v1::v2::nil => Some (Val.shl v1 v2) + | Oshlimm n, v1::nil => Some (Val.shl v1 (Vint n)) + | Oshr, v1::v2::nil => Some (Val.shr v1 v2) + | Oshrimm n, v1::nil => Some (Val.shr v1 (Vint n)) + | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Oshru, v1::v2::nil => Some (Val.shru v1 v2) + | Oshruimm n, v1::nil => Some (Val.shru v1 (Vint n)) + | Ororimm n, v1::nil => Some (Val.ror v1 (Vint n)) + | Oshldimm n, v1::v2::nil => Some (Val.or (Val.shl v1 (Vint n)) + (Val.shru v2 (Vint (Int.sub Int.iwordsize n)))) + | Olea addr, _ => eval_addressing32 genv sp addr vl + | Omakelong, v1::v2::nil => Some(Val.longofwords v1 v2) + | Olowlong, v1::nil => Some(Val.loword v1) + | Ohighlong, v1::nil => Some(Val.hiword v1) + | Ocast32signed, v1 :: nil => Some (Val.longofint v1) + | Ocast32unsigned, v1 :: nil => Some (Val.longofintu v1) + | Onegl, v1::nil => Some (Val.negl v1) + | Oaddlimm n, v1::nil => Some (Val.addl v1 (Vlong n)) + | Osubl, v1::v2::nil => Some (Val.subl v1 v2) + | Omull, v1::v2::nil => Some (Val.mull v1 v2) + | Omullimm n, v1::nil => Some (Val.mull v1 (Vlong n)) + | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2) + | Omullhu, v1::v2::nil => Some (Val.mullhu v1 v2) + | Odivl, v1::v2::nil => Val.divls v1 v2 + | Odivlu, v1::v2::nil => Val.divlu v1 v2 + | Omodl, v1::v2::nil => Val.modls v1 v2 + | Omodlu, v1::v2::nil => Val.modlu v1 v2 + | Oandl, v1::v2::nil => Some(Val.andl v1 v2) + | Oandlimm n, v1::nil => Some (Val.andl v1 (Vlong n)) + | Oorl, v1::v2::nil => Some(Val.orl v1 v2) + | Oorlimm n, v1::nil => Some (Val.orl v1 (Vlong n)) + | Oxorl, v1::v2::nil => Some(Val.xorl v1 v2) + | Oxorlimm n, v1::nil => Some (Val.xorl v1 (Vlong n)) + | Onotl, v1::nil => Some(Val.notl v1) + | Oshll, v1::v2::nil => Some (Val.shll v1 v2) + | Oshllimm n, v1::nil => Some (Val.shll v1 (Vint n)) + | Oshrl, v1::v2::nil => Some (Val.shrl v1 v2) + | Oshrlimm n, v1::nil => Some (Val.shrl v1 (Vint n)) + | Oshrxlimm n, v1::nil => Val.shrxl v1 (Vint n) + | Oshrlu, v1::v2::nil => Some (Val.shrlu v1 v2) + | Oshrluimm n, v1::nil => Some (Val.shrlu v1 (Vint n)) + | Ororlimm n, v1::nil => Some (Val.rorl v1 (Vint n)) + | Oleal addr, _ => eval_addressing64 genv sp addr vl + | Onegf, v1::nil => Some(Val.negf v1) + | Oabsf, v1::nil => Some(Val.absf v1) + | Oaddf, v1::v2::nil => Some(Val.addf v1 v2) + | Osubf, v1::v2::nil => Some(Val.subf v1 v2) + | Omulf, v1::v2::nil => Some(Val.mulf v1 v2) + | Odivf, v1::v2::nil => Some(Val.divf v1 v2) + | Onegfs, v1::nil => Some(Val.negfs v1) + | Oabsfs, v1::nil => Some(Val.absfs v1) + | Oaddfs, v1::v2::nil => Some(Val.addfs v1 v2) + | Osubfs, v1::v2::nil => Some(Val.subfs v1 v2) + | Omulfs, v1::v2::nil => Some(Val.mulfs v1 v2) + | Odivfs, v1::v2::nil => Some(Val.divfs v1 v2) + | Osingleoffloat, v1::nil => Some(Val.singleoffloat v1) + | Ofloatofsingle, v1::nil => Some(Val.floatofsingle v1) + | Ointoffloat, v1::nil => Val.intoffloat v1 + | Ofloatofint, v1::nil => Val.floatofint v1 + | Ointofsingle, v1::nil => Val.intofsingle v1 + | Osingleofint, v1::nil => Val.singleofint v1 + | Olongoffloat, v1::nil => Val.longoffloat v1 + | Ofloatoflong, v1::nil => Val.floatoflong v1 + | Olongofsingle, v1::nil => Val.longofsingle v1 + | Osingleoflong, v1::nil => Val.singleoflong v1 + | Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m)) + | _, _ => None + end. + +Remark eval_addressing_Aglobal: + forall (F V: Type) (genv: Genv.t F V) sp id ofs, + eval_addressing genv sp (Aglobal id ofs) nil = Some (Genv.symbol_address genv id ofs). +Proof. + intros. unfold eval_addressing, eval_addressing32, eval_addressing64; destruct Archi.ptr64; auto. +Qed. + +Remark eval_addressing_Ainstack: + forall (F V: Type) (genv: Genv.t F V) sp ofs, + eval_addressing genv sp (Ainstack ofs) nil = Some (Val.offset_ptr sp ofs). +Proof. + intros. unfold eval_addressing, eval_addressing32, eval_addressing64; destruct Archi.ptr64; auto. +Qed. + +Remark eval_addressing_Ainstack_inv: + forall (F V: Type) (genv: Genv.t F V) sp ofs vl v, + eval_addressing genv sp (Ainstack ofs) vl = Some v -> vl = nil /\ v = Val.offset_ptr sp ofs. +Proof. + unfold eval_addressing, eval_addressing32, eval_addressing64; + intros; destruct Archi.ptr64; destruct vl; inv H; auto. +Qed. + +Ltac FuncInv := + match goal with + | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => + destruct x; simpl in H; FuncInv + | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ => + destruct v; simpl in H; FuncInv + | H: (if Archi.ptr64 then _ else _) = Some _ |- _ => + destruct Archi.ptr64 eqn:?; FuncInv + | H: (Some _ = Some _) |- _ => + injection H; intros; clear H; FuncInv + | H: (None = Some _) |- _ => + discriminate H + | _ => + idtac + end. + +(** * 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 + | Ccompl _ => Tlong :: Tlong :: nil + | Ccomplu _ => Tlong :: Tlong :: nil + | Ccomplimm _ _ => Tlong :: nil + | Ccompluimm _ _ => Tlong :: nil + | Ccompf _ => Tfloat :: Tfloat :: nil + | Cnotcompf _ => Tfloat :: Tfloat :: nil + | Ccompfs _ => Tsingle :: Tsingle :: nil + | Cnotcompfs _ => Tsingle :: Tsingle :: nil + | Cmaskzero _ => Tint :: nil + | Cmasknotzero _ => Tint :: nil + end. + +Definition type_of_addressing_gen (tyA: typ) (addr: addressing): list typ := + match addr with + | Aindexed _ => tyA :: nil + | Aindexed2 _ => tyA :: tyA :: nil + | Ascaled _ _ => tyA :: nil + | Aindexed2scaled _ _ => tyA :: tyA :: nil + | Aglobal _ _ => nil + | Abased _ _ => tyA :: nil + | Abasedscaled _ _ _ => tyA :: nil + | Ainstack _ => nil + end. + +Definition type_of_addressing := type_of_addressing_gen Tptr. +Definition type_of_addressing32 := type_of_addressing_gen Tint. +Definition type_of_addressing64 := type_of_addressing_gen Tlong. + +Definition type_of_operation (op: operation) : list typ * typ := + match op with + | Omove => (nil, Tint) (* treated specially *) + | Ointconst _ => (nil, Tint) + | Olongconst _ => (nil, Tlong) + | Ofloatconst f => (nil, Tfloat) + | Osingleconst f => (nil, Tsingle) + | Oindirectsymbol _ => (nil, Tptr) + | Ocast8signed => (Tint :: nil, Tint) + | Ocast8unsigned => (Tint :: nil, Tint) + | Ocast16signed => (Tint :: nil, Tint) + | Ocast16unsigned => (Tint :: nil, Tint) + | Oneg => (Tint :: nil, Tint) + | Osub => (Tint :: Tint :: nil, Tint) + | Omul => (Tint :: Tint :: nil, Tint) + | Omulimm _ => (Tint :: nil, Tint) + | Omulhs => (Tint :: Tint :: nil, Tint) + | Omulhu => (Tint :: Tint :: nil, Tint) + | Odiv => (Tint :: Tint :: nil, Tint) + | Odivu => (Tint :: Tint :: nil, Tint) + | Omod => (Tint :: Tint :: nil, Tint) + | Omodu => (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) + | Onot => (Tint :: nil, Tint) + | Oshl => (Tint :: Tint :: nil, Tint) + | Oshlimm _ => (Tint :: nil, Tint) + | Oshr => (Tint :: Tint :: nil, Tint) + | Oshrimm _ => (Tint :: nil, Tint) + | Oshrximm _ => (Tint :: nil, Tint) + | Oshru => (Tint :: Tint :: nil, Tint) + | Oshruimm _ => (Tint :: nil, Tint) + | Ororimm _ => (Tint :: nil, Tint) + | Oshldimm _ => (Tint :: Tint :: nil, Tint) + | Olea addr => (type_of_addressing32 addr, Tint) + | Omakelong => (Tint :: Tint :: nil, Tlong) + | Olowlong => (Tlong :: nil, Tint) + | Ohighlong => (Tlong :: nil, Tint) + | Ocast32signed => (Tint :: nil, Tlong) + | Ocast32unsigned => (Tint :: nil, Tlong) + | Onegl => (Tlong :: nil, Tlong) + | Oaddlimm _ => (Tlong :: nil, Tlong) + | Osubl => (Tlong :: Tlong :: nil, Tlong) + | Omull => (Tlong :: Tlong :: nil, Tlong) + | Omullimm _ => (Tlong :: nil, Tlong) + | Omullhs => (Tlong :: Tlong :: nil, Tlong) + | Omullhu => (Tlong :: Tlong :: nil, Tlong) + | Odivl => (Tlong :: Tlong :: nil, Tlong) + | Odivlu => (Tlong :: Tlong :: nil, Tlong) + | Omodl => (Tlong :: Tlong :: nil, Tlong) + | Omodlu => (Tlong :: Tlong :: nil, Tlong) + | Oandl => (Tlong :: Tlong :: nil, Tlong) + | Oandlimm _ => (Tlong :: nil, Tlong) + | Oorl => (Tlong :: Tlong :: nil, Tlong) + | Oorlimm _ => (Tlong :: nil, Tlong) + | Oxorl => (Tlong :: Tlong :: nil, Tlong) + | Oxorlimm _ => (Tlong :: nil, Tlong) + | Onotl => (Tlong :: nil, Tlong) + | Oshll => (Tlong :: Tint :: nil, Tlong) + | Oshllimm _ => (Tlong :: nil, Tlong) + | Oshrl => (Tlong :: Tint :: nil, Tlong) + | Oshrlimm _ => (Tlong :: nil, Tlong) + | Oshrxlimm _ => (Tlong :: nil, Tlong) + | Oshrlu => (Tlong :: Tint :: nil, Tlong) + | Oshrluimm _ => (Tlong :: nil, Tlong) + | Ororlimm _ => (Tlong :: nil, Tlong) + | Oleal addr => (type_of_addressing64 addr, Tlong) + | 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) + | Onegfs => (Tsingle :: nil, Tsingle) + | Oabsfs => (Tsingle :: nil, Tsingle) + | Oaddfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Osubfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Omulfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Odivfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Osingleoffloat => (Tfloat :: nil, Tsingle) + | Ofloatofsingle => (Tsingle :: nil, Tfloat) + | Ointoffloat => (Tfloat :: nil, Tint) + | Ofloatofint => (Tint :: nil, Tfloat) + | Ointofsingle => (Tsingle :: nil, Tint) + | Osingleofint => (Tint :: nil, Tsingle) + | Olongoffloat => (Tfloat :: nil, Tlong) + | Ofloatoflong => (Tlong :: nil, Tfloat) + | Olongofsingle => (Tsingle :: nil, Tlong) + | Osingleoflong => (Tlong :: nil, Tsingle) + | Ocmp c => (type_of_condition c, Tint) + 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 V: Type. +Variable genv: Genv.t A V. + +Remark type_add: + forall v1 v2, Val.has_type (Val.add v1 v2) Tint. +Proof. + intros. unfold Val.has_type, Val.add. destruct Archi.ptr64, v1, v2; auto. +Qed. + +Remark type_addl: + forall v1 v2, Val.has_type (Val.addl v1 v2) Tlong. +Proof. + intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto. +Qed. + +Lemma type_of_addressing64_sound: + forall addr vl sp v, + eval_addressing64 genv sp addr vl = Some v -> + Val.has_type v Tlong. +Proof. + intros. destruct addr; simpl in H; FuncInv; subst; simpl; auto using type_addl. +- unfold Genv.symbol_address; destruct (Genv.find_symbol genv i); simpl; auto. +- destruct sp; simpl; auto. +Qed. + +Lemma type_of_addressing32_sound: + forall addr vl sp v, + eval_addressing32 genv sp addr vl = Some v -> + Val.has_type v Tint. +Proof. + intros. destruct addr; simpl in H; FuncInv; subst; simpl; auto using type_add. +- unfold Genv.symbol_address; destruct (Genv.find_symbol genv i); simpl; auto. +- destruct sp; simpl; auto. +Qed. + +Corollary type_of_addressing_sound: + forall addr vl sp v, + eval_addressing genv sp addr vl = Some v -> + Val.has_type v Tptr. +Proof. + unfold eval_addressing, Tptr; intros. + destruct Archi.ptr64; eauto using type_of_addressing64_sound, type_of_addressing32_sound. +Qed. + +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 with (try exact I; try reflexivity). + intros. + destruct op; simpl in H0; FuncInv; subst; simpl. + congruence. + exact I. + exact I. + exact I. + exact I. + unfold Genv.symbol_address; destruct (Genv.find_symbol genv id)... + destruct v0... + destruct v0... + destruct v0... + destruct v0... + destruct v0... + unfold Val.sub, Val.has_type; destruct Archi.ptr64, v0, v1... destruct (eq_block b b0)... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 31)); inv H0... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + destruct v0... + destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + destruct v1; simpl... destruct (Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize)... + eapply type_of_addressing32_sound; eauto. + destruct v0; destruct v1... + destruct v0... + destruct v0... + destruct v0... + destruct v0... + destruct v0... + unfold Val.addl, Val.has_type; destruct Archi.ptr64, v0... + unfold Val.subl, Val.has_type; destruct Archi.ptr64, v0, v1... destruct (eq_block b b0)... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int64.eq i0 Int64.zero); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int64.eq i0 Int64.zero); inv H2... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... + destruct v0; inv H0. destruct (Int.ltu n (Int.repr 63)); inv H2... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... + destruct v0... + eapply type_of_addressing64_sound; eauto. + destruct v0... + destruct v0... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0... + destruct v0... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0... + destruct v0... + destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... + destruct v0; simpl in H0; inv H0... + destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); inv H2... + destruct v0; simpl in H0; inv H0... + destruct v0; simpl in H0; inv H0. destruct (Float.to_long f); inv H2... + destruct v0; simpl in H0; inv H0... + destruct v0; simpl in H0; inv H0. destruct (Float32.to_long f); inv H2... + destruct v0; simpl in H0; inv H0... + destruct (eval_condition cond vl m); simpl... destruct b... +Qed. + +End SOUNDNESS. + +(** * Manipulating and transforming operations *) + +(** Recognition of move operations. *) + +Definition is_move_operation + (A: Type) (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: Type) (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. + +(** [negate_condition cond] returns a condition that is logically + equivalent to the negation of [cond]. *) + +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 + | Ccompl c => Ccompl(negate_comparison c) + | Ccomplu c => Ccomplu(negate_comparison c) + | Ccomplimm c n => Ccomplimm (negate_comparison c) n + | Ccompluimm c n => Ccompluimm (negate_comparison c) n + | Ccompf c => Cnotcompf c + | Cnotcompf c => Ccompf c + | Ccompfs c => Cnotcompfs c + | Cnotcompfs c => Ccompfs c + | Cmaskzero n => Cmasknotzero n + | Cmasknotzero n => Cmaskzero n + end. + +Lemma eval_negate_condition: + forall cond vl m, + eval_condition (negate_condition cond) vl m = option_map negb (eval_condition cond vl m). +Proof. + intros. destruct cond; simpl. + repeat (destruct vl; auto). apply Val.negate_cmp_bool. + repeat (destruct vl; auto). apply Val.negate_cmpu_bool. + repeat (destruct vl; auto). apply Val.negate_cmp_bool. + repeat (destruct vl; auto). apply Val.negate_cmpu_bool. + repeat (destruct vl; auto). apply Val.negate_cmpl_bool. + repeat (destruct vl; auto). apply Val.negate_cmplu_bool. + repeat (destruct vl; auto). apply Val.negate_cmpl_bool. + repeat (destruct vl; auto). apply Val.negate_cmplu_bool. + repeat (destruct vl; auto). + repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0) as [[]|]; auto. + repeat (destruct vl; auto). + repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto. + destruct vl; auto. destruct vl; auto. + destruct vl; auto. destruct vl; auto. destruct (Val.maskzero_bool v n) as [[]|]; auto. +Qed. + +(** Shifting stack-relative references. This is used in [Stacking]. *) + +Definition shift_stack_addressing (delta: Z) (addr: addressing) := + match addr with + | Ainstack ofs => Ainstack (Ptrofs.add ofs (Ptrofs.repr delta)) + | _ => addr + end. + +Definition shift_stack_operation (delta: Z) (op: operation) := + match op with + | Olea addr => Olea (shift_stack_addressing delta addr) + | Oleal addr => Oleal (shift_stack_addressing delta addr) + | _ => op + end. + +Lemma type_shift_stack_addressing: + forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. +Proof. + intros. destruct addr; auto. +Qed. + +Lemma type_shift_stack_operation: + forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. +Proof. + intros. destruct op; auto; simpl; decEq; destruct a; auto. +Qed. + +Lemma eval_shift_stack_addressing32: + forall F V (ge: Genv.t F V) sp addr vl delta, + eval_addressing32 ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl = + eval_addressing32 ge (Vptr sp (Ptrofs.repr delta)) addr vl. +Proof. + intros. + assert (A: forall i, Ptrofs.add Ptrofs.zero (Ptrofs.add i (Ptrofs.repr delta)) = Ptrofs.add (Ptrofs.repr delta) i). + { intros. rewrite Ptrofs.add_zero_l. apply Ptrofs.add_commut. } + destruct addr; simpl; rewrite ?A; reflexivity. +Qed. + +Lemma eval_shift_stack_addressing64: + forall F V (ge: Genv.t F V) sp addr vl delta, + eval_addressing64 ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl = + eval_addressing64 ge (Vptr sp (Ptrofs.repr delta)) addr vl. +Proof. + intros. + assert (A: forall i, Ptrofs.add Ptrofs.zero (Ptrofs.add i (Ptrofs.repr delta)) = Ptrofs.add (Ptrofs.repr delta) i). + { intros. rewrite Ptrofs.add_zero_l. apply Ptrofs.add_commut. } + destruct addr; simpl; rewrite ?A; reflexivity. +Qed. + +Lemma eval_shift_stack_addressing: + forall F V (ge: Genv.t F V) sp addr vl delta, + eval_addressing ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl = + eval_addressing ge (Vptr sp (Ptrofs.repr delta)) addr vl. +Proof. + intros. unfold eval_addressing. + destruct Archi.ptr64; auto using eval_shift_stack_addressing32, eval_shift_stack_addressing64. +Qed. + +Lemma eval_shift_stack_operation: + forall F V (ge: Genv.t F V) sp op vl m delta, + eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m = + eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m. +Proof. + intros. destruct op; simpl; auto using eval_shift_stack_addressing32, eval_shift_stack_addressing64. +Qed. + +(** Offset an addressing mode [addr] by a quantity [delta], so that + it designates the pointer [delta] bytes past the pointer designated + by [addr]. This may be undefined if an offset overflows, in which case + [None] is returned. *) + +Definition offset_addressing_total (addr: addressing) (delta: Z) : addressing := + match addr with + | Aindexed n => Aindexed (n + delta) + | Aindexed2 n => Aindexed2 (n + delta) + | Ascaled sc n => Ascaled sc (n + delta) + | Aindexed2scaled sc n => Aindexed2scaled sc (n + delta) + | Aglobal s n => Aglobal s (Ptrofs.add n (Ptrofs.repr delta)) + | Abased s n => Abased s (Ptrofs.add n (Ptrofs.repr delta)) + | Abasedscaled sc s n => Abasedscaled sc s (Ptrofs.add n (Ptrofs.repr delta)) + | Ainstack n => Ainstack (Ptrofs.add n (Ptrofs.repr delta)) + end. + +Definition offset_addressing (addr: addressing) (delta: Z) : option addressing := + let addr' := offset_addressing_total addr delta in + if addressing_valid addr' then Some addr' else None. + +Lemma eval_offset_addressing_total_32: + forall (F V: Type) (ge: Genv.t F V) sp addr args delta v, + eval_addressing32 ge sp addr args = Some v -> + eval_addressing32 ge sp (offset_addressing_total addr delta) args = Some(Val.add v (Vint (Int.repr delta))). +Proof. + assert (A: forall x y, Int.add (Int.repr x) (Int.repr y) = Int.repr (x + y)). + { intros. apply Int.eqm_samerepr; auto with ints. } + assert (B: forall delta, Archi.ptr64 = false -> Ptrofs.repr delta = Ptrofs.of_int (Int.repr delta)). + { intros; symmetry; auto with ptrofs. } + intros. destruct addr; simpl in *; FuncInv; subst; simpl. +- rewrite <- A, ! Val.add_assoc; auto. +- rewrite <- A, ! Val.add_assoc; auto. +- rewrite <- A, ! Val.add_assoc; auto. +- rewrite <- A, ! Val.add_assoc; auto. +- rewrite B, Genv.shift_symbol_address_32 by auto. auto. +- rewrite B, Genv.shift_symbol_address_32 by auto. rewrite ! Val.add_assoc. do 2 f_equal. apply Val.add_commut. +- rewrite B, Genv.shift_symbol_address_32 by auto. rewrite ! Val.add_assoc. do 2 f_equal. apply Val.add_commut. +- destruct sp; simpl; auto. rewrite Heqb. rewrite Ptrofs.add_assoc. do 4 f_equal. symmetry; auto with ptrofs. +Qed. + +Lemma eval_offset_addressing_total_64: + forall (F V: Type) (ge: Genv.t F V) sp addr args delta v, + eval_addressing64 ge sp addr args = Some v -> + eval_addressing64 ge sp (offset_addressing_total addr delta) args = Some(Val.addl v (Vlong (Int64.repr delta))). +Proof. + assert (A: forall x y, Int64.add (Int64.repr x) (Int64.repr y) = Int64.repr (x + y)). + { intros. apply Int64.eqm_samerepr; auto with ints. } + assert (B: forall delta, Archi.ptr64 = true -> Ptrofs.repr delta = Ptrofs.of_int64 (Int64.repr delta)). + { intros; symmetry; auto with ptrofs. } + intros. destruct addr; simpl in *; FuncInv; subst; simpl. +- rewrite <- A, ! Val.addl_assoc; auto. +- rewrite <- A, ! Val.addl_assoc; auto. +- rewrite <- A, ! Val.addl_assoc; auto. +- rewrite <- A, ! Val.addl_assoc; auto. +- rewrite B, Genv.shift_symbol_address_64 by auto. auto. +- destruct sp; simpl; auto. rewrite Heqb. rewrite Ptrofs.add_assoc. do 4 f_equal. symmetry; auto with ptrofs. +Qed. + +(** The following lemma is used only in [Allocproof] in cases where [Archi.ptr64 = false]. *) + +Lemma eval_offset_addressing: + forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v, + offset_addressing addr delta = Some addr' -> + eval_addressing ge sp addr args = Some v -> + Archi.ptr64 = false -> + eval_addressing ge sp addr' args = Some(Val.add v (Vint (Int.repr delta))). +Proof. + intros. unfold offset_addressing in H. destruct (addressing_valid (offset_addressing_total addr delta)); inv H. + unfold eval_addressing in *; rewrite H1 in *. apply eval_offset_addressing_total_32; auto. +Qed. + +(** Operations that are so cheap to recompute that CSE should not factor them out. *) + +Definition is_trivial_op (op: operation) : bool := + match op with + | Omove => true + | Ointconst _ => true + | Olongconst _ => true + | Olea (Aglobal _ _) => true + | Olea (Ainstack _) => true + | Oleal (Aglobal _ _) => true + | Oleal (Ainstack _) => true + | _ => false + end. + +(** Operations that depend on the memory state. *) + +Definition op_depends_on_memory (op: operation) : bool := + match op with + | Ocmp (Ccompu _) => negb Archi.ptr64 + | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 + | Ocmp (Ccomplu _) => Archi.ptr64 + | Ocmp (Ccompluimm _ _) => Archi.ptr64 + | _ => false + end. + +Lemma op_depends_on_memory_correct: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + op_depends_on_memory op = false -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. +Proof. + intros until m2. destruct op; simpl; try congruence. + destruct cond; simpl; intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. +Qed. + +(** Global variables mentioned in an operation or addressing mode *) + +Definition globals_addressing (addr: addressing) : list ident := + match addr with + | Aglobal s n => s :: nil + | Abased s n => s :: nil + | Abasedscaled sc s n => s :: nil + | _ => nil + end. + +Definition globals_operation (op: operation) : list ident := + match op with + | Oindirectsymbol s => s :: nil + | Olea addr => globals_addressing addr + | Oleal addr => globals_addressing addr + | _ => nil + end. + +(** * Invariance and compatibility properties. *) + +(** [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 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. +Hypothesis agree_on_symbols: + forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. + +Lemma eval_addressing32_preserved: + forall sp addr vl, + eval_addressing32 ge2 sp addr vl = eval_addressing32 ge1 sp addr vl. +Proof. + intros. + unfold eval_addressing32, Genv.symbol_address; destruct addr; try rewrite agree_on_symbols; + reflexivity. +Qed. + +Lemma eval_addressing64_preserved: + forall sp addr vl, + eval_addressing64 ge2 sp addr vl = eval_addressing64 ge1 sp addr vl. +Proof. + intros. + unfold eval_addressing64, Genv.symbol_address; destruct addr; 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 Archi.ptr64; auto using eval_addressing32_preserved, eval_addressing64_preserved. +Qed. + +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; auto using eval_addressing32_preserved, eval_addressing64_preserved. + unfold Genv.symbol_address. rewrite agree_on_symbols. auto. +Qed. + +End GENV_TRANSF. + +(** Compatibility of the evaluation functions with value injections. *) + +Section EVAL_COMPAT. + +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. +Variable f: meminj. + +Variable m1: mem. +Variable m2: mem. + +Hypothesis valid_pointer_inj: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. + +Hypothesis weak_valid_pointer_inj: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. + +Hypothesis weak_valid_pointer_no_overflow: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. + +Hypothesis valid_different_pointers_inj: + forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). + +Ltac InvInject := + match goal with + | [ H: Val.inject _ (Vint _) _ |- _ ] => + inv H; InvInject + | [ H: Val.inject _ (Vfloat _) _ |- _ ] => + inv H; InvInject + | [ H: Val.inject _ (Vptr _ _) _ |- _ ] => + inv H; InvInject + | [ H: Val.inject_list _ nil _ |- _ ] => + inv H; InvInject + | [ H: Val.inject_list _ (_ :: _) _ |- _ ] => + inv H; InvInject + | _ => idtac + end. + +Lemma eval_condition_inj: + forall cond vl1 vl2 b, + Val.inject_list f vl1 vl2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. +- inv H3; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. +- inv H3; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; try discriminate; auto. +- inv H3; try discriminate; auto. +Qed. + +Ltac TrivialExists := + match goal with + | [ |- exists v2, Some ?v1 = Some v2 /\ Val.inject _ _ v2 ] => + exists v1; split; auto + | _ => idtac + end. + +Lemma eval_addressing32_inj: + forall addr sp1 vl1 sp2 vl2 v1, + (forall id ofs, + In id (globals_addressing addr) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_addressing32 ge1 sp1 addr vl1 = Some v1 -> + exists v2, eval_addressing32 ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. +Proof. + assert (A: forall v1 v2 v1' v2', Val.inject f v1 v1' -> Val.inject f v2 v2' -> Val.inject f (Val.mul v1 v2) (Val.mul v1' v2')). + { intros. inv H; simpl; auto. inv H0; auto. } + intros. destruct addr; simpl in *; FuncInv; InvInject; TrivialExists; eauto using Val.add_inject, Val.offset_ptr_inject with coqlib. +Qed. + +Lemma eval_addressing64_inj: + forall addr sp1 vl1 sp2 vl2 v1, + (forall id ofs, + In id (globals_addressing addr) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_addressing64 ge1 sp1 addr vl1 = Some v1 -> + exists v2, eval_addressing64 ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. +Proof. + assert (A: forall v1 v2 v1' v2', Val.inject f v1 v1' -> Val.inject f v2 v2' -> Val.inject f (Val.mull v1 v2) (Val.mull v1' v2')). + { intros. inv H; simpl; auto. inv H0; auto. } + intros. destruct addr; simpl in *; FuncInv; InvInject; TrivialExists; eauto using Val.addl_inject, Val.offset_ptr_inject with coqlib. +Qed. + +Lemma eval_addressing_inj: + forall addr sp1 vl1 sp2 vl2 v1, + (forall id ofs, + In id (globals_addressing addr) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_addressing ge1 sp1 addr vl1 = Some v1 -> + exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. +Proof. + unfold eval_addressing; intros. destruct Archi.ptr64; eauto using eval_addressing32_inj, eval_addressing64_inj. +Qed. + +Lemma eval_operation_inj: + forall op sp1 vl1 sp2 vl2 v1, + (forall id ofs, + In id (globals_operation op) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_operation ge1 sp1 op vl1 m1 = Some v1 -> + exists v2, eval_operation ge2 sp2 op vl2 m2 = Some v2 /\ Val.inject f v1 v2. +Proof. + intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + apply GL; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + apply Val.sub_inject; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + inv H4; simpl in H1; try discriminate. simpl. + destruct (Int.ltu n (Int.repr 31)); inv H1. TrivialExists. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + inv H4; simpl; auto. + inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + inv H2; simpl; auto. destruct (Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize); auto. + eapply eval_addressing32_inj; eauto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + apply Val.addl_inject; auto. + apply Val.subl_inject; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. + inv H4; simpl in H1; try discriminate. simpl. destruct (Int.ltu n (Int.repr 63)); inv H1. TrivialExists. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. + inv H4; simpl; auto. + eapply eval_addressing64_inj; eauto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2. + exists (Vint i); auto. + inv H4; simpl in H1; inv H1. simpl. TrivialExists. + inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2. + exists (Vint i); auto. + inv H4; simpl in H1; inv H1. simpl. TrivialExists. + inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_long f0); simpl in H2; inv H2. + exists (Vlong i); auto. + inv H4; simpl in H1; inv H1. simpl. TrivialExists. + inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_long f0); simpl in H2; inv H2. + exists (Vlong i); auto. + inv H4; simpl in H1; inv H1. simpl. TrivialExists. + subst v1. destruct (eval_condition cond vl1 m1) eqn:?. + exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. + destruct b; simpl; constructor. + simpl; constructor. +Qed. + +End EVAL_COMPAT. + +(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) + +Section EVAL_LESSDEF. + +Variable F V: Type. +Variable genv: Genv.t F V. + +Remark valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.valid_pointer_extends; eauto. +Qed. + +Remark weak_valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. +Qed. + +Remark weak_valid_pointer_no_overflow_extends: + forall m1 b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. +Proof. + intros. inv H. rewrite Zplus_0_r. apply Ptrofs.unsigned_range_2. +Qed. + +Remark valid_different_pointers_extends: + forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> + Some(b1, 0) = Some (b1', delta1) -> + Some(b2, 0) = Some (b2', delta2) -> + b1' <> b2' \/ + Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)). +Proof. + intros. inv H2; inv H3. auto. +Qed. + +Lemma eval_condition_lessdef: + forall cond vl1 vl2 b m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1). + apply valid_pointer_extends; auto. + apply weak_valid_pointer_extends; auto. + apply weak_valid_pointer_no_overflow_extends. + apply valid_different_pointers_extends; auto. + rewrite <- val_inject_list_lessdef. eauto. auto. +Qed. + +Lemma eval_operation_lessdef: + forall sp op vl1 vl2 v1 m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + 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. rewrite val_inject_list_lessdef in H. + assert (exists v2 : val, + eval_operation genv sp op vl2 m2 = Some v2 + /\ Val.inject (fun b => Some(b, 0)) v1 v2). + eapply eval_operation_inj with (m1 := m1) (sp1 := sp). + apply valid_pointer_extends; auto. + apply weak_valid_pointer_extends; auto. + apply weak_valid_pointer_no_overflow_extends. + apply valid_different_pointers_extends; auto. + intros. apply val_inject_lessdef. auto. + apply val_inject_lessdef; auto. + eauto. + auto. + destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +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. rewrite val_inject_list_lessdef in H. + assert (exists v2 : val, + eval_addressing genv sp addr vl2 = Some v2 + /\ Val.inject (fun b => Some(b, 0)) v1 v2). + eapply eval_addressing_inj with (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + +End EVAL_LESSDEF. + +(** Compatibility of the evaluation functions with memory injections. *) + +Section EVAL_INJECT. + +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. +Hypothesis globals: meminj_preserves_globals genv f. +Variable sp1: block. +Variable sp2: block. +Variable delta: Z. +Hypothesis sp_inj: f sp1 = Some(sp2, delta). + +Remark symbol_address_inject: + forall id ofs, Val.inject f (Genv.symbol_address genv id ofs) (Genv.symbol_address genv id ofs). +Proof. + intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto. + exploit (proj1 globals); eauto. intros. + econstructor; eauto. rewrite Ptrofs.add_zero; auto. +Qed. + +Lemma eval_condition_inject: + forall cond vl1 vl2 b m1 m2, + Val.inject_list f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. +Qed. + +Lemma eval_addressing_inject: + forall addr vl1 vl2 v1, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 -> + exists v2, + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = Some v2 + /\ Val.inject f v1 v2. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + +Lemma eval_operation_inject: + forall op vl1 vl2 v1 m1 m2, + Val.inject_list f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 -> + exists v2, + eval_operation genv (Vptr sp2 Ptrofs.zero) (shift_stack_operation delta op) vl2 m2 = Some v2 + /\ Val.inject f v1 v2. +Proof. + intros. + rewrite eval_shift_stack_operation. simpl. + eapply eval_operation_inj with (sp1 := Vptr sp1 Ptrofs.zero) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + +End EVAL_INJECT. diff --git a/ia32/PrintOp.ml b/x86/PrintOp.ml index 2a80e3d4..faa5bb5f 100644 --- a/ia32/PrintOp.ml +++ b/x86/PrintOp.ml @@ -33,7 +33,15 @@ let print_condition reg pp = function | (Ccompimm(c, n), [r1]) -> fprintf pp "%a %ss %ld" reg r1 (comparison_name c) (camlint_of_coqint n) | (Ccompuimm(c, n), [r1]) -> - fprintf pp "%a %su %ld" reg r1 (comparison_name c) (camlint_of_coqint n) + fprintf pp "%a %su %lu" reg r1 (comparison_name c) (camlint_of_coqint n) + | (Ccompl c, [r1;r2]) -> + fprintf pp "%a %sls %a" reg r1 (comparison_name c) reg r2 + | (Ccomplu c, [r1;r2]) -> + fprintf pp "%a %slu %a" reg r1 (comparison_name c) reg r2 + | (Ccomplimm(c, n), [r1]) -> + fprintf pp "%a %sls %Ld" reg r1 (comparison_name c) (camlint64_of_coqint n) + | (Ccompluimm(c, n), [r1]) -> + fprintf pp "%a %slu %Lu" reg r1 (comparison_name c) (camlint64_of_coqint n) | (Ccompf c, [r1;r2]) -> fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2 | (Cnotcompf c, [r1;r2]) -> @@ -51,22 +59,23 @@ let print_condition reg pp = function let print_addressing reg pp = function | Aindexed n, [r1] -> - fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) + fprintf pp "%a + %s" reg r1 (Z.to_string n) | Aindexed2 n, [r1; r2] -> - fprintf pp "%a + %a + %ld" reg r1 reg r2 (camlint_of_coqint n) + fprintf pp "%a + %a + %s" reg r1 reg r2 (Z.to_string n) | Ascaled(sc,n), [r1] -> - fprintf pp "%a * %ld + %ld" reg r1 (camlint_of_coqint sc) (camlint_of_coqint n) + fprintf pp "%a * %s + %s" reg r1 (Z.to_string sc) (Z.to_string n) | Aindexed2scaled(sc, n), [r1; r2] -> - fprintf pp "%a + %a * %ld + %ld" reg r1 reg r2 (camlint_of_coqint sc) (camlint_of_coqint n) - | Aglobal(id, ofs), [] -> fprintf pp "%s + %ld" (extern_atom id) (camlint_of_coqint ofs) - | Abased(id, ofs), [r1] -> fprintf pp "%s + %ld + %a" (extern_atom id) (camlint_of_coqint ofs) reg r1 - | Abasedscaled(sc,id, ofs), [r1] -> fprintf pp "%s + %ld + %a * %ld" (extern_atom id) (camlint_of_coqint ofs) reg r1 (camlint_of_coqint sc) - | Ainstack ofs, [] -> fprintf pp "stack(%ld)" (camlint_of_coqint ofs) + fprintf pp "%a + %a * %s + %s" reg r1 reg r2 (Z.to_string sc) (Z.to_string n) + | Aglobal(id, ofs), [] -> fprintf pp "%s + %s" (extern_atom id) (Z.to_string ofs) + | Abased(id, ofs), [r1] -> fprintf pp "%s + %s + %a" (extern_atom id) (Z.to_string ofs) reg r1 + | Abasedscaled(sc,id, ofs), [r1] -> fprintf pp "%s + %s + %a * %ld" (extern_atom id) (Z.to_string ofs) reg r1 (camlint_of_coqint sc) + | Ainstack ofs, [] -> fprintf pp "stack(%s)" (Z.to_string ofs) | _ -> fprintf pp "<bad addressing>" let print_operation reg pp = function | Omove, [r1] -> reg pp r1 | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) + | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n) | Ofloatconst n, [] -> fprintf pp "%.15F" (camlfloat_of_coqfloat n) | Osingleconst n, [] -> fprintf pp "%.15Ff" (camlfloat_of_coqfloat32 n) | Oindirectsymbol id, [] -> fprintf pp "&%s" (extern_atom id) @@ -78,6 +87,8 @@ let print_operation reg pp = function | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2 | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2 | Omulimm n, [r1] -> fprintf pp "%a * %ld" reg r1 (camlint_of_coqint n) + | Omulhs, [r1;r2] -> fprintf pp "mulhs(%a,%a)" reg r1 reg r2 + | Omulhu, [r1;r2] -> fprintf pp "mulhu(%a,%a)" reg r1 reg r2 | Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2 | Odivu, [r1;r2] -> fprintf pp "%a /u %a" reg r1 reg r2 | Omod, [r1;r2] -> fprintf pp "%a %%s %a" reg r1 reg r2 @@ -88,6 +99,7 @@ let print_operation reg pp = function | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n) | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2 | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n) + | Onot, [r1] -> fprintf pp "not(%a)" reg r1 | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2 | Oshlimm n, [r1] -> fprintf pp "%a << %ld" reg r1 (camlint_of_coqint n) | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2 @@ -97,7 +109,38 @@ let print_operation reg pp = function | Oshruimm n, [r1] -> fprintf pp "%a >>u %ld" reg r1 (camlint_of_coqint n) | Ororimm n, [r1] -> fprintf pp "%a ror %ld" reg r1 (camlint_of_coqint n) | Oshldimm n, [r1;r2] -> fprintf pp "(%a, %a) << %ld" reg r1 reg r2 (camlint_of_coqint n) - | Olea addr, args -> print_addressing reg pp (addr, args) + | Olea addr, args -> print_addressing reg pp (addr, args); fprintf pp " (int)" + | Omakelong, [r1;r2] -> fprintf pp "makelong(%a,%a)" reg r1 reg r2 + | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1 + | Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1 + | Ocast32signed, [r1] -> fprintf pp "long32signed(%a)" reg r1 + | Ocast32unsigned, [r1] -> fprintf pp "long32unsigned(%a)" reg r1 + | Onegl, [r1] -> fprintf pp "(-l %a)" reg r1 + | Osubl, [r1;r2] -> fprintf pp "%a -l %a" reg r1 reg r2 + | Omull, [r1;r2] -> fprintf pp "%a *l %a" reg r1 reg r2 + | Omullimm n, [r1] -> fprintf pp "%a *l %Ld" reg r1 (camlint64_of_coqint n) + | Omullhs, [r1;r2] -> fprintf pp "mullhs(%a,%a)" reg r1 reg r2 + | Omullhu, [r1;r2] -> fprintf pp "mullhu(%a,%a)" reg r1 reg r2 + | Odivl, [r1;r2] -> fprintf pp "%a /ls %a" reg r1 reg r2 + | Odivlu, [r1;r2] -> fprintf pp "%a /lu %a" reg r1 reg r2 + | Omodl, [r1;r2] -> fprintf pp "%a %%ls %a" reg r1 reg r2 + | Omodlu, [r1;r2] -> fprintf pp "%a %%lu %a" reg r1 reg r2 + | Oandl, [r1;r2] -> fprintf pp "%a &l %a" reg r1 reg r2 + | Oandlimm n, [r1] -> fprintf pp "%a &l %Ld" reg r1 (camlint64_of_coqint n) + | Oorl, [r1;r2] -> fprintf pp "%a |l %a" reg r1 reg r2 + | Oorlimm n, [r1] -> fprintf pp "%a |l %Ld" reg r1 (camlint64_of_coqint n) + | Oxorl, [r1;r2] -> fprintf pp "%a ^l %a" reg r1 reg r2 + | Oxorlimm n, [r1] -> fprintf pp "%a ^l %Ld" reg r1 (camlint64_of_coqint n) + | Onotl, [r1] -> fprintf pp "notl(%a)" reg r1 + | Oshll, [r1;r2] -> fprintf pp "%a <<l %a" reg r1 reg r2 + | Oshllimm n, [r1] -> fprintf pp "%a <<l %ld" reg r1 (camlint_of_coqint n) + | Oshrl, [r1;r2] -> fprintf pp "%a >>ls %a" reg r1 reg r2 + | Oshrlimm n, [r1] -> fprintf pp "%a >>ls %ld" reg r1 (camlint_of_coqint n) + | Oshrxlimm n, [r1] -> fprintf pp "%a >>lx %ld" reg r1 (camlint_of_coqint n) + | Oshrlu, [r1;r2] -> fprintf pp "%a >>lu %a" reg r1 reg r2 + | Oshrluimm n, [r1] -> fprintf pp "%a >>lu %ld" reg r1 (camlint_of_coqint n) + | Ororlimm n, [r1] -> fprintf pp "%a rorl %ld" reg r1 (camlint_of_coqint n) + | Oleal addr, args -> print_addressing reg pp (addr, args); fprintf pp " (long)" | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1 | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1 | Oaddf, [r1;r2] -> fprintf pp "%a +f %a" reg r1 reg r2 @@ -116,12 +159,10 @@ let print_operation reg pp = function | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1 | Ointofsingle, [r1] -> fprintf pp "intofsingle(%a)" reg r1 | Osingleofint, [r1] -> fprintf pp "singleofint(%a)" reg r1 - | Omakelong, [r1;r2] -> fprintf pp "makelong(%a,%a)" reg r1 reg r2 - | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1 - | Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1 - | Onot, [r1] -> fprintf pp "not(%a)" reg r1 - | Omulhs, [r1;r2] -> fprintf pp "mulhs(%a,%a)" reg r1 reg r2 - | Omulhu, [r1;r2] -> fprintf pp "mulhu(%a,%a)" reg r1 reg r2 + | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1 + | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1 + | Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1 + | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 | Ocmp c, args -> print_condition reg pp (c, args) | _ -> fprintf pp "<bad operator>" diff --git a/x86/SelectLong.vp b/x86/SelectLong.vp new file mode 100644 index 00000000..b213e23f --- /dev/null +++ b/x86/SelectLong.vp @@ -0,0 +1,347 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for 64-bit integer operations *) + +Require Import Coqlib. +Require Import Compopts. +Require Import AST Integers Floats. +Require Import Op CminorSel. +Require Import SelectOp SplitLong. + +Local Open Scope cminorsel_scope. +Local Open Scope string_scope. + +Section SELECT. + +Context {hf: helper_functions}. + +Definition longconst (n: int64) : expr := + if Archi.splitlong then SplitLong.longconst n else Eop (Olongconst n) Enil. + +Definition is_longconst (e: expr) := + if Archi.splitlong then SplitLong.is_longconst e else + match e with + | Eop (Olongconst n) Enil => Some n + | _ => None + end. + +Definition intoflong (e: expr) := + if Archi.splitlong then SplitLong.intoflong e else + match is_longconst e with + | Some n => Eop (Ointconst (Int.repr (Int64.unsigned n))) Enil + | None => Eop Olowlong (e ::: Enil) + end. + +Definition longofint (e: expr) := + if Archi.splitlong then SplitLong.longofint e else + match is_intconst e with + | Some n => longconst (Int64.repr (Int.signed n)) + | None => Eop Ocast32signed (e ::: Enil) + end. + +Definition longofintu (e: expr) := + if Archi.splitlong then SplitLong.longofintu e else + match is_intconst e with + | Some n => longconst (Int64.repr (Int.unsigned n)) + | None => Eop Ocast32unsigned (e ::: Enil) + end. + +Nondetfunction notl (e: expr) := + if Archi.splitlong then SplitLong.notl e else + match e with + | Eop (Olongconst n) Enil => longconst (Int64.not n) + | Eop Onotl (t1:::Enil) => t1 + | _ => Eop Onotl (e:::Enil) + end. + +Nondetfunction andlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then longconst Int64.zero else + if Int64.eq n1 Int64.mone then e2 else + match e2 with + | Eop (Olongconst n2) Enil => + longconst (Int64.and n1 n2) + | Eop (Oandlimm n2) (t2:::Enil) => + Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) + | _ => + Eop (Oandlimm n1) (e2:::Enil) + end. + +Nondetfunction andl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.andl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => andlimm n2 t1 + | _, _ => Eop Oandl (e1:::e2:::Enil) + end. + +Nondetfunction orlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + if Int64.eq n1 Int64.mone then longconst Int64.mone else + match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.or n1 n2) + | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorlimm n1) (e2:::Enil) + end. + +Nondetfunction orl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.orl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => orlimm n2 t1 + | Eop (Oshllimm n1) (t1:::Enil), Eop (Oshrluimm n2) (t2:::Enil) => + if Int.eq (Int.add n1 n2) Int64.iwordsize' && same_expr_pure t1 t2 + then Eop (Ororlimm n2) (t1:::Enil) + else Eop Oorl (e1:::e2:::Enil) + | Eop (Oshrluimm n2) (t2:::Enil), Eop (Oshllimm n1) (t1:::Enil) => + if Int.eq (Int.add n1 n2) Int64.iwordsize' && same_expr_pure t1 t2 + then Eop (Ororlimm n2) (t1:::Enil) + else Eop Oorl (e1:::e2:::Enil) + | _, _ => + Eop Oorl (e1:::e2:::Enil) + end. + +Nondetfunction xorlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + if Int64.eq n1 Int64.mone then notl e2 else + match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.xor n1 n2) + | Eop (Oxorlimm n2) (t2:::Enil) => Eop (Oxorlimm (Int64.xor n1 n2)) (t2:::Enil) + | Eop Onotl (t2:::Enil) => Eop (Oxorlimm (Int64.not n1)) (t2:::Enil) + | _ => Eop (Oxorlimm n1) (e2:::Enil) + end. + +Nondetfunction xorl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.xorl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => xorlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => xorlimm n2 t1 + | _, _ => Eop Oxorl (e1:::e2:::Enil) + end. + +Nondetfunction shllimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shllimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshll (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + Eop (Olongconst(Int64.shl' n1 n)) Enil + | Eop (Oshllimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshllimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshllimm n) (e1:::Enil) + | Eop (Oleal (Aindexed n1)) (t1:::Enil) => + if shift_is_scale n + then Eop (Oleal (Ascaled (Int64.unsigned (Int64.shl' Int64.one n)) + (Int64.unsigned (Int64.shl' (Int64.repr n1) n)))) (t1:::Enil) + else Eop (Oshllimm n) (e1:::Enil) + | _ => + if shift_is_scale n + then Eop (Oleal (Ascaled (Int64.unsigned (Int64.shl' Int64.one n)) 0)) (e1:::Enil) + else Eop (Oshllimm n) (e1:::Enil) + end. + +Nondetfunction shrluimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrluimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + Eop (Olongconst(Int64.shru' n1 n)) Enil + | Eop (Oshrluimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrluimm n) (e1:::Enil) + | _ => + Eop (Oshrluimm n) (e1:::Enil) + end. + +Nondetfunction shrlimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrlimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + Eop (Olongconst(Int64.shr' n1 n)) Enil + | Eop (Oshrlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrlimm n) (e1:::Enil) + | _ => + Eop (Oshrlimm n) (e1:::Enil) + end. + +Definition shll (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shll e1 e2 else + match is_intconst e2 with + | Some n2 => shllimm e1 n2 + | None => Eop Oshll (e1:::e2:::Enil) + end. + +Definition shrl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shrl e1 e2 else + match is_intconst e2 with + | Some n2 => shrlimm e1 n2 + | None => Eop Oshrl (e1:::e2:::Enil) + end. + +Definition shrlu (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shrlu e1 e2 else + match is_intconst e2 with + | Some n2 => shrluimm e1 n2 + | _ => Eop Oshrlu (e1:::e2:::Enil) + end. + +Nondetfunction addlimm (n: int64) (e: expr) := + if Int64.eq n Int64.zero then e else + match e with + | Eop (Olongconst m) Enil => longconst (Int64.add n m) + | Eop (Oleal addr) args => Eop (Oleal (offset_addressing_total addr (Int64.signed n))) args + | _ => Eop (Oleal (Aindexed (Int64.signed n))) (e ::: Enil) + end. + +Nondetfunction addl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.addl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => addlimm n2 t1 + | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) => + Eop (Oleal (Aindexed2 (n1 + n2))) (t1:::t2:::Enil) + | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Ascaled sc n2)) (t2:::Enil) => + Eop (Oleal (Aindexed2scaled sc (n1 + n2))) (t1:::t2:::Enil) + | Eop (Oleal (Ascaled sc n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) => + Eop (Oleal (Aindexed2scaled sc (n1 + n2))) (t2:::t1:::Enil) + | Eop (Oleal (Ascaled sc n)) (t1:::Enil), t2 => + Eop (Oleal (Aindexed2scaled sc n)) (t2:::t1:::Enil) + | t1, Eop (Oleal (Ascaled sc n)) (t2:::Enil) => + Eop (Oleal (Aindexed2scaled sc n)) (t1:::t2:::Enil) + | Eop (Oleal (Aindexed n)) (t1:::Enil), t2 => + Eop (Oleal (Aindexed2 n)) (t1:::t2:::Enil) + | t1, Eop (Oleal (Aindexed n)) (t2:::Enil) => + Eop (Oleal (Aindexed2 n)) (t1:::t2:::Enil) + | _, _ => + Eop (Oleal (Aindexed2 0)) (e1:::e2:::Enil) + end. + +Definition negl (e: expr) := + if Archi.splitlong then SplitLong.negl e else + match is_longconst e with + | Some n => longconst (Int64.neg n) + | None => Eop Onegl (e ::: Enil) + end. + +Nondetfunction subl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.subl e1 e2 else + match e1, e2 with + | t1, Eop (Olongconst n2) Enil => addlimm (Int64.neg n2) t1 + | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) => + addlimm (Int64.repr (n1 - n2)) (Eop Osubl (t1:::t2:::Enil)) + | Eop (Oleal (Aindexed n1)) (t1:::Enil), t2 => + addlimm (Int64.repr n1) (Eop Osubl (t1:::t2:::Enil)) + | t1, Eop (Oleal (Aindexed n2)) (t2:::Enil) => + addlimm (Int64.repr (- n2)) (Eop Osubl (t1:::t2:::Enil)) + | _, _ => + Eop Osubl (e1:::e2:::Enil) + end. + +Definition mullimm_base (n1: int64) (e2: expr) := + match Int64.one_bits' n1 with + | i :: nil => + shllimm e2 i + | i :: j :: nil => + Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j)) + | _ => + Eop (Omullimm n1) (e2:::Enil) + end. + +Nondetfunction mullimm (n1: int64) (e2: expr) := + if Archi.splitlong then SplitLong.mullimm n1 e2 + else if Int64.eq n1 Int64.zero then longconst Int64.zero + else if Int64.eq n1 Int64.one then e2 + else match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.mul n1 n2) + | Eop (Oleal (Aindexed n2)) (t2:::Enil) => addlimm (Int64.mul n1 (Int64.repr n2)) (mullimm_base n1 t2) + | _ => mullimm_base n1 e2 + end. + +Nondetfunction mull (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.mull e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => mullimm n1 t2 + | t1, Eop (Olongconst n2) Enil => mullimm n2 t1 + | _, _ => Eop Omull (e1:::e2:::Enil) + end. + +Definition mullhu (e1: expr) (n2: int64) := + if Archi.splitlong then SplitLong.mullhu e1 n2 else + Eop Omullhu (e1 ::: longconst n2 ::: Enil). + +Definition mullhs (e1: expr) (n2: int64) := + if Archi.splitlong then SplitLong.mullhs e1 n2 else + Eop Omullhs (e1 ::: longconst n2 ::: Enil). + +Definition shrxlimm (e: expr) (n: int) := + if Archi.splitlong then SplitLong.shrxlimm e n else + if Int.eq n Int.zero then e else Eop (Oshrxlimm n) (e ::: Enil). + +Definition divlu_base (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.divlu_base e1 e2 else Eop Odivlu (e1:::e2:::Enil). +Definition modlu_base (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.modlu_base e1 e2 else Eop Omodlu (e1:::e2:::Enil). +Definition divls_base (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.divls_base e1 e2 else Eop Odivl (e1:::e2:::Enil). +Definition modls_base (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.modls_base e1 e2 else Eop Omodl (e1:::e2:::Enil). + +Definition cmplu (c: comparison) (e1 e2: expr) := + if Archi.splitlong then SplitLong.cmplu c e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => + Eop (Ointconst (if Int64.cmpu c n1 n2 then Int.one else Int.zero)) Enil + | Some n1, None => Eop (Ocmp (Ccompluimm (swap_comparison c) n1)) (e2:::Enil) + | None, Some n2 => Eop (Ocmp (Ccompluimm c n2)) (e1:::Enil) + | None, None => Eop (Ocmp (Ccomplu c)) (e1:::e2:::Enil) + end. + +Definition cmpl (c: comparison) (e1 e2: expr) := + if Archi.splitlong then SplitLong.cmpl c e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => + Eop (Ointconst (if Int64.cmp c n1 n2 then Int.one else Int.zero)) Enil + | Some n1, None => Eop (Ocmp (Ccomplimm (swap_comparison c) n1)) (e2:::Enil) + | None, Some n2 => Eop (Ocmp (Ccomplimm c n2)) (e1:::Enil) + | None, None => Eop (Ocmp (Ccompl c)) (e1:::e2:::Enil) + end. + +Definition longoffloat (e: expr) := + if Archi.splitlong then SplitLong.longoffloat e else + Eop Olongoffloat (e:::Enil). + +Definition floatoflong (e: expr) := + if Archi.splitlong then SplitLong.floatoflong e else + Eop Ofloatoflong (e:::Enil). + +Definition longofsingle (e: expr) := + if Archi.splitlong then SplitLong.longofsingle e else + Eop Olongofsingle (e:::Enil). + +Definition singleoflong (e: expr) := + if Archi.splitlong then SplitLong.singleoflong e else + Eop Osingleoflong (e:::Enil). + +End SELECT. diff --git a/x86/SelectLongproof.v b/x86/SelectLongproof.v new file mode 100644 index 00000000..f7d5df10 --- /dev/null +++ b/x86/SelectLongproof.v @@ -0,0 +1,555 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness of instruction selection for 64-bit integer operations *) + +Require Import String Coqlib Maps Integers Floats Errors. +Require Archi. +Require Import AST Values Memory Globalenvs Events. +Require Import Cminor Op CminorSel. +Require Import SelectOp SelectOpproof SplitLong SplitLongproof. +Require Import SelectLong. + +Open Local Scope cminorsel_scope. +Open Local Scope string_scope. + +(** * Correctness of the instruction selection functions for 64-bit operators *) + +Section CMCONSTR. + +Variable prog: program. +Variable hf: helper_functions. +Hypothesis HELPERS: helper_functions_declared prog hf. +Let ge := Genv.globalenv prog. +Variable sp: val. +Variable e: env. +Variable m: mem. + +Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. + +Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := + forall le a x b y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. + +Definition partial_unary_constructor_sound (cstr: expr -> expr) (sem: val -> option val) : Prop := + forall le a x y, + eval_expr ge sp e m le a x -> + sem x = Some y -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef y v. + +Definition partial_binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> option val) : Prop := + forall le a x b y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + sem x y = Some z -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef z v. + +Theorem eval_longconst: + forall le n, eval_expr ge sp e m le (longconst n) (Vlong n). +Proof. + unfold longconst; intros; destruct Archi.splitlong. + apply SplitLongproof.eval_longconst. + EvalOp. +Qed. + +Lemma is_longconst_sound: + forall v a n le, + is_longconst a = Some n -> eval_expr ge sp e m le a v -> v = Vlong n. +Proof with (try discriminate). + intros. unfold is_longconst in *. destruct Archi.splitlong. + eapply SplitLongproof.is_longconst_sound; eauto. + assert (a = Eop (Olongconst n) Enil). + { destruct a... destruct o... destruct e0... congruence. } + subst a. InvEval. auto. +Qed. + +Theorem eval_intoflong: unary_constructor_sound intoflong Val.loword. +Proof. + unfold intoflong; destruct Archi.splitlong. apply SplitLongproof.eval_intoflong. + red; intros. destruct (is_longconst a) as [n|] eqn:C. +- TrivialExists. simpl. erewrite (is_longconst_sound x) by eauto. auto. +- TrivialExists. +Qed. + +Theorem eval_longofintu: unary_constructor_sound longofintu Val.longofintu. +Proof. + unfold longofintu; destruct Archi.splitlong. apply SplitLongproof.eval_longofintu. + red; intros. destruct (is_intconst a) as [n|] eqn:C. +- econstructor; split. apply eval_longconst. + exploit is_intconst_sound; eauto. intros; subst x. auto. +- TrivialExists. +Qed. + +Theorem eval_longofint: unary_constructor_sound longofint Val.longofint. +Proof. + unfold longofint; destruct Archi.splitlong. apply SplitLongproof.eval_longofint. + red; intros. destruct (is_intconst a) as [n|] eqn:C. +- econstructor; split. apply eval_longconst. + exploit is_intconst_sound; eauto. intros; subst x. auto. +- TrivialExists. +Qed. + +Theorem eval_notl: unary_constructor_sound notl Val.notl. +Proof. + unfold notl; destruct Archi.splitlong. apply SplitLongproof.eval_notl. + red; intros. destruct (notl_match a). +- InvEval. econstructor; split. apply eval_longconst. auto. +- InvEval. subst. exists v1; split; auto. destruct v1; simpl; auto. rewrite Int64.not_involutive; auto. +- TrivialExists. +Qed. + +Theorem eval_andlimm: forall n, unary_constructor_sound (andlimm n) (fun v => Val.andl v (Vlong n)). +Proof. + unfold andlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists (Vlong Int64.zero); split. apply eval_longconst. + subst. destruct x; simpl; auto. rewrite Int64.and_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone. + exists x; split. assumption. + subst. destruct x; simpl; auto. rewrite Int64.and_mone; auto. + destruct (andlimm_match a); InvEval; subst. +- econstructor; split. apply eval_longconst. simpl. rewrite Int64.and_commut; auto. +- TrivialExists. simpl. rewrite Val.andl_assoc. rewrite Int64.and_commut; auto. +- TrivialExists. +Qed. + +Theorem eval_andl: binary_constructor_sound andl Val.andl. +Proof. + unfold andl; destruct Archi.splitlong. apply SplitLongproof.eval_andl. + red; intros. destruct (andl_match a b). +- InvEval. rewrite Val.andl_commut. apply eval_andlimm; auto. +- InvEval. apply eval_andlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_orlimm: forall n, unary_constructor_sound (orlimm n) (fun v => Val.orl v (Vlong n)). +Proof. + unfold orlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.or_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone. + econstructor; split. apply eval_longconst. subst. destruct x; simpl; auto. rewrite Int64.or_mone; auto. + destruct (orlimm_match a); InvEval; subst. +- econstructor; split. apply eval_longconst. simpl. rewrite Int64.or_commut; auto. +- TrivialExists. simpl. rewrite Val.orl_assoc. rewrite Int64.or_commut; auto. +- TrivialExists. +Qed. + +Theorem eval_orl: binary_constructor_sound orl Val.orl. +Proof. + unfold orl; destruct Archi.splitlong. apply SplitLongproof.eval_orl. + red; intros. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop Oorl (a:::b:::Enil)) v /\ Val.lessdef (Val.orl x y) v) by TrivialExists. + assert (ROR: forall v n1 n2, + Int.add n1 n2 = Int64.iwordsize' -> + Val.lessdef (Val.orl (Val.shll v (Vint n1)) (Val.shrlu v (Vint n2))) + (Val.rorl v (Vint n2))). + { intros. destruct v; simpl; auto. + destruct (Int.ltu n1 Int64.iwordsize') eqn:N1; auto. + destruct (Int.ltu n2 Int64.iwordsize') eqn:N2; auto. + simpl. rewrite <- Int64.or_ror'; auto. } + destruct (orl_match a b). +- InvEval. rewrite Val.orl_commut. apply eval_orlimm; auto. +- InvEval. apply eval_orlimm; auto. +- predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int64.iwordsize'; auto. + destruct (same_expr_pure t1 t2) eqn:?; auto. + InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. + exists (Val.rorl v0 (Vint n2)); split. EvalOp. apply ROR; auto. +- predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int64.iwordsize'; auto. + destruct (same_expr_pure t1 t2) eqn:?; auto. + InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. + exists (Val.rorl v1 (Vint n2)); split. EvalOp. rewrite Val.orl_commut. apply ROR; auto. +- apply DEFAULT. +Qed. + +Theorem eval_xorlimm: forall n, unary_constructor_sound (xorlimm n) (fun v => Val.xorl v (Vlong n)). +Proof. + unfold xorlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.xor_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone. + replace (Val.xorl x (Vlong n)) with (Val.notl x). apply eval_notl; auto. + subst n. destruct x; simpl; auto. + destruct (xorlimm_match a); InvEval; subst. +- econstructor; split. apply eval_longconst. simpl. rewrite Int64.xor_commut; auto. +- TrivialExists. simpl. rewrite Val.xorl_assoc. rewrite Int64.xor_commut; auto. +- TrivialExists. simpl. destruct v1; simpl; auto. unfold Int64.not. + rewrite Int64.xor_assoc. apply f_equal. apply f_equal. apply f_equal. + apply Int64.xor_commut. +- TrivialExists. +Qed. + +Theorem eval_xorl: binary_constructor_sound xorl Val.xorl. +Proof. + unfold xorl; destruct Archi.splitlong. apply SplitLongproof.eval_xorl. + red; intros. destruct (xorl_match a b). +- InvEval. rewrite Val.xorl_commut. apply eval_xorlimm; auto. +- InvEval. apply eval_xorlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_shllimm: forall n, unary_constructor_sound (fun e => shllimm e n) (fun v => Val.shll v (Vint n)). +Proof. + intros; unfold shllimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shllimm; auto. + red; intros. + predSpec Int.eq Int.eq_spec n Int.zero. + exists x; split; auto. subst n; destruct x; simpl; auto. + destruct (Int.ltu Int.zero Int64.iwordsize'); auto. + change (Int64.shl' i Int.zero) with (Int64.shl i Int64.zero). rewrite Int64.shl_zero; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshllimm n) (a:::Enil)) v + /\ Val.lessdef (Val.shll x (Vint n)) v) by TrivialExists. + destruct (shllimm_match a); InvEval. +- TrivialExists. simpl; rewrite LT; auto. +- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. + subst. econstructor; split. EvalOp. simpl; eauto. + destruct v1; simpl; auto. rewrite LT'. + destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. + simpl; rewrite LT. rewrite Int.add_commut, Int64.shl'_shl'; auto. rewrite Int.add_commut; auto. +- destruct (shift_is_scale n); auto. + TrivialExists. simpl. destruct v1; simpl; auto. + rewrite LT. rewrite ! Int64.repr_unsigned. rewrite Int64.shl'_one_two_p. + rewrite ! Int64.shl'_mul_two_p. rewrite Int64.mul_add_distr_l. auto. +- destruct (shift_is_scale n); auto. + TrivialExists. simpl. destruct x; simpl; auto. + rewrite LT. rewrite ! Int64.repr_unsigned. rewrite Int64.shl'_one_two_p. + rewrite ! Int64.shl'_mul_two_p. rewrite Int64.add_zero. auto. +- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + +Theorem eval_shrluimm: forall n, unary_constructor_sound (fun e => shrluimm e n) (fun v => Val.shrlu v (Vint n)). +Proof. + intros; unfold shrluimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrluimm; auto. + red; intros. + predSpec Int.eq Int.eq_spec n Int.zero. + exists x; split; auto. subst n; destruct x; simpl; auto. + destruct (Int.ltu Int.zero Int64.iwordsize'); auto. + change (Int64.shru' i Int.zero) with (Int64.shru i Int64.zero). rewrite Int64.shru_zero; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrluimm n) (a:::Enil)) v + /\ Val.lessdef (Val.shrlu x (Vint n)) v) by TrivialExists. + destruct (shrluimm_match a); InvEval. +- TrivialExists. simpl; rewrite LT; auto. +- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. + subst. econstructor; split. EvalOp. simpl; eauto. + destruct v1; simpl; auto. rewrite LT'. + destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. + simpl; rewrite LT. rewrite Int.add_commut, Int64.shru'_shru'; auto. rewrite Int.add_commut; auto. +- apply DEFAULT. +- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + +Theorem eval_shrlimm: forall n, unary_constructor_sound (fun e => shrlimm e n) (fun v => Val.shrl v (Vint n)). +Proof. + intros; unfold shrlimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlimm; auto. + red; intros. + predSpec Int.eq Int.eq_spec n Int.zero. + exists x; split; auto. subst n; destruct x; simpl; auto. + destruct (Int.ltu Int.zero Int64.iwordsize'); auto. + change (Int64.shr' i Int.zero) with (Int64.shr i Int64.zero). rewrite Int64.shr_zero; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrlimm n) (a:::Enil)) v + /\ Val.lessdef (Val.shrl x (Vint n)) v) by TrivialExists. + destruct (shrlimm_match a); InvEval. +- TrivialExists. simpl; rewrite LT; auto. +- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. + subst. econstructor; split. EvalOp. simpl; eauto. + destruct v1; simpl; auto. rewrite LT'. + destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. + simpl; rewrite LT. rewrite Int.add_commut, Int64.shr'_shr'; auto. rewrite Int.add_commut; auto. +- apply DEFAULT. +- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + +Theorem eval_shll: binary_constructor_sound shll Val.shll. +Proof. + unfold shll. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shll; auto. + red; intros. destruct (is_intconst b) as [n2|] eqn:C. +- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shllimm; auto. +- TrivialExists. +Qed. + +Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu. +Proof. + unfold shrlu. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlu; auto. + red; intros. destruct (is_intconst b) as [n2|] eqn:C. +- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrluimm; auto. +- TrivialExists. +Qed. + +Theorem eval_shrl: binary_constructor_sound shrl Val.shrl. +Proof. + unfold shrl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrl; auto. + red; intros. destruct (is_intconst b) as [n2|] eqn:C. +- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_negl: unary_constructor_sound negl Val.negl. +Proof. + unfold negl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_negl; auto. + red; intros. destruct (is_longconst a) as [n|] eqn:C. +- exploit is_longconst_sound; eauto. intros EQ; subst x. + econstructor; split. apply eval_longconst. auto. +- TrivialExists. +Qed. + +Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)). +Proof. + unfold addlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + subst. exists x; split; auto. + destruct x; simpl; rewrite ?Int64.add_zero, ?Ptrofs.add_zero; auto. + destruct (addlimm_match a); InvEval. +- econstructor; split. apply eval_longconst. rewrite Int64.add_commut; auto. +- inv H. simpl in H6. TrivialExists. simpl. + erewrite eval_offset_addressing_total_64 by eauto. rewrite Int64.repr_signed; auto. +- TrivialExists. simpl. rewrite Int64.repr_signed; auto. +Qed. + +Theorem eval_addl: binary_constructor_sound addl Val.addl. +Proof. + assert (A: forall x y, Int64.repr (x + y) = Int64.add (Int64.repr x) (Int64.repr y)). + { intros; apply Int64.eqm_samerepr; auto with ints. } + assert (B: forall id ofs n, Archi.ptr64 = true -> + Genv.symbol_address ge id (Ptrofs.add ofs (Ptrofs.repr n)) = + Val.addl (Genv.symbol_address ge id ofs) (Vlong (Int64.repr n))). + { intros. replace (Ptrofs.repr n) with (Ptrofs.of_int64 (Int64.repr n)) by auto with ptrofs. + apply Genv.shift_symbol_address_64; auto. } + unfold addl. destruct Archi.splitlong eqn:SL. + apply SplitLongproof.eval_addl. apply Archi.splitlong_ptr32; auto. + red; intros; destruct (addl_match a b); InvEval. +- rewrite Val.addl_commut. apply eval_addlimm; auto. +- apply eval_addlimm; auto. +- subst. TrivialExists. simpl. rewrite A, Val.addl_permut_4. auto. +- subst. TrivialExists. simpl. rewrite A, Val.addl_assoc. decEq; decEq. rewrite Val.addl_permut. auto. +- subst. TrivialExists. simpl. rewrite A, Val.addl_permut_4. rewrite <- Val.addl_permut. rewrite <- Val.addl_assoc. auto. +- subst. TrivialExists. simpl. rewrite Val.addl_commut; auto. +- subst. TrivialExists. +- subst. TrivialExists. simpl. rewrite ! Val.addl_assoc. rewrite (Val.addl_commut y). auto. +- subst. TrivialExists. simpl. rewrite ! Val.addl_assoc. auto. +- TrivialExists. simpl. + unfold Val.addl. destruct Archi.ptr64, x, y; auto. + + rewrite Int64.add_zero; auto. + + rewrite Ptrofs.add_assoc, Ptrofs.add_zero. auto. + + rewrite Ptrofs.add_assoc, Ptrofs.add_zero. auto. + + rewrite Int64.add_zero; auto. +Qed. + +Theorem eval_subl: binary_constructor_sound subl Val.subl. +Proof. + unfold subl. destruct Archi.splitlong eqn:SL. + apply SplitLongproof.eval_subl. apply Archi.splitlong_ptr32; auto. + red; intros; destruct (subl_match a b); InvEval. +- rewrite Val.subl_addl_opp. apply eval_addlimm; auto. +- subst. rewrite Val.subl_addl_l. rewrite Val.subl_addl_r. + rewrite Val.addl_assoc. simpl. rewrite Int64.add_commut. rewrite <- Int64.sub_add_opp. + replace (Int64.repr (n1 - n2)) with (Int64.sub (Int64.repr n1) (Int64.repr n2)). + apply eval_addlimm; EvalOp. + apply Int64.eqm_samerepr; auto with ints. +- subst. rewrite Val.subl_addl_l. apply eval_addlimm; EvalOp. +- subst. rewrite Val.subl_addl_r. + replace (Int64.repr (-n2)) with (Int64.neg (Int64.repr n2)). + apply eval_addlimm; EvalOp. + apply Int64.eqm_samerepr; auto with ints. +- TrivialExists. +Qed. + +Theorem eval_mullimm_base: forall n, unary_constructor_sound (mullimm_base n) (fun v => Val.mull v (Vlong n)). +Proof. + intros; unfold mullimm_base. red; intros. + generalize (Int64.one_bits'_decomp n); intros D. + destruct (Int64.one_bits' n) as [ | i [ | j [ | ? ? ]]] eqn:B. +- TrivialExists. +- replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)). + apply eval_shllimm; auto. + simpl in D. rewrite D, Int64.add_zero. destruct x; simpl; auto. + rewrite (Int64.one_bits'_range n) by (rewrite B; auto with coqlib). + rewrite Int64.shl'_mul; auto. +- set (le' := x :: le). + assert (A0: eval_expr ge sp e m le' (Eletvar O) x) by (constructor; reflexivity). + exploit (eval_shllimm i). eexact A0. intros (v1 & A1 & B1). + exploit (eval_shllimm j). eexact A0. intros (v2 & A2 & B2). + exploit (eval_addl). eexact A1. eexact A2. intros (v3 & A3 & B3). + exists v3; split. econstructor; eauto. + rewrite D. simpl. rewrite Int64.add_zero. destruct x; auto. + simpl in *. + rewrite (Int64.one_bits'_range n) in B1 by (rewrite B; auto with coqlib). + rewrite (Int64.one_bits'_range n) in B2 by (rewrite B; auto with coqlib). + inv B1; inv B2. simpl in B3; inv B3. + rewrite Int64.mul_add_distr_r. rewrite <- ! Int64.shl'_mul. auto. +- TrivialExists. +Qed. + +Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)). +Proof. + unfold mullimm. intros; red; intros. + destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_mullimm; eauto. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists (Vlong Int64.zero); split. apply eval_longconst. + destruct x; simpl; auto. subst n; rewrite Int64.mul_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.one. + exists x; split; auto. + destruct x; simpl; auto. subst n; rewrite Int64.mul_one; auto. + destruct (mullimm_match a); InvEval. +- econstructor; split. apply eval_longconst. rewrite Int64.mul_commut; auto. +- exploit (eval_mullimm_base n); eauto. intros (v2 & A2 & B2). + exploit (eval_addlimm (Int64.mul n (Int64.repr n2))). eexact A2. intros (v3 & A3 & B3). + exists v3; split; auto. + destruct v1; simpl; auto. + simpl in B2; inv B2. simpl in B3; inv B3. rewrite Int64.mul_add_distr_l. + rewrite (Int64.mul_commut n). auto. +- apply eval_mullimm_base; auto. +Qed. + +Theorem eval_mull: binary_constructor_sound mull Val.mull. +Proof. + unfold mull. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mull; auto. + red; intros; destruct (mull_match a b); InvEval. +- rewrite Val.mull_commut. apply eval_mullimm; auto. +- apply eval_mullimm; auto. +- TrivialExists. +Qed. + +Theorem eval_mullhu: + forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)). +Proof. + unfold mullhu; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhu; auto. + red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto. +Qed. + +Theorem eval_mullhs: + forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)). +Proof. + unfold mullhs; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhs; auto. + red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto. +Qed. + +Theorem eval_shrxlimm: + forall le a n x z, + eval_expr ge sp e m le a x -> + Val.shrxl x (Vint n) = Some z -> + exists v, eval_expr ge sp e m le (shrxlimm a n) v /\ Val.lessdef z v. +Proof. + unfold shrxlimm; intros. destruct Archi.splitlong eqn:SL. ++ eapply SplitLongproof.eval_shrxlimm; eauto using Archi.splitlong_ptr32. ++ predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. destruct x; simpl in H0; inv H0. econstructor; split; eauto. + change (Int.ltu Int.zero (Int.repr 63)) with true. simpl. rewrite Int64.shrx'_zero; auto. +- TrivialExists. +Qed. + +Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls. +Proof. + unfold divls_base; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_divls_base; eauto. + TrivialExists. +Qed. + +Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls. +Proof. + unfold modls_base; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_modls_base; eauto. + TrivialExists. +Qed. + +Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu. +Proof. + unfold divlu_base; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_divlu_base; eauto. + TrivialExists. +Qed. + +Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu. +Proof. + unfold modlu_base; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_modlu_base; eauto. + TrivialExists. +Qed. + +Theorem eval_cmplu: + forall c le a x b y v, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.cmplu (Mem.valid_pointer m) c x y = Some v -> + eval_expr ge sp e m le (cmplu c a b) v. +Proof. + unfold cmplu; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_cmplu; eauto using Archi.splitlong_ptr32. + unfold Val.cmplu in H1. + destruct (Val.cmplu_bool (Mem.valid_pointer m) c x y) as [vb|] eqn:C; simpl in H1; inv H1. + destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2; + try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto)); + try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto)); + subst. +- simpl in C; inv C. EvalOp. destruct (Int64.cmpu c n1 n2); reflexivity. +- EvalOp. simpl. rewrite Val.swap_cmplu_bool. rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +Qed. + +Theorem eval_cmpl: + forall c le a x b y v, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.cmpl c x y = Some v -> + eval_expr ge sp e m le (cmpl c a b) v. +Proof. + unfold cmpl; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_cmpl; eauto. + unfold Val.cmpl in H1. + destruct (Val.cmpl_bool c x y) as [vb|] eqn:C; simpl in H1; inv H1. + destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2; + try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto)); + try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto)); + subst. +- simpl in C; inv C. EvalOp. destruct (Int64.cmp c n1 n2); reflexivity. +- EvalOp. simpl. rewrite Val.swap_cmpl_bool. rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +Qed. + +Theorem eval_longoffloat: partial_unary_constructor_sound longoffloat Val.longoffloat. +Proof. + unfold longoffloat; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_longoffloat; eauto. + TrivialExists. +Qed. + +Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong. +Proof. + unfold floatoflong; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_floatoflong; eauto. + TrivialExists. +Qed. + +Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle. +Proof. + unfold longofsingle; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_longofsingle; eauto. + TrivialExists. +Qed. + +Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong. +Proof. + unfold singleoflong; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_singleoflong; eauto. + TrivialExists. +Qed. + +End CMCONSTR. diff --git a/ia32/SelectOp.vp b/x86/SelectOp.vp index bc331b9c..db546d99 100644 --- a/ia32/SelectOp.vp +++ b/x86/SelectOp.vp @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -38,33 +38,33 @@ Require Import Coqlib. Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Op. -Require Import CminorSel. +Require Import AST Integers Floats. +Require Import Op CminorSel. Open Local Scope cminorsel_scope. (** ** Constants **) -(** External oracle to determine whether a symbol is external and must - be addressed through [Oaddrsymbol], or is local and can be addressed - through [Olea Aglobal]. This is to accommodate MacOS X's limitations - on references to data symbols imported from shared libraries. *) +(** External oracle to determine whether a symbol should be addressed + through [Oindirectsymbol] or can be addressed via [Oleal Aglobal]. + This is to accommodate MacOS X's limitations on references to data + symbols imported from shared libraries. It can also help with PIC + code under ELF. *) Parameter symbol_is_external: ident -> bool. -Definition addrsymbol (id: ident) (ofs: int) := +Definition Olea_ptr (a: addressing) := if Archi.ptr64 then Oleal a else Olea a. + +Definition addrsymbol (id: ident) (ofs: ptrofs) := if symbol_is_external id then - if Int.eq ofs Int.zero + if Ptrofs.eq ofs Ptrofs.zero then Eop (Oindirectsymbol id) Enil - else Eop (Olea (Aindexed ofs)) (Eop (Oindirectsymbol id) Enil ::: Enil) + else Eop (Olea_ptr (Aindexed (Ptrofs.unsigned ofs))) (Eop (Oindirectsymbol id) Enil ::: Enil) else - Eop (Olea (Aglobal id ofs)) Enil. + Eop (Olea_ptr (Aglobal id ofs)) Enil. -Definition addrstack (ofs: int) := - Eop (Olea (Ainstack ofs)) Enil. +Definition addrstack (ofs: ptrofs) := + Eop (Olea_ptr (Ainstack ofs)) Enil. (** ** Integer logical negation *) @@ -81,8 +81,8 @@ Nondetfunction 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 (Olea addr) args => Eop (Olea (offset_addressing_total addr n)) args - | _ => Eop (Olea (Aindexed n)) (e ::: Enil) + | Eop (Olea addr) args => Eop (Olea (offset_addressing_total addr (Int.signed n))) args + | _ => Eop (Olea (Aindexed (Int.signed n))) (e ::: Enil) end. Nondetfunction add (e1: expr) (e2: expr) := @@ -90,19 +90,19 @@ Nondetfunction add (e1: expr) (e2: expr) := | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 | t1, Eop (Ointconst n2) Enil => addimm n2 t1 | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => - Eop (Olea (Aindexed2 (Int.add n1 n2))) (t1:::t2:::Enil) + Eop (Olea (Aindexed2 (n1 + n2))) (t1:::t2:::Enil) | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => - Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t1:::t2:::Enil) + Eop (Olea (Aindexed2scaled sc (n1 + n2))) (t1:::t2:::Enil) | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => - Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t2:::t1:::Enil) + Eop (Olea (Aindexed2scaled sc (n1 + n2))) (t2:::t1:::Enil) | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => - Eop (Olea (Abased id (Int.add ofs n1))) (t1:::Enil) + Eop (Olea (Abased id (Ptrofs.add ofs (Ptrofs.repr n1)))) (t1:::Enil) | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Aindexed n2)) (t2:::Enil) => - Eop (Olea (Abased id (Int.add ofs n2))) (t2:::Enil) + Eop (Olea (Abased id (Ptrofs.add ofs (Ptrofs.repr n2)))) (t2:::Enil) | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => - Eop (Olea (Abasedscaled sc id (Int.add ofs n1))) (t1:::Enil) + Eop (Olea (Abasedscaled sc id (Ptrofs.add ofs (Ptrofs.repr n1)))) (t1:::Enil) | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Ascaled sc n2)) (t2:::Enil) => - Eop (Olea (Abasedscaled sc id (Int.add ofs n2))) (t2:::Enil) + Eop (Olea (Abasedscaled sc id (Ptrofs.add ofs (Ptrofs.repr n2)))) (t2:::Enil) | Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 => Eop (Olea (Aindexed2scaled sc n)) (t2:::t1:::Enil) | t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) => @@ -112,7 +112,7 @@ Nondetfunction add (e1: expr) (e2: expr) := | t1, Eop (Olea (Aindexed n)) (t2:::Enil) => Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) | _, _ => - Eop (Olea (Aindexed2 Int.zero)) (e1:::e2:::Enil) + Eop (Olea (Aindexed2 0)) (e1:::e2:::Enil) end. (** ** Opposite *) @@ -129,11 +129,11 @@ Nondetfunction sub (e1: expr) (e2: expr) := match e1, e2 with | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1 | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => - addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + addimm (Int.repr (n1 - n2)) (Eop Osub (t1:::t2:::Enil)) | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 => - addimm n1 (Eop Osub (t1:::t2:::Enil)) + addimm (Int.repr n1) (Eop Osub (t1:::t2:::Enil)) | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) => - addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + addimm (Int.repr (-n2)) (Eop Osub (t1:::t2:::Enil)) | _, _ => Eop Osub (e1:::e2:::Enil) end. @@ -157,11 +157,12 @@ Nondetfunction shlimm (e1: expr) (n: int) := else Eop (Oshlimm n) (e1:::Enil) | Eop (Olea (Aindexed n1)) (t1:::Enil) => if shift_is_scale n - then Eop (Olea (Ascaled (Int.shl Int.one n) (Int.shl n1 n))) (t1:::Enil) + then Eop (Olea (Ascaled (Int.unsigned (Int.shl Int.one n)) + (Int.unsigned (Int.shl (Int.repr n1) n)))) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) | _ => if shift_is_scale n - then Eop (Olea (Ascaled (Int.shl Int.one n) Int.zero)) (e1:::Enil) + then Eop (Olea (Ascaled (Int.unsigned (Int.shl Int.one n)) 0)) (e1:::Enil) else Eop (Oshlimm n) (e1:::Enil) end. @@ -214,7 +215,7 @@ Nondetfunction mulimm (n1: int) (e2: expr) := else if Int.eq n1 Int.one then e2 else match e2 with | Eop (Ointconst n2) Enil => Eop (Ointconst(Int.mul n1 n2)) Enil - | Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.mul n1 (Int.repr n2)) (mulimm_base n1 t2) | _ => mulimm_base n1 e2 end. @@ -503,8 +504,11 @@ Nondetfunction singleofintu (e: expr) := Nondetfunction addressing (chunk: memory_chunk) (e: expr) := match e with - | Eop (Olea addr) args => (addr, args) - | _ => (Aindexed Int.zero, e:::Enil) + | Eop (Olea addr) args => + if (negb Archi.ptr64) && addressing_valid addr then (addr, args) else (Aindexed 0, e:::Enil) + | Eop (Oleal addr) args => + if Archi.ptr64 && addressing_valid addr then (addr, args) else (Aindexed 0, e:::Enil) + | _ => (Aindexed 0, e:::Enil) end. (** ** Arguments of builtins *) @@ -512,8 +516,11 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := Nondetfunction builtin_arg (e: expr) := match e with | Eop (Ointconst n) Enil => BA_int n - | Eop (Olea (Aglobal id ofs)) Enil => BA_addrglobal id ofs - | Eop (Olea (Ainstack ofs)) Enil => BA_addrstack ofs + | Eop (Olongconst n) Enil => BA_long n + | Eop (Olea (Aglobal id ofs)) Enil => if Archi.ptr64 then BA e else BA_addrglobal id ofs + | Eop (Olea (Ainstack ofs)) Enil => if Archi.ptr64 then BA e else BA_addrstack ofs + | Eop (Oleal (Aglobal id ofs)) Enil => if Archi.ptr64 then BA_addrglobal id ofs else BA e + | Eop (Oleal (Ainstack ofs)) Enil => if Archi.ptr64 then BA_addrstack ofs else BA e | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => BA_long (Int64.ofwords h l) | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) diff --git a/ia32/SelectOpproof.v b/x86/SelectOpproof.v index bcfc13c9..ce15b6e1 100644 --- a/ia32/SelectOpproof.v +++ b/x86/SelectOpproof.v @@ -53,7 +53,7 @@ Ltac InvEval1 := Ltac InvEval2 := match goal with | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => - simpl in H; inv H + simpl in H; FuncInv | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => simpl in H; FuncInv | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => @@ -64,7 +64,7 @@ Ltac InvEval2 := idtac end. -Ltac InvEval := InvEval1; InvEval2; InvEval2. +Ltac InvEval := InvEval1; InvEval2; InvEval2; subst. Ltac TrivialExists := match goal with @@ -111,35 +111,44 @@ Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> va eval_expr ge sp e m le b y -> exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. +Lemma eval_Olea_ptr: + forall a el m, + eval_operation ge sp (Olea_ptr a) el m = eval_addressing ge sp a el. +Proof. + unfold Olea_ptr, eval_addressing; intros. destruct Archi.ptr64; auto. +Qed. + Theorem eval_addrsymbol: forall le id ofs, exists v, eval_expr ge sp e m le (addrsymbol id ofs) v /\ Val.lessdef (Genv.symbol_address ge id ofs) v. Proof. intros. unfold addrsymbol. exists (Genv.symbol_address ge id ofs); split; auto. destruct (symbol_is_external id). - predSpec Int.eq Int.eq_spec ofs Int.zero. + predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero. subst. EvalOp. - EvalOp. econstructor. EvalOp. simpl; eauto. econstructor. simpl. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge id); auto. - simpl. rewrite Int.add_commut. rewrite Int.add_zero. auto. - EvalOp. + EvalOp. econstructor. EvalOp. simpl; eauto. econstructor. + unfold Olea_ptr; destruct Archi.ptr64 eqn:SF; simpl; + [ rewrite <- Genv.shift_symbol_address_64 by auto | rewrite <- Genv.shift_symbol_address_32 by auto ]; + f_equal; f_equal; + rewrite Ptrofs.add_zero_l; + [ apply Ptrofs.of_int64_to_int64 | apply Ptrofs.of_int_to_int ]; + auto. + EvalOp. (*rewrite eval_Olea_ptr. apply eval_addressing_Aglobal. *) Qed. Theorem eval_addrstack: forall le ofs, - exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.add sp (Vint ofs)) v. + exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.offset_ptr sp ofs) v. Proof. - intros. unfold addrstack. econstructor; split. - EvalOp. simpl; eauto. - auto. + intros. unfold addrstack. TrivialExists. (*rewrite eval_Olea_ptr. apply eval_addressing_Ainstack.*) Qed. Theorem eval_notint: unary_constructor_sound notint Val.notint. Proof. - unfold notint; red; intros until x. case (notint_match a); intros. - InvEval. TrivialExists. - InvEval. subst x. rewrite Val.not_xor. rewrite Val.xor_assoc. TrivialExists. - TrivialExists. + unfold notint; red; intros until x. case (notint_match a); intros; InvEval. +- TrivialExists. +- rewrite Val.not_xor. rewrite Val.xor_assoc. TrivialExists. +- TrivialExists. Qed. Theorem eval_addimm: @@ -147,57 +156,72 @@ Theorem eval_addimm: Proof. red; unfold addimm; intros until x. predSpec Int.eq Int.eq_spec n Int.zero. - subst n. intros. exists x; split; auto. - destruct x; simpl; auto. rewrite Int.add_zero. auto. rewrite Int.add_zero. auto. - case (addimm_match a); intros; InvEval; simpl. - TrivialExists; simpl. rewrite Int.add_commut. auto. - inv H0. simpl in H6. TrivialExists. simpl. eapply eval_offset_addressing_total; eauto. - TrivialExists. +- subst n. intros. exists x; split; auto. + destruct x; simpl; rewrite ?Int.add_zero, ?Ptrofs.add_zero; auto. +- case (addimm_match a); intros; InvEval. ++ TrivialExists; simpl. rewrite Int.add_commut. auto. ++ inv H0. simpl in H6. TrivialExists. simpl. + erewrite eval_offset_addressing_total_32 by eauto. rewrite Int.repr_signed; auto. ++ TrivialExists. simpl. rewrite Int.repr_signed; auto. Qed. Theorem eval_add: binary_constructor_sound add Val.add. Proof. + assert (A: forall x y, Int.repr (x + y) = Int.add (Int.repr x) (Int.repr y)). + { intros; apply Int.eqm_samerepr; auto with ints. } + assert (B: forall id ofs n, Archi.ptr64 = false -> + Genv.symbol_address ge id (Ptrofs.add ofs (Ptrofs.repr n)) = + Val.add (Genv.symbol_address ge id ofs) (Vint (Int.repr n))). + { intros. replace (Ptrofs.repr n) with (Ptrofs.of_int (Int.repr n)) by auto with ptrofs. + apply Genv.shift_symbol_address_32; auto. } red; intros until y. unfold add; case (add_match a b); intros; InvEval. - rewrite Val.add_commut. apply eval_addimm; auto. - apply eval_addimm; auto. - subst. TrivialExists. simpl. rewrite Val.add_permut_4. auto. - subst. TrivialExists. simpl. rewrite Val.add_assoc. decEq; decEq. rewrite Val.add_permut. auto. - subst. TrivialExists. simpl. rewrite Val.add_permut_4. rewrite <- Val.add_permut. rewrite <- Val.add_assoc. auto. - subst. TrivialExists. simpl. rewrite Genv.shift_symbol_address. - rewrite Val.add_commut. rewrite Val.add_assoc. decEq. decEq. apply Val.add_commut. - subst. TrivialExists. simpl. rewrite Genv.shift_symbol_address. rewrite Val.add_assoc. - decEq; decEq. apply Val.add_commut. - subst. TrivialExists. simpl. rewrite Genv.shift_symbol_address. rewrite Val.add_commut. - rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. - subst. TrivialExists. simpl. rewrite Genv.shift_symbol_address. - rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. - subst. TrivialExists. simpl. rewrite Val.add_permut. rewrite Val.add_assoc. +- rewrite Val.add_commut. apply eval_addimm; auto. +- apply eval_addimm; auto. +- TrivialExists. simpl. rewrite A, Val.add_permut_4. auto. +- TrivialExists. simpl. rewrite A, Val.add_assoc. decEq; decEq. rewrite Val.add_permut. auto. +- TrivialExists. simpl. rewrite A, Val.add_permut_4. rewrite <- Val.add_permut. rewrite <- Val.add_assoc. auto. +- TrivialExists. simpl. rewrite Heqb0. rewrite B by auto. rewrite ! Val.add_assoc. + rewrite (Val.add_commut v1). rewrite Val.add_permut. rewrite Val.add_assoc. auto. +- TrivialExists. simpl. rewrite Heqb0. rewrite B by auto. rewrite Val.add_assoc. do 2 f_equal. apply Val.add_commut. +- TrivialExists. simpl. rewrite Heqb0. rewrite B by auto. rewrite !Val.add_assoc. + rewrite (Val.add_commut (Vint (Int.repr n1))). rewrite Val.add_permut. do 2 f_equal. apply Val.add_commut. +- TrivialExists. simpl. rewrite Heqb0. rewrite B by auto. rewrite !Val.add_assoc. + rewrite (Val.add_commut (Vint (Int.repr n2))). rewrite Val.add_permut. auto. +- TrivialExists. simpl. rewrite Val.add_permut. rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. - subst. TrivialExists. - subst. TrivialExists. simpl. repeat rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. - subst. TrivialExists. simpl. rewrite Val.add_assoc; auto. - TrivialExists. simpl. destruct x; destruct y; simpl; auto; rewrite Int.add_zero; auto. +- TrivialExists. +- TrivialExists. simpl. repeat rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. +- TrivialExists. simpl. rewrite Val.add_assoc; auto. +- TrivialExists. simpl. + unfold Val.add; destruct Archi.ptr64, x, y; auto. + + rewrite Int.add_zero; auto. + + rewrite Int.add_zero; auto. + + rewrite Ptrofs.add_assoc, Ptrofs.add_zero. auto. + + rewrite Ptrofs.add_assoc, Ptrofs.add_zero. auto. Qed. Theorem eval_sub: binary_constructor_sound sub Val.sub. Proof. red; intros until y. unfold sub; case (sub_match a b); intros; InvEval. - rewrite Val.sub_add_opp. apply eval_addimm; auto. - subst. rewrite Val.sub_add_l. rewrite Val.sub_add_r. +- rewrite Val.sub_add_opp. apply eval_addimm; auto. +- rewrite Val.sub_add_l. rewrite Val.sub_add_r. rewrite Val.add_assoc. simpl. rewrite Int.add_commut. rewrite <- Int.sub_add_opp. + replace (Int.repr (n1 - n2)) with (Int.sub (Int.repr n1) (Int.repr n2)). apply eval_addimm; EvalOp. - subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp. - subst. rewrite Val.sub_add_r. apply eval_addimm; EvalOp. - TrivialExists. + apply Int.eqm_samerepr; auto with ints. +- rewrite Val.sub_add_l. apply eval_addimm; EvalOp. +- rewrite Val.sub_add_r. replace (Int.repr (-n2)) with (Int.neg (Int.repr n2)). apply eval_addimm; EvalOp. + apply Int.eqm_samerepr; auto with ints. +- TrivialExists. Qed. -Theorem eval_negint: unary_constructor_sound negint (fun v => Val.sub Vzero v). +Theorem eval_negint: unary_constructor_sound negint Val.neg. Proof. red; intros until x. unfold negint. case (negint_match a); intros; InvEval. - TrivialExists. - TrivialExists. +- TrivialExists. +- TrivialExists. Qed. Theorem eval_shlimm: @@ -209,28 +233,29 @@ Proof. intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shl_zero; auto. destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. destruct (shlimm_match a); intros; InvEval. - exists (Vint (Int.shl n1 n)); split. EvalOp. +- exists (Vint (Int.shl n1 n)); split. EvalOp. simpl. rewrite LT. auto. - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. - exists (Val.shl v1 (Vint (Int.add n n1))); split. EvalOp. - subst. destruct v1; simpl; auto. +- destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. ++ exists (Val.shl v1 (Vint (Int.add n n1))); split. EvalOp. + destruct v1; simpl; auto. rewrite Heqb. destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. destruct (Int.ltu n Int.iwordsize) eqn:?; simpl; auto. rewrite Int.add_commut. rewrite Int.shl_shl; auto. rewrite Int.add_commut; auto. - subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. ++ TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. simpl. auto. - subst. destruct (shift_is_scale n). - econstructor; split. EvalOp. simpl. eauto. +- destruct (shift_is_scale n). ++ econstructor; split. EvalOp. simpl. eauto. + rewrite ! Int.repr_unsigned. destruct v1; simpl; auto. rewrite LT. - rewrite Int.shl_mul. rewrite Int.mul_add_distr_l. rewrite (Int.shl_mul n1). auto. - TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. auto. - destruct (shift_is_scale n). - econstructor; split. EvalOp. simpl. eauto. + rewrite Int.shl_mul. rewrite Int.mul_add_distr_l. rewrite (Int.shl_mul (Int.repr n1)). auto. ++ TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. auto. +- destruct (shift_is_scale n). ++ econstructor; split. EvalOp. simpl. eauto. destruct x; simpl; auto. rewrite LT. - rewrite Int.add_zero. rewrite Int.shl_mul. auto. - TrivialExists. - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. + rewrite Int.repr_unsigned. rewrite Int.add_zero. rewrite Int.shl_mul. auto. ++ TrivialExists. +- intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. auto. Qed. @@ -243,18 +268,18 @@ Proof. intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto. destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. destruct (shruimm_match a); intros; InvEval. - exists (Vint (Int.shru n1 n)); split. EvalOp. +- exists (Vint (Int.shru n1 n)); split. EvalOp. simpl. rewrite LT; auto. - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. - exists (Val.shru v1 (Vint (Int.add n n1))); split. EvalOp. +- destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. ++ exists (Val.shru v1 (Vint (Int.add n n1))); split. EvalOp. subst. destruct v1; simpl; auto. rewrite Heqb. destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. rewrite LT. rewrite Int.add_commut. rewrite Int.shru_shru; auto. rewrite Int.add_commut; auto. - subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. ++ TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. simpl. auto. - TrivialExists. - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. +- TrivialExists. +- intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. auto. Qed. @@ -267,19 +292,19 @@ Proof. intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto. destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. destruct (shrimm_match a); intros; InvEval. - exists (Vint (Int.shr n1 n)); split. EvalOp. +- exists (Vint (Int.shr n1 n)); split. EvalOp. simpl. rewrite LT; auto. - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. - exists (Val.shr v1 (Vint (Int.add n n1))); split. EvalOp. +- destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. ++ exists (Val.shr v1 (Vint (Int.add n n1))); split. EvalOp. subst. destruct v1; simpl; auto. rewrite Heqb. destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. rewrite LT. rewrite Int.add_commut. rewrite Int.shr_shr; auto. rewrite Int.add_commut; auto. - subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. ++ TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. simpl. auto. - TrivialExists. - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. +- TrivialExists. +- intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. auto. Qed. @@ -287,29 +312,26 @@ Lemma eval_mulimm_base: forall n, unary_constructor_sound (mulimm_base n) (fun x => Val.mul x (Vint n)). Proof. intros; red; intros; unfold mulimm_base. - generalize (Int.one_bits_decomp n). - generalize (Int.one_bits_range n). - destruct (Int.one_bits n). - intros. TrivialExists. - destruct l. - intros. rewrite H1. simpl. - rewrite Int.add_zero. - replace (Vint (Int.shl Int.one i)) with (Val.shl Vone (Vint i)). rewrite Val.shl_mul. - apply eval_shlimm. auto. simpl. rewrite H0; auto with coqlib. - destruct l. - intros. rewrite H1. simpl. + generalize (Int.one_bits_decomp n) (Int.one_bits_range n); intros D R. + destruct (Int.one_bits n) as [ | i l]. + TrivialExists. + destruct l as [ | j l ]. + replace (Val.mul x (Vint n)) with (Val.shl x (Vint i)). apply eval_shlimm; auto. + destruct x; auto; simpl. rewrite D; simpl; rewrite Int.add_zero. + rewrite R by auto with coqlib. rewrite Int.shl_mul. auto. + destruct l as [ | k l ]. exploit (eval_shlimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]]. - exploit (eval_shlimm i0 (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]]. + exploit (eval_shlimm j (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]]. exploit eval_add. eexact A1. eexact A2. intros [v3 [A3 B3]]. exists v3; split. econstructor; eauto. - rewrite Int.add_zero. - replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one i0))) - with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint i0))). + rewrite D; simpl; rewrite Int.add_zero. + replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one j))) + with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint j))). rewrite Val.mul_add_distr_r. repeat rewrite Val.shl_mul. apply Val.lessdef_trans with (Val.add v1 v2); auto. apply Val.add_lessdef; auto. - simpl. repeat rewrite H0; auto with coqlib. - intros. TrivialExists. + simpl. rewrite ! R by auto with coqlib. auto. + TrivialExists. Qed. Theorem eval_mulimm: @@ -322,23 +344,23 @@ Proof. predSpec Int.eq Int.eq_spec n Int.one. intros. exists x; split; auto. destruct x; simpl; auto. subst n. rewrite Int.mul_one. auto. - case (mulimm_match a); intros; InvEval. - TrivialExists. simpl. rewrite Int.mul_commut; auto. - subst. rewrite Val.mul_add_distr_l. +- case (mulimm_match a); intros; InvEval. ++ TrivialExists. simpl. rewrite Int.mul_commut; auto. ++ rewrite Val.mul_add_distr_l. exploit eval_mulimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]]. - exploit (eval_addimm (Int.mul n n2) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]]. + exploit (eval_addimm (Int.mul n (Int.repr n2)) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]]. exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.add_lessdef; eauto. rewrite Val.mul_commut; auto. - apply eval_mulimm_base; auto. ++ apply eval_mulimm_base; auto. Qed. Theorem eval_mul: binary_constructor_sound mul Val.mul. Proof. red; intros until y. unfold mul; case (mul_match a b); intros; InvEval. - rewrite Val.mul_commut. apply eval_mulimm. auto. - apply eval_mulimm. auto. - TrivialExists. +- rewrite Val.mul_commut. apply eval_mulimm. auto. +- apply eval_mulimm. auto. +- TrivialExists. Qed. Theorem eval_andimm: @@ -352,21 +374,21 @@ Proof. intros. exists x; split; auto. destruct x; simpl; auto. subst n. rewrite Int.and_mone. auto. case (andimm_match a); intros; InvEval. - TrivialExists. simpl. rewrite Int.and_commut; auto. - subst. TrivialExists. simpl. rewrite Val.and_assoc. rewrite Int.and_commut. auto. - subst. rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. +- TrivialExists. simpl. rewrite Int.and_commut; auto. +- TrivialExists. simpl. rewrite Val.and_assoc. rewrite Int.and_commut. auto. +- rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. rewrite Int.and_commut. auto. compute; auto. - subst. rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. +- rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. rewrite Int.and_commut. auto. compute; auto. - TrivialExists. +- TrivialExists. Qed. Theorem eval_and: binary_constructor_sound and Val.and. Proof. red; intros until y; unfold and; case (and_match a b); intros; InvEval. - rewrite Val.and_commut. apply eval_andimm; auto. - apply eval_andimm; auto. - TrivialExists. +- rewrite Val.and_commut. apply eval_andimm; auto. +- apply eval_andimm; auto. +- TrivialExists. Qed. Theorem eval_orimm: @@ -380,9 +402,9 @@ Proof. intros. exists (Vint Int.mone); split. EvalOp. destruct x; simpl; auto. subst n. rewrite Int.or_mone. auto. destruct (orimm_match a); intros; InvEval. - TrivialExists. simpl. rewrite Int.or_commut; auto. - subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists. - TrivialExists. +- TrivialExists. simpl. rewrite Int.or_commut; auto. +- subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists. +- TrivialExists. Qed. Remark eval_same_expr: @@ -409,10 +431,10 @@ Qed. Lemma eval_or: binary_constructor_sound or Val.or. Proof. red; intros until y; unfold or; case (or_match a b); intros. -(* intconst *) - InvEval. rewrite Val.or_commut. apply eval_orimm; auto. - InvEval. apply eval_orimm; auto. -(* shlimm - shruimm *) + (* intconst *) +- InvEval. rewrite Val.or_commut. apply eval_orimm; auto. +- InvEval. apply eval_orimm; auto. +- (* shlimm - shruimm *) predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int.iwordsize. destruct (same_expr_pure t1 t2) eqn:?. InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. @@ -421,10 +443,10 @@ Proof. destruct (Int.ltu n1 Int.iwordsize) eqn:?; auto. destruct (Int.ltu n2 Int.iwordsize) eqn:?; auto. simpl. rewrite <- Int.or_ror; auto. - InvEval. exists (Val.or x y); split. EvalOp. - simpl. erewrite int_add_sub_eq; eauto. rewrite H0; rewrite H; auto. auto. + InvEval. econstructor; split; eauto. EvalOp. + simpl. erewrite int_add_sub_eq; eauto. TrivialExists. -(* shruimm - shlimm *) +- (* shruimm - shlimm *) predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int.iwordsize. destruct (same_expr_pure t1 t2) eqn:?. InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. @@ -433,11 +455,11 @@ Proof. destruct (Int.ltu n2 Int.iwordsize) eqn:?; auto. destruct (Int.ltu n1 Int.iwordsize) eqn:?; auto. simpl. rewrite Int.or_commut. rewrite <- Int.or_ror; auto. - InvEval. exists (Val.or y x); split. EvalOp. - simpl. erewrite int_add_sub_eq; eauto. rewrite H0; rewrite H; auto. + InvEval. econstructor; split; eauto. EvalOp. + simpl. erewrite int_add_sub_eq; eauto. rewrite Val.or_commut; auto. TrivialExists. -(* default *) +- (* default *) TrivialExists. Qed. @@ -449,19 +471,19 @@ Proof. intros. exists x; split. auto. destruct x; simpl; auto. subst n. rewrite Int.xor_zero. auto. destruct (xorimm_match a); intros; InvEval. - TrivialExists. simpl. rewrite Int.xor_commut; auto. - subst. rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. TrivialExists. - subst. rewrite Val.not_xor. rewrite Val.xor_assoc. +- TrivialExists. simpl. rewrite Int.xor_commut; auto. +- rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. TrivialExists. +- rewrite Val.not_xor. rewrite Val.xor_assoc. rewrite (Val.xor_commut (Vint Int.mone)). TrivialExists. - TrivialExists. +- TrivialExists. Qed. Theorem eval_xor: binary_constructor_sound xor Val.xor. Proof. red; intros until y; unfold xor; case (xor_match a b); intros; InvEval. - rewrite Val.xor_commut. apply eval_xorimm; auto. - apply eval_xorimm; auto. - TrivialExists. +- rewrite Val.xor_commut. apply eval_xorimm; auto. +- apply eval_xorimm; auto. +- TrivialExists. Qed. Theorem eval_divs_base: @@ -524,22 +546,22 @@ Qed. Theorem eval_shl: binary_constructor_sound shl Val.shl. Proof. red; intros until y; unfold shl; case (shl_match b); intros. - InvEval. apply eval_shlimm; auto. - TrivialExists. +- InvEval. apply eval_shlimm; auto. +- TrivialExists. Qed. Theorem eval_shr: binary_constructor_sound shr Val.shr. Proof. red; intros until y; unfold shr; case (shr_match b); intros. - InvEval. apply eval_shrimm; auto. - TrivialExists. +- InvEval. apply eval_shrimm; auto. +- TrivialExists. Qed. Theorem eval_shru: binary_constructor_sound shru Val.shru. Proof. red; intros until y; unfold shru; case (shru_match b); intros. - InvEval. apply eval_shruimm; auto. - TrivialExists. +- InvEval. apply eval_shruimm; auto. +- TrivialExists. Qed. Theorem eval_negf: unary_constructor_sound negf Val.negf. @@ -612,9 +634,9 @@ Lemma eval_compimm: Proof. intros until x. unfold compimm; case (compimm_match c a); intros. -(* constant *) +- (* constant *) InvEval. rewrite sem_int. TrivialExists. simpl. destruct (intsem c0 n1 n2); auto. -(* eq cmp *) +- (* eq cmp *) InvEval. inv H. simpl in H5. inv H5. destruct (Int.eq_dec n2 Int.zero). subst n2. TrivialExists. simpl. rewrite eval_negate_condition. @@ -629,7 +651,7 @@ Proof. destruct (eval_condition c0 vl m); simpl. unfold Vtrue, Vfalse. destruct b; rewrite sem_eq; rewrite Int.eq_false; auto. rewrite sem_undef; auto. -(* ne cmp *) +- (* ne cmp *) InvEval. inv H. simpl in H5. inv H5. destruct (Int.eq_dec n2 Int.zero). subst n2. TrivialExists. simpl. destruct (eval_condition c0 vl m); simpl. @@ -643,19 +665,19 @@ Proof. destruct (eval_condition c0 vl m); simpl. unfold Vtrue, Vfalse. destruct b; rewrite sem_ne; rewrite Int.eq_false; auto. rewrite sem_undef; auto. -(* eq andimm *) +- (* eq andimm *) destruct (Int.eq_dec n2 Int.zero). InvEval; subst. econstructor; split. EvalOp. simpl; eauto. destruct v1; simpl; try (rewrite sem_undef; auto). rewrite sem_eq. destruct (Int.eq (Int.and i n1) Int.zero); auto. TrivialExists. simpl. rewrite sem_default. auto. -(* ne andimm *) +- (* ne andimm *) destruct (Int.eq_dec n2 Int.zero). InvEval; subst. econstructor; split. EvalOp. simpl; eauto. destruct v1; simpl; try (rewrite sem_undef; auto). rewrite sem_ne. destruct (Int.eq (Int.and i n1) Int.zero); auto. TrivialExists. simpl. rewrite sem_default. auto. -(* default *) +- (* default *) TrivialExists. simpl. rewrite sem_default. auto. Qed. @@ -893,9 +915,26 @@ Theorem eval_addressing: eval_addressing ge sp mode vl = Some v end. Proof. - intros until v. unfold addressing; case (addressing_match a); intros; InvEval. - inv H. exists vl; auto. - exists (v :: nil); split. constructor; auto. constructor. subst; simpl. rewrite Int.add_zero; auto. + intros until ofs. + assert (A: v = Vptr b ofs -> eval_addressing ge sp (Aindexed 0) (v :: nil) = Some v). + { intros. subst v. unfold eval_addressing. + destruct Archi.ptr64 eqn:SF; simpl; rewrite SF; rewrite Ptrofs.add_zero; auto. } + assert (D: forall a, + eval_expr ge sp e m le a v -> + v = Vptr b ofs -> + exists vl, eval_exprlist ge sp e m le (a ::: Enil) vl + /\ eval_addressing ge sp (Aindexed 0) vl = Some v). + { intros. exists (v :: nil); split. constructor; auto. constructor. auto. } + unfold addressing; case (addressing_match a); intros. +- destruct (negb Archi.ptr64 && addressing_valid addr) eqn:E. ++ inv H. InvBooleans. apply negb_true_iff in H. unfold eval_addressing; rewrite H. + exists vl; auto. ++ apply D; auto. +- destruct (Archi.ptr64 && addressing_valid addr) eqn:E. ++ inv H. InvBooleans. unfold eval_addressing; rewrite H. + exists vl; auto. ++ apply D; auto. +- apply D; auto. Qed. Theorem eval_builtin_arg: @@ -907,10 +946,13 @@ Proof. - constructor. - constructor. - constructor. +- constructor. +- constructor. +- constructor. - simpl in H5. inv H5. constructor. -- subst v. constructor; auto. -- inv H. InvEval. simpl in H6; inv H6. constructor; auto. -- inv H. InvEval. simpl in H6. inv H6. constructor; auto. +- constructor; auto. +- inv H. InvEval. rewrite eval_addressing_Aglobal in H6. inv H6. constructor; auto. +- inv H. InvEval. rewrite eval_addressing_Ainstack in H6. inv H6. constructor; auto. - constructor; auto. Qed. diff --git a/ia32/Stacklayout.v b/x86/Stacklayout.v index f19f036c..44fd43b2 100644 --- a/ia32/Stacklayout.v +++ b/x86/Stacklayout.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -13,9 +13,11 @@ (** Machine- and ABI-dependent layout information for activation records. *) Require Import Coqlib. -Require Import Memory Separation. +Require Import AST Memory Separation. Require Import Bounds. +Local Open Scope sep_scope. + (** The general shape of activation records is as follows, from bottom (lowest offsets) to top: - Space for outgoing arguments to function calls. @@ -29,16 +31,14 @@ Require Import Bounds. Definition fe_ofs_arg := 0. -(** Computation of the frame environment from the bounds of the current - function. *) - Definition make_env (b: bounds) : frame_env := - let olink := 4 * b.(bound_outgoing) in (* back link *) - let ocs := olink + 4 in (* callee-saves *) + let w := if Archi.ptr64 then 8 else 4 in + let olink := align (4 * b.(bound_outgoing)) w in (* back link *) + let ocs := olink + w in (* callee-saves *) let ol := align (size_callee_save_area b ocs) 8 in (* locals *) let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *) - let oretaddr := align (ostkdata + b.(bound_stack_data)) 4 in (* return address *) - let sz := oretaddr + 4 in (* total size *) + let oretaddr := align (ostkdata + b.(bound_stack_data)) w in (* return address *) + let sz := oretaddr + w in (* total size *) {| fe_size := sz; fe_ofs_link := olink; fe_ofs_retaddr := oretaddr; @@ -47,31 +47,31 @@ Definition make_env (b: bounds) : frame_env := fe_stack_data := ostkdata; fe_used_callee_save := b.(used_callee_save) |}. -(** Separation property *) - -Local Open Scope sep_scope. - Lemma frame_env_separated: forall b sp m P, let fe := make_env b in m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P -> m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b) ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b) - ** range sp (fe_ofs_link fe) (fe_ofs_link fe + 4) - ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + 4) + ** range sp (fe_ofs_link fe) (fe_ofs_link fe + size_chunk Mptr) + ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + size_chunk Mptr) ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe)) ** P. Proof. Local Opaque Z.add Z.mul sepconj range. intros; simpl. - set (olink := 4 * b.(bound_outgoing)). - set (ocs := olink + 4). + set (w := if Archi.ptr64 then 8 else 4). + set (olink := align (4 * b.(bound_outgoing)) w). + set (ocs := olink + w). set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). - set (oretaddr := align (ostkdata + b.(bound_stack_data)) 4). + set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). + replace (size_chunk Mptr) with w by (rewrite size_chunk_Mptr; auto). + assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= olink) by (unfold olink; omega). - assert (olink + 4 <= ocs) by (unfold ocs; omega). + assert (0 <= 4 * b.(bound_outgoing)) by omega. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). + assert (olink + w <= ocs) by (unfold ocs; omega). assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). @@ -88,7 +88,7 @@ Local Opaque Z.add Z.mul sepconj range. rewrite sep_swap34. (* Apply range_split and range_split2 repeatedly *) unfold fe_ofs_arg. - apply range_split. omega. + apply range_split_2. fold olink. omega. omega. apply range_split. omega. apply range_split_2. fold ol. omega. omega. apply range_drop_right with ostkdata. omega. @@ -104,14 +104,17 @@ Lemma frame_env_range: 0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe. Proof. intros; simpl. - set (olink := 4 * b.(bound_outgoing)). - set (ocs := olink + 4). + set (w := if Archi.ptr64 then 8 else 4). + set (olink := align (4 * b.(bound_outgoing)) w). + set (ocs := olink + w). set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). - set (oretaddr := align (ostkdata + b.(bound_stack_data)) 4). + set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). + assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= olink) by (unfold olink; omega). - assert (olink + 4 <= ocs) by (unfold ocs; omega). + assert (0 <= 4 * b.(bound_outgoing)) by omega. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). + assert (olink + w <= ocs) by (unfold ocs; omega). assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). @@ -125,18 +128,21 @@ Lemma frame_env_aligned: (8 | fe_ofs_arg) /\ (8 | fe_ofs_local fe) /\ (8 | fe_stack_data fe) - /\ (4 | fe_ofs_link fe) - /\ (4 | fe_ofs_retaddr fe). + /\ (align_chunk Mptr | fe_ofs_link fe) + /\ (align_chunk Mptr | fe_ofs_retaddr fe). Proof. intros; simpl. - set (olink := 4 * b.(bound_outgoing)). - set (ocs := olink + 4). + set (w := if Archi.ptr64 then 8 else 4). + set (olink := align (4 * b.(bound_outgoing)) w). + set (ocs := olink + w). set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). - set (oretaddr := align (ostkdata + b.(bound_stack_data)) 4). + set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). + assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + replace (align_chunk Mptr) with w by (rewrite align_chunk_Mptr; auto). split. apply Zdivide_0. split. apply align_divides; omega. split. apply align_divides; omega. - split. apply Z.divide_factor_l. + split. apply align_divides; omega. apply align_divides; omega. Qed. diff --git a/ia32/TargetPrinter.ml b/x86/TargetPrinter.ml index 4ffb701b..33d47830 100644 --- a/ia32/TargetPrinter.ml +++ b/x86/TargetPrinter.ml @@ -10,7 +10,7 @@ (* *) (* *********************************************************************) -(* Printing IA32 assembly code in asm syntax *) +(* Printing x86-64 assembly code in asm syntax *) open Printf open !Datatypes @@ -25,30 +25,41 @@ module StringSet = Set.Make(String) (* Basic printing functions used in definition of the systems *) -let int_reg_name = function - | EAX -> "%eax" | EBX -> "%ebx" | ECX -> "%ecx" | EDX -> "%edx" - | ESI -> "%esi" | EDI -> "%edi" | EBP -> "%ebp" | ESP -> "%esp" +let int64_reg_name = function + | RAX -> "%rax" | RBX -> "%rbx" | RCX -> "%rcx" | RDX -> "%rdx" + | RSI -> "%rsi" | RDI -> "%rdi" | RBP -> "%rbp" | RSP -> "%rsp" + | R8 -> "%r8" | R9 -> "%r9" | R10 -> "%r10" | R11 -> "%r11" + | R12 -> "%r12" | R13 -> "%r13" | R14 -> "%r14" | R15 -> "%r15" -let int8_reg_name = function - | EAX -> "%al" | EBX -> "%bl" | ECX -> "%cl" | EDX -> "%dl" - | _ -> assert false +let int32_reg_name = function + | RAX -> "%eax" | RBX -> "%ebx" | RCX -> "%ecx" | RDX -> "%edx" + | RSI -> "%esi" | RDI -> "%edi" | RBP -> "%ebp" | RSP -> "%esp" + | R8 -> "%r8d" | R9 -> "%r9d" | R10 -> "%r10d" | R11 -> "%r11d" + | R12 -> "%r12d" | R13 -> "%r13d" | R14 -> "%r14d" | R15 -> "%r15d" -let high_int8_reg_name = function - | EAX -> "%ah" | EBX -> "%bh" | ECX -> "%ch" | EDX -> "%dh" - | _ -> assert false +let int8_reg_name = function + | RAX -> "%al" | RBX -> "%bl" | RCX -> "%cl" | RDX -> "%dl" + | RSI -> "%sil" | RDI -> "%dil" | RBP -> "%bpl" | RSP -> "%spl" + | R8 -> "%r8b" | R9 -> "%r9b" | R10 -> "%r10b" | R11 -> "%r11b" + | R12 -> "%r12b" | R13 -> "%r13b" | R14 -> "%r14b" | R15 -> "%r15b" let int16_reg_name = function - | EAX -> "%ax" | EBX -> "%bx" | ECX -> "%cx" | EDX -> "%dx" - | ESI -> "%si" | EDI -> "%di" | EBP -> "%bp" | ESP -> "%sp" + | RAX -> "%ax" | RBX -> "%bx" | RCX -> "%cx" | RDX -> "%dx" + | RSI -> "%si" | RDI -> "%di" | RBP -> "%bp" | RSP -> "%sp" + | R8 -> "%r8w" | R9 -> "%r9w" | R10 -> "%r10w" | R11 -> "%r11w" + | R12 -> "%r12w" | R13 -> "%r13w" | R14 -> "%r14w" | R15 -> "%r15w" let float_reg_name = function | XMM0 -> "%xmm0" | XMM1 -> "%xmm1" | XMM2 -> "%xmm2" | XMM3 -> "%xmm3" | XMM4 -> "%xmm4" | XMM5 -> "%xmm5" | XMM6 -> "%xmm6" | XMM7 -> "%xmm7" + | XMM8 -> "%xmm8" | XMM9 -> "%xmm9" | XMM10 -> "%xmm10" | XMM11 -> "%xmm11" + | XMM12 -> "%xmm12" | XMM13 -> "%xmm13" | XMM14 -> "%xmm14" | XMM15 -> "%xmm15" -let ireg oc r = output_string oc (int_reg_name r) let ireg8 oc r = output_string oc (int8_reg_name r) -let high_ireg8 oc r = output_string oc (high_int8_reg_name r) let ireg16 oc r = output_string oc (int16_reg_name r) +let ireg32 oc r = output_string oc (int32_reg_name r) +let ireg64 oc r = output_string oc (int64_reg_name r) +let ireg = if Archi.ptr64 then ireg64 else ireg32 let freg oc r = output_string oc (float_reg_name r) let preg oc = function @@ -56,6 +67,12 @@ let preg oc = function | FR r -> freg oc r | _ -> assert false +let z oc n = output_string oc (Z.to_string n) + +(* 32/64 bit dependencies *) + +let data_pointer = if Archi.ptr64 then ".quad" else ".long" + (* The comment deliminiter *) let comment = "#" @@ -68,7 +85,7 @@ module type SYSTEM = val name_of_section: section_name -> string val stack_alignment: int val print_align: out_channel -> int -> unit - val print_mov_ra: out_channel -> ireg -> ident -> unit + val print_mov_rs: out_channel -> ireg -> ident -> unit val print_fun_info: out_channel -> P.t -> unit val print_var_info: out_channel -> P.t -> unit val print_epilogue: out_channel -> unit @@ -76,61 +93,6 @@ module type SYSTEM = val print_lcomm_decl: out_channel -> P.t -> Z.t -> int -> unit end -(* Printer functions for cygwin *) -module Cygwin_System : SYSTEM = - struct - - let raw_symbol oc s = - fprintf oc "_%s" s - - let symbol oc symb = - raw_symbol oc (extern_atom symb) - - let label oc lbl = - fprintf oc "L%d" lbl - - let name_of_section = function - | Section_text -> ".text" - | Section_data i | Section_small_data i -> - if i then ".data" else "COMM" - | Section_const i | Section_small_const i -> - if i then ".section .rdata,\"dr\"" else "COMM" - | Section_string -> ".section .rdata,\"dr\"" - | Section_literal -> ".section .rdata,\"dr\"" - | Section_jumptable -> ".text" - | Section_user(s, wr, ex) -> - sprintf ".section \"%s\", \"%s\"\n" - s (if ex then "xr" else if wr then "d" else "dr") - | Section_debug_info _ -> ".section .debug_info,\"dr\"" - | Section_debug_loc -> ".section .debug_loc,\"dr\"" - | Section_debug_line _ -> ".section .debug_line,\"dr\"" - | Section_debug_abbrev -> ".section .debug_abbrev,\"dr\"" - | Section_debug_ranges -> ".section .debug_ranges,\"dr\"" - | Section_debug_str-> assert false (* Should not be used *) - - let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) - - let print_align oc n = - fprintf oc " .align %d\n" n - - let print_mov_ra oc rd id = - fprintf oc " movl $%a, %a\n" symbol id ireg rd - - let print_fun_info _ _ = () - - let print_var_info _ _ = () - - let print_epilogue _ = () - - let print_comm_decl oc name sz al = - fprintf oc " .comm %a, %s, %d\n" symbol name (Z.to_string sz) al - - let print_lcomm_decl oc name sz al = - fprintf oc " .local %a\n" symbol name; - print_comm_decl oc name sz al - - end - (* Printer functions for ELF *) module ELF_System : SYSTEM = struct @@ -161,13 +123,15 @@ module ELF_System : SYSTEM = | Section_debug_ranges -> ".section .debug_ranges,\"\",@progbits" | Section_debug_str -> ".section .debug_str,\"MS\",@progbits,1" - let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) + let stack_alignment = 16 let print_align oc n = fprintf oc " .align %d\n" n - let print_mov_ra oc rd id = - fprintf oc " movl $%a, %a\n" symbol id ireg rd + let print_mov_rs oc rd id = + if Archi.ptr64 + then fprintf oc " movq %a@GOTPCREL(%%rip), %a\n" symbol id ireg64 rd + else fprintf oc " movl $%a, %a\n" symbol id ireg32 rd let print_fun_info = elf_print_fun_info @@ -230,24 +194,30 @@ module MacOS_System : SYSTEM = let indirect_symbols : StringSet.t ref = ref StringSet.empty - let print_mov_ra oc rd id = - let id = extern_atom id in - indirect_symbols := StringSet.add id !indirect_symbols; - fprintf oc " movl L%a$non_lazy_ptr, %a\n" raw_symbol id ireg rd + let print_mov_rs oc rd id = + if Archi.ptr64 then begin + fprintf oc " movq %a@GOTPCREL(%%rip), %a\n" symbol id ireg64 rd + end else begin + let id = extern_atom id in + indirect_symbols := StringSet.add id !indirect_symbols; + fprintf oc " movl L%a$non_lazy_ptr, %a\n" raw_symbol id ireg rd + end let print_fun_info _ _ = () let print_var_info _ _ = () let print_epilogue oc = - fprintf oc " .section __IMPORT,__pointers,non_lazy_symbol_pointers\n"; - StringSet.iter - (fun s -> - fprintf oc "L%a$non_lazy_ptr:\n" raw_symbol s; - fprintf oc " .indirect_symbol %a\n" raw_symbol s; - fprintf oc " .long 0\n") - !indirect_symbols; - indirect_symbols := StringSet.empty + if not Archi.ptr64 then begin + fprintf oc " .section __IMPORT,__pointers,non_lazy_symbol_pointers\n"; + StringSet.iter + (fun s -> + fprintf oc "L%a$non_lazy_ptr:\n" raw_symbol s; + fprintf oc " .indirect_symbol %a\n" raw_symbol s; + fprintf oc " .long 0\n") + !indirect_symbols; + indirect_symbols := StringSet.empty + end let print_comm_decl oc name sz al = fprintf oc " .comm %a, %s, %d\n" @@ -269,27 +239,39 @@ module Target(System: SYSTEM):TARGET = let symbol_offset oc (symb, ofs) = symbol oc symb; - if ofs <> 0l then fprintf oc " + %ld" ofs - + let ofs = Z.to_int64 ofs in + if ofs <> 0L then fprintf oc " + %Ld" ofs - let addressing oc (Addrmode(base, shift, cst)) = + let addressing_gen ireg oc (Addrmode(base, shift, cst)) = begin match cst with | Coq_inl n -> - let n = camlint_of_coqint n in - fprintf oc "%ld" n + fprintf oc "%s" (Z.to_string n) | Coq_inr(id, ofs) -> - let ofs = camlint_of_coqint ofs in - if ofs = 0l - then symbol oc id - else fprintf oc "(%a + %ld)" symbol id ofs + if Archi.ptr64 then begin + (* RIP-relative addressing *) + let ofs' = Z.to_int64 ofs in + if ofs' = 0L + then fprintf oc "%a(%%rip)" symbol id + else fprintf oc "(%a + %Ld)(%%rip)" symbol id ofs' + end else begin + (* Absolute addressing *) + let ofs' = Z.to_int32 ofs in + if ofs' = 0l + then fprintf oc "%a" symbol id + else fprintf oc "(%a + %ld)" symbol id ofs' + end end; begin match base, shift with | None, None -> () | Some r1, None -> fprintf oc "(%a)" ireg r1 - | None, Some(r2,sc) -> fprintf oc "(,%a,%a)" ireg r2 coqint sc - | Some r1, Some(r2,sc) -> fprintf oc "(%a,%a,%a)" ireg r1 ireg r2 coqint sc + | None, Some(r2,sc) -> fprintf oc "(,%a,%a)" ireg r2 z sc + | Some r1, Some(r2,sc) -> fprintf oc "(%a,%a,%a)" ireg r1 ireg r2 z sc end + let addressing32 = addressing_gen ireg32 + let addressing64 = addressing_gen ireg64 + let addressing = addressing_gen ireg + let name_of_condition = function | Cond_e -> "e" | Cond_ne -> "ne" | Cond_b -> "b" | Cond_be -> "be" | Cond_ae -> "ae" | Cond_a -> "a" @@ -308,7 +290,7 @@ module Target(System: SYSTEM):TARGET = let section oc sec = fprintf oc " %s\n" (name_of_section sec) -(* Emit a align directive *) +(* For "abs" and "neg" FP operations *) let need_masks = ref false @@ -317,15 +299,28 @@ module Target(System: SYSTEM):TARGET = let print_file_line oc file line = print_file_line oc comment file line +(* In 64-bit mode use RIP-relative addressing to designate labels *) + + let rip_rel = + if Archi.ptr64 then "(%rip)" else "" + +(* Large 64-bit immediates (bigger than a 32-bit signed integer) are + not supported by the processor. Turn them into memory operands. *) + + let intconst64 oc n = + let n1 = camlint64_of_coqint n in + let n2 = Int64.to_int32 n1 in + if n1 = Int64.of_int32 n2 then + (* fit in a 32-bit signed integer, can use as immediate *) + fprintf oc "$%ld" n2 + else begin + (* put the constant in memory and use a PC-relative memory operand *) + let lbl = new_label() in + float64_literals := (lbl, n1) :: !float64_literals; + fprintf oc "%a(%%rip)" label lbl + end -(* Built-in functions *) - -(* Built-ins. They come in two flavors: - - annotation statements: take their arguments in registers or stack - locations; generate no code; - - inlined by the compiler: take their arguments in arbitrary - registers; preserve all registers except ECX, EDX, XMM6 and XMM7. *) (* Printing of instructions *) @@ -334,21 +329,44 @@ module Target(System: SYSTEM):TARGET = let print_instruction oc = function (* Moves *) | Pmov_rr(rd, r1) -> - fprintf oc " movl %a, %a\n" ireg r1 ireg rd - | Pmov_ri(rd, n) -> - fprintf oc " movl $%ld, %a\n" (camlint_of_coqint n) ireg rd - | Pmov_ra(rd, id) -> - print_mov_ra oc rd id - | Pmov_rm(rd, a) | Pmov_rm_a(rd, a) -> - fprintf oc " movl %a, %a\n" addressing a ireg rd - | Pmov_mr(a, r1) | Pmov_mr_a(a, r1) -> - fprintf oc " movl %a, %a\n" ireg r1 addressing a + if Archi.ptr64 + then fprintf oc " movq %a, %a\n" ireg64 r1 ireg64 rd + else fprintf oc " movl %a, %a\n" ireg32 r1 ireg32 rd + | Pmovl_ri(rd, n) -> + fprintf oc " movl $%ld, %a\n" (camlint_of_coqint n) ireg32 rd + | Pmovq_ri(rd, n) -> + let n1 = camlint64_of_coqint n in + let n2 = Int64.to_int32 n1 in + if n1 = Int64.of_int32 n2 then + fprintf oc " movq $%ld, %a\n" n2 ireg64 rd + else + fprintf oc " movabsq $%Ld, %a\n" n1 ireg64 rd + | Pmov_rs(rd, id) -> + print_mov_rs oc rd id + | Pmovl_rm(rd, a) -> + fprintf oc " movl %a, %a\n" addressing a ireg32 rd + | Pmovq_rm(rd, a) -> + fprintf oc " movq %a, %a\n" addressing a ireg64 rd + | Pmov_rm_a(rd, a) -> + if Archi.ptr64 + then fprintf oc " movq %a, %a\n" addressing a ireg64 rd + else fprintf oc " movl %a, %a\n" addressing a ireg32 rd + | Pmovl_mr(a, r1) -> + fprintf oc " movl %a, %a\n" ireg32 r1 addressing a + | Pmovq_mr(a, r1) -> + fprintf oc " movq %a, %a\n" ireg64 r1 addressing a + | Pmov_mr_a(a, r1) -> + if Archi.ptr64 + then fprintf oc " movq %a, %a\n" ireg64 r1 addressing a + else fprintf oc " movl %a, %a\n" ireg32 r1 addressing a | Pmovsd_ff(rd, r1) -> fprintf oc " movapd %a, %a\n" freg r1 freg rd | Pmovsd_fi(rd, n) -> let b = camlint64_of_coqint (Floats.Float.to_bits n) in let lbl = new_label() in - fprintf oc " movsd %a, %a %s %.18g\n" label lbl freg rd comment (camlfloat_of_coqfloat n); + fprintf oc " movsd %a%s, %a %s %.18g\n" + label lbl rip_rel + freg rd comment (camlfloat_of_coqfloat n); float64_literals := (lbl, b) :: !float64_literals | Pmovsd_fm(rd, a) | Pmovsd_fm_a(rd, a) -> fprintf oc " movsd %a, %a\n" addressing a freg rd @@ -357,7 +375,9 @@ module Target(System: SYSTEM):TARGET = | Pmovss_fi(rd, n) -> let b = camlint_of_coqint (Floats.Float32.to_bits n) in let lbl = new_label() in - fprintf oc " movss %a, %a %s %.18g\n" label lbl freg rd comment (camlfloat_of_coqfloat32 n); + fprintf oc " movss %a%s, %a %s %.18g\n" + label lbl rip_rel + freg rd comment (camlfloat_of_coqfloat32 n); float32_literals := (lbl, b) :: !float32_literals | Pmovss_fm(rd, a) -> fprintf oc " movss %a, %a\n" addressing a freg rd @@ -366,112 +386,187 @@ module Target(System: SYSTEM):TARGET = | Pfldl_m(a) -> fprintf oc " fldl %a\n" addressing a | Pfstpl_m(a) -> - fprintf oc " fstpl %a\n" addressing a + fprintf oc " fstpl %a\n" addressing a | Pflds_m(a) -> fprintf oc " flds %a\n" addressing a | Pfstps_m(a) -> fprintf oc " fstps %a\n" addressing a - | Pxchg_rr(r1, r2) -> - fprintf oc " xchgl %a, %a\n" ireg r1 ireg r2 (* Moves with conversion *) | Pmovb_mr(a, r1) -> fprintf oc " movb %a, %a\n" ireg8 r1 addressing a | Pmovw_mr(a, r1) -> fprintf oc " movw %a, %a\n" ireg16 r1 addressing a | Pmovzb_rr(rd, r1) -> - fprintf oc " movzbl %a, %a\n" ireg8 r1 ireg rd + fprintf oc " movzbl %a, %a\n" ireg8 r1 ireg32 rd | Pmovzb_rm(rd, a) -> - fprintf oc " movzbl %a, %a\n" addressing a ireg rd + fprintf oc " movzbl %a, %a\n" addressing a ireg32 rd | Pmovsb_rr(rd, r1) -> - fprintf oc " movsbl %a, %a\n" ireg8 r1 ireg rd + fprintf oc " movsbl %a, %a\n" ireg8 r1 ireg32 rd | Pmovsb_rm(rd, a) -> - fprintf oc " movsbl %a, %a\n" addressing a ireg rd + fprintf oc " movsbl %a, %a\n" addressing a ireg32 rd | Pmovzw_rr(rd, r1) -> - fprintf oc " movzwl %a, %a\n" ireg16 r1 ireg rd + fprintf oc " movzwl %a, %a\n" ireg16 r1 ireg32 rd | Pmovzw_rm(rd, a) -> - fprintf oc " movzwl %a, %a\n" addressing a ireg rd + fprintf oc " movzwl %a, %a\n" addressing a ireg32 rd | Pmovsw_rr(rd, r1) -> - fprintf oc " movswl %a, %a\n" ireg16 r1 ireg rd + fprintf oc " movswl %a, %a\n" ireg16 r1 ireg32 rd | Pmovsw_rm(rd, a) -> - fprintf oc " movswl %a, %a\n" addressing a ireg rd + fprintf oc " movswl %a, %a\n" addressing a ireg32 rd + | Pmovzl_rr(rd, r1) -> + fprintf oc " movl %a, %a\n" ireg32 r1 ireg32 rd + (* movl sets the high 32 bits of the destination to zero *) + | Pmovsl_rr(rd, r1) -> + fprintf oc " movslq %a, %a\n" ireg32 r1 ireg64 rd + | Pmovls_rr(rd) -> + () (* nothing to do *) | Pcvtsd2ss_ff(rd, r1) -> fprintf oc " cvtsd2ss %a, %a\n" freg r1 freg rd | Pcvtss2sd_ff(rd, r1) -> fprintf oc " cvtss2sd %a, %a\n" freg r1 freg rd | Pcvttsd2si_rf(rd, r1) -> - fprintf oc " cvttsd2si %a, %a\n" freg r1 ireg rd + fprintf oc " cvttsd2si %a, %a\n" freg r1 ireg32 rd | Pcvtsi2sd_fr(rd, r1) -> - fprintf oc " cvtsi2sd %a, %a\n" ireg r1 freg rd + fprintf oc " cvtsi2sd %a, %a\n" ireg32 r1 freg rd | Pcvttss2si_rf(rd, r1) -> - fprintf oc " cvttss2si %a, %a\n" freg r1 ireg rd + fprintf oc " cvttss2si %a, %a\n" freg r1 ireg32 rd | Pcvtsi2ss_fr(rd, r1) -> - fprintf oc " cvtsi2ss %a, %a\n" ireg r1 freg rd + fprintf oc " cvtsi2ss %a, %a\n" ireg32 r1 freg rd + | Pcvttsd2sl_rf(rd, r1) -> + fprintf oc " cvttsd2si %a, %a\n" freg r1 ireg64 rd + | Pcvtsl2sd_fr(rd, r1) -> + fprintf oc " cvtsi2sdq %a, %a\n" ireg64 r1 freg rd + | Pcvttss2sl_rf(rd, r1) -> + fprintf oc " cvttss2si %a, %a\n" freg r1 ireg64 rd + | Pcvtsl2ss_fr(rd, r1) -> + fprintf oc " cvtsi2ssq %a, %a\n" ireg64 r1 freg rd (* Arithmetic and logical operations over integers *) - | Plea(rd, a) -> - fprintf oc " leal %a, %a\n" addressing a ireg rd - | Pneg(rd) -> - fprintf oc " negl %a\n" ireg rd - | Psub_rr(rd, r1) -> - fprintf oc " subl %a, %a\n" ireg r1 ireg rd - | Pimul_rr(rd, r1) -> - fprintf oc " imull %a, %a\n" ireg r1 ireg rd - | Pimul_ri(rd, n) -> - fprintf oc " imull $%a, %a\n" coqint n ireg rd - | Pimul_r(r1) -> - fprintf oc " imull %a\n" ireg r1 - | Pmul_r(r1) -> - fprintf oc " mull %a\n" ireg r1 + | Pleal(rd, a) -> + fprintf oc " leal %a, %a\n" addressing32 a ireg32 rd + | Pleaq(rd, a) -> + fprintf oc " leaq %a, %a\n" addressing64 a ireg64 rd + | Pnegl(rd) -> + fprintf oc " negl %a\n" ireg32 rd + | Pnegq(rd) -> + fprintf oc " negq %a\n" ireg64 rd + | Paddl_ri (res,n) -> + fprintf oc " addl $%ld, %a\n" (camlint_of_coqint n) ireg32 res + | Paddq_ri (res,n) -> + fprintf oc " addq %a, %a\n" intconst64 n ireg64 res + | Psubl_rr(rd, r1) -> + fprintf oc " subl %a, %a\n" ireg32 r1 ireg32 rd + | Psubq_rr(rd, r1) -> + fprintf oc " subq %a, %a\n" ireg64 r1 ireg64 rd + | Pimull_rr(rd, r1) -> + fprintf oc " imull %a, %a\n" ireg32 r1 ireg32 rd + | Pimulq_rr(rd, r1) -> + fprintf oc " imulq %a, %a\n" ireg64 r1 ireg64 rd + | Pimull_ri(rd, n) -> + fprintf oc " imull $%a, %a\n" coqint n ireg32 rd + | Pimulq_ri(rd, n) -> + fprintf oc " imulq %a, %a\n" intconst64 n ireg64 rd + | Pimull_r(r1) -> + fprintf oc " imull %a\n" ireg32 r1 + | Pimulq_r(r1) -> + fprintf oc " imulq %a\n" ireg64 r1 + | Pmull_r(r1) -> + fprintf oc " mull %a\n" ireg32 r1 + | Pmulq_r(r1) -> + fprintf oc " mulq %a\n" ireg64 r1 | Pcltd -> fprintf oc " cltd\n" - | Pdiv(r1) -> - fprintf oc " divl %a\n" ireg r1 - | Pidiv(r1) -> - fprintf oc " idivl %a\n" ireg r1 - | Pand_rr(rd, r1) -> - fprintf oc " andl %a, %a\n" ireg r1 ireg rd - | Pand_ri(rd, n) -> - fprintf oc " andl $%a, %a\n" coqint n ireg rd - | Por_rr(rd, r1) -> - fprintf oc " orl %a, %a\n" ireg r1 ireg rd - | Por_ri(rd, n) -> - fprintf oc " orl $%a, %a\n" coqint n ireg rd - | Pxor_r(rd) -> - fprintf oc " xorl %a, %a\n" ireg rd ireg rd - | Pxor_rr(rd, r1) -> - fprintf oc " xorl %a, %a\n" ireg r1 ireg rd - | Pxor_ri(rd, n) -> - fprintf oc " xorl $%a, %a\n" coqint n ireg rd - | Pnot(rd) -> - fprintf oc " notl %a\n" ireg rd - | Psal_rcl(rd) -> - fprintf oc " sall %%cl, %a\n" ireg rd - | Psal_ri(rd, n) -> - fprintf oc " sall $%a, %a\n" coqint n ireg rd - | Pshr_rcl(rd) -> - fprintf oc " shrl %%cl, %a\n" ireg rd - | Pshr_ri(rd, n) -> - fprintf oc " shrl $%a, %a\n" coqint n ireg rd - | Psar_rcl(rd) -> - fprintf oc " sarl %%cl, %a\n" ireg rd - | Psar_ri(rd, n) -> - fprintf oc " sarl $%a, %a\n" coqint n ireg rd + | Pcqto -> + fprintf oc " cqto\n"; + | Pdivl(r1) -> + fprintf oc " divl %a\n" ireg32 r1 + | Pdivq(r1) -> + fprintf oc " divq %a\n" ireg64 r1 + | Pidivl(r1) -> + fprintf oc " idivl %a\n" ireg32 r1 + | Pidivq(r1) -> + fprintf oc " idivq %a\n" ireg64 r1 + | Pandl_rr(rd, r1) -> + fprintf oc " andl %a, %a\n" ireg32 r1 ireg32 rd + | Pandq_rr(rd, r1) -> + fprintf oc " andq %a, %a\n" ireg64 r1 ireg64 rd + | Pandl_ri(rd, n) -> + fprintf oc " andl $%a, %a\n" coqint n ireg32 rd + | Pandq_ri(rd, n) -> + fprintf oc " andq %a, %a\n" intconst64 n ireg64 rd + | Porl_rr(rd, r1) -> + fprintf oc " orl %a, %a\n" ireg32 r1 ireg32 rd + | Porq_rr(rd, r1) -> + fprintf oc " orq %a, %a\n" ireg64 r1 ireg64 rd + | Porl_ri(rd, n) -> + fprintf oc " orl $%a, %a\n" coqint n ireg32 rd + | Porq_ri(rd, n) -> + fprintf oc " orq %a, %a\n" intconst64 n ireg64 rd + | Pxorl_r(rd) -> + fprintf oc " xorl %a, %a\n" ireg32 rd ireg32 rd + | Pxorq_r(rd) -> + fprintf oc " xorq %a, %a\n" ireg64 rd ireg64 rd + | Pxorl_rr(rd, r1) -> + fprintf oc " xorl %a, %a\n" ireg32 r1 ireg32 rd + | Pxorq_rr(rd, r1) -> + fprintf oc " xorq %a, %a\n" ireg64 r1 ireg64 rd + | Pxorl_ri(rd, n) -> + fprintf oc " xorl $%a, %a\n" coqint n ireg32 rd + | Pxorq_ri(rd, n) -> + fprintf oc " xorq %a, %a\n" intconst64 n ireg64 rd + | Pnotl(rd) -> + fprintf oc " notl %a\n" ireg32 rd + | Pnotq(rd) -> + fprintf oc " notq %a\n" ireg64 rd + | Psall_rcl(rd) -> + fprintf oc " sall %%cl, %a\n" ireg32 rd + | Psalq_rcl(rd) -> + fprintf oc " salq %%cl, %a\n" ireg64 rd + | Psall_ri(rd, n) -> + fprintf oc " sall $%a, %a\n" coqint n ireg32 rd + | Psalq_ri(rd, n) -> + fprintf oc " salq $%a, %a\n" coqint n ireg64 rd + | Pshrl_rcl(rd) -> + fprintf oc " shrl %%cl, %a\n" ireg32 rd + | Pshrq_rcl(rd) -> + fprintf oc " shrq %%cl, %a\n" ireg64 rd + | Pshrl_ri(rd, n) -> + fprintf oc " shrl $%a, %a\n" coqint n ireg32 rd + | Pshrq_ri(rd, n) -> + fprintf oc " shrq $%a, %a\n" coqint n ireg64 rd + | Psarl_rcl(rd) -> + fprintf oc " sarl %%cl, %a\n" ireg32 rd + | Psarq_rcl(rd) -> + fprintf oc " sarq %%cl, %a\n" ireg64 rd + | Psarl_ri(rd, n) -> + fprintf oc " sarl $%a, %a\n" coqint n ireg32 rd + | Psarq_ri(rd, n) -> + fprintf oc " sarq $%a, %a\n" coqint n ireg64 rd | Pshld_ri(rd, r1, n) -> - fprintf oc " shldl $%a, %a, %a\n" coqint n ireg r1 ireg rd - | Pror_ri(rd, n) -> - fprintf oc " rorl $%a, %a\n" coqint n ireg rd - | Pcmp_rr(r1, r2) -> - fprintf oc " cmpl %a, %a\n" ireg r2 ireg r1 - | Pcmp_ri(r1, n) -> - fprintf oc " cmpl $%a, %a\n" coqint n ireg r1 - | Ptest_rr(r1, r2) -> - fprintf oc " testl %a, %a\n" ireg r2 ireg r1 - | Ptest_ri(r1, n) -> - fprintf oc " testl $%a, %a\n" coqint n ireg r1 + fprintf oc " shldl $%a, %a, %a\n" coqint n ireg32 r1 ireg32 rd + | Prorl_ri(rd, n) -> + fprintf oc " rorl $%a, %a\n" coqint n ireg32 rd + | Prorq_ri(rd, n) -> + fprintf oc " rorq $%a, %a\n" coqint n ireg64 rd + | Pcmpl_rr(r1, r2) -> + fprintf oc " cmpl %a, %a\n" ireg32 r2 ireg32 r1 + | Pcmpq_rr(r1, r2) -> + fprintf oc " cmpq %a, %a\n" ireg64 r2 ireg64 r1 + | Pcmpl_ri(r1, n) -> + fprintf oc " cmpl $%a, %a\n" coqint n ireg32 r1 + | Pcmpq_ri(r1, n) -> + fprintf oc " cmpq %a, %a\n" intconst64 n ireg64 r1 + | Ptestl_rr(r1, r2) -> + fprintf oc " testl %a, %a\n" ireg32 r2 ireg32 r1 + | Ptestq_rr(r1, r2) -> + fprintf oc " testq %a, %a\n" ireg64 r2 ireg64 r1 + | Ptestl_ri(r1, n) -> + fprintf oc " testl $%a, %a\n" coqint n ireg32 r1 + | Ptestq_ri(r1, n) -> + fprintf oc " testl %a, %a\n" intconst64 n ireg64 r1 | Pcmov(c, rd, r1) -> fprintf oc " cmov%s %a, %a\n" (name_of_condition c) ireg r1 ireg rd | Psetcc(c, rd) -> fprintf oc " set%s %a\n" (name_of_condition c) ireg8 rd; - fprintf oc " movzbl %a, %a\n" ireg8 rd ireg rd + fprintf oc " movzbl %a, %a\n" ireg8 rd ireg32 rd (* Arithmetic operations over floats *) | Paddd_ff(rd, r1) -> fprintf oc " addsd %a, %a\n" freg r1 freg rd @@ -483,10 +578,12 @@ module Target(System: SYSTEM):TARGET = fprintf oc " divsd %a, %a\n" freg r1 freg rd | Pnegd (rd) -> need_masks := true; - fprintf oc " xorpd %a, %a\n" raw_symbol "__negd_mask" freg rd + fprintf oc " xorpd %a%s, %a\n" + raw_symbol "__negd_mask" rip_rel freg rd | Pabsd (rd) -> need_masks := true; - fprintf oc " andpd %a, %a\n" raw_symbol "__absd_mask" freg rd + fprintf oc " andpd %a%s, %a\n" + raw_symbol "__absd_mask" rip_rel freg rd | Pcomisd_ff(r1, r2) -> fprintf oc " comisd %a, %a\n" freg r2 freg r1 | Pxorpd_f (rd) -> @@ -501,10 +598,12 @@ module Target(System: SYSTEM):TARGET = fprintf oc " divss %a, %a\n" freg r1 freg rd | Pnegs (rd) -> need_masks := true; - fprintf oc " xorpd %a, %a\n" raw_symbol "__negs_mask" freg rd + fprintf oc " xorpd %a%s, %a\n" + raw_symbol "__negs_mask" rip_rel freg rd | Pabss (rd) -> need_masks := true; - fprintf oc " andpd %a, %a\n" raw_symbol "__abss_mask" freg rd + fprintf oc " andpd %a%s, %a\n" + raw_symbol "__abss_mask" rip_rel freg rd | Pcomiss_ff(r1, r2) -> fprintf oc " comiss %a, %a\n" freg r2 freg r1 | Pxorps_f (rd) -> @@ -513,10 +612,8 @@ module Target(System: SYSTEM):TARGET = | Pjmp_l(l) -> fprintf oc " jmp %a\n" label (transl_label l) | Pjmp_s(f, sg) -> - assert (not sg.sig_cc.cc_structret); fprintf oc " jmp %a\n" symbol f | Pjmp_r(r, sg) -> - assert (not sg.sig_cc.cc_structret); fprintf oc " jmp *%a\n" ireg r | Pjcc(c, l) -> let l = transl_label l in @@ -529,40 +626,54 @@ module Target(System: SYSTEM):TARGET = fprintf oc "%a:\n" label l' | Pjmptbl(r, tbl) -> let l = new_label() in - fprintf oc " jmp *%a(, %a, 4)\n" label l ireg r; - jumptables := (l, tbl) :: !jumptables + jumptables := (l, tbl) :: !jumptables; + if Archi.ptr64 then begin + let (tmp1, tmp2) = + if r = RAX then (RDX, RAX) else (RAX, RDX) in + fprintf oc " leaq %a(%%rip), %a\n" label l ireg tmp1; + fprintf oc " movslq (%a, %a, 4), %a\n" ireg tmp1 ireg r ireg tmp2; + fprintf oc " addq %a, %a\n" ireg tmp2 ireg tmp1; + fprintf oc " jmp *%a\n" ireg tmp1 + end else begin + fprintf oc " jmp *%a(, %a, 4)\n" label l ireg r + end | Pcall_s(f, sg) -> fprintf oc " call %a\n" symbol f; - if sg.sig_cc.cc_structret then + if (not Archi.ptr64) && sg.sig_cc.cc_structret then fprintf oc " pushl %%eax\n" | Pcall_r(r, sg) -> fprintf oc " call *%a\n" ireg r; - if sg.sig_cc.cc_structret then + if (not Archi.ptr64) && sg.sig_cc.cc_structret then fprintf oc " pushl %%eax\n" | Pret -> - if (!current_function_sig).sig_cc.cc_structret then begin + if (not Archi.ptr64) + && (!current_function_sig).sig_cc.cc_structret then begin fprintf oc " movl 0(%%esp), %%eax\n"; fprintf oc " ret $4\n" end else begin fprintf oc " ret\n" end (* Instructions produced by Asmexpand *) - | Padc_ri (res,n) -> - fprintf oc " adcl $%ld, %a\n" (camlint_of_coqint n) ireg res; - | Padc_rr (res,a1) -> - fprintf oc " adcl %a, %a\n" ireg a1 ireg res; - | Padd_ri (res,n) -> - fprintf oc " addl $%ld, %a\n" (camlint_of_coqint n) ireg res - | Padd_rr (res,a1) -> - fprintf oc " addl %a, %a\n" ireg a1 ireg res; - | Padd_mi (addr,n) -> + | Padcl_ri (res,n) -> + fprintf oc " adcl $%ld, %a\n" (camlint_of_coqint n) ireg32 res; + | Padcl_rr (res,a1) -> + fprintf oc " adcl %a, %a\n" ireg32 a1 ireg32 res; + | Paddl_rr (res,a1) -> + fprintf oc " addl %a, %a\n" ireg32 a1 ireg32 res; + | Paddl_mi (addr,n) -> fprintf oc " addl $%ld, %a\n" (camlint_of_coqint n) addressing addr - | Pbsf (res,a1) -> - fprintf oc " bsfl %a, %a\n" ireg a1 ireg res - | Pbsr (res,a1) -> - fprintf oc " bsrl %a, %a\n" ireg a1 ireg res - | Pbswap res -> - fprintf oc " bswap %a\n" ireg res + | Pbsfl (res,a1) -> + fprintf oc " bsfl %a, %a\n" ireg32 a1 ireg32 res + | Pbsfq (res,a1) -> + fprintf oc " bsfq %a, %a\n" ireg64 a1 ireg64 res + | Pbsrl (res,a1) -> + fprintf oc " bsrl %a, %a\n" ireg32 a1 ireg32 res + | Pbsrq (res,a1) -> + fprintf oc " bsrq %a, %a\n" ireg64 a1 ireg64 res + | Pbswap64 res -> + fprintf oc " bswap %a\n" ireg64 res + | Pbswap32 res -> + fprintf oc " bswap %a\n" ireg32 res | Pbswap16 res -> fprintf oc " rolw $8, %a\n" ireg16 res | Pcfi_adjust sz -> @@ -597,9 +708,9 @@ module Target(System: SYSTEM):TARGET = fprintf oc " minsd %a, %a\n" freg a1 freg res | Pmovb_rm (rd,a) -> fprintf oc " movb %a, %a\n" addressing a ireg8 rd - | Pmovq_mr(a, rs) -> + | Pmovsq_mr(a, rs) -> fprintf oc " movq %a, %a\n" freg rs addressing a - | Pmovq_rm(rd, a) -> + | Pmovsq_rm(rd, a) -> fprintf oc " movq %a, %a\n" addressing a freg rd | Pmovsb -> fprintf oc " movsb\n"; @@ -609,12 +720,14 @@ module Target(System: SYSTEM):TARGET = fprintf oc " movw %a, %a\n" addressing a ireg16 rd | Prep_movsl -> fprintf oc " rep movsl\n" - | Psbb_rr (res,a1) -> - fprintf oc " sbbl %a, %a\n" ireg a1 ireg res + | Psbbl_rr (res,a1) -> + fprintf oc " sbbl %a, %a\n" ireg32 a1 ireg32 res | Psqrtsd (res,a1) -> fprintf oc " sqrtsd %a, %a\n" freg a1 freg res - | Psub_ri (res,n) -> - fprintf oc " subl $%ld, %a\n" (camlint_of_coqint n) ireg res; + | Psubl_ri (res,n) -> + fprintf oc " subl $%ld, %a\n" (camlint_of_coqint n) ireg32 res; + | Psubq_ri (res,n) -> + fprintf oc " subq %a, %a\n" intconst64 n ireg64 res; (* Pseudo-instructions *) | Plabel(l) -> fprintf oc "%a:\n" label (transl_label l) @@ -643,15 +756,20 @@ module Target(System: SYSTEM):TARGET = fprintf oc "%a: .long 0x%lx\n" label lbl n let print_jumptable oc jmptbl = - let print_jumptable oc (lbl, tbl) = + let print_jumptable (lbl, tbl) = + let print_entry l = + if Archi.ptr64 then + fprintf oc " .long %a - %a\n" label (transl_label l) label lbl + else + fprintf oc " .long %a\n" label (transl_label l) + in fprintf oc "%a:" label lbl; - List.iter - (fun l -> fprintf oc " .long %a\n" label (transl_label l)) - tbl in + List.iter print_entry tbl + in if !jumptables <> [] then begin section oc jmptbl; print_align oc 4; - List.iter (print_jumptable oc) !jumptables; + List.iter print_jumptable !jumptables; jumptables := [] end @@ -674,10 +792,9 @@ module Target(System: SYSTEM):TARGET = comment (camlfloat_of_coqfloat n) | Init_space n -> if Z.gt n Z.zero then - fprintf oc " .space %s\n" (Z.to_string n) + fprintf oc " .space %a\n" z n | Init_addrof(symb, ofs) -> - fprintf oc " .long %a\n" - symbol_offset (symb, camlint_of_coqint ofs) + fprintf oc " %s %a\n" data_pointer symbol_offset (symb, ofs) let print_align = print_align @@ -760,6 +877,5 @@ let sel_target () = | "macosx" -> (module MacOS_System:SYSTEM) | "linux" | "bsd" -> (module ELF_System:SYSTEM) - | "cygwin" -> (module Cygwin_System:SYSTEM) | _ -> invalid_arg ("System " ^ Configuration.system ^ " not supported") ):SYSTEM) in (module Target(S):TARGET) diff --git a/ia32/ValueAOp.v b/x86/ValueAOp.v index ad18c4f6..1021a9c8 100644 --- a/ia32/ValueAOp.v +++ b/x86/ValueAOp.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -10,19 +10,11 @@ (* *) (* *********************************************************************) -Require Import Coqlib. -Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Op. -Require Import ValueDomain. -Require Import RTL. +Require Import Coqlib Compopts. +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Op RTL ValueDomain. -(** Value analysis for IA32 operators *) +(** Value analysis for x86_64 operators *) Definition eval_static_condition (cond: condition) (vl: list aval): abool := match cond, vl with @@ -30,6 +22,10 @@ Definition eval_static_condition (cond: condition) (vl: list aval): abool := | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2 | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n) | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n) + | Ccompl c, v1 :: v2 :: nil => cmpl_bool c v1 v2 + | Ccomplu c, v1 :: v2 :: nil => cmplu_bool c v1 v2 + | Ccomplimm c n, v1 :: nil => cmpl_bool c v1 (L n) + | Ccompluimm c n, v1 :: nil => cmplu_bool c v1 (L n) | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2 | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2) | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2 @@ -39,26 +35,45 @@ Definition eval_static_condition (cond: condition) (vl: list aval): abool := | _, _ => Bnone end. -Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := +Definition eval_static_addressing_32 (addr: addressing) (vl: list aval): aval := match addr, vl with - | Aindexed n, v1::nil => add v1 (I n) - | Aindexed2 n, v1::v2::nil => add (add v1 v2) (I n) - | Ascaled sc ofs, v1::nil => add (mul v1 (I sc)) (I ofs) - | Aindexed2scaled sc ofs, v1::v2::nil => add v1 (add (mul v2 (I sc)) (I ofs)) + | Aindexed n, v1::nil => add v1 (I (Int.repr n)) + | Aindexed2 n, v1::v2::nil => add (add v1 v2) (I (Int.repr n)) + | Ascaled sc ofs, v1::nil => add (mul v1 (I (Int.repr sc))) (I (Int.repr ofs)) + | Aindexed2scaled sc ofs, v1::v2::nil => add v1 (add (mul v2 (I (Int.repr sc))) (I (Int.repr ofs))) | Aglobal s ofs, nil => Ptr (Gl s ofs) | Abased s ofs, v1::nil => add (Ptr (Gl s ofs)) v1 - | Abasedscaled sc s ofs, v1::nil => add (Ptr (Gl s ofs)) (mul v1 (I sc)) + | Abasedscaled sc s ofs, v1::nil => add (Ptr (Gl s ofs)) (mul v1 (I (Int.repr sc))) + | Ainstack ofs, nil => Ptr(Stk ofs) + | _, _ => Vbot + end. + +Definition eval_static_addressing_64 (addr: addressing) (vl: list aval): aval := + match addr, vl with + | Aindexed n, v1::nil => addl v1 (L (Int64.repr n)) + | Aindexed2 n, v1::v2::nil => addl (addl v1 v2) (L (Int64.repr n)) + | Ascaled sc ofs, v1::nil => addl (mull v1 (L (Int64.repr sc))) (L (Int64.repr ofs)) + | Aindexed2scaled sc ofs, v1::v2::nil => addl v1 (addl (mull v2 (L (Int64.repr sc))) (L (Int64.repr ofs))) + | Aglobal s ofs, nil => Ptr (Gl s ofs) + | Abased s ofs, v1::nil => addl (Ptr (Gl s ofs)) v1 + | Abasedscaled sc s ofs, v1::nil => addl (Ptr (Gl s ofs)) (mull v1 (L (Int64.repr sc))) | Ainstack ofs, nil => Ptr(Stk ofs) | _, _ => Vbot end. +Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := + if Archi.ptr64 + then eval_static_addressing_64 addr vl + else eval_static_addressing_32 addr vl. + Definition eval_static_operation (op: operation) (vl: list aval): aval := match op, vl with | Omove, v1::nil => v1 | Ointconst n, nil => I n + | Olongconst n, nil => L n | Ofloatconst n, nil => if propagate_float_constants tt then F n else ntop | Osingleconst n, nil => if propagate_float_constants tt then FS n else ntop - | Oindirectsymbol id, nil => Ifptr (Gl id Int.zero) + | Oindirectsymbol id, nil => Ifptr (Gl id Ptrofs.zero) | Ocast8signed, v1 :: nil => sign_ext 8 v1 | Ocast8unsigned, v1 :: nil => zero_ext 8 v1 | Ocast16signed, v1 :: nil => sign_ext 16 v1 @@ -89,7 +104,39 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Oshruimm n, v1::nil => shru v1 (I n) | Ororimm n, v1::nil => ror v1 (I n) | Oshldimm n, v1::v2::nil => or (shl v1 (I n)) (shru v2 (I (Int.sub Int.iwordsize n))) - | Olea addr, _ => eval_static_addressing addr vl + | Olea addr, _ => eval_static_addressing_32 addr vl + | Omakelong, v1::v2::nil => longofwords v1 v2 + | Olowlong, v1::nil => loword v1 + | Ohighlong, v1::nil => hiword v1 + | Ocast32signed, v1::nil => longofint v1 + | Ocast32unsigned, v1::nil => longofintu v1 + | Onegl, v1::nil => negl v1 + | Oaddlimm n, v1::nil => addl v1 (L n) + | Osubl, v1::v2::nil => subl v1 v2 + | Omull, v1::v2::nil => mull v1 v2 + | Omullimm n, v1::nil => mull v1 (L n) + | Omullhs, v1::v2::nil => mullhs v1 v2 + | Omullhu, v1::v2::nil => mullhu v1 v2 + | Odivl, v1::v2::nil => divls v1 v2 + | Odivlu, v1::v2::nil => divlu v1 v2 + | Omodl, v1::v2::nil => modls v1 v2 + | Omodlu, v1::v2::nil => modlu v1 v2 + | Oandl, v1::v2::nil => andl v1 v2 + | Oandlimm n, v1::nil => andl v1 (L n) + | Oorl, v1::v2::nil => orl v1 v2 + | Oorlimm n, v1::nil => orl v1 (L n) + | Oxorl, v1::v2::nil => xorl v1 v2 + | Oxorlimm n, v1::nil => xorl v1 (L n) + | Onotl, v1::nil => notl v1 + | Oshll, v1::v2::nil => shll v1 v2 + | Oshllimm n, v1::nil => shll v1 (I n) + | Oshrl, v1::v2::nil => shrl v1 v2 + | Oshrlimm n, v1::nil => shrl v1 (I n) + | Oshrxlimm n, v1::nil => shrxl v1 (I n) + | Oshrlu, v1::v2::nil => shrlu v1 v2 + | Oshrluimm n, v1::nil => shrlu v1 (I n) + | Ororlimm n, v1::nil => rorl v1 (I n) + | Oleal addr, _ => eval_static_addressing_64 addr vl | Onegf, v1::nil => negf v1 | Oabsf, v1::nil => absf v1 | Oaddf, v1::v2::nil => addf v1 v2 @@ -108,9 +155,10 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Ofloatofint, v1::nil => floatofint v1 | Ointofsingle, v1::nil => intofsingle v1 | Osingleofint, v1::nil => singleofint v1 - | Omakelong, v1::v2::nil => longofwords v1 v2 - | Olowlong, v1::nil => loword v1 - | Ohighlong, v1::nil => hiword v1 + | Olongoffloat, v1::nil => longoffloat v1 + | Ofloatoflong, v1::nil => floatoflong v1 + | Olongofsingle, v1::nil => longofsingle v1 + | Osingleoflong, v1::nil => singleoflong v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) | _, _ => Vbot end. @@ -128,8 +176,7 @@ Theorem eval_static_condition_sound: list_forall2 (vmatch bc) vargs aargs -> cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs). Proof. - intros until aargs; intros VM. - inv VM. + intros until aargs; intros VM. inv VM. destruct cond; auto with va. inv H0. destruct cond; simpl; eauto with va. @@ -162,23 +209,45 @@ Ltac InvHyps := | [H: Some _ = Some _ |- _] => inv H | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ , H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps + | [H: (if Archi.ptr64 then _ else _) = Some _ |- _] => destruct Archi.ptr64 eqn:?; InvHyps | _ => idtac end. +Theorem eval_static_addressing_32_sound: + forall addr vargs vres aargs, + eval_addressing32 ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> + list_forall2 (vmatch bc) vargs aargs -> + vmatch bc vres (eval_static_addressing_32 addr aargs). +Proof. + unfold eval_addressing32, eval_static_addressing_32; intros; + destruct addr; InvHyps; eauto with va. + rewrite Ptrofs.add_zero_l; eauto with va. +Qed. + +Theorem eval_static_addressing_64_sound: + forall addr vargs vres aargs, + eval_addressing64 ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> + list_forall2 (vmatch bc) vargs aargs -> + vmatch bc vres (eval_static_addressing_64 addr aargs). +Proof. + unfold eval_addressing64, eval_static_addressing_64; intros; + destruct addr; InvHyps; eauto with va. + rewrite Ptrofs.add_zero_l; eauto with va. +Qed. + Theorem eval_static_addressing_sound: forall addr vargs vres aargs, - eval_addressing ge (Vptr sp Int.zero) addr vargs = Some vres -> + eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> list_forall2 (vmatch bc) vargs aargs -> vmatch bc vres (eval_static_addressing addr aargs). Proof. - unfold eval_addressing, eval_static_addressing; intros; - destruct addr; InvHyps; eauto with va. - rewrite Int.add_zero_l; auto with va. + unfold eval_addressing, eval_static_addressing; intros. + destruct Archi.ptr64; eauto using eval_static_addressing_32_sound, eval_static_addressing_64_sound. Qed. Theorem eval_static_operation_sound: forall op vargs m vres aargs, - eval_operation ge (Vptr sp Int.zero) op vargs m = Some vres -> + eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> list_forall2 (vmatch bc) vargs aargs -> vmatch bc vres (eval_static_operation op aargs). Proof. @@ -186,7 +255,8 @@ Proof. destruct op; InvHyps; eauto with va. destruct (propagate_float_constants tt); constructor. destruct (propagate_float_constants tt); constructor. - eapply eval_static_addressing_sound; eauto. + eapply eval_static_addressing_32_sound; eauto. + eapply eval_static_addressing_64_sound; eauto. apply of_optbool_sound. eapply eval_static_condition_sound; eauto. Qed. diff --git a/ia32/extractionMachdep.v b/x86/extractionMachdep.v index 3c6ee2e0..14cb6447 100644 --- a/ia32/extractionMachdep.v +++ b/x86/extractionMachdep.v @@ -10,11 +10,17 @@ (* *) (* *********************************************************************) -(* Additional extraction directives specific to the IA32 port *) +(* Additional extraction directives specific to the x86-64 port *) -Require SelectOp. +Require SelectOp ConstpropOp. (* SelectOp *) Extract Constant SelectOp.symbol_is_external => "fun id -> Configuration.system = ""macosx"" && C2C.atom_is_extern id". + +(* ConstpropOp *) + +Extract Constant ConstpropOp.symbol_is_external => + "fun id -> Configuration.system = ""macosx"" && C2C.atom_is_extern id". + diff --git a/x86_32/Archi.v b/x86_32/Archi.v new file mode 100644 index 00000000..29073be8 --- /dev/null +++ b/x86_32/Archi.v @@ -0,0 +1,54 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* Jacques-Henri Jourdan, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Architecture-dependent parameters for x86 in 32-bit mode *) + +Require Import ZArith. +Require Import Fappli_IEEE. +Require Import Fappli_IEEE_bits. + +Definition ptr64 := false. + +Definition big_endian := false. + +Definition align_int64 := 4%Z. +Definition align_float64 := 4%Z. + +Definition splitlong := negb ptr64. + +Lemma splitlong_ptr32: splitlong = true -> ptr64 = false. +Proof. + unfold splitlong. destruct ptr64; simpl; congruence. +Qed. + +Program Definition default_pl_64 : bool * nan_pl 53 := + (true, iter_nat 51 _ xO xH). + +Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) := + false. (**r always choose first NaN *) + +Program Definition default_pl_32 : bool * nan_pl 24 := + (true, iter_nat 22 _ xO xH). + +Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) := + false. (**r always choose first NaN *) + +Definition float_of_single_preserves_sNaN := false. + +Global Opaque ptr64 big_endian splitlong + default_pl_64 choose_binop_pl_64 + default_pl_32 choose_binop_pl_32 + float_of_single_preserves_sNaN. diff --git a/ia32/Archi.v b/x86_64/Archi.v index ded460d2..7b1136c8 100644 --- a/ia32/Archi.v +++ b/x86_64/Archi.v @@ -2,8 +2,8 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) +(* Jacques-Henri Jourdan, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -14,16 +14,25 @@ (* *) (* *********************************************************************) -(** Architecture-dependent parameters for IA32 *) +(** Architecture-dependent parameters for x86 in 64-bit mode *) Require Import ZArith. Require Import Fappli_IEEE. Require Import Fappli_IEEE_bits. +Definition ptr64 := true. + Definition big_endian := false. -Notation align_int64 := 4%Z (only parsing). -Notation align_float64 := 4%Z (only parsing). +Definition align_int64 := 8%Z. +Definition align_float64 := 8%Z. + +Definition splitlong := negb ptr64. + +Lemma splitlong_ptr32: splitlong = true -> ptr64 = false. +Proof. + unfold splitlong. destruct ptr64; simpl; congruence. +Qed. Program Definition default_pl_64 : bool * nan_pl 53 := (true, iter_nat 51 _ xO xH). @@ -39,7 +48,7 @@ Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_p Definition float_of_single_preserves_sNaN := false. -Global Opaque big_endian +Global Opaque ptr64 big_endian splitlong default_pl_64 choose_binop_pl_64 default_pl_32 choose_binop_pl_32 float_of_single_preserves_sNaN. |