diff options
76 files changed, 4834 insertions, 2557 deletions
@@ -14,8 +14,8 @@ lib/Ordered.vo lib/Ordered.glob lib/Ordered.v.beautified: lib/Ordered.v lib/Coql 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 +lib/Integers.vo lib/Integers.glob lib/Integers.v.beautified: lib/Integers.v lib/Coqlib.vo $(ARCH)/Archi.vo +lib/Integers.vio: lib/Integers.v lib/Coqlib.vio $(ARCH)/Archi.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 @@ -38,8 +38,8 @@ lib/Decidableplus.vo lib/Decidableplus.glob lib/Decidableplus.v.beautified: lib/ 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/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 $(ARCH)/Archi.vo +common/AST.vio: common/AST.v lib/Coqlib.vio lib/Maps.vio common/Errors.vio lib/Integers.vio lib/Floats.vio $(ARCH)/Archi.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 @@ -52,8 +52,8 @@ common/Memtype.vo common/Memtype.glob common/Memtype.v.beautified: common/Memtyp 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/Values.vo common/Values.glob common/Values.v.beautified: common/Values.v $(ARCH)/Archi.vo lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo +common/Values.vio: common/Values.v $(ARCH)/Archi.vio 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 @@ -76,18 +76,22 @@ $(ARCH)/SelectOp.vo $(ARCH)/SelectOp.glob $(ARCH)/SelectOp.v.beautified: $(ARCH) $(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 +backend/SplitLong.vo backend/SplitLong.glob backend/SplitLong.v.beautified: backend/SplitLong.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo +backend/SplitLong.vio: backend/SplitLong.v lib/Coqlib.vio common/AST.vio lib/Integers.vio lib/Floats.vio $(ARCH)/Op.vio backend/CminorSel.vio $(ARCH)/SelectOp.vio +$(ARCH)/SelectLong.vo $(ARCH)/SelectLong.glob $(ARCH)/SelectLong.v.beautified: $(ARCH)/SelectLong.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/SplitLong.vo +$(ARCH)/SelectLong.vio: $(ARCH)/SelectLong.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/SplitLong.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/SplitLong.vo $(ARCH)/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/SplitLong.vio $(ARCH)/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/SplitLongproof.vo backend/SplitLongproof.glob backend/SplitLongproof.v.beautified: backend/SplitLongproof.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/SplitLong.vo +backend/SplitLongproof.vio: backend/SplitLongproof.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/SplitLong.vio +$(ARCH)/SelectLongproof.vo $(ARCH)/SelectLongproof.glob $(ARCH)/SelectLongproof.v.beautified: $(ARCH)/SelectLongproof.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Errors.vo $(ARCH)/Archi.vo common/AST.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/SplitLong.vo backend/SplitLongproof.vo $(ARCH)/SelectLong.vo +$(ARCH)/SelectLongproof.vio: $(ARCH)/SelectLongproof.v lib/Coqlib.vio lib/Maps.vio lib/Integers.vio lib/Floats.vio common/Errors.vio $(ARCH)/Archi.vio common/AST.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/SplitLong.vio backend/SplitLongproof.vio $(ARCH)/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/SplitLong.vo $(ARCH)/SelectLong.vo backend/Selection.vo $(ARCH)/SelectOpproof.vo backend/SelectDivproof.vo backend/SplitLongproof.vo $(ARCH)/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/SplitLong.vio $(ARCH)/SelectLong.vio backend/Selection.vio $(ARCH)/SelectOpproof.vio backend/SelectDivproof.vio backend/SplitLongproof.vio $(ARCH)/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 @@ -210,8 +214,8 @@ $(ARCH)/Asmgenproof.vo $(ARCH)/Asmgenproof.glob $(ARCH)/Asmgenproof.v.beautified $(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/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 $(ARCH)/Archi.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 $(ARCH)/Archi.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 @@ -28,12 +28,18 @@ Makefile.config compcert.ini ia32/ConstpropOp.v ia32/SelectOp.v +ia32/SelectLong.v powerpc/ConstpropOp.v powerpc/SelectOp.v +powerpc/SelectLong.v arm/ConstpropOp.v arm/SelectOp.v +arm/SelectLong.v +x86_64/ConstpropOp.v +x86_64/SelectOp.v +x86_64/SelectLong.v backend/SelectDiv.v -backend/SelectLong.v +backend/SplitLong.v backend/CMlexer.ml backend/CMparser.ml backend/CMparser.mli @@ -65,8 +65,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 \ 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..d708afb7 100644 --- a/backend/SelectDiv.vp +++ b/backend/SelectDiv.vp @@ -36,7 +36,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 +47,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 +63,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 +72,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). diff --git a/backend/SelectDivproof.v b/backend/SelectDivproof.v index ffe607e4..5621acd5 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 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. diff --git a/backend/Selection.v b/backend/Selection.v index 02b37c48..3aff446e 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 SelectDiv SplitLong SelectLong. 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 => divl arg1 arg2 + | Cminor.Odivlu => divlu arg1 arg2 + | Cminor.Omodl => modl 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. *) diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index a57e5ea6..34157553 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. @@ -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..305e20f3 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 *) @@ -54,7 +51,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). @@ -129,21 +126,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 +161,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 +173,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 +186,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 +197,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) := @@ -245,8 +242,8 @@ Definition mull_base (e1 e2: expr) := Definition mullimm (e: expr) (n: int64) := 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. @@ -264,23 +261,23 @@ Definition binop_long (id: ident) (sem: int64 -> int64 -> int64) (e1 e2: expr) : | _, _ => Eexternal id sig_ll_l (e1 ::: e2 ::: Enil) end. -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 divl e1 e2 := binop_long i64_sdiv Int64.divs e1 e2. +Definition modl e1 e2 := binop_long i64_smod Int64.mods e1 e2. Definition divlu (e1 e2: expr) := - let default := Eexternal hf.(i64_udiv) sig_ll_l (e1 ::: e2 ::: Enil) in + let default := Eexternal 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)) + match Int64.is_power2' n2 with + | Some l => shrluimm e1 l | None => default end | _, _ => default end. Definition modlu (e1 e2: expr) := - let default := Eexternal hf.(i64_umod) sig_ll_l (e1 ::: e2 ::: Enil) in + let default := Eexternal 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 => @@ -307,15 +304,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..1dbe25bd 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. @@ -66,19 +54,19 @@ Definition helper_declared {F V: Type} (p: AST.program (AST.fundef F) V) (id: id (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. (** * Correctness of the instruction selection functions for 64-bit operators *) @@ -414,7 +402,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 +412,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 +422,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 +432,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 +442,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 +456,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 +470,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 +480,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 +580,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 +613,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 +626,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 +658,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 +671,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 +707,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 +718,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 +734,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 +761,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 +787,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 (fun a => mullimm a n) (fun v => Val.mull v (Vlong n)). Proof. unfold mullimm; red; intros. predSpec Int64.eq Int64.eq_spec n Int64.zero. @@ -808,28 +796,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; @@ -870,7 +847,7 @@ Theorem eval_divl: 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. + exists v, eval_expr ge sp e m le (divl a b) v /\ Val.lessdef z v. Proof. intros. eapply eval_binop_long; eauto. intros; subst; simpl in H1. @@ -885,7 +862,7 @@ Theorem eval_modl: 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. + exists v, eval_expr ge sp e m le (modl a b) v /\ Val.lessdef z v. Proof. intros. eapply eval_binop_long; eauto. intros; subst; simpl in H1. @@ -900,10 +877,10 @@ Theorem eval_divlu: 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. + exists v, eval_expr ge sp e m le (divlu a b) v /\ Val.lessdef z v. Proof. intros. unfold divlu. - set (default := Eexternal hf.(i64_udiv) sig_ll_l (a ::: b ::: Enil)). + set (default := Eexternal 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). { @@ -916,25 +893,15 @@ Proof. 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. +- 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)))). + replace z with (Val.shrlu x (Vint 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. + simpl. erewrite Int64.is_power2'_range by eauto. + erewrite Int64.divu_pow2' by eauto. + auto. - auto. Qed. @@ -943,10 +910,10 @@ Theorem eval_modlu: 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. + exists v, eval_expr ge sp e m le (modlu a b) v /\ Val.lessdef z v. Proof. intros. unfold modlu. - set (default := Eexternal hf.(i64_umod) sig_ll_l (a ::: b ::: Enil)). + set (default := Eexternal 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). { @@ -1058,11 +1025,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..6b314904 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,246 @@ 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 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. + (** Floating-point arithmetic operations *) Definition negf := unop_float Float.neg. @@ -1778,6 +2057,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 +2235,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 +2593,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 +2630,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 +2781,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 +2797,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 +2813,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 +2847,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 +2875,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 +2889,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 +2916,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 +3142,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 +3198,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 +3672,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 +3688,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 +3700,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 +3708,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 +3746,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 +3754,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 +3771,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 +3816,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 +3894,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 +3927,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 +4211,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 +4247,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 +4260,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 +4541,21 @@ 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 + divls_sound divlu_sound modls_sound modlu_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 14976d01..b68887c5 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", @@ -390,14 +390,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) @@ -442,27 +441,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 @@ -482,14 +485,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) -> @@ -514,8 +513,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 @@ -650,7 +648,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..8defd9d9 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,57 +625,55 @@ 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 (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 + | add_case_pi ty si => (**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))) + 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 => - Some (Vint (Int.add n2 (Int.mul (Int.repr (sizeof cenv ty)) n1))) + 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 | add_case_pl ty => (**r pointer plus 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.add ofs1 (Int.mul (Int.repr (sizeof cenv ty)) 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 - 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))) + 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 | add_default => @@ -688,14 +688,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 +703,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 +732,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 +909,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 +918,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 +1087,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 +1122,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 +1143,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 +1175,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 +1232,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 +1260,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))). { @@ -1220,26 +1286,22 @@ 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. + + inv H0; inv H1; TrivialInject. + econstructor. eauto. repeat rewrite Ptrofs.add_assoc. decEq. apply Ptrofs.add_commut. + + inv H0; inv H1; TrivialInject. + econstructor. eauto. repeat rewrite Ptrofs.add_assoc. decEq. apply Ptrofs.add_commut. + 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 +1348,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 +1414,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 +1423,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 +1436,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 f; auto. + destruct ptr64; 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 (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 +1469,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 +1489,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 +1503,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 +1514,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..4e7aca8a 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 *) @@ -241,40 +242,52 @@ Definition make_binarith (iop iopu fop sop lop lopu: binary_operation) Definition make_add (ce: composite_env) (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_add ty1 ty2 with - | add_case_pi ty => - 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 => + | add_case_pi ty si => do sz <- sizeof ce ty; - let n := make_intconst (Int.repr sz) in - OK (Ebinop Oadd e2 (Ebinop Omul n e1)) + 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)) | 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))) + 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))) | 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 +346,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 +443,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 +493,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..3a35b87e 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -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. - econstructor; eauto with cshm. simpl. unfold Val.cmpu, Val.cmpu_bool. - unfold Mem.weak_valid_pointer in V; rewrite V. auto. + 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 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: @@ -561,19 +619,66 @@ End MAKE_BIN. Hint Extern 2 (@eq (option val) _ _) => (simpl; reflexivity) : cshm. +(* +Lemma eqm_ptrofs_of_int: + forall si i, + Ptrofs.eqm (Ptrofs.unsigned (ptrofs_of_int si i)) + (match si with Signed => Int.signed i | Unsigned => Int.unsigned i end). +Proof. + intros. unfold ptrofs_of_int. destruct si; apply Ptrofs.eqm_sym; apply Ptrofs.eqm_unsigned_repr. +Qed. + +Lemma ptrofs_mul_32: + forall si n i, + Archi.ptr64 = false -> + Ptrofs.of_int (Int.mul (Int.repr n) i) = Ptrofs.mul (Ptrofs.repr n) (ptrofs_of_int si i). +Proof. + intros. apply Ptrofs.eqm_samerepr. + eapply Ptrofs.eqm_trans; [ | apply Ptrofs.eqm_mult ]. + apply -> Val.ptrofs_eqm_32; auto. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. + apply Ptrofs.eqm_unsigned_repr_r. apply -> Val.ptrofs_eqm_32; auto. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. + apply Ptrofs.eqm_sym. eapply Ptrofs.eqm_trans. apply eqm_ptrofs_of_int. + apply -> Val.ptrofs_eqm_32; auto. destruct si. apply Int.eqm_signed_unsigned. apply Int.eqm_refl. +Qed. + +Lemma ptrofs_mul_32_64: + forall n i, + Archi.ptr64 = false -> + Ptrofs.of_int (Int.mul (Int.repr n) (Int64.loword i)) = Ptrofs.mul (Ptrofs.repr n) (Ptrofs.of_int64 i). +Proof. + intros. apply Ptrofs.eqm_samerepr. + eapply Ptrofs.eqm_trans; [ | apply Ptrofs.eqm_mult ]. + apply -> Val.ptrofs_eqm_32; auto. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. + apply Ptrofs.eqm_unsigned_repr_r. apply -> Val.ptrofs_eqm_32; auto. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. + unfold Ptrofs.of_int64. apply Ptrofs.eqm_unsigned_repr_r. + unfold Int64.loword. apply -> Val.ptrofs_eqm_32; auto. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. +Qed. +*) + Lemma make_add_correct: binary_constructor_correct (make_add cunit.(prog_comp_env)) (sem_add prog.(prog_comp_env)). Proof. red; unfold make_add, sem_add; intros until m; intros SEM MAKE EV1 EV2; destruct (classify_add tya tyb); 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 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. do 3 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. do 3 f_equal. + assert (Ptrofs.agree32 (ptrofs_of_int si i0) i0) by (destruct si; simpl; auto with ptrofs). + 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. do 3 f_equal. auto with ptrofs. ++ destruct va; InvEval; destruct vb; inv SEM; eauto with cshm. + econstructor; eauto with cshm. simpl. rewrite SF. do 3 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. @@ -582,25 +687,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. do 3 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. do 3 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. do 2 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. do 2 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. do 3 f_equal. + auto with ptrofs. ++ destruct va; InvEval; destruct vb; inv SEM; eauto with cshm. + econstructor; eauto with cshm. simpl. rewrite SF. do 3 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 +857,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. do 2 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. @@ -1042,49 +1219,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 *) +- (* 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. do 3 f_equal. auto with ptrofs. ++ eapply eval_Ebinop; eauto using make_intconst_correct. + simpl. rewrite SF. do 3 f_equal. auto with ptrofs. +- (* field union *) unfold make_field_access in EQ0; rewrite H1 in EQ0; monadInv EQ0. auto. Qed. 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..521ae519 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,20 @@ 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_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_pp ty => OK ptrdiff_t | sub_default => binarith_type ty1 ty2 "operator infix -" end | Omul => binarith_type ty1 ty2 "operator infix *" @@ -281,9 +287,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 +301,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 +373,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 +536,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 +641,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 +700,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 +970,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 +987,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 +1008,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 +1034,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 +1094,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 +1103,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 +1391,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 +1485,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'|]... @@ -1480,6 +1508,7 @@ Proof. 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 +1551,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 +1570,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 +1590,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 +1641,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 +1713,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 +2146,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..5b7e52c8 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,7 @@ 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 (Val.offset_ptr v (Ptrofs.repr delta)) | Tunion id _ => constval ce l | _ => @@ -161,11 +152,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..49ac858e 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'. @@ -459,7 +447,7 @@ Proof. 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. + rewrite ! Ptrofs.add_assoc. f_equal. apply Ptrofs.add_commut. simpl. auto. (* field union *) rewrite H0 in CV. eauto. @@ -617,30 +605,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 +645,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 +709,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..d1058fe8 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. @@ -626,6 +656,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 +713,24 @@ Definition shrlu (v1 v2: val): val := | _, _ => Vundef 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 +756,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 +801,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 +855,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 +879,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 +893,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 +978,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 +1008,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 +1019,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 +1069,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: @@ -1165,6 +1266,144 @@ 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 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 +1416,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 (Int.unsigned i) && valid_ptr b0 (Int.unsigned i0)); 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 (Ptrofs.unsigned i) && valid_ptr b0 (Ptrofs.unsigned i0)); auto. +- rewrite Int64.negate_cmpu. auto. Qed. Lemma not_of_optbool: @@ -1223,21 +1489,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 +1718,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 +1733,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 +1816,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 +1857,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 +1873,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 +1890,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 +1899,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 +1914,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 +1980,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 +2012,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 +2158,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 +2180,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 +2205,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. diff --git a/cparser/PackedStructs.ml b/cparser/PackedStructs.ml index a921e2d8..fd6bd936 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) = 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/Ctydescr.ml b/driver/Ctydescr.ml new file mode 100644 index 00000000..8091257b --- /dev/null +++ b/driver/Ctydescr.ml @@ -0,0 +1,456 @@ +open Printf +open Camlcoq +open Tydesc + +let check ty x = TyIO.check x ty; true + +(* From stdlib *) + +let list t = List t +let pair t1 t2 = Tuple [t1;t2] + +let rec repr_nat = Sum("nat", [ + "O", []; + "S", [repr_nat] +]) + +let nat = Base { + base_name = "nat"; + base_check = check repr_nat; + base_parse = (fun synt s -> assert false); + base_print = (fun synt x -> + let s = string_of_int (Nat.to_int x) in + match synt with + | `Coq -> s ^ "%nat" + | _ -> s) +} + +let rec repr_positive = Sum("positive", [ + "xI", [repr_positive]; + "xO", [repr_positive]; + "xH", [] +]) + +let positive = Base { + base_name = "positive"; + base_check = check repr_positive; + base_parse = (fun synt s -> assert false); + base_print = (fun synt x -> Z.to_string (Z.Zpos x)) +} + +let repr_N = Sum("N", [ + "N0", []; + "Npos", [repr_positive] +]) + +let _N = Base { + base_name = "N"; + base_check = check repr_N; + base_parse = (fun synt s -> assert false); + base_print = (fun synt x -> + let y = match x with N.N0 -> Z.Z0 | N.Npos p -> Z.Zpos p in + let s = Z.to_string y in + match synt with + | `Coq -> s ^ "%N" + | _ -> s) +} + +let repr_Z = Sum("Z", [ + "Z0", []; + "Zpos", [repr_positive]; + "Zneg", [repr_positive] +]) + +let _Z = Base { + base_name = "Z"; + base_check = check repr_Z; + base_parse = (fun synt s -> assert false); + base_print = (fun synt x -> + let s = Z.to_string x in + match synt with + | `Coq -> s ^ "%Z" + | _ -> s) +} + +(* From Integers *) + +let int = Base { + base_name = "int"; + base_check = check repr_Z; + base_parse = (fun synt s -> + let (n, s') = get_number s in + try (coqint_of_camlint (Int32.of_string n), s') + with Failure _ -> + raise (Parsing_failure(get_position s, sprintf "bad 'int' literal %S" n))); + base_print = (fun synt x -> + let s = Z.to_string x in + match synt with + | `Coq -> "(mkint " ^ s ^ "%Z)" + | _ -> s) +} + +let int64 = Base { + base_name = "int64"; + base_check = check repr_Z; + base_parse = (fun synt s -> + let (n, s') = get_number s in + try (coqint_of_camlint64 (Int64.of_string n), s') + with Failure _ -> + raise (Parsing_failure(get_position s, sprintf "bad 'int64' literal %S" n))); + base_print = (fun synt x -> + let s = Z.to_string x in + match synt with + | `Coq -> "(mkint64 " ^ s ^ "%Z)" + | _ -> s) +} + +(* From Floats *) + +let nan_pl = positive + +let binary_float = Sum("binary_float", [ + "B754_zero", [bool]; + "B754_infinity", [bool]; + "B754_nan", [bool; nan_pl]; + "B754_finite", [bool; positive; _Z] +]) + +let float = Base { + base_name = "float"; + base_check = check binary_float; + base_parse = (fun synt s -> + let (n, s') = get_number s in + try (Floats.Float.of_bits (coqint_of_camlint64 (Int64.of_string n)), s') + with Failure _ -> + raise (Parsing_failure(get_position s, sprintf "bad 'float' literal %S" n))); + base_print = (fun synt x -> + let s = Z.to_string (Floats.Float.to_bits x) in + match synt with + | `Coq -> "(mkfloat " ^ s ^ "%Z)" + | _ -> s) +} + +let float32 = Base { + base_name = "float32"; + base_check = check binary_float; + base_parse = (fun synt s -> + let (n, s') = get_number s in + try (Floats.Float32.of_bits (coqint_of_camlint (Int32.of_string n)), s') + with Failure _ -> + raise (Parsing_failure(get_position s, sprintf "bad 'float32' literal %S" n))); + base_print = (fun synt x -> + let s = Z.to_string (Floats.Float.to_bits x) in + match synt with + | `Coq -> "(mkfloat32 " ^ s ^ "%Z)" + | _ -> s) +} + +(* From Maps *) + +let ptree a = + let rec t = Sum(sprintf "PTree.t[%s]" (describe_ty a), [ + "Leaf", []; + "Node", [t; option a; t] + ]) in t + +(* From AST *) + +let ident = positive + +let typ = Sum("typ", [ + "AST.Tint", []; + "AST.Tfloat", []; + "AST.Tlong", []; + "AST.Tsingle", []; + "AST.Tany32", []; + "AST.Tany64", []; +]) + +let calling_convention = Record("calling_convention", [ + "cc_vararg", bool; + "cc_structret", bool; +]) + +let default_calling_convention = { + dfl_val = AST.cc_default; + dfl_print = (function `Coq -> Some "cc_default" | _ -> None) +} + +let calling_convention_d = + Default(calling_convention, default_calling_convention) + +let signature = Record("signature", [ + "sig_args", list typ; + "sig_res", option typ; + "sig_cc", calling_convention_d; +]) + +let memory_chunk = Sum("memory_chunk", [ + "Mint8signed", []; + "Mint8unsigned", []; + "Mint16signed", []; + "Mint16unsigned", []; + "Mint32", []; + "Mint64", []; + "Mfloat32", []; + "Mfloat64", []; + "Many32", []; + "Many64", []; +]) + +let init_data = Sum("init_data", [ + "Init_int8", [int]; + "Init_int16", [int]; + "Init_int32", [int]; + "Init_int64", [int64]; + "Init_float32", [float32]; + "Init_float64", [float]; + "Init_space", [_Z]; + "Init_addrof", [ident; int]; +]) + +let globvar v = Record(sprintf "globvar[%s]" (describe_ty v), [ + "gvar_info", v; + "gvar_init", list init_data; + "gvar_readonly", bool; + "gvar_volatile", bool; +]) + +let globdef f v = Sum(sprintf "globdef[%s][%s]" (describe_ty f) (describe_ty v), [ + "Gfun", [f]; + "Gvar", [globvar v]; +]) + +let external_function = Sum("external_function", [ + "EF_external", [ident; signature]; + "EF_builtin", [ident; signature]; + "EF_vload", [memory_chunk]; + "EF_vstore", [memory_chunk]; + "EF_vload_global", [memory_chunk; ident; int]; + "EF_vstore_global", [memory_chunk; ident; int]; + "EF_malloc", []; + "EF_free", []; + "EF_memcpy", [_Z; _Z]; + "EF_annot", [ident; list typ]; + "EF_annot_val", [ident; typ]; + "EF_inline_asm", [ident; signature; list string]; +]) + +(* From Values *) + +let block = positive + +let val_ = Sum("val", [ + "Vundef", []; + "Vint", [int]; + "Vlong", [int64]; + "Vfloat", [float]; + "Vsingle", [float32]; + "Vptr", [block; int]; +]) + +(* From Ctypes *) + +let signedness = Sum("signedness", [ + "Signed", []; + "Unsigned", []; +]) + +let intsize = Sum("intsize", [ + "I8", []; + "I16", []; + "I32", []; + "IBool", []; +]) + +let floatsize = Sum("floatsize", [ + "F32", []; + "F64", []; +]) + +let attr = Record("attr", [ + "attr_volatile", bool; + "attr_alignas", option _N; +]) + +let attr_default = { + dfl_val = Ctypes.noattr; + dfl_print = (function `Coq -> Some "noattr" | _ -> None) +} + +let attr_d = Default(attr, attr_default) + +let rec type_ = Sum("type", [ + "Tvoid", []; + "Tint", [intsize; signedness; attr_d]; + "Tlong", [signedness; attr_d]; + "Tfloat", [floatsize; attr_d]; + "Tpointer", [type_; attr_d]; + "Tarray", [type_; _Z; attr_d]; + "Tfunction", [typelist; type_; calling_convention_d]; + "Tstruct", [ident; attr_d]; + "Tunion", [ident; attr_d]; +]) +and typelist = Sum("typelist", [ + "Tnil", []; + "Tcons", [type_; typelist]; +]) + +let struct_or_union = Sum("struct_or_union", [ + "Struct", []; + "Union", []; +]) + +let members = list (pair ident type_) + +let composite_definition = Sum("composite_definition", [ + "Composite", [ident; struct_or_union; members; attr_d]; +]) + +let composite = Record("composite",[ + "co_su", struct_or_union; + "co_members", members; + "co_attr", attr; + "co_sizeof", _Z; + "co_alignof", _Z; + "co_rank", nat +]) + +let composite_env = ptree composite + +(* From Cop *) + +let unary_operation = Sum("unary_operation", [ + "Onotbool", []; + "Onotint", []; + "Oneg", []; + "Oabsfloat", []; +]) + +let binary_operation = Sum("binary_operation", [ + "Oadd", []; + "Osub", []; + "Omul", []; + "Odiv", []; + "Omod", []; + "Oand", []; + "Oor", []; + "Oxor", []; + "Oshl", []; + "Oshr", []; + "Oeq", []; + "One", []; + "Olt", []; + "Ogt", []; + "Ole", []; + "Oge", []; +]) + +let incr_or_decr = Sum("incr_or_decr", [ + "Incr", []; + "Decr", []; +]) + +(* From Csyntax *) + +let rec expr = Sum("expr", [ + "Eval", [val_; type_]; + "Evar", [ident; type_]; + "Efield", [expr; ident; type_]; + "Evalof", [expr; type_]; + "Ederef", [expr; type_]; + "Eaddrof", [expr; type_]; + "Eunop", [unary_operation; expr; type_]; + "Ebinop", [binary_operation; expr; expr; type_]; + "Ecast", [expr; type_]; + "Eseqand", [expr; expr; type_]; + "Eseqor", [expr; expr; type_]; + "Econdition", [expr; expr; expr; type_]; + "Esizeof", [type_; type_]; + "Ealignof", [type_; type_]; + "Eassign", [expr; expr; type_]; + "Eassignop", [binary_operation; expr; expr; type_; type_]; + "Epostincr", [incr_or_decr; expr; type_]; + "Ecomma", [expr; expr; type_]; + "Ecall", [expr; exprlist; type_]; + "Ebuiltin", [external_function; typelist; exprlist; type_]; + "Eloc", [block; int; type_]; + "Eparen", [expr; type_; type_]; +]) +and exprlist = Sum("exprlist", [ + "Enil", []; + "Econs", [expr; exprlist]; +]) + +let label = ident + +let rec statement = Sum("statement", [ + "Sskip", []; + "Sdo", [expr]; + "Ssequence", [statement; statement]; + "Sifthenelse", [expr; statement; statement]; + "Swhile", [expr; statement]; + "Sdowhile", [expr; statement]; + "Sfor", [statement; expr; statement; statement]; + "Sbreak", []; + "Scontinue", []; + "Sreturn", [option expr]; + "Sswitch", [expr; labeled_statements]; + "Slabel", [label; statement]; + "Sgoto", [label]; +]) +and labeled_statements = Sum("labeled_statements", [ + "LSnil", []; + "LScons", [option _Z; statement; labeled_statements]; +]) + +let function_ = Record("function", [ + "fn_return", type_; + "fn_callconv", calling_convention_d; + "fn_params", list (pair ident type_); + "fn_vars", list (pair ident type_); + "fn_body", statement; +]) + +let fundef = Sum("fundef", [ + "Internal", [function_]; + "External", [external_function; typelist; type_; calling_convention_d]; +]) + +let repr_program = Record("program", [ + "prog_defs", list (pair ident (globdef fundef type_)); + "prog_public", list ident; + "prog_main", ident; + "prog_types", list composite_definition; + "prog_comp_env", composite_env +]) + +type program2 = Program of + (AST.ident * (Csyntax.fundef, Ctypes.coq_type) AST.globdef) list + * AST.ident list + * AST.ident + * Ctypes.composite_definition list + +let program2 = Sum("program2", [ + "mkprogram", [list (pair ident (globdef fundef type_)); + list ident; + ident; + list composite_definition] +]) + +let program2_of_program p = + Csyntax.(Program(p.prog_defs, p.prog_public, p.prog_main, p.prog_types)) +let program_of_program2 (Program(d,p,m,t)) = + Csyntax.( + match Ctypes.build_composite_env t with + | Errors.Error _ -> assert false + | Errors.OK e -> {prog_defs = d; prog_public = p; prog_main = m; + prog_types = t; prog_comp_env = e}) + +let program = As(program2, { + conv_name = "program"; + conv_check = check repr_program; + conv_out = program2_of_program; + conv_in = program_of_program2 +}) + diff --git a/driver/Driver.ml b/driver/Driver.ml index b89d93c1..4bd08a88 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -536,9 +536,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 + | "ia32" -> 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/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/lib/Integers.v b/lib/Integers.v index 16c95e01..593f0ccc 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 := @@ -4007,6 +4053,130 @@ 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. + +(** 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 +4698,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/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) |