diff options
80 files changed, 4487 insertions, 2683 deletions
@@ -22,7 +22,7 @@ common/Smallstep.vo common/Smallstep.glob: common/Smallstep.v lib/Coqlib.vo comm common/Determinism.vo common/Determinism.glob: common/Determinism.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo common/Switch.glob: common/Switch.v lib/Coqlib.vo lib/Integers.vo lib/Ordered.vo backend/Cminor.vo backend/Cminor.glob: backend/Cminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Events.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo -$(ARCH)/Op.vo $(ARCH)/Op.glob: $(ARCH)/Op.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memory.vo common/Globalenvs.vo +$(ARCH)/Op.vo $(ARCH)/Op.glob: $(ARCH)/Op.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memory.vo common/Globalenvs.vo common/Events.vo backend/CminorSel.vo backend/CminorSel.glob: backend/CminorSel.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Events.vo common/Values.vo common/Memory.vo backend/Cminor.vo $(ARCH)/Op.vo common/Globalenvs.vo common/Switch.vo common/Smallstep.vo $(ARCH)/SelectOp.vo $(ARCH)/SelectOp.glob: $(ARCH)/SelectOp.v lib/Coqlib.vo lib/Maps.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 backend/Selection.vo backend/Selection.glob: backend/Selection.v lib/Coqlib.vo lib/Maps.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 @@ -66,21 +66,19 @@ backend/Linearize.vo backend/Linearize.glob: backend/Linearize.v lib/Coqlib.vo l backend/Linearizeproof.vo backend/Linearizeproof.glob: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Errors.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/LTLin.vo backend/Linearize.vo lib/Lattice.vo backend/Linearizetyping.vo backend/Linearizetyping.glob: backend/Linearizetyping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/LTLin.vo backend/Linearize.vo backend/LTLintyping.vo backend/Conventions.vo backend/Linear.vo backend/Linear.glob: backend/Linear.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo -backend/Lineartyping.vo backend/Lineartyping.glob: backend/Lineartyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Memdata.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo backend/Conventions.vo +backend/Lineartyping.vo backend/Lineartyping.glob: backend/Lineartyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Conventions.vo backend/Parallelmove.vo backend/Parallelmove.glob: backend/Parallelmove.v lib/Coqlib.vo lib/Parmov.vo common/Values.vo common/Events.vo common/AST.vo backend/Locations.vo backend/Conventions.vo backend/Reload.vo backend/Reload.glob: backend/Reload.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTLin.vo backend/Conventions.vo backend/Parallelmove.vo backend/Linear.vo backend/Reloadproof.vo backend/Reloadproof.glob: backend/Reloadproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Allocproof.vo backend/RTLtyping.vo backend/LTLin.vo backend/LTLintyping.vo backend/Linear.vo backend/Parallelmove.vo backend/Reload.vo backend/Reloadtyping.vo backend/Reloadtyping.glob: backend/Reloadtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTLin.vo backend/LTLintyping.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo backend/Parallelmove.vo backend/Reload.vo backend/Reloadproof.vo -backend/Mach.vo backend/Mach.glob: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo -backend/Machabstr.vo backend/Machabstr.glob: backend/Machabstr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Memory.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Stacklayout.vo -backend/Machtyping.vo backend/Machtyping.glob: backend/Machtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Memory.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo backend/Machabstr.vo +backend/Mach.vo backend/Mach.glob: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo +backend/Machtyping.vo backend/Machtyping.glob: backend/Machtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Memory.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo backend/Bounds.vo backend/Bounds.glob: backend/Bounds.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo $(ARCH)/$(VARIANT)/Stacklayout.glob: $(ARCH)/$(VARIANT)/Stacklayout.v lib/Coqlib.vo backend/Bounds.vo backend/Stacking.vo backend/Stacking.glob: backend/Stacking.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo backend/Bounds.vo backend/Mach.vo backend/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo -backend/Stackingproof.vo backend/Stackingproof.glob: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo common/Values.vo $(ARCH)/Op.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machabstr.vo backend/Bounds.vo backend/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo +backend/Stackingproof.vo backend/Stackingproof.glob: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo common/Values.vo $(ARCH)/Op.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machconcr.vo backend/Bounds.vo backend/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo backend/Stackingtyping.vo backend/Stackingtyping.glob: backend/Stackingtyping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machtyping.vo backend/Bounds.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo backend/Stackingproof.vo backend/Machconcr.vo backend/Machconcr.glob: backend/Machconcr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Stacklayout.vo $(ARCH)/Asmgenretaddr.vo -backend/Machabstr2concr.vo backend/Machabstr2concr.glob: backend/Machabstr2concr.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/Machabstr.vo backend/Machconcr.vo backend/Conventions.vo $(ARCH)/Asmgenretaddr.vo $(ARCH)/Asm.vo $(ARCH)/Asm.glob: $(ARCH)/Asm.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Conventions.vo $(ARCH)/Asmgen.vo $(ARCH)/Asmgen.glob: $(ARCH)/Asmgen.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgenretaddr.vo $(ARCH)/Asmgenretaddr.glob: $(ARCH)/Asmgenretaddr.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 $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo @@ -90,7 +88,7 @@ cfrontend/Csyntax.vo cfrontend/Csyntax.glob: cfrontend/Csyntax.v lib/Coqlib.vo c cfrontend/Csem.vo cfrontend/Csem.glob: 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/Csyntax.vo common/Smallstep.vo cfrontend/Cstrategy.vo cfrontend/Cstrategy.glob: cfrontend/Cstrategy.v lib/Axioms.vo lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Determinism.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Initializers.vo cfrontend/Initializers.glob: cfrontend/Initializers.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo cfrontend/Csyntax.vo cfrontend/Csem.vo -cfrontend/Initializersproof.vo cfrontend/Initializersproof.glob: cfrontend/Initializersproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Initializers.vo +cfrontend/Initializersproof.vo cfrontend/Initializersproof.glob: cfrontend/Initializersproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/SimplExpr.glob: cfrontend/SimplExpr.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo cfrontend/Csyntax.vo cfrontend/Clight.vo cfrontend/SimplExprspec.vo cfrontend/SimplExprspec.glob: cfrontend/SimplExprspec.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/AST.vo cfrontend/Csyntax.vo cfrontend/Clight.vo cfrontend/SimplExpr.vo cfrontend/SimplExprproof.vo cfrontend/SimplExprproof.glob: cfrontend/SimplExprproof.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo common/Determinism.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo cfrontend/SimplExpr.vo cfrontend/SimplExprspec.vo @@ -100,5 +98,5 @@ cfrontend/Cshmgenproof.vo cfrontend/Cshmgenproof.glob: cfrontend/Cshmgenproof.v cfrontend/Csharpminor.vo cfrontend/Csharpminor.glob: cfrontend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo backend/Cminor.vo common/Smallstep.vo cfrontend/Cminorgen.vo cfrontend/Cminorgen.glob: cfrontend/Cminorgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo common/Memdata.vo cfrontend/Csharpminor.vo backend/Cminor.vo cfrontend/Cminorgenproof.vo cfrontend/Cminorgenproof.glob: cfrontend/Cminorgenproof.v lib/Coqlib.vo lib/Intv.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo cfrontend/Csharpminor.vo backend/Cminor.vo cfrontend/Cminorgen.vo -driver/Compiler.vo driver/Compiler.glob: driver/Compiler.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Values.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/LTLin.vo backend/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/CastOptim.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/Reload.vo backend/Stacking.vo $(ARCH)/Asmgen.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/LTLintyping.vo backend/Lineartyping.vo backend/Machtyping.vo cfrontend/SimplExprproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/CastOptimproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/Reloadproof.vo backend/Reloadtyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo backend/Machabstr2concr.vo $(ARCH)/Asmgenproof.vo +driver/Compiler.vo driver/Compiler.glob: driver/Compiler.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Values.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/LTLin.vo backend/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/CastOptim.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/Reload.vo backend/Stacking.vo $(ARCH)/Asmgen.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/LTLintyping.vo backend/Lineartyping.vo backend/Machtyping.vo cfrontend/SimplExprproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/CastOptimproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/Reloadproof.vo backend/Reloadtyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo $(ARCH)/Asmgenproof.vo driver/Complements.vo driver/Complements.glob: driver/Complements.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Determinism.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo $(ARCH)/Asm.vo driver/Compiler.vo common/Errors.vo @@ -62,9 +62,9 @@ BACKEND=\ Linearize.v Linearizeproof.v Linearizetyping.v \ Linear.v Lineartyping.v \ Parallelmove.v Reload.v Reloadproof.v Reloadtyping.v \ - Mach.v Machabstr.v Machtyping.v \ + Mach.v Machtyping.v \ Bounds.v Stacklayout.v Stacking.v Stackingproof.v Stackingtyping.v \ - Machconcr.v Machabstr2concr.v \ + Machconcr.v \ Asm.v Asmgen.v Asmgenretaddr.v Asmgenproof1.v Asmgenproof.v # C front-end modules (in cfrontend/) @@ -165,8 +165,8 @@ Inductive instruction : Type := | Psufd: freg -> freg -> freg -> instruction (**r float subtraction *) (* Pseudo-instructions *) - | Pallocframe: Z -> Z -> int -> instruction (**r allocate new stack frame *) - | Pfreeframe: Z -> Z -> int -> instruction (**r deallocate stack frame and restore previous frame *) + | Pallocframe: Z -> int -> instruction (**r allocate new stack frame *) + | Pfreeframe: Z -> int -> instruction (**r deallocate stack frame and restore previous frame *) | Plabel: label -> instruction (**r define a code label *) | Ploadsymbol: ireg -> ident -> int -> instruction (**r load the address of a symbol *) | Pbtbl: ireg -> list label -> instruction (**r N-way branch through a jump table *) @@ -186,20 +186,20 @@ lbl: .word symbol >> Initialized data in the constant data section are not modeled here, which is why we use a pseudo-instruction for this purpose. -- [Pallocframe lo hi pos]: in the formal semantics, this pseudo-instruction - allocates a memory block with bounds [lo] and [hi], stores the value +- [Pallocframe sz pos]: in the formal semantics, this pseudo-instruction + allocates a memory block with bounds [0] and [sz], stores the value of the stack pointer at offset [pos] in this block, and sets the stack pointer to the address of the bottom of this block. In the printed ASM assembly code, this allocation is: << mov r12, sp - sub sp, sp, #(hi - lo) + sub sp, sp, #sz str r12, [sp, #pos] >> This cannot be expressed in our memory model, which does not reflect the fact that stack frames are adjacent and allocated/freed following a stack discipline. -- [Pfreeframe pos]: in the formal semantics, this pseudo-instruction +- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction reads the word at [pos] of the block pointed by the stack pointer, frees this block, and sets the stack pointer to the value read. In the printed ASM assembly code, this freeing @@ -494,20 +494,20 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Psufd r1 r2 r3 => OK (nextinstr (rs#r1 <- (Val.subf rs#r2 rs#r3))) m (* Pseudo-instructions *) - | Pallocframe lo hi pos => - let (m1, stk) := Mem.alloc m lo hi in - let sp := (Vptr stk (Int.repr lo)) in + | Pallocframe sz pos => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Int.zero) in match Mem.storev Mint32 m1 (Val.add sp (Vint pos)) rs#IR13 with | None => Error - | Some m2 => OK (nextinstr (rs#IR13 <- sp)) m2 + | Some m2 => OK (nextinstr (rs #IR12 <- (rs#IR13) #IR13 <- sp)) m2 end - | Pfreeframe lo hi pos => + | Pfreeframe sz pos => match Mem.loadv Mint32 m (Val.add rs#IR13 (Vint pos)) with | None => Error | Some v => match rs#IR13 with | Vptr stk ofs => - match Mem.free m stk lo hi with + match Mem.free m stk 0 sz with | None => Error | Some m' => OK (nextinstr (rs#IR13 <- v)) m' end @@ -521,7 +521,7 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pbtbl r tbl => match rs#r with | Vint n => - let pos := Int.signed n in + let pos := Int.unsigned n in if zeq (Zmod pos 4) 0 then match list_nth_z tbl (pos / 4) with | None => Error diff --git a/arm/Asmgen.v b/arm/Asmgen.v index b3412fb..a1f8d96 100644 --- a/arm/Asmgen.v +++ b/arm/Asmgen.v @@ -36,7 +36,7 @@ Require Import Asm. Fixpoint is_immed_arith_aux (n: nat) (x msk: int) {struct n}: bool := match n with - | O => false + | Datatypes.O => false | Datatypes.S n' => Int.eq (Int.and x (Int.not msk)) Int.zero || is_immed_arith_aux n' x (Int.ror msk (Int.repr 2)) @@ -55,46 +55,65 @@ Definition is_immed_mem_float (x: int) : bool := Int.eq (Int.and x (Int.repr 3)) Int.zero && Int.lt x (Int.repr 1024) && Int.lt (Int.repr (-1024)) x. +(** Decomposition of a 32-bit integer into a list of immediate arguments, + whose sum or "or" or "xor" equals the integer. *) + +Fixpoint decompose_int_rec (N: nat) (n p: int) : list int := + match N with + | Datatypes.O => + if Int.eq_dec n Int.zero then nil else n :: nil + | Datatypes.S M => + if Int.eq_dec (Int.and n (Int.shl (Int.repr 3) p)) Int.zero then + decompose_int_rec M n (Int.add p (Int.repr 2)) + else + let m := Int.shl (Int.repr 255) p in + Int.and n m :: + decompose_int_rec M (Int.and n (Int.not m)) (Int.add p (Int.repr 2)) + end. + +Definition decompose_int (n: int) : list int := + match decompose_int_rec 12%nat n Int.zero with + | nil => Int.zero :: nil + | l => l + end. + +Definition iterate_op (op1 op2: shift_op -> instruction) (l: list int) (k: code) := + match l with + | nil => + op1 (SOimm Int.zero) :: k (**r should never happen *) + | i :: l' => + op1 (SOimm i) :: map (fun i => op2 (SOimm i)) l' ++ k + end. + (** Smart constructors for integer immediate arguments. *) Definition loadimm (r: ireg) (n: int) (k: code) := - if is_immed_arith n then - Pmov r (SOimm n) :: k - else if is_immed_arith (Int.not n) then - Pmvn r (SOimm (Int.not n)) :: k - else (* could be much improved! *) - Pmov r (SOimm (Int.and n (Int.repr 255))) :: - Porr r r (SOimm (Int.and n (Int.repr 65280))) :: - Porr r r (SOimm (Int.and n (Int.repr 16711680))) :: - Porr r r (SOimm (Int.and n (Int.repr 4278190080))) :: - k. + let d1 := decompose_int n in + let d2 := decompose_int (Int.not n) in + if le_dec (List.length d1) (List.length d2) + then iterate_op (Pmov r) (Porr r r) d1 k + else iterate_op (Pmvn r) (Pbic r r) d2 k. Definition addimm (r1 r2: ireg) (n: int) (k: code) := - if is_immed_arith n then - Padd r1 r2 (SOimm n) :: k - else if is_immed_arith (Int.neg n) then - Psub r1 r2 (SOimm (Int.neg n)) :: k - else - Padd r1 r2 (SOimm (Int.and n (Int.repr 255))) :: - Padd r1 r1 (SOimm (Int.and n (Int.repr 65280))) :: - Padd r1 r1 (SOimm (Int.and n (Int.repr 16711680))) :: - Padd r1 r1 (SOimm (Int.and n (Int.repr 4278190080))) :: - k. + let d1 := decompose_int n in + let d2 := decompose_int (Int.neg n) in + if le_dec (List.length d1) (List.length d2) + then iterate_op (Padd r1 r2) (Padd r1 r1) d1 k + else iterate_op (Psub r1 r2) (Psub r1 r1) d2 k. Definition andimm (r1 r2: ireg) (n: int) (k: code) := - if is_immed_arith n then - Pand r1 r2 (SOimm n) :: k - else if is_immed_arith (Int.not n) then - Pbic r1 r2 (SOimm (Int.not n)) :: k - else - loadimm IR14 n (Pand r1 r2 (SOreg IR14) :: k). + if is_immed_arith n + then Pand r1 r2 (SOimm n) :: k + else iterate_op (Pbic r1 r2) (Pbic r1 r1) (decompose_int (Int.not n)) k. -Definition makeimm (instr: ireg -> ireg -> shift_op -> instruction) - (r1 r2: ireg) (n: int) (k: code) := - if is_immed_arith n then - instr r1 r2 (SOimm n) :: k - else - loadimm IR14 n (instr r1 r2 (SOreg IR14) :: k). +Definition rsubimm (r1 r2: ireg) (n: int) (k: code) := + iterate_op (Prsb r1 r2) (Padd r1 r1) (decompose_int n) k. + +Definition orimm (r1 r2: ireg) (n: int) (k: code) := + iterate_op (Porr r1 r2) (Porr r1 r1) (decompose_int n) k. + +Definition xorimm (r1 r2: ireg) (n: int) (k: code) := + iterate_op (Peor r1 r2) (Peor r1 r1) (decompose_int n) k. (** Translation of a shift immediate operation (type [Op.shift]) *) @@ -235,7 +254,7 @@ Definition transl_op | Orsubshift s, a1 :: a2 :: nil => Prsb (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k | Orsubimm n, a1 :: nil => - makeimm Prsb (ireg_of r) (ireg_of a1) n k + rsubimm (ireg_of r) (ireg_of a1) n k | Omul, a1 :: a2 :: nil => if ireg_eq (ireg_of r) (ireg_of a1) || ireg_eq (ireg_of r) (ireg_of a2) @@ -256,13 +275,13 @@ Definition transl_op | Oorshift s, a1 :: a2 :: nil => Porr (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k | Oorimm n, a1 :: nil => - makeimm Porr (ireg_of r) (ireg_of a1) n k + orimm (ireg_of r) (ireg_of a1) n k | Oxor, a1 :: a2 :: nil => Peor (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k | Oxorshift s, a1 :: a2 :: nil => Peor (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k | Oxorimm n, a1 :: nil => - makeimm Peor (ireg_of r) (ireg_of a1) n k + xorimm (ireg_of r) (ireg_of a1) n k | Obic, a1 :: a2 :: nil => Pbic (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k | Obicshift s, a1 :: a2 :: nil => @@ -469,12 +488,10 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := Pblsymb symb :: k | Mtailcall sig (inl r) => loadind_int IR13 f.(fn_retaddr_ofs) IR14 - (Pfreeframe (-f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) - :: Pbreg (ireg_of r) :: k) + (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbreg (ireg_of r) :: k) | Mtailcall sig (inr symb) => loadind_int IR13 f.(fn_retaddr_ofs) IR14 - (Pfreeframe (-f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) - :: Pbsymb symb :: k) + (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbsymb symb :: k) | Mbuiltin ef args res => Pbuiltin ef (map preg_of args) (preg_of res) :: k | Mlabel lbl => @@ -488,8 +505,7 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := Pbtbl IR14 tbl :: k | Mreturn => loadind_int IR13 f.(fn_retaddr_ofs) IR14 - (Pfreeframe (-f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) - :: Pbreg IR14 :: k) + (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbreg IR14 :: k) end. Definition transl_code (f: Mach.function) (il: list Mach.instruction) := @@ -501,7 +517,7 @@ Definition transl_code (f: Mach.function) (il: list Mach.instruction) := around, leading to incorrect executions. *) Definition transl_function (f: Mach.function) := - Pallocframe (- f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: + Pallocframe f.(fn_stacksize) f.(fn_link_ofs) :: Pstr IR14 IR13 (SAimm f.(fn_retaddr_ofs)) :: transl_code f f.(fn_code). diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v index d3e082f..0a429cc 100644 --- a/arm/Asmgenproof.v +++ b/arm/Asmgenproof.v @@ -330,12 +330,26 @@ Section TRANSL_LABEL. Variable lbl: label. +Remark iterate_op_label: + forall op1 op2 l k, + (forall so, is_label lbl (op1 so) = false) -> + (forall so, is_label lbl (op2 so) = false) -> + find_label lbl (iterate_op op1 op2 l k) = find_label lbl k. +Proof. + intros. unfold iterate_op. + destruct l as [ | hd tl]. + simpl. rewrite H. auto. + simpl. rewrite H. + induction tl; simpl. auto. rewrite H0; auto. +Qed. +Hint Resolve iterate_op_label: labels. + Remark loadimm_label: forall r n k, find_label lbl (loadimm r n k) = find_label lbl k. Proof. - intros. unfold loadimm. - destruct (is_immed_arith n). reflexivity. - destruct (is_immed_arith (Int.not n)); reflexivity. + intros. unfold loadimm. + destruct (le_dec (length (decompose_int n)) (length (decompose_int (Int.not n)))); + auto with labels. Qed. Hint Rewrite loadimm_label: labels. @@ -343,9 +357,8 @@ Remark addimm_label: forall r1 r2 n k, find_label lbl (addimm r1 r2 n k) = find_label lbl k. Proof. intros; unfold addimm. - destruct (is_immed_arith n). reflexivity. - destruct (is_immed_arith (Int.neg n)). reflexivity. - autorewrite with labels. reflexivity. + destruct (le_dec (length (decompose_int n)) (length (decompose_int (Int.neg n)))); + auto with labels. Qed. Hint Rewrite addimm_label: labels. @@ -353,31 +366,30 @@ Remark andimm_label: forall r1 r2 n k, find_label lbl (andimm r1 r2 n k) = find_label lbl k. Proof. intros; unfold andimm. - destruct (is_immed_arith n). reflexivity. - destruct (is_immed_arith (Int.not n)). reflexivity. - autorewrite with labels. reflexivity. + destruct (is_immed_arith n). reflexivity. auto with labels. Qed. Hint Rewrite andimm_label: labels. -Remark makeimm_Prsb_label: - forall r1 r2 n k, find_label lbl (makeimm Prsb r1 r2 n k) = find_label lbl k. +Remark rsubimm_label: + forall r1 r2 n k, find_label lbl (rsubimm r1 r2 n k) = find_label lbl k. Proof. - intros; unfold makeimm. - destruct (is_immed_arith n). reflexivity. autorewrite with labels; auto. + intros; unfold rsubimm. auto with labels. Qed. -Remark makeimm_Porr_label: - forall r1 r2 n k, find_label lbl (makeimm Porr r1 r2 n k) = find_label lbl k. +Hint Rewrite rsubimm_label: labels. + +Remark orimm_label: + forall r1 r2 n k, find_label lbl (orimm r1 r2 n k) = find_label lbl k. Proof. - intros; unfold makeimm. - destruct (is_immed_arith n). reflexivity. autorewrite with labels; auto. + intros; unfold orimm. auto with labels. Qed. -Remark makeimm_Peor_label: - forall r1 r2 n k, find_label lbl (makeimm Peor r1 r2 n k) = find_label lbl k. +Hint Rewrite orimm_label: labels. + +Remark xorimm_label: + forall r1 r2 n k, find_label lbl (xorimm r1 r2 n k) = find_label lbl k. Proof. - intros; unfold makeimm. - destruct (is_immed_arith n). reflexivity. autorewrite with labels; auto. + intros; unfold xorimm. auto with labels. Qed. -Hint Rewrite makeimm_Prsb_label makeimm_Porr_label makeimm_Peor_label: labels. +Hint Rewrite xorimm_label: labels. Remark loadind_int_label: forall base ofs dst k, find_label lbl (loadind_int base ofs dst k) = find_label lbl k. @@ -692,7 +704,7 @@ Proof. rewrite (sp_val _ _ _ AG) in A. exploit loadind_correct. eexact A. reflexivity. intros [rs2 [EX [RES OTH]]]. - left; eapply exec_straight_steps; eauto with coqlib. + left; eapply exec_straight_steps. auto. eauto. auto. eauto with coqlib. eauto. eauto. exists m'; split; auto. simpl. exists rs2; split. eauto. apply agree_set_mreg with rs; auto. congruence. auto with ppcgen. @@ -715,19 +727,19 @@ Proof. rewrite (sp_val _ _ _ AG) in B. exploit storeind_correct. eexact B. reflexivity. congruence. intros [rs2 [EX OTH]]. - left; eapply exec_straight_steps; eauto with coqlib. + left; eapply exec_straight_steps. auto. eauto. auto. eauto with coqlib. eauto. eauto. exists m2; split; auto. - exists rs2; split; eauto. + simpl. exists rs2; split. eauto. apply agree_exten with rs; auto with ppcgen. Qed. Lemma exec_Mgetparam_prop: - forall (s : list stackframe) (fb : block) (f: Mach.function) (sp parent : val) + forall (s : list stackframe) (fb : block) (f: Mach.function) (sp : val) (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (v : val), Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m sp Tint f.(fn_link_ofs) = Some parent -> - load_stack m parent ty ofs = Some v -> + load_stack m sp Tint f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (parent_sp s) ty ofs = Some v -> exec_instr_prop (Machconcr.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0 (Machconcr.State s fb sp c (Regmap.set dst v (Regmap.set IT1 Vundef ms)) m). Proof. @@ -738,18 +750,18 @@ Proof. unfold load_stack in *. exploit Mem.loadv_extends. eauto. eexact H0. eauto. intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. - assert (parent' = parent). inv B. auto. simpl in H1; discriminate. subst parent'. + assert (parent' = parent_sp s). inv B. auto. rewrite <- H3 in H1; discriminate. subst parent'. exploit Mem.loadv_extends. eauto. eexact H1. eauto. intros [v' [C D]]. exploit (loadind_int_correct tge (transl_function f) IR13 f.(fn_link_ofs) IR14 - rs m' parent (loadind IR14 ofs (mreg_type dst) dst (transl_code f c))). + rs m' (parent_sp s) (loadind IR14 ofs (mreg_type dst) dst (transl_code f c))). auto. intros [rs1 [EX1 [RES1 OTH1]]]. exploit (loadind_correct tge (transl_function f) IR14 ofs (mreg_type dst) dst (transl_code f c) rs1 m' v'). rewrite RES1. auto. auto. intros [rs2 [EX2 [RES2 OTH2]]]. - left. eapply exec_straight_steps; eauto with coqlib. + left; eapply exec_straight_steps. auto. eauto. auto. eauto with coqlib. eauto. eauto. exists m'; split; auto. exists rs2; split; simpl. eapply exec_straight_trans; eauto. @@ -762,20 +774,20 @@ Lemma exec_Mop_prop: forall (s : list stackframe) (fb : block) (sp : val) (op : operation) (args : list mreg) (res : mreg) (c : list Mach.instruction) (ms : mreg -> val) (m : mem) (v : val), - eval_operation ge sp op ms ## args = Some v -> + eval_operation ge sp op ms ## args m = Some v -> exec_instr_prop (Machconcr.State s fb sp (Mop op args res :: c) ms m) E0 (Machconcr.State s fb sp c (Regmap.set res v (undef_op op ms)) m). Proof. intros; red; intros; inv MS. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI. - exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. + exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eauto. intros [v' [A B]]. - assert (C: eval_operation tge sp op rs ## (preg_of ## args) = Some v'). + assert (C: eval_operation tge sp op rs ## (preg_of ## args) m' = Some v'). rewrite <- A. apply eval_operation_preserved. exact symbols_preserved. rewrite (sp_val _ _ _ AG) in C. exploit transl_op_correct; eauto. intros [rs' [P [Q R]]]. - left; eapply exec_straight_steps; eauto with coqlib. + left; eapply exec_straight_steps. auto. eauto. auto. eauto with coqlib. eauto. eauto. exists m'; split; auto. exists rs'; split. simpl. eexact P. assert (agree (Regmap.set res v ms) sp rs'). @@ -809,7 +821,8 @@ Proof. eauto; intros; reflexivity. Qed. -Lemma storev_8_signed_unsigned:
forall m a v,
Mem.storev Mint8signed m a v = Mem.storev Mint8unsigned m a v.
Proof.
intros. unfold Mem.storev. destruct a; auto.
apply Mem.store_signed_unsigned_8.
Qed.
Lemma storev_16_signed_unsigned:
forall m a v,
Mem.storev Mint16signed m a v = Mem.storev Mint16unsigned m a v.
Proof.
intros. unfold Mem.storev. destruct a; auto.
apply Mem.store_signed_unsigned_16.
Qed. +Lemma storev_8_signed_unsigned:
forall m a v,
Mem.storev Mint8signed m a v = Mem.storev Mint8unsigned m a v.
Proof.
intros. unfold Mem.storev. + destruct a; auto.
apply Mem.store_signed_unsigned_8.
Qed.
Lemma storev_16_signed_unsigned:
forall m a v,
Mem.storev Mint16signed m a v = Mem.storev Mint16unsigned m a v.
Proof.
intros. unfold Mem.storev. destruct a; auto.
apply Mem.store_signed_unsigned_16.
Qed. Lemma exec_Mstore_prop: forall (s : list stackframe) (fb : block) (sp : val) @@ -826,7 +839,7 @@ Proof. intro WTI; inv WTI. assert (eval_addressing tge sp addr ms##args = Some a). rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - left; eapply exec_straight_steps; eauto with coqlib. + left; eapply exec_straight_steps. auto. eauto. auto. eauto with coqlib. eauto. eauto. destruct chunk; simpl; simpl in H6; try (rewrite storev_8_signed_unsigned in H0); try (rewrite storev_16_signed_unsigned in H0); @@ -896,8 +909,19 @@ Proof. intros. rewrite Pregmap.gso; auto with ppcgen. Qed. - -Lemma exec_Mtailcall_prop:
forall (s : list stackframe) (fb stk : block) (soff : int)
(sig : signature) (ros : mreg + ident) (c : list Mach.instruction)
(ms : Mach.regset) (m : mem) (f: Mach.function) (f' : block) m',
find_function_ptr ge ros ms = Some f' ->
Genv.find_funct_ptr ge fb = Some (Internal f) ->
load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' ->
exec_instr_prop
(Machconcr.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0
(Callstate s f' ms m').
Proof. +Lemma exec_Mtailcall_prop: + forall (s : list stackframe) (fb stk : block) (soff : int) + (sig : signature) (ros : mreg + ident) (c : list Mach.instruction) + (ms : Mach.regset) (m : mem) (f: Mach.function) (f' : block) m', + find_function_ptr ge ros ms = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + exec_instr_prop + (Machconcr.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0 + (Callstate s f' ms m'). +Proof. intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). @@ -906,7 +930,7 @@ Lemma exec_Mtailcall_prop:
forall (s : list stackframe) (fb stk : block) (soff match ros with inl r => Pbreg (ireg_of r) | inr symb => Pbsymb symb end). assert (TR: transl_code f (Mtailcall sig ros :: c) = loadind_int IR13 (fn_retaddr_ofs f) IR14 - (Pfreeframe (-f.(fn_framesize)) f.(fn_stacksize) (fn_link_ofs f) :: call_instr :: transl_code f c)). + (Pfreeframe f.(fn_stacksize) (fn_link_ofs f) :: call_instr :: transl_code f c)). unfold call_instr; destruct ros; auto. unfold load_stack in *. exploit Mem.loadv_extends. eauto. eexact H1. auto. @@ -918,7 +942,7 @@ Lemma exec_Mtailcall_prop:
forall (s : list stackframe) (fb stk : block) (soff exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. destruct (loadind_int_correct tge (transl_function f) IR13 f.(fn_retaddr_ofs) IR14 rs m'0 (parent_ra s) - (Pfreeframe (-f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: call_instr :: transl_code f c)) + (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: call_instr :: transl_code f c)) as [rs1 [EXEC1 [RES1 OTH1]]]. rewrite <- (sp_val ms (Vptr stk soff) rs); auto. set (rs2 := nextinstr (rs1#IR13 <- (parent_sp s))). @@ -1021,7 +1045,7 @@ Lemma exec_Mcond_true_prop: (cond : condition) (args : list mreg) (lbl : Mach.label) (c : list Mach.instruction) (ms : mreg -> val) (m : mem) (c' : Mach.code), - eval_condition cond ms ## args = Some true -> + eval_condition cond ms ## args m = Some true -> Genv.find_funct_ptr ge fb = Some (Internal f) -> Mach.find_label lbl (fn_code f) = Some c' -> exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0 @@ -1030,7 +1054,8 @@ Proof. intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI. inv WTI. - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. intros A. + exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. + intros A. exploit transl_cond_correct. eauto. eauto. intros [rs2 [EX [RES OTH]]]. inv AT. simpl in H5. @@ -1057,14 +1082,15 @@ Lemma exec_Mcond_false_prop: forall (s : list stackframe) (fb : block) (sp : val) (cond : condition) (args : list mreg) (lbl : Mach.label) (c : list Mach.instruction) (ms : mreg -> val) (m : mem), - eval_condition cond ms ## args = Some false -> + eval_condition cond ms ## args m = Some false -> exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0 (Machconcr.State s fb sp c (undef_temps ms) m). Proof. intros; red; intros; inv MS. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI. inv WTI. - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. intros A. + exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. + intros A. exploit transl_cond_correct. eauto. eauto. intros [rs2 [EX [RES OTH]]]. left; eapply exec_straight_steps; eauto with coqlib. @@ -1081,7 +1107,7 @@ Lemma exec_Mjumptable_prop: (ms : mreg -> val) (m : mem) (n : int) (lbl : Mach.label) (c' : Mach.code), ms arg = Vint n -> - list_nth_z tbl (Int.signed n) = Some lbl -> + list_nth_z tbl (Int.unsigned n) = Some lbl -> Genv.find_funct_ptr ge fb = Some (Internal f) -> Mach.find_label lbl (fn_code f) = Some c' -> exec_instr_prop @@ -1093,11 +1119,10 @@ Proof. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI. inv WTI. exploit list_nth_z_range; eauto. intro RANGE. - assert (SHIFT: Int.signed (Int.shl n (Int.repr 2)) = Int.signed n * 4). + assert (SHIFT: Int.unsigned (Int.shl n (Int.repr 2)) = Int.unsigned n * 4). rewrite Int.shl_mul. - rewrite Int.mul_signed. - apply Int.signed_repr. - split. apply Zle_trans with 0. vm_compute; congruence. omega. + unfold Int.mul. + apply Int.unsigned_repr. omega. inv AT. simpl in H7. set (k1 := Pbtbl IR14 tbl :: transl_code f c). @@ -1122,9 +1147,8 @@ Proof. eapply find_instr_tail. unfold k1 in CT1. eauto. unfold exec_instr. change (rs1 IR14) with (Vint (Int.shl n (Int.repr 2))). -Opaque Zmod. Opaque Zdiv. - simpl. rewrite SHIFT. rewrite Z_mod_mult. rewrite zeq_true. - rewrite Z_div_mult. + lazy iota beta. rewrite SHIFT. + rewrite Z_mod_mult. rewrite zeq_true. rewrite Z_div_mult. change label with Mach.label; rewrite H0. exact GOTO. omega. traceEq. econstructor; eauto. eapply Mach.find_label_incl; eauto. @@ -1133,7 +1157,16 @@ Opaque Zmod. Opaque Zdiv. apply agree_undef_temps; auto. Qed. -Lemma exec_Mreturn_prop:
forall (s : list stackframe) (fb stk : block) (soff : int)
(c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: Mach.function) 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) ->
Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' ->
exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0
(Returnstate s ms m').
Proof. +Lemma exec_Mreturn_prop: + forall (s : list stackframe) (fb stk : block) (soff : int) + (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: Mach.function) 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) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0 + (Returnstate s ms m'). +Proof. intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0. unfold load_stack in *. @@ -1147,13 +1180,13 @@ Lemma exec_Mreturn_prop:
forall (s : list stackframe) (fb stk : block) (soff : exploit (loadind_int_correct tge (transl_function f) IR13 f.(fn_retaddr_ofs) IR14 rs m'0 (parent_ra s) - (Pfreeframe (-f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: Pbreg IR14 :: transl_code f c)). + (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbreg IR14 :: transl_code f c)). rewrite <- (sp_val ms (Vptr stk soff) rs); auto. intros [rs1 [EXEC1 [RES1 OTH1]]]. set (rs2 := nextinstr (rs1#IR13 <- (parent_sp s))). assert (EXEC2: exec_straight tge (transl_function f) (loadind_int IR13 (fn_retaddr_ofs f) IR14 - (Pfreeframe (-f.(fn_framesize)) f.(fn_stacksize) (fn_link_ofs f) :: Pbreg IR14 :: transl_code f c)) + (Pfreeframe f.(fn_stacksize) (fn_link_ofs f) :: Pbreg IR14 :: transl_code f c)) rs m'0 (Pbreg IR14 :: transl_code f c) rs2 m2'). eapply exec_straight_trans. eexact EXEC1. apply exec_straight_one. simpl. rewrite OTH1; try congruence. @@ -1188,12 +1221,12 @@ Lemma exec_function_internal_prop: forall (s : list stackframe) (fb : block) (ms : Mach.regset) (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block), Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mem.alloc m (- fn_framesize f) (fn_stacksize f) = (m1, stk) -> - let sp := Vptr stk (Int.repr (- fn_framesize f)) in + Mem.alloc m 0 (fn_stacksize f) = (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 -> exec_instr_prop (Machconcr.Callstate s fb ms m) E0 - (Machconcr.State s fb sp (fn_code f) ms m3). + (Machconcr.State s fb sp (fn_code f) (undef_temps ms) m3). Proof. intros; red; intros; inv MS. assert (WTF: wt_function f). @@ -1201,7 +1234,7 @@ Proof. inversion TY; auto. exploit functions_transl; eauto. intro TFIND. generalize (functions_transl_no_overflow _ _ H); intro NOOV. - set (rs2 := nextinstr (rs#IR13 <- sp)). + set (rs2 := nextinstr (rs#IR12 <- (rs#IR13) #IR13 <- sp)). set (rs3 := nextinstr rs2). exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl. intros [m1' [A B]]. @@ -1218,7 +1251,7 @@ Proof. unfold transl_function at 2. apply exec_straight_two with rs2 m2'. unfold exec_instr. rewrite A. fold sp. - rewrite <- (sp_val ms (parent_sp s) rs); auto. rewrite C. auto. + rewrite (sp_val ms (parent_sp s) rs) in C; auto. rewrite C. auto. unfold exec_instr. unfold eval_shift_addr. unfold exec_store. change (rs2 IR13) with sp. change (rs2 IR14) with (rs IR14). rewrite ATLR. rewrite E. auto. @@ -1231,10 +1264,12 @@ Proof. eapply code_tail_next_int; auto. change (Int.unsigned Int.zero) with 0. unfold transl_function. constructor. - assert (AG3: agree ms sp rs3). + assert (AG3: agree (undef_temps ms) sp rs3). unfold rs3. apply agree_nextinstr. unfold rs2. apply agree_nextinstr. - apply agree_change_sp with (parent_sp s); auto. + apply agree_change_sp with (parent_sp s). + apply agree_exten_temps with rs; auto. + intros. apply Pregmap.gso; auto with ppcgen. unfold sp. congruence. left; exists (State rs3 m3'); split. (* execution *) diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v index c10c9df..fb49cb7 100644 --- a/arm/Asmgenproof1.v +++ b/arm/Asmgenproof1.v @@ -441,6 +441,169 @@ Qed. (** * Correctness of ARM constructor functions *) +(** Decomposition of an integer constant *) + +Lemma decompose_int_rec_or: + forall N n p x, List.fold_left Int.or (decompose_int_rec N n p) x = Int.or x n. +Proof. + induction N; intros; simpl. + destruct (Int.eq_dec n Int.zero); simpl. + subst n. rewrite Int.or_zero. auto. + auto. + destruct (Int.eq_dec (Int.and n (Int.shl (Int.repr 3) p)) Int.zero). + auto. + simpl. rewrite IHN. rewrite Int.or_assoc. decEq. rewrite <- Int.and_or_distrib. + rewrite Int.or_not_self. apply Int.and_mone. +Qed. + +Lemma decompose_int_rec_xor: + forall N n p x, List.fold_left Int.xor (decompose_int_rec N n p) x = Int.xor x n. +Proof. + induction N; intros; simpl. + destruct (Int.eq_dec n Int.zero); simpl. + subst n. rewrite Int.xor_zero. auto. + auto. + destruct (Int.eq_dec (Int.and n (Int.shl (Int.repr 3) p)) Int.zero). + auto. + simpl. rewrite IHN. rewrite Int.xor_assoc. decEq. rewrite <- Int.and_xor_distrib. + rewrite Int.xor_not_self. apply Int.and_mone. +Qed. + +Lemma decompose_int_rec_add: + forall N n p x, List.fold_left Int.add (decompose_int_rec N n p) x = Int.add x n. +Proof. + induction N; intros; simpl. + destruct (Int.eq_dec n Int.zero); simpl. + subst n. rewrite Int.add_zero. auto. + auto. + destruct (Int.eq_dec (Int.and n (Int.shl (Int.repr 3) p)) Int.zero). + auto. + simpl. rewrite IHN. rewrite Int.add_assoc. decEq. rewrite Int.add_and. + rewrite Int.or_not_self. apply Int.and_mone. apply Int.and_not_self. +Qed. + +Remark decompose_int_rec_nil: + forall N n p, decompose_int_rec N n p = nil -> n = Int.zero. +Proof. + intros. generalize (decompose_int_rec_or N n p Int.zero). rewrite H. simpl. + rewrite Int.or_commut; rewrite Int.or_zero; auto. +Qed. + +Lemma decompose_int_general: + forall (f: val -> int -> val) (g: int -> int -> int), + (forall v1 n2 n3, f (f v1 n2) n3 = f v1 (g n2 n3)) -> + (forall n1 n2 n3, g (g n1 n2) n3 = g n1 (g n2 n3)) -> + (forall n, g Int.zero n = n) -> + (forall N n p x, List.fold_left g (decompose_int_rec N n p) x = g x n) -> + forall n v, + List.fold_left f (decompose_int n) v = f v n. +Proof. + intros f g DISTR ASSOC ZERO DECOMP. + assert (A: forall l x y, g x (fold_left g l y) = fold_left g l (g x y)). + induction l; intros; simpl. auto. rewrite IHl. decEq. rewrite ASSOC; auto. + assert (B: forall l v n, fold_left f l (f v n) = f v (fold_left g l n)). + induction l; intros; simpl. + auto. + rewrite IHl. rewrite DISTR. decEq. decEq. auto. + intros. unfold decompose_int. + destruct (decompose_int_rec 12 n Int.zero) as []_eqn. + simpl. exploit decompose_int_rec_nil; eauto. congruence. + simpl. rewrite B. decEq. + generalize (DECOMP 12%nat n Int.zero Int.zero). + rewrite Heql. simpl. repeat rewrite ZERO. auto. +Qed. + +Lemma decompose_int_or: + forall n v, + List.fold_left (fun v i => Val.or v (Vint i)) (decompose_int n) v = Val.or v (Vint n). +Proof. + intros. apply decompose_int_general with (f := fun v n => Val.or v (Vint n)) (g := Int.or). + intros. rewrite Val.or_assoc. auto. + apply Int.or_assoc. + intros. rewrite Int.or_commut. apply Int.or_zero. + apply decompose_int_rec_or. +Qed. + +Lemma decompose_int_bic: + forall n v, + List.fold_left (fun v i => Val.and v (Vint (Int.not i))) (decompose_int n) v = Val.and v (Vint (Int.not n)). +Proof. + intros. apply decompose_int_general with (f := fun v n => Val.and v (Vint (Int.not n))) (g := Int.or). + intros. rewrite Val.and_assoc. simpl. decEq. decEq. rewrite Int.not_or_and_not. auto. + apply Int.or_assoc. + intros. rewrite Int.or_commut. apply Int.or_zero. + apply decompose_int_rec_or. +Qed. + +Lemma decompose_int_xor: + forall n v, + List.fold_left (fun v i => Val.xor v (Vint i)) (decompose_int n) v = Val.xor v (Vint n). +Proof. + intros. apply decompose_int_general with (f := fun v n => Val.xor v (Vint n)) (g := Int.xor). + intros. rewrite Val.xor_assoc. auto. + apply Int.xor_assoc. + intros. rewrite Int.xor_commut. apply Int.xor_zero. + apply decompose_int_rec_xor. +Qed. + +Lemma decompose_int_add: + forall n v, + List.fold_left (fun v i => Val.add v (Vint i)) (decompose_int n) v = Val.add v (Vint n). +Proof. + intros. apply decompose_int_general with (f := fun v n => Val.add v (Vint n)) (g := Int.add). + intros. rewrite Val.add_assoc. auto. + apply Int.add_assoc. + intros. rewrite Int.add_commut. apply Int.add_zero. + apply decompose_int_rec_add. +Qed. + +Lemma decompose_int_sub: + forall n v, + List.fold_left (fun v i => Val.sub v (Vint i)) (decompose_int n) v = Val.sub v (Vint n). +Proof. + intros. apply decompose_int_general with (f := fun v n => Val.sub v (Vint n)) (g := Int.add). + intros. repeat rewrite Val.sub_add_opp. rewrite Val.add_assoc. decEq. simpl. decEq. + rewrite Int.neg_add_distr; auto. + apply Int.add_assoc. + intros. rewrite Int.add_commut. apply Int.add_zero. + apply decompose_int_rec_add. +Qed. + +Lemma iterate_op_correct: + forall op1 op2 (f: val -> int -> val) (rs: regset) (r: ireg) m v0 n k, + (forall (rs:regset) n, + exec_instr ge fn (op2 (SOimm n)) rs m = + OK (nextinstr (rs#r <- (f (rs#r) n))) m) -> + (forall n, + exec_instr ge fn (op1 (SOimm n)) rs m = + OK (nextinstr (rs#r <- (f v0 n))) m) -> + exists rs', + exec_straight (iterate_op op1 op2 (decompose_int n) k) rs m k rs' m + /\ rs'#r = List.fold_left f (decompose_int n) v0 + /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros until k; intros SEM2 SEM1. + unfold iterate_op. + destruct (decompose_int n) as [ | i tl] _eqn. + unfold decompose_int in Heql. destruct (decompose_int_rec 12%nat n Int.zero); congruence. + revert k. pattern tl. apply List.rev_ind. + (* base case *) + intros; simpl. econstructor. + split. apply exec_straight_one. rewrite SEM1. reflexivity. reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. auto. + intros. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gso; auto with ppcgen. + (* inductive case *) + intros. + rewrite List.map_app. simpl. rewrite app_ass. simpl. + destruct (H (op2 (SOimm x) :: k)) as [rs' [A [B C]]]. + econstructor. + split. eapply exec_straight_trans. eexact A. apply exec_straight_one. + rewrite SEM2. reflexivity. reflexivity. + split. rewrite fold_left_app; simpl. rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gss. rewrite B. auto. + intros. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gso; auto with ppcgen. +Qed. + (** Loading a constant. *) Lemma loadimm_correct: @@ -451,46 +614,19 @@ Lemma loadimm_correct: /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'. Proof. intros. unfold loadimm. - case (is_immed_arith n). - (* single move *) - exists (nextinstr (rs#r <- (Vint n))). - split. apply exec_straight_one. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. - apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - case (is_immed_arith (Int.not n)). - (* single move-complement *) - exists (nextinstr (rs#r <- (Vint n))). - split. apply exec_straight_one. - simpl. change (Int.xor (Int.not n) Int.mone) with (Int.not (Int.not n)). - rewrite Int.not_involutive. auto. - reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. - apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* mov - or - or - or *) - set (n1 := Int.and n (Int.repr 255)). - set (n2 := Int.and n (Int.repr 65280)). - set (n3 := Int.and n (Int.repr 16711680)). - set (n4 := Int.and n (Int.repr 4278190080)). - set (rs1 := nextinstr (rs#r <- (Vint n1))). - set (rs2 := nextinstr (rs1#r <- (Val.or rs1#r (Vint n2)))). - set (rs3 := nextinstr (rs2#r <- (Val.or rs2#r (Vint n3)))). - set (rs4 := nextinstr (rs3#r <- (Val.or rs3#r (Vint n4)))). - exists rs4. - split. apply exec_straight_four with rs1 m rs2 m rs3 m; auto. - split. unfold rs4. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - unfold rs3. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - unfold rs2. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - repeat rewrite Val.or_assoc. simpl. decEq. - unfold n4, n3, n2, n1. repeat rewrite <- Int.and_or_distrib. - change (Int.and n Int.mone = n). apply Int.and_mone. - intros. - unfold rs4. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs3. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs2. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + destruct (le_dec (length (decompose_int n)) (length (decompose_int (Int.not n)))). + (* mov - orr* *) + replace (Vint n) with (List.fold_left (fun v i => Val.or v (Vint i)) (decompose_int n) Vzero). + apply iterate_op_correct. + auto. + intros; simpl. rewrite Int.or_commut; rewrite Int.or_zero; auto. + rewrite decompose_int_or. simpl. rewrite Int.or_commut; rewrite Int.or_zero; auto. + (* mvn - bic* *) + replace (Vint n) with (List.fold_left (fun v i => Val.and v (Vint (Int.not i))) (decompose_int (Int.not n)) (Vint Int.mone)). + apply iterate_op_correct. + auto. + intros. simpl. rewrite Int.and_commut; rewrite Int.and_mone; auto. + rewrite decompose_int_bic. simpl. rewrite Int.not_involutive. rewrite Int.and_commut. rewrite Int.and_mone; auto. Qed. (** Add integer immediate. *) @@ -503,46 +639,21 @@ Lemma addimm_correct: /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. Proof. intros. unfold addimm. - (* addi *) - case (is_immed_arith n). - exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))). - split. apply exec_straight_one; auto. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* subi *) - case (is_immed_arith (Int.neg n)). - exists (nextinstr (rs#r1 <- (Val.sub rs#r2 (Vint (Int.neg n))))). - split. apply exec_straight_one; auto. - split. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - apply Val.sub_opp_add. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* general *) - set (n1 := Int.and n (Int.repr 255)). - set (n2 := Int.and n (Int.repr 65280)). - set (n3 := Int.and n (Int.repr 16711680)). - set (n4 := Int.and n (Int.repr 4278190080)). - set (rs1 := nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n1)))). - set (rs2 := nextinstr (rs1#r1 <- (Val.add rs1#r1 (Vint n2)))). - set (rs3 := nextinstr (rs2#r1 <- (Val.add rs2#r1 (Vint n3)))). - set (rs4 := nextinstr (rs3#r1 <- (Val.add rs3#r1 (Vint n4)))). - exists rs4. - split. apply exec_straight_four with rs1 m rs2 m rs3 m; auto. - simpl. - split. unfold rs4. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - unfold rs3. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - unfold rs2. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - repeat rewrite Val.add_assoc. simpl. decEq. decEq. - unfold n4, n3, n2, n1. repeat rewrite Int.add_and. - change (Int.and n Int.mone = n). apply Int.and_mone. - vm_compute; auto. - vm_compute; auto. - vm_compute; auto. - intros. - unfold rs4. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs3. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs2. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + destruct (le_dec (length (decompose_int n)) (length (decompose_int (Int.neg n)))). + (* add - add* *) + replace (Val.add (rs r2) (Vint n)) + with (List.fold_left (fun v i => Val.add v (Vint i)) (decompose_int n) (rs r2)). + apply iterate_op_correct. + auto. + auto. + apply decompose_int_add. + (* sub - sub* *) + replace (Val.add (rs r2) (Vint n)) + with (List.fold_left (fun v i => Val.sub v (Vint i)) (decompose_int (Int.neg n)) (rs r2)). + apply iterate_op_correct. + auto. + auto. + rewrite decompose_int_sub. apply Val.sub_opp_add. Qed. (* And integer immediate *) @@ -553,7 +664,7 @@ Lemma andimm_correct: exists rs', exec_straight (andimm r1 r2 n k) rs m k rs' m /\ rs'#r1 = Val.and rs#r2 (Vint n) - /\ forall r': preg, r' <> r1 -> r' <> IR14 -> r' <> PC -> rs'#r' = rs#r'. + /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. Proof. intros. unfold andimm. (* andi *) @@ -562,57 +673,72 @@ Proof. split. apply exec_straight_one; auto. split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* bici *) - case (is_immed_arith (Int.not n)). - exists (nextinstr (rs#r1 <- (Val.and rs#r2 (Vint n)))). - split. apply exec_straight_one; auto. simpl. - change (Int.xor (Int.not n) Int.mone) with (Int.not (Int.not n)). - rewrite Int.not_involutive. auto. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* general *) - exploit loadimm_correct. intros [rs' [A [B C]]]. - exists (nextinstr (rs'#r1 <- (Val.and rs#r2 (Vint n)))). - split. eapply exec_straight_trans. eauto. apply exec_straight_one. - simpl. rewrite B. rewrite C; auto with ppcgen. + (* bic - bic* *) + replace (Val.and (rs r2) (Vint n)) + with (List.fold_left (fun v i => Val.and v (Vint (Int.not i))) (decompose_int (Int.not n)) (rs r2)). + apply iterate_op_correct. auto. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + auto. + rewrite decompose_int_bic. rewrite Int.not_involutive. auto. Qed. -(** Other integer immediate *) +(** Reverse sub immediate *) -Lemma makeimm_correct: - forall (instr: ireg -> ireg -> shift_op -> instruction) - (sem: val -> val -> val) - r1 (r2: ireg) n k (rs : regset) m, - (forall c r1 r2 so rs m, - exec_instr ge c (instr r1 r2 so) rs m - = OK (nextinstr rs#r1 <- (sem rs#r2 (eval_shift_op so rs))) m) -> - r2 <> IR14 -> +Lemma rsubimm_correct: + forall r1 r2 n k rs m, exists rs', - exec_straight (makeimm instr r1 r2 n k) rs m k rs' m - /\ rs'#r1 = sem rs#r2 (Vint n) - /\ forall r': preg, r' <> r1 -> r' <> PC -> r' <> IR14 -> rs'#r' = rs#r'. + exec_straight (rsubimm r1 r2 n k) rs m k rs' m + /\ rs'#r1 = Val.sub (Vint n) rs#r2 + /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. Proof. - intros. unfold makeimm. - case (is_immed_arith n). - (* one immed instr *) - exists (nextinstr (rs#r1 <- (sem rs#r2 (Vint n)))). - split. apply exec_straight_one. - change (Vint n) with (eval_shift_op (SOimm n) rs). auto. - auto. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* general case *) - exploit loadimm_correct. intros [rs' [A [B C]]]. - exists (nextinstr (rs'#r1 <- (sem rs#r2 (Vint n)))). - split. eapply exec_straight_trans. eauto. apply exec_straight_one. - rewrite <- B. rewrite <- (C r2). - change (rs' IR14) with (eval_shift_op (SOreg IR14) rs'). auto. - congruence. auto with ppcgen. auto. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto with ppcgen. + intros. unfold rsubimm. + (* rsb - add* *) + replace (Val.sub (Vint n) (rs r2)) + with (List.fold_left (fun v i => Val.add v (Vint i)) (decompose_int n) (Val.neg (rs r2))). + apply iterate_op_correct. + auto. + intros. simpl. destruct (rs r2); auto. simpl. rewrite Int.sub_add_opp. + rewrite Int.add_commut; auto. + rewrite decompose_int_add. + destruct (rs r2); simpl; auto. rewrite Int.sub_add_opp. rewrite Int.add_commut; auto. +Qed. + +(** Or immediate *) + +Lemma orimm_correct: + forall r1 r2 n k rs m, + exists rs', + exec_straight (orimm r1 r2 n k) rs m k rs' m + /\ rs'#r1 = Val.or rs#r2 (Vint n) + /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold orimm. + (* ori - ori* *) + replace (Val.or (rs r2) (Vint n)) + with (List.fold_left (fun v i => Val.or v (Vint i)) (decompose_int n) (rs r2)). + apply iterate_op_correct. + auto. + auto. + apply decompose_int_or. +Qed. + +(** Xor immediate *) + +Lemma xorimm_correct: + forall r1 r2 n k rs m, + exists rs', + exec_straight (xorimm r1 r2 n k) rs m k rs' m + /\ rs'#r1 = Val.xor rs#r2 (Vint n) + /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold xorimm. + (* xori - xori* *) + replace (Val.xor (rs r2) (Vint n)) + with (List.fold_left (fun v i => Val.xor v (Vint i)) (decompose_int n) (rs r2)). + apply iterate_op_correct. + auto. + auto. + apply decompose_int_xor. Qed. (** Indexed memory loads. *) @@ -636,8 +762,7 @@ Proof. split. eapply exec_straight_trans. eauto. apply exec_straight_one. simpl. unfold exec_load. rewrite B. rewrite Val.add_assoc. simpl. rewrite Int.add_zero. - rewrite H. auto. - auto. + rewrite H. auto. auto. split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. Qed. @@ -659,7 +784,8 @@ Proof. exploit addimm_correct. eauto. intros [rs' [A [B C]]]. exists (nextinstr (rs'#dst <- v)). split. eapply exec_straight_trans. eauto. apply exec_straight_one. - simpl. unfold exec_load. rewrite B. rewrite Val.add_assoc. simpl. + simpl. unfold exec_load. rewrite B. + rewrite Val.add_assoc. simpl. rewrite Int.add_zero. rewrite H. auto. auto. split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. @@ -700,8 +826,8 @@ Proof. exploit addimm_correct. eauto. intros [rs' [A [B C]]]. exists (nextinstr rs'). split. eapply exec_straight_trans. eauto. apply exec_straight_one. - simpl. unfold exec_store. rewrite B. rewrite C. - rewrite Val.add_assoc. simpl. rewrite Int.add_zero. + simpl. unfold exec_store. rewrite B. + rewrite C. rewrite Val.add_assoc. simpl. rewrite Int.add_zero. rewrite H. auto. congruence. auto with ppcgen. auto. intros. rewrite nextinstr_inv; auto. @@ -723,10 +849,11 @@ Proof. exploit addimm_correct. eauto. intros [rs' [A [B C]]]. exists (nextinstr rs'). split. eapply exec_straight_trans. eauto. apply exec_straight_one. - simpl. unfold exec_store. rewrite B. rewrite C. - rewrite Val.add_assoc. simpl. rewrite Int.add_zero. + simpl. unfold exec_store. rewrite B. + rewrite C. rewrite Val.add_assoc. simpl. rewrite Int.add_zero. rewrite H. auto. - congruence. congruence. auto with ppcgen. auto. + congruence. congruence. + auto with ppcgen. intros. rewrite nextinstr_inv; auto. Qed. @@ -827,13 +954,14 @@ Ltac TypeInv := TypeInv1; simpl in *; unfold preg_of in *; TypeInv2. Lemma transl_cond_correct: forall cond args k rs m b, map mreg_type args = type_of_condition cond -> - eval_condition cond (map rs (map preg_of args)) = Some b -> + eval_condition cond (map rs (map preg_of args)) m = Some b -> exists rs', exec_straight (transl_cond cond args k) rs m k rs' m /\ rs'#(CR (crbit_for_cond cond)) = Val.of_bool b /\ forall r, important_preg r = true -> rs'#r = rs r. Proof. - intros until b; intros TY EV. rewrite <- (eval_condition_weaken _ _ EV). clear EV. + intros until b; intros TY EV. + rewrite <- (eval_condition_weaken _ _ _ EV). clear EV. destruct cond; simpl in TY; TypeInv. (* Ccomp *) generalize (compare_int_spec rs (rs (ireg_of m0)) (rs (ireg_of m1))). @@ -917,11 +1045,11 @@ Qed. Ltac Simpl := match goal with - | [ |- nextinstr _ _ = _ ] => rewrite nextinstr_inv; [auto | auto with ppcgen] - | [ |- Pregmap.get ?x (Pregmap.set ?x _ _) = _ ] => rewrite Pregmap.gss; auto - | [ |- Pregmap.set ?x _ _ ?x = _ ] => rewrite Pregmap.gss; auto - | [ |- Pregmap.get _ (Pregmap.set _ _ _) = _ ] => rewrite Pregmap.gso; [auto | auto with ppcgen] - | [ |- Pregmap.set _ _ _ _ = _ ] => rewrite Pregmap.gso; [auto | auto with ppcgen] + | [ |- context[nextinstr _ _] ] => rewrite nextinstr_inv; [auto | auto with ppcgen] + | [ |- context[Pregmap.get ?x (Pregmap.set ?x _ _)] ] => rewrite Pregmap.gss; auto + | [ |- context[Pregmap.set ?x _ _ ?x] ] => rewrite Pregmap.gss; auto + | [ |- context[Pregmap.get _ (Pregmap.set _ _ _)] ] => rewrite Pregmap.gso; [auto | auto with ppcgen] + | [ |- context[Pregmap.set _ _ _ _] ] => rewrite Pregmap.gso; [auto | auto with ppcgen] end. Ltac TranslOpSimpl := @@ -932,13 +1060,13 @@ Ltac TranslOpSimpl := Lemma transl_op_correct: forall op args res k (rs: regset) m v, wt_instr (Mop op args res) -> - eval_operation ge rs#IR13 op (map rs (map preg_of args)) = Some v -> + eval_operation ge rs#IR13 op (map rs (map preg_of args)) m = Some v -> exists rs', exec_straight (transl_op op args res k) rs m k rs' m /\ rs'#(preg_of res) = v /\ forall r, important_preg r = true -> r <> preg_of res -> rs'#r = rs#r. Proof. - intros. rewrite <- (eval_operation_weaken _ _ _ _ H0). inv H. + intros. rewrite <- (eval_operation_weaken _ _ _ _ _ H0). inv H. (* Omove *) simpl. exists (nextinstr (rs#(preg_of res) <- (rs#(preg_of r1)))). @@ -952,7 +1080,7 @@ Proof. congruence. (* Ointconst *) generalize (loadimm_correct (ireg_of res) i k rs m). intros [rs' [A [B C]]]. - exists rs'. split. auto. split. auto. intros. auto with ppcgen. + exists rs'. split. auto. split. rewrite B; auto. intros. auto with ppcgen. (* Oaddrstack *) generalize (addimm_correct (ireg_of res) IR13 i k rs m). intros [rs' [EX [RES OTH]]]. @@ -960,41 +1088,43 @@ Proof. (* Ocast8signed *) econstructor; split. eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split. Simpl. Simpl. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.sign_ext_shr_shl. reflexivity. + split. Simpl. Simpl. Simpl. Simpl. + destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.sign_ext_shr_shl. + reflexivity. compute; auto. intros. repeat Simpl. (* Ocast8unsigned *) econstructor; split. - eapply exec_straight_one. simpl; eauto. auto. - split. Simpl. Simpl. - destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.zero_ext_and. reflexivity. + eapply exec_straight_one. simpl; eauto. auto. + split. Simpl. Simpl. + destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.zero_ext_and. auto. compute; auto. - intros. repeat Simpl. + intros. repeat Simpl. (* Ocast16signed *) econstructor; split. eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split. Simpl. Simpl. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.sign_ext_shr_shl. reflexivity. + split. Simpl. Simpl. Simpl. Simpl. + destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.sign_ext_shr_shl. auto. compute; auto. intros. repeat Simpl. (* Ocast16unsigned *) econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split. Simpl. Simpl. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.zero_ext_shru_shl. reflexivity. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split. Simpl. Simpl. Simpl. Simpl. + destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.zero_ext_shru_shl; auto. compute; auto. - intros. repeat Simpl. + intros. repeat Simpl. (* Oaddimm *) generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m). intros [rs' [A [B C]]]. exists rs'. split. auto. split. auto. auto with ppcgen. (* Orsbimm *) - exploit (makeimm_correct Prsb (fun v1 v2 => Val.sub v2 v1) (ireg_of res) (ireg_of m0)); - auto with ppcgen. + generalize (rsubimm_correct (ireg_of res) (ireg_of m0) i k rs m). intros [rs' [A [B C]]]. exists rs'. - split. eauto. split. rewrite B. auto. auto with ppcgen. + split. eauto. split. rewrite B. + destruct (rs (ireg_of m0)); auto. + auto with ppcgen. (* Omul *) destruct (ireg_eq (ireg_of res) (ireg_of m0) || ireg_eq (ireg_of res) (ireg_of m1)). econstructor; split. @@ -1006,17 +1136,15 @@ Proof. generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m (ireg_of_not_IR14 m0)). intros [rs' [A [B C]]]. - exists rs'. split. auto. split. auto. auto with ppcgen. + exists rs'; auto with ppcgen. (* Oorimm *) - exploit (makeimm_correct Porr Val.or (ireg_of res) (ireg_of m0)); - auto with ppcgen. + generalize (orimm_correct (ireg_of res) (ireg_of m0) i k rs m). intros [rs' [A [B C]]]. - exists rs'. split. eauto. split. auto. auto with ppcgen. + exists rs'; auto with ppcgen. (* Oxorimm *) - exploit (makeimm_correct Peor Val.xor (ireg_of res) (ireg_of m0)); - auto with ppcgen. + generalize (xorimm_correct (ireg_of res) (ireg_of m0) i k rs m). intros [rs' [A [B C]]]. - exists rs'. split. eauto. split. auto. auto with ppcgen. + exists rs'; auto with ppcgen. (* Oshrximm *) assert (exists n, rs (ireg_of m0) = Vint n /\ Int.ltu i (Int.repr 31) = true). destruct (rs (ireg_of m0)); try discriminate. @@ -1050,8 +1178,11 @@ Proof. auto. unfold rs3. case islt; auto. auto. split. unfold rs4. repeat Simpl. rewrite ARG1. simpl. rewrite LTU'. rewrite Int.shrx_shr. fold islt. unfold rs3. rewrite nextinstr_inv; auto with ppcgen. - destruct islt. rewrite RES2. change (rs1 (IR (ireg_of m0))) with (rs (IR (ireg_of m0))). - rewrite ARG1. simpl. rewrite LTU'. auto. + destruct islt. + rewrite RES2. + change (rs1 (IR (ireg_of m0))) with (rs (IR (ireg_of m0))). + rewrite ARG1. + simpl. rewrite LTU'. auto. rewrite Pregmap.gss. simpl. rewrite LTU'. auto. assumption. intros. unfold rs4; repeat Simpl. unfold rs3; repeat Simpl. @@ -1059,10 +1190,10 @@ Proof. rewrite OTH2; auto with ppcgen. (* Ocmp *) fold preg_of in *. - assert (exists b, eval_condition c rs ## (preg_of ## args) = Some b /\ v = Val.of_bool b). - fold preg_of in H0. destruct (eval_condition c rs ## (preg_of ## args)). + assert (exists b, eval_condition c rs ## (preg_of ## args) m = Some b /\ v = Val.of_bool b). + fold preg_of in H0. destruct (eval_condition c rs ## (preg_of ## args) m). exists b; split; auto. destruct b; inv H0; auto. congruence. - clear H0. destruct H as [b [EVC VBO]]. rewrite (eval_condition_weaken _ _ EVC). + clear H0. destruct H as [b [EVC VBO]]. rewrite (eval_condition_weaken _ _ _ EVC). destruct (transl_cond_correct c args (Pmov (ireg_of res) (SOimm Int.zero) :: Pmovc (crbit_for_cond c) (ireg_of res) (SOimm Int.one) :: k) diff --git a/arm/Asmgenretaddr.v b/arm/Asmgenretaddr.v index 359aaf2..97250a6 100644 --- a/arm/Asmgenretaddr.v +++ b/arm/Asmgenretaddr.v @@ -102,6 +102,16 @@ Ltac IsTail := | _ => idtac end. +Lemma iterate_op_tail: + forall op1 op2 l k, is_tail k (iterate_op op1 op2 l k). +Proof. + intros. unfold iterate_op. + destruct l. + auto with coqlib. + constructor. revert l; induction l; simpl; auto with coqlib. +Qed. +Hint Resolve iterate_op_tail: ppcretaddr. + Lemma loadimm_tail: forall r n k, is_tail k (loadimm r n k). Proof. unfold loadimm; intros; IsTail. Qed. @@ -117,10 +127,20 @@ Lemma andimm_tail: Proof. unfold andimm; intros; IsTail. Qed. Hint Resolve andimm_tail: ppcretaddr. -Lemma makeimm_tail: - forall f r1 r2 n k, is_tail k (makeimm f r1 r2 n k). -Proof. unfold makeimm; intros; IsTail. Qed. -Hint Resolve makeimm_tail: ppcretaddr. +Lemma rsubimm_tail: + forall r1 r2 n k, is_tail k (rsubimm r1 r2 n k). +Proof. unfold rsubimm; intros; IsTail. Qed. +Hint Resolve rsubimm_tail: ppcretaddr. + +Lemma orimm_tail: + forall r1 r2 n k, is_tail k (orimm r1 r2 n k). +Proof. unfold orimm; intros; IsTail. Qed. +Hint Resolve orimm_tail: ppcretaddr. + +Lemma xorimm_tail: + forall r1 r2 n k, is_tail k (xorimm r1 r2 n k). +Proof. unfold xorimm; intros; IsTail. Qed. +Hint Resolve xorimm_tail: ppcretaddr. Lemma transl_cond_tail: forall cond args k, is_tail k (transl_cond cond args k). @@ -189,11 +209,11 @@ Proof. Qed. Lemma return_address_exists: - forall f c, is_tail c f.(fn_code) -> + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(fn_code) -> exists ra, return_address_offset f c ra. Proof. intros. assert (is_tail (transl_code f c) (transl_function f)). - unfold transl_function. IsTail. apply transl_code_tail; auto. + unfold transl_function. IsTail. apply transl_code_tail; eauto with coqlib. destruct (is_tail_code_tail _ _ H0) as [ofs A]. exists (Int.repr ofs). constructor. auto. Qed. diff --git a/arm/ConstpropOpproof.v b/arm/ConstpropOpproof.v index 3f98b88..25758cc 100644 --- a/arm/ConstpropOpproof.v +++ b/arm/ConstpropOpproof.v @@ -88,10 +88,10 @@ Ltac InvVLMA := approximations returned by [eval_static_operation]. *) Lemma eval_static_condition_correct: - forall cond al vl b, + forall cond al vl m b, val_list_match_approx al vl -> eval_static_condition cond al = Some b -> - eval_condition cond vl = Some b. + eval_condition cond vl m = Some b. Proof. intros until b. unfold eval_static_condition. @@ -100,9 +100,9 @@ Proof. Qed. Lemma eval_static_operation_correct: - forall op sp al vl v, + forall op sp al vl m v, val_list_match_approx al vl -> - eval_operation ge sp op vl = Some v -> + eval_operation ge sp op vl m = Some v -> val_match_approx (eval_static_operation op al) v. Proof. intros until v. @@ -144,7 +144,7 @@ Proof. inv H4. destruct (Float.intoffloat f); simpl in H0; inv H0. red; auto. caseEq (eval_static_condition c vl0). - intros. generalize (eval_static_condition_correct _ _ _ _ H H1). + intros. generalize (eval_static_condition_correct _ _ _ m _ H H1). intro. rewrite H2 in H0. destruct b; injection H0; intro; subst v; simpl; auto. intros; simpl; auto. @@ -168,6 +168,7 @@ Section STRENGTH_REDUCTION. Variable app: reg -> approx. Variable sp: val. Variable rs: regset. +Variable m: mem. Hypothesis MATCH: forall r, val_match_approx (app r) rs#r. Lemma intval_correct: @@ -183,7 +184,7 @@ Qed. Lemma cond_strength_reduction_correct: forall cond args, let (cond', args') := cond_strength_reduction app cond args in - eval_condition cond' rs##args' = eval_condition cond rs##args. + eval_condition cond' rs##args' m = eval_condition cond rs##args m. Proof. intros. unfold cond_strength_reduction. case (cond_strength_reduction_match cond args); intros. @@ -191,7 +192,6 @@ Proof. caseEq (intval app r1); intros. simpl. rewrite (intval_correct _ _ H). destruct (rs#r2); auto. rewrite Int.swap_cmp. auto. - destruct c; reflexivity. caseEq (intval app r2); intros. simpl. rewrite (intval_correct _ _ H0). auto. auto. @@ -199,6 +199,7 @@ Proof. caseEq (intval app r1); intros. simpl. rewrite (intval_correct _ _ H). destruct (rs#r2); auto. rewrite Int.swap_cmpu. auto. + destruct c; reflexivity. caseEq (intval app r2); intros. simpl. rewrite (intval_correct _ _ H0). auto. auto. @@ -217,8 +218,8 @@ Qed. Lemma make_addimm_correct: forall n r v, let (op, args) := make_addimm n r in - eval_operation ge sp Oadd (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oadd (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_addimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -230,8 +231,8 @@ Qed. Lemma make_shlimm_correct: forall n r v, let (op, args) := make_shlimm n r in - eval_operation ge sp Oshl (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oshl (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_shlimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -244,8 +245,8 @@ Qed. Lemma make_shrimm_correct: forall n r v, let (op, args) := make_shrimm n r in - eval_operation ge sp Oshr (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oshr (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_shrimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -258,8 +259,8 @@ Qed. Lemma make_shruimm_correct: forall n r v, let (op, args) := make_shruimm n r in - eval_operation ge sp Oshru (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oshru (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_shruimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -273,8 +274,8 @@ Lemma make_mulimm_correct: forall n r r' v, rs#r' = Vint n -> let (op, args) := make_mulimm n r r' in - eval_operation ge sp Omul (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Omul (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_mulimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -282,8 +283,8 @@ Proof. generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros. subst n. simpl in H2. simpl. FuncInv. rewrite Int.mul_one in H1. congruence. caseEq (Int.is_power2 n); intros. - replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil)) - with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil)). + replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil) m) + with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil) m). apply make_shlimm_correct. simpl. generalize (Int.is_power2_range _ _ H2). change (Z_of_nat Int.wordsize) with 32. intro. rewrite H3. @@ -294,8 +295,8 @@ Qed. Lemma make_andimm_correct: forall n r v, let (op, args) := make_andimm n r in - eval_operation ge sp Oand (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oand (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_andimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -308,8 +309,8 @@ Qed. Lemma make_orimm_correct: forall n r v, let (op, args) := make_orimm n r in - eval_operation ge sp Oor (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oor (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_orimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -322,8 +323,8 @@ Qed. Lemma make_xorimm_correct: forall n r v, let (op, args) := make_xorimm n r in - eval_operation ge sp Oxor (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oxor (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_xorimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -336,16 +337,16 @@ Qed. Lemma op_strength_reduction_correct: forall op args v, let (op', args') := op_strength_reduction app op args in - eval_operation ge sp op rs##args = Some v -> - eval_operation ge sp op' rs##args' = Some v. + eval_operation ge sp op rs##args m = Some v -> + eval_operation ge sp op' rs##args' m = Some v. Proof. intros; unfold op_strength_reduction; case (op_strength_reduction_match op args); intros; simpl List.map. (* Oadd *) caseEq (intval app r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oadd (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Oadd (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Oadd (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oadd (rs # r2 :: Vint i :: nil) m). apply make_addimm_correct. simpl. destruct rs#r2; auto. rewrite Int.add_commut; auto. caseEq (intval app r2); intros. @@ -354,8 +355,8 @@ Proof. (* Oaddshift *) caseEq (intval app r2); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp (Oaddshift s) (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oadd (rs # r1 :: Vint (eval_shift s i) :: nil)). + replace (eval_operation ge sp (Oaddshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oadd (rs # r1 :: Vint (eval_shift s i) :: nil) m). apply make_addimm_correct. simpl. destruct rs#r1; auto. assumption. @@ -365,16 +366,16 @@ Proof. simpl in *. destruct rs#r2; auto. caseEq (intval app r2); intros. rewrite (intval_correct _ _ H0). - replace (eval_operation ge sp Osub (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg i) :: nil)). + replace (eval_operation ge sp Osub (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg i) :: nil) m). apply make_addimm_correct. simpl. destruct rs#r1; auto; rewrite Int.sub_add_opp; auto. assumption. (* Osubshift *) caseEq (intval app r2); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp (Osubshift s) (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg (eval_shift s i)) :: nil)). + replace (eval_operation ge sp (Osubshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg (eval_shift s i)) :: nil) m). apply make_addimm_correct. simpl. destruct rs#r1; auto; rewrite Int.sub_add_opp; auto. assumption. @@ -386,8 +387,8 @@ Proof. (* Omul *) caseEq (intval app r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Omul (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Omul (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Omul (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Omul (rs # r2 :: Vint i :: nil) m). apply make_mulimm_correct. apply intval_correct; auto. simpl. destruct rs#r2; auto. rewrite Int.mul_commut; auto. caseEq (intval app r2); intros. @@ -398,8 +399,8 @@ Proof. caseEq (intval app r2); intros. caseEq (Int.is_power2 i); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil)). + replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil) m). apply make_shruimm_correct. simpl. destruct rs#r1; auto. change 32 with (Z_of_nat Int.wordsize). @@ -412,8 +413,8 @@ Proof. (* Oand *) caseEq (intval app r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oand (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Oand (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Oand (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oand (rs # r2 :: Vint i :: nil) m). apply make_andimm_correct. simpl. destruct rs#r2; auto. rewrite Int.and_commut; auto. caseEq (intval app r2); intros. @@ -422,15 +423,15 @@ Proof. (* Oandshift *) caseEq (intval app r2); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp (Oandshift s) (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oand (rs # r1 :: Vint (eval_shift s i) :: nil)). + replace (eval_operation ge sp (Oandshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oand (rs # r1 :: Vint (eval_shift s i) :: nil) m). apply make_andimm_correct. reflexivity. assumption. (* Oor *) caseEq (intval app r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oor (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Oor (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Oor (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oor (rs # r2 :: Vint i :: nil) m). apply make_orimm_correct. simpl. destruct rs#r2; auto. rewrite Int.or_commut; auto. caseEq (intval app r2); intros. @@ -439,15 +440,15 @@ Proof. (* Oorshift *) caseEq (intval app r2); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp (Oorshift s) (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oor (rs # r1 :: Vint (eval_shift s i) :: nil)). + replace (eval_operation ge sp (Oorshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oor (rs # r1 :: Vint (eval_shift s i) :: nil) m). apply make_orimm_correct. reflexivity. assumption. (* Oxor *) caseEq (intval app r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oxor (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Oxor (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Oxor (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oxor (rs # r2 :: Vint i :: nil) m). apply make_xorimm_correct. simpl. destruct rs#r2; auto. rewrite Int.xor_commut; auto. caseEq (intval app r2); intros. @@ -456,22 +457,22 @@ Proof. (* Oxorshift *) caseEq (intval app r2); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp (Oxorshift s) (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oxor (rs # r1 :: Vint (eval_shift s i) :: nil)). + replace (eval_operation ge sp (Oxorshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oxor (rs # r1 :: Vint (eval_shift s i) :: nil) m). apply make_xorimm_correct. reflexivity. assumption. (* Obic *) caseEq (intval app r2); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Obic (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oand (rs # r1 :: Vint (Int.not i) :: nil)). + replace (eval_operation ge sp Obic (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oand (rs # r1 :: Vint (Int.not i) :: nil) m). apply make_andimm_correct. reflexivity. assumption. (* Obicshift *) caseEq (intval app r2); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp (Obicshift s) (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oand (rs # r1 :: Vint (Int.not (eval_shift s i)) :: nil)). + replace (eval_operation ge sp (Obicshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oand (rs # r1 :: Vint (Int.not (eval_shift s i)) :: nil) m). apply make_andimm_correct. reflexivity. assumption. (* Oshl *) @@ -32,6 +32,7 @@ Require Import Floats. Require Import Values. Require Import Memory. Require Import Globalenvs. +Require Import Events. Set Implicit Arguments. @@ -175,33 +176,36 @@ Definition eval_shift (s: shift) (n: int) : int := | Sror x => Int.ror n (s_amount x) end. -Definition eval_condition (cond: condition) (vl: list val): +Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := match cond, vl with | Ccomp c, Vint n1 :: Vint n2 :: nil => Some (Int.cmp c n1 n2) - | Ccomp c, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if eq_block b1 b2 - then Some (Int.cmp c n1 n2) - else eval_compare_mismatch c - | Ccomp c, Vptr b1 n1 :: Vint n2 :: nil => - eval_compare_null c n2 - | Ccomp c, Vint n1 :: Vptr b2 n2 :: nil => - eval_compare_null c n1 | Ccompu c, Vint n1 :: Vint n2 :: nil => Some (Int.cmpu c n1 n2) + | Ccompu c, Vptr b1 n1 :: Vptr b2 n2 :: nil => + if Mem.valid_pointer m b1 (Int.unsigned n1) + && Mem.valid_pointer m b2 (Int.unsigned n2) then + if eq_block b1 b2 + then Some (Int.cmpu c n1 n2) + else eval_compare_mismatch c + else None + | Ccompu c, Vptr b1 n1 :: Vint n2 :: nil => + eval_compare_null c n2 + | Ccompu c, Vint n1 :: Vptr b2 n2 :: nil => + eval_compare_null c n1 | Ccompshift c s, Vint n1 :: Vint n2 :: nil => Some (Int.cmp c n1 (eval_shift s n2)) - | Ccompshift c s, Vptr b1 n1 :: Vint n2 :: nil => - eval_compare_null c (eval_shift s n2) | Ccompushift c s, Vint n1 :: Vint n2 :: nil => Some (Int.cmpu c n1 (eval_shift s n2)) + | Ccompushift c s, Vptr b1 n1 :: Vint n2 :: nil => + eval_compare_null c (eval_shift s n2) | Ccompimm c n, Vint n1 :: nil => Some (Int.cmp c n1 n) - | Ccompimm c n, Vptr b1 n1 :: nil => - eval_compare_null c n | Ccompuimm c n, Vint n1 :: nil => Some (Int.cmpu c n1 n) + | Ccompuimm c n, Vptr b1 n1 :: nil => + eval_compare_null c n | Ccompf c, Vfloat f1 :: Vfloat f2 :: nil => Some (Float.cmp c f1 f2) | Cnotcompf c, Vfloat f1 :: Vfloat f2 :: nil => @@ -218,7 +222,7 @@ Definition offset_sp (sp: val) (delta: int) : option val := Definition eval_operation (F V: Type) (genv: Genv.t F V) (sp: val) - (op: operation) (vl: list val): option val := + (op: operation) (vl: list val) (m: mem): option val := match op, vl with | Omove, v1::nil => Some v1 | Ointconst n, nil => Some (Vint n) @@ -285,7 +289,7 @@ Definition eval_operation | Ointoffloat, Vfloat f1 :: nil => option_map Vint (Float.intoffloat f1) | Ofloatofint, Vint n1 :: nil => Some (Vfloat (Float.floatofint n1)) | Ocmp c, _ => - match eval_condition c vl with + match eval_condition c vl m with | None => None | Some false => Some Vfalse | Some true => Some Vtrue @@ -346,24 +350,26 @@ Proof. Qed. Lemma eval_negate_condition: - forall (cond: condition) (vl: list val) (b: bool), - eval_condition cond vl = Some b -> - eval_condition (negate_condition cond) vl = Some (negb b). + forall (cond: condition) (vl: list val) (b: bool) (m: mem), + eval_condition cond vl m = Some b -> + eval_condition (negate_condition cond) vl m = Some (negb b). Proof. intros. destruct cond; simpl in H; FuncInv; try subst b; simpl. rewrite Int.negate_cmp. auto. + rewrite Int.negate_cmpu. auto. apply eval_negate_compare_null; auto. apply eval_negate_compare_null; auto. - destruct (eq_block b0 b1). rewrite Int.negate_cmp. congruence. + destruct (Mem.valid_pointer m b0 (Int.unsigned i) && + Mem.valid_pointer m b1 (Int.unsigned i0)); try discriminate. + destruct (eq_block b0 b1). rewrite Int.negate_cmpu. congruence. destruct c; simpl in H; inv H; auto. - rewrite Int.negate_cmpu. auto. rewrite Int.negate_cmp. auto. - apply eval_negate_compare_null; auto. rewrite Int.negate_cmpu. auto. - rewrite Int.negate_cmp. auto. apply eval_negate_compare_null; auto. + rewrite Int.negate_cmp. auto. rewrite Int.negate_cmpu. auto. + apply eval_negate_compare_null; auto. auto. rewrite negb_elim. auto. Qed. @@ -382,8 +388,8 @@ Hypothesis agree_on_symbols: forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. Lemma eval_operation_preserved: - forall sp op vl, - eval_operation ge2 sp op vl = eval_operation ge1 sp op vl. + forall sp op vl m, + eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. Proof. intros. unfold eval_operation; destruct op; try rewrite agree_on_symbols; @@ -518,9 +524,9 @@ Variable A V: Type. Variable genv: Genv.t A V. Lemma type_of_operation_sound: - forall op vl sp v, + forall op vl sp v m, op <> Omove -> - eval_operation genv sp op vl = Some v -> + eval_operation genv sp op vl m = Some v -> Val.has_type v (snd (type_of_operation op)). Proof. intros. @@ -684,22 +690,24 @@ Proof. Qed. Lemma eval_condition_weaken: - forall c vl b, - eval_condition c vl = Some b -> + forall c vl b m, + eval_condition c vl m = Some b -> eval_condition_total c vl = Val.of_bool b. Proof. intros. unfold eval_condition in H; destruct c; FuncInv; try subst b; try reflexivity; simpl; try (apply eval_compare_null_weaken; auto). + destruct (Mem.valid_pointer m b0 (Int.unsigned i) && + Mem.valid_pointer m b1 (Int.unsigned i0)); try discriminate. unfold eq_block in H. destruct (zeq b0 b1); try congruence. apply eval_compare_mismatch_weaken; auto. symmetry. apply Val.notbool_negb_1. Qed. Lemma eval_operation_weaken: - forall sp op vl v, - eval_operation genv sp op vl = Some v -> + forall sp op vl v m, + eval_operation genv sp op vl m = Some v -> eval_operation_total sp op vl = v. Proof. intros. @@ -721,7 +729,7 @@ Proof. assert (Int.unsigned (Int.repr 31) < Int.unsigned Int.iwordsize). vm_compute; auto. omega. discriminate. destruct (Float.intoffloat f); simpl in H; inv H. auto. - caseEq (eval_condition c vl); intros; rewrite H0 in H. + caseEq (eval_condition c vl m); intros; rewrite H0 in H. replace v with (Val.of_bool b). eapply eval_condition_weaken; eauto. destruct b; simpl; congruence. @@ -783,12 +791,20 @@ Ltac InvLessdef := end. Lemma eval_condition_lessdef: - forall cond vl1 vl2 b, + forall cond vl1 vl2 b m1 m2, Val.lessdef_list vl1 vl2 -> - eval_condition cond vl1 = Some b -> - eval_condition cond vl2 = Some b. + Mem.extends m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. Proof. intros. destruct cond; simpl in *; FuncInv; InvLessdef; auto. + destruct (Mem.valid_pointer m1 b0 (Int.unsigned i) && + Mem.valid_pointer m1 b1 (Int.unsigned i0)) as [] _eqn; try discriminate. + destruct (andb_prop _ _ Heqb2) as [A B]. + assert (forall b ofs, Mem.valid_pointer m1 b ofs = true -> Mem.valid_pointer m2 b ofs = true). + intros until ofs. repeat rewrite Mem.valid_pointer_nonempty_perm. + apply Mem.perm_extends; auto. + rewrite (H _ _ A). rewrite (H _ _ B). auto. Qed. Ltac TrivialExists := @@ -799,34 +815,36 @@ Ltac TrivialExists := end. Lemma eval_operation_lessdef: - forall sp op vl1 vl2 v1, + forall sp op vl1 vl2 v1 m1 m2, Val.lessdef_list vl1 vl2 -> - eval_operation genv sp op vl1 = Some v1 -> - exists v2, eval_operation genv sp op vl2 = Some v2 /\ Val.lessdef v1 v2. + Mem.extends m1 m2 -> + eval_operation genv sp op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. Proof. intros. destruct op; simpl in *; FuncInv; InvLessdef; TrivialExists. exists v2; auto. - destruct (Genv.find_symbol genv i); inv H0. TrivialExists. + destruct (Genv.find_symbol genv i); inv H1. TrivialExists. exists v1; auto. exists (Val.sign_ext 8 v2); split. auto. apply Val.sign_ext_lessdef; auto. exists (Val.zero_ext 8 v2); split. auto. apply Val.zero_ext_lessdef; auto. exists (Val.sign_ext 16 v2); split. auto. apply Val.sign_ext_lessdef; auto. exists (Val.zero_ext 16 v2); split. auto. apply Val.zero_ext_lessdef; auto. - destruct (eq_block b b0); inv H0. TrivialExists. - destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. - destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. - destruct (Int.ltu i0 Int.iwordsize); inv H0; TrivialExists. - destruct (Int.ltu i0 Int.iwordsize); inv H0; TrivialExists. - destruct (Int.ltu i Int.iwordsize); inv H0; TrivialExists. + destruct (eq_block b b0); inv H1. TrivialExists. + destruct (Int.eq i0 Int.zero); inv H1; TrivialExists. + destruct (Int.eq i0 Int.zero); inv H1; TrivialExists. destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialExists. destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialExists. - destruct (Int.ltu i (Int.repr 31)); inv H0; TrivialExists. + destruct (Int.ltu i Int.iwordsize); inv H1; TrivialExists. + destruct (Int.ltu i0 Int.iwordsize); inv H2; TrivialExists. + destruct (Int.ltu i0 Int.iwordsize); inv H2; TrivialExists. + destruct (Int.ltu i (Int.repr 31)); inv H1; TrivialExists. exists (Val.singleoffloat v2); split. auto. apply Val.singleoffloat_lessdef; auto. - destruct (Float.intoffloat f); simpl in *; inv H0. TrivialExists. - caseEq (eval_condition c vl1); intros. rewrite H1 in H0. - rewrite (eval_condition_lessdef c H H1). - destruct b; inv H0; TrivialExists. - rewrite H1 in H0. discriminate. + destruct (Float.intoffloat f); simpl in *; inv H1. TrivialExists. + exists v1; split; auto. + destruct (eval_condition c vl1 m1) as [] _eqn. + rewrite (eval_condition_lessdef c H H0 Heqo). + auto. + discriminate. Qed. Lemma eval_addressing_lessdef: @@ -841,6 +859,154 @@ Qed. End EVAL_LESSDEF. +(** Shifting stack-relative references. This is used in [Stacking]. *) + +Definition shift_stack_addressing (delta: int) (addr: addressing) := + match addr with + | Ainstack ofs => Ainstack (Int.add delta ofs) + | _ => addr + end. + +Definition shift_stack_operation (delta: int) (op: operation) := + match op with + | Oaddrstack ofs => Oaddrstack (Int.add delta ofs) + | _ => op + end. + +Lemma type_shift_stack_addressing: + forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. +Proof. + intros. destruct addr; auto. +Qed. + +Lemma type_shift_stack_operation: + forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. +Proof. + intros. destruct op; auto. +Qed. + +(** Compatibility of the evaluation functions with memory injections. *) + +Section EVAL_INJECT. + +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. +Hypothesis globals: meminj_preserves_globals genv f. +Variable sp1: block. +Variable sp2: block. +Variable delta: Z. +Hypothesis sp_inj: f sp1 = Some(sp2, delta). + +Ltac InvInject := + match goal with + | [ H: val_inject _ (Vint _) _ |- _ ] => + inv H; InvInject + | [ H: val_inject _ (Vfloat _) _ |- _ ] => + inv H; InvInject + | [ H: val_inject _ (Vptr _ _) _ |- _ ] => + inv H; InvInject + | [ H: val_list_inject _ nil _ |- _ ] => + inv H; InvInject + | [ H: val_list_inject _ (_ :: _) _ |- _ ] => + inv H; InvInject + | _ => idtac + end. + +Lemma eval_condition_inject: + forall cond vl1 vl2 b m1 m2, + val_list_inject f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. destruct cond; simpl in *; FuncInv; InvInject; auto. + destruct (Mem.valid_pointer m1 b0 (Int.unsigned i)) as [] _eqn; try discriminate. + destruct (Mem.valid_pointer m1 b1 (Int.unsigned i0)) as [] _eqn; try discriminate. + simpl in H1. + exploit Mem.valid_pointer_inject_val. eauto. eexact Heqb0. econstructor; eauto. + intros V1. rewrite V1. + exploit Mem.valid_pointer_inject_val. eauto. eexact Heqb2. econstructor; eauto. + intros V2. rewrite V2. + simpl. + destruct (eq_block b0 b1); inv H1. + rewrite H3 in H5; inv H5. rewrite dec_eq_true. + decEq. apply Int.translate_cmpu. + eapply Mem.valid_pointer_inject_no_overflow; eauto. + eapply Mem.valid_pointer_inject_no_overflow; eauto. + exploit Mem.different_pointers_inject; eauto. intros P. + destruct (eq_block b3 b4); auto. + destruct P. contradiction. + destruct c; unfold eval_compare_mismatch in *; inv H2. + unfold Int.cmpu. rewrite Int.eq_false; auto. congruence. + unfold Int.cmpu. rewrite Int.eq_false; auto. congruence. +Qed. + +Ltac TrivialExists2 := + match goal with + | [ |- exists v2, Some ?v1 = Some v2 /\ val_inject _ _ v2 ] => + exists v1; split; [auto | econstructor; eauto] + | _ => idtac + end. + +Lemma eval_addressing_inject: + forall addr vl1 vl2 v1, + val_list_inject f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Int.zero) addr vl1 = Some v1 -> + exists v2, + eval_addressing genv (Vptr sp2 Int.zero) (shift_stack_addressing (Int.repr delta) addr) vl2 = Some v2 + /\ val_inject f v1 v2. +Proof. + assert (UNUSED: meminj_preserves_globals genv f). exact globals. + intros. destruct addr; simpl in *; FuncInv; InvInject; TrivialExists2. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. auto. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. +Qed. + +Lemma eval_operation_inject: + forall op vl1 vl2 v1 m1 m2, + val_list_inject f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_operation genv (Vptr sp1 Int.zero) op vl1 m1 = Some v1 -> + exists v2, + eval_operation genv (Vptr sp2 Int.zero) (shift_stack_operation (Int.repr delta) op) vl2 m2 = Some v2 + /\ val_inject f v1 v2. +Proof. + intros. destruct op; simpl in *; FuncInv; InvInject; TrivialExists2. + exists v'; auto. + destruct (Genv.find_symbol genv i) as [] _eqn; inv H1. + TrivialExists2. eapply (proj1 globals); eauto. rewrite Int.add_zero; auto. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + exists (Val.sign_ext 8 v'); split; auto. inv H4; simpl; auto. + exists (Val.zero_ext 8 v'); split; auto. inv H4; simpl; auto. + exists (Val.sign_ext 16 v'); split; auto. inv H4; simpl; auto. + exists (Val.zero_ext 16 v'); split; auto. inv H4; simpl; auto. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + rewrite Int.sub_add_l. auto. + destruct (eq_block b b0); inv H1. rewrite H3 in H5; inv H5. rewrite dec_eq_true. + rewrite Int.sub_shifted. TrivialExists2. + rewrite Int.sub_add_l. auto. + destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. + destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. + destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialExists2. + destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialExists2. + destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialExists2. + destruct (Int.ltu i (Int.repr 31)); inv H1. TrivialExists2. + exists (Val.singleoffloat v'); split; auto. inv H4; simpl; auto. + destruct (Float.intoffloat f0); simpl in *; inv H1. TrivialExists2. + destruct (eval_condition c vl1 m1) as [] _eqn; try discriminate. + exploit eval_condition_inject; eauto. intros EQ; rewrite EQ. + destruct b; inv H1; TrivialExists2. +Qed. + +End EVAL_INJECT. + (** Recognition of integers that are valid shift amounts. *) Definition is_shift_amount_aux (n: int) : @@ -891,10 +1057,10 @@ Definition op_for_binary_addressing (addr: addressing) : operation := end. Lemma eval_op_for_binary_addressing: - forall (F V: Type) (ge: Genv.t F V) sp addr args v, + forall (F V: Type) (ge: Genv.t F V) sp addr args v m, (length args >= 2)%nat -> eval_addressing ge sp addr args = Some v -> - eval_operation ge sp (op_for_binary_addressing addr) args = Some v. + eval_operation ge sp (op_for_binary_addressing addr) args m = Some v. Proof. intros. unfold eval_addressing in H0; destruct addr; FuncInv; simpl in H; try omegaContradiction; simpl. @@ -926,54 +1092,22 @@ Definition is_trivial_op (op: operation) : bool := | _ => false end. -(** Shifting stack-relative references. This is used in [Stacking]. *) -Definition shift_stack_addressing (delta: int) (addr: addressing) := - match addr with - | Ainstack ofs => Ainstack (Int.add delta ofs) - | _ => addr - end. +(** Operations that depend on the memory state. *) -Definition shift_stack_operation (delta: int) (op: operation) := +Definition op_depends_on_memory (op: operation) : bool := match op with - | Oaddrstack ofs => Oaddrstack (Int.add delta ofs) - | _ => op + | Ocmp (Ccompu _) => true + | _ => false end. -Lemma shift_stack_eval_addressing: - forall (F V: Type) (ge: Genv.t F V) sp addr args delta, - eval_addressing ge (Val.sub sp (Vint delta)) (shift_stack_addressing delta addr) args = - eval_addressing ge sp addr args. +Lemma op_depends_on_memory_correct: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + op_depends_on_memory op = false -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. - intros. destruct addr; simpl; auto. - destruct args; auto. unfold offset_sp. destruct sp; simpl; auto. - decEq. decEq. rewrite <- Int.add_assoc. decEq. - rewrite Int.sub_add_opp. rewrite Int.add_assoc. - rewrite (Int.add_commut (Int.neg delta)). rewrite <- Int.sub_add_opp. - rewrite Int.sub_idem. apply Int.add_zero. + intros until m2. destruct op; simpl; try congruence. + destruct c; simpl; congruence. Qed. -Lemma shift_stack_eval_operation: - forall (F V: Type) (ge: Genv.t F V) sp op args delta, - eval_operation ge (Val.sub sp (Vint delta)) (shift_stack_operation delta op) args = - eval_operation ge sp op args. -Proof. - intros. destruct op; simpl; auto. - destruct args; auto. unfold offset_sp. destruct sp; simpl; auto. - decEq. decEq. rewrite <- Int.add_assoc. decEq. - rewrite Int.sub_add_opp. rewrite Int.add_assoc. - rewrite (Int.add_commut (Int.neg delta)). rewrite <- Int.sub_add_opp. - rewrite Int.sub_idem. apply Int.add_zero. -Qed. -Lemma type_shift_stack_addressing: - forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. -Proof. - intros. destruct addr; auto. -Qed. - -Lemma type_shift_stack_operation: - forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. -Proof. - intros. destruct op; auto. -Qed. diff --git a/arm/PrintAsm.ml b/arm/PrintAsm.ml index 4f470ce..883ee72 100644 --- a/arm/PrintAsm.ml +++ b/arm/PrintAsm.ml @@ -453,30 +453,21 @@ let print_instruction oc labels = function | Psufd(r1, r2, r3) -> fprintf oc " sufd %a, %a, %a\n" freg r1 freg r2 freg r3; 1 (* Pseudo-instructions *) - | Pallocframe(lo, hi, ofs) -> - let lo = camlint_of_coqint lo - and hi = camlint_of_coqint hi - and ofs = camlint_of_coqint ofs in - let sz = Int32.sub hi lo in - (* Keep stack 4-aligned *) - let sz4 = Int32.logand (Int32.add sz 3l) 0xFFFF_FFFCl in - (* FIXME: consider a store multiple? *) - (* R12 = first int temporary is unused at this point, - but this should be reflected in the proof *) + | Pallocframe(sz, ofs) -> fprintf oc " mov r12, sp\n"; let ninstr = ref 0 in List.iter - (fun mask -> - let b = Int32.logand sz4 mask in - if b <> 0l then begin - fprintf oc " sub sp, sp, #%ld\n" b; - incr ninstr - end) - [0xFF000000l; 0x00FF0000l; 0x0000FF00l; 0x000000FFl]; - fprintf oc " str r12, [sp, #%ld]\n" ofs; + (fun n -> + fprintf oc " sub sp, sp, #%a\n" coqint n; + incr ninstr) + (Asmgen.decompose_int sz); + fprintf oc " str r12, [sp, #%a]\n" coqint ofs; 2 + !ninstr - | Pfreeframe(lo, hi, ofs) -> - fprintf oc " ldr sp, [sp, #%a]\n" coqint ofs; 1 + | Pfreeframe(sz, ofs) -> + if Asmgen.is_immed_arith sz + then fprintf oc " add sp, sp, #%a\n" coqint sz + else fprintf oc " ldr sp, [sp, #%a]\n" coqint ofs; + 1 | Plabel lbl -> if Labelset.mem lbl labels then fprintf oc "%a:\n" print_label lbl; 0 diff --git a/arm/SelectOp.v b/arm/SelectOp.v index df2413a..44528c6 100644 --- a/arm/SelectOp.v +++ b/arm/SelectOp.v @@ -146,7 +146,7 @@ Definition notint (e: expr) := (** ** Boolean negation *) Definition notbool_base (e: expr) := - Eop (Ocmp (Ccompimm Ceq Int.zero)) (e ::: Enil). + Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil). Fixpoint notbool (e: expr) {struct e} : expr := match e with diff --git a/arm/SelectOpproof.v b/arm/SelectOpproof.v index cdb21cb..7602b11 100644 --- a/arm/SelectOpproof.v +++ b/arm/SelectOpproof.v @@ -64,13 +64,13 @@ Ltac InvEval1 := Ltac InvEval2 := match goal with - | [ H: (eval_operation _ _ _ nil = Some _) |- _ ] => + | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => simpl in H; inv H - | [ H: (eval_operation _ _ _ (_ :: nil) = Some _) |- _ ] => + | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: nil) = Some _) |- _ ] => + | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) = Some _) |- _ ] => + | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => simpl in H; FuncInv | _ => idtac @@ -162,12 +162,12 @@ Proof. eapply eval_notbool_base; eauto. inv H. eapply eval_Eop; eauto. - simpl. assert (eval_condition c vl = Some b). + simpl. assert (eval_condition c vl m = Some b). generalize H6. simpl. case (eval_condition c vl); intros. destruct b0; inv H1; inversion H0; auto; congruence. congruence. - rewrite (Op.eval_negate_condition _ _ H). + rewrite (Op.eval_negate_condition _ _ _ H). destruct b; reflexivity. inv H. eapply eval_Econdition; eauto. @@ -524,9 +524,9 @@ Qed. Lemma eval_mod_aux: forall divop semdivop, - (forall sp x y, + (forall sp x y m, y <> Int.zero -> - eval_operation ge sp divop (Vint x :: Vint y :: nil) = + eval_operation ge sp divop (Vint x :: Vint y :: nil) m = Some (Vint (semdivop x y))) -> forall le a b x y, eval_expr ge sp e m le a (Vint x) -> @@ -757,7 +757,7 @@ Theorem eval_singleoffloat: eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v). Proof. TrivialOp singleoffloat. Qed. -Theorem eval_comp_int: +Theorem eval_comp: forall le c a x b y, eval_expr ge sp e m le a (Vint x) -> eval_expr ge sp e m le b (Vint y) -> @@ -767,11 +767,26 @@ Proof. unfold comp; case (comp_match a b); intros; InvEval. EvalOp. simpl. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity. EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. rewrite Int.swap_cmp. rewrite H. destruct (Int.cmp c x y); reflexivity. + EvalOp. simpl. rewrite H. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity. EvalOp. simpl. rewrite H0. destruct (Int.cmp c x y); reflexivity. EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. Qed. +Theorem eval_compu_int: + forall le c a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)). +Proof. + intros until y. + unfold compu; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. rewrite Int.swap_cmpu. rewrite H. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. rewrite H0. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. +Qed. + Remark eval_compare_null_trans: forall c x v, (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> @@ -786,15 +801,15 @@ Proof. destruct c; try discriminate; auto. Qed. -Theorem eval_comp_ptr_int: +Theorem eval_compu_ptr_int: forall le c a x1 x2 b y v, eval_expr ge sp e m le a (Vptr x1 x2) -> eval_expr ge sp e m le b (Vint y) -> (if Int.eq y Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> - eval_expr ge sp e m le (comp c a b) v. + eval_expr ge sp e m le (compu c a b) v. Proof. intros until v. - unfold comp; case (comp_match a b); intros; InvEval. + unfold compu; case (comp_match a b); intros; InvEval. EvalOp. simpl. apply eval_compare_null_trans; auto. EvalOp. simpl. rewrite H0. apply eval_compare_null_trans; auto. EvalOp. simpl. apply eval_compare_null_trans; auto. @@ -814,61 +829,49 @@ Proof. destruct c; simpl; try discriminate; auto. Qed. -Theorem eval_comp_int_ptr: +Theorem eval_compu_int_ptr: forall le c a x b y1 y2 v, eval_expr ge sp e m le a (Vint x) -> eval_expr ge sp e m le b (Vptr y1 y2) -> (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> - eval_expr ge sp e m le (comp c a b) v. + eval_expr ge sp e m le (compu c a b) v. Proof. intros until v. - unfold comp; case (comp_match a b); intros; InvEval. + unfold compu; case (comp_match a b); intros; InvEval. EvalOp. simpl. apply eval_swap_compare_null_trans; auto. EvalOp. simpl. rewrite H. apply eval_swap_compare_null_trans; auto. EvalOp. simpl. apply eval_compare_null_trans; auto. Qed. -Theorem eval_comp_ptr_ptr: +Theorem eval_compu_ptr_ptr: forall le c a x1 x2 b y1 y2, eval_expr ge sp e m le a (Vptr x1 x2) -> eval_expr ge sp e m le b (Vptr y1 y2) -> + Mem.valid_pointer m x1 (Int.unsigned x2) + && Mem.valid_pointer m y1 (Int.unsigned y2) = true -> x1 = y1 -> - eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x2 y2)). + eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x2 y2)). Proof. intros until y2. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. subst y1. rewrite dec_eq_true. - destruct (Int.cmp c x2 y2); reflexivity. + unfold compu; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite H1. subst y1. rewrite dec_eq_true. + destruct (Int.cmpu c x2 y2); reflexivity. Qed. -Theorem eval_comp_ptr_ptr_2: +Theorem eval_compu_ptr_ptr_2: forall le c a x1 x2 b y1 y2 v, eval_expr ge sp e m le a (Vptr x1 x2) -> eval_expr ge sp e m le b (Vptr y1 y2) -> + Mem.valid_pointer m x1 (Int.unsigned x2) + && Mem.valid_pointer m y1 (Int.unsigned y2) = true -> x1 <> y1 -> Cminor.eval_compare_mismatch c = Some v -> - eval_expr ge sp e m le (comp c a b) v. + eval_expr ge sp e m le (compu c a b) v. Proof. intros until y2. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite dec_eq_false; auto. - destruct c; simpl in H2; inv H2; auto. -Qed. - - -Theorem eval_compu: - forall le c a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)). -Proof. - intros until y. unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. rewrite H. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. rewrite H0. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto. + destruct c; simpl in H3; inv H3; auto. Qed. Theorem eval_compf: diff --git a/arm/linux/Stacklayout.v b/arm/linux/Stacklayout.v index b374bfd..4521114 100644 --- a/arm/linux/Stacklayout.v +++ b/arm/linux/Stacklayout.v @@ -28,12 +28,6 @@ Require Import Bounds. - Pointer to activation record of the caller. - Space for the stack-allocated data declared in Cminor. -To facilitate some of the proofs, the Cminor stack-allocated data -starts at offset 0; the preceding areas in the activation record -therefore have negative offsets. This part (with negative offsets) -is called the ``frame'', by opposition with the ``Cminor stack data'' -which is the part with positive offsets. - The [frame_env] compilation environment records the positions of the boundaries between areas in the frame part. *) @@ -49,7 +43,8 @@ Record frame_env : Type := mk_frame_env { fe_num_int_callee_save: Z; fe_ofs_float_local: Z; fe_ofs_float_callee_save: Z; - fe_num_float_callee_save: Z + fe_num_float_callee_save: Z; + fe_stack_data: Z }. (** Computation of the frame environment from the bounds of the current @@ -63,17 +58,84 @@ Definition make_env (b: bounds) := let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *) let ora := ofcs + 8 * b.(bound_float_callee_save) in (* retaddr *) let olink := ora + 4 in (* back link *) - let sz := olink + 4 in (* total frame size *) + let ostkdata := olink + 4 in (* stack data *) + let sz := align (ostkdata + b.(bound_stack_data)) 8 in mk_frame_env sz olink ora oil oics b.(bound_int_callee_save) - ofl ofcs b.(bound_float_callee_save). + ofl ofcs b.(bound_float_callee_save) + ostkdata. +(** Separation property *) -Remark align_float_part: +Remark frame_env_separated: forall b, - 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b <= - align (4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b) 8. + let fe := make_env b in + 0 <= fe_ofs_arg + /\ fe_ofs_arg + 4 * b.(bound_outgoing) <= fe.(fe_ofs_int_local) + /\ fe.(fe_ofs_int_local) + 4 * b.(bound_int_local) <= fe.(fe_ofs_int_callee_save) + /\ fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save) <= fe.(fe_ofs_float_local) + /\ fe.(fe_ofs_float_local) + 8 * b.(bound_float_local) <= fe.(fe_ofs_float_callee_save) + /\ fe.(fe_ofs_float_callee_save) + 8 * b.(bound_float_callee_save) <= fe.(fe_ofs_retaddr) + /\ fe.(fe_ofs_retaddr) + 4 <= fe.(fe_ofs_link) + /\ fe.(fe_ofs_link) + 4 <= fe.(fe_stack_data) + /\ fe.(fe_stack_data) + b.(bound_stack_data) <= fe.(fe_size). Proof. - intros. apply align_le. omega. + intros. + generalize (align_le (fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save)) 8 (refl_equal _)). + generalize (align_le (fe.(fe_stack_data) + b.(bound_stack_data)) 8 (refl_equal _)). + unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr, + fe_ofs_int_local, fe_ofs_int_callee_save, + fe_num_int_callee_save, + fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save, + fe_stack_data, fe_ofs_arg. + intros. + generalize (bound_int_local_pos b); intro; + generalize (bound_float_local_pos b); intro; + generalize (bound_int_callee_save_pos b); intro; + generalize (bound_float_callee_save_pos b); intro; + generalize (bound_outgoing_pos b); intro; + generalize (bound_stack_data_pos b); intro. + omega. Qed. +(** Alignment property *) + +Remark frame_env_aligned: + forall b, + let fe := make_env b in + (4 | fe.(fe_ofs_link)) + /\ (4 | fe.(fe_ofs_int_local)) + /\ (4 | fe.(fe_ofs_int_callee_save)) + /\ (8 | fe.(fe_ofs_float_local)) + /\ (8 | fe.(fe_ofs_float_callee_save)) + /\ (4 | fe.(fe_ofs_retaddr)) + /\ (4 | fe.(fe_stack_data)) + /\ (8 | fe.(fe_size)). +Proof. + intros. + unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr, + fe_ofs_int_local, fe_ofs_int_callee_save, + fe_num_int_callee_save, + fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save, + fe_stack_data. + set (x1 := 4 * bound_outgoing b). + assert (4 | x1). unfold x1; exists (bound_outgoing b); ring. + set (x2 := x1 + 4 * bound_int_local b). + assert (4 | x2). unfold x2; apply Zdivide_plus_r; auto. exists (bound_int_local b); ring. + set (x3 := x2 + 4 * bound_int_callee_save b). + set (x4 := align x3 8). + assert (8 | x4). unfold x4. apply align_divides. omega. + set (x5 := x4 + 8 * bound_float_local b). + assert (8 | x5). unfold x5. apply Zdivide_plus_r; auto. exists (bound_float_local b); ring. + set (x6 := x5 + 8 * bound_float_callee_save b). + assert (4 | x6). + apply Zdivides_trans with 8. exists 2; auto. + unfold x6. apply Zdivide_plus_r; auto. exists (bound_float_callee_save b); ring. + set (x7 := x6 + 4). + assert (4 | x7). unfold x7; apply Zdivide_plus_r; auto. exists 1; auto. + set (x8 := x7 + 4). + assert (4 | x8). unfold x8; apply Zdivide_plus_r; auto. exists 1; auto. + set (x9 := align (x8 + bound_stack_data b) 8). + assert (8 | x9). unfold x9; apply align_divides. omega. + tauto. +Qed. diff --git a/backend/Allocproof.v b/backend/Allocproof.v index daa53e5..e7d9995 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -618,7 +618,7 @@ Proof. unfold ls1. simpl. apply Locmap.guo. eapply regalloc_not_temporary; eauto. (* Not a move *) intros INMO CORR CODE. - assert (eval_operation tge sp op (map ls (map assign args)) = Some v). + assert (eval_operation tge sp op (map ls (map assign args)) m = Some v). replace (map ls (map assign args)) with (rs##args). rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved. eapply agree_eval_regs; eauto. @@ -706,7 +706,7 @@ Proof. eapply agree_reg_list_live; eauto. (* Icond, true *) - assert (COND: eval_condition cond (map ls (map assign args)) = Some true). + assert (COND: eval_condition cond (map ls (map assign args)) m = Some true). replace (map ls (map assign args)) with (rs##args). auto. eapply agree_eval_regs; eauto. econstructor; split. @@ -715,7 +715,7 @@ Proof. eapply agree_undef_temps; eauto. eapply agree_reg_list_live. eauto. (* Icond, false *) - assert (COND: eval_condition cond (map ls (map assign args)) = Some false). + assert (COND: eval_condition cond (map ls (map assign args)) m = Some false). replace (map ls (map assign args)) with (rs##args). auto. eapply agree_eval_regs; eauto. econstructor; split. diff --git a/backend/Bounds.v b/backend/Bounds.v index 514895b..0415670 100644 --- a/backend/Bounds.v +++ b/backend/Bounds.v @@ -10,7 +10,7 @@ (* *) (* *********************************************************************) -(** Computation of resource bounds forr Linear code. *) +(** Computation of resource bounds for Linear code. *) Require Import Coqlib. Require Import Maps. @@ -36,11 +36,13 @@ Record bounds : Type := mkbounds { bound_int_callee_save: Z; bound_float_callee_save: Z; bound_outgoing: Z; + bound_stack_data: Z; bound_int_local_pos: bound_int_local >= 0; bound_float_local_pos: bound_float_local >= 0; bound_int_callee_save_pos: bound_int_callee_save >= 0; bound_float_callee_save_pos: bound_float_callee_save >= 0; - bound_outgoing_pos: bound_outgoing >= 0 + bound_outgoing_pos: bound_outgoing >= 0; + bound_stack_data_pos: bound_stack_data >= 0 }. (** The following predicates define the correctness of a set of bounds @@ -186,15 +188,19 @@ Program Definition function_bounds := (max_over_regs_of_funct float_callee_save) (Zmax (max_over_instrs outgoing_space) (max_over_slots_of_funct outgoing_slot)) + (Zmax f.(fn_stacksize) 0) (max_over_slots_of_funct_pos int_local) (max_over_slots_of_funct_pos float_local) (max_over_regs_of_funct_pos int_callee_save) (max_over_regs_of_funct_pos float_callee_save) - _. + _ _. Next Obligation. apply Zle_ge. eapply Zle_trans. 2: apply Zmax2. apply Zge_le. apply max_over_slots_of_funct_pos. Qed. +Next Obligation. + apply Zle_ge. apply Zmax2. +Qed. (** We now show the correctness of the inferred bounds. *) diff --git a/backend/CSE.v b/backend/CSE.v index 45b50d6..44ed590 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -188,15 +188,19 @@ Definition add_unknown (n: numbering) (rd: reg) := n.(num_eqs) (PTree.set rd n.(num_next) n.(num_reg)). -(** [kill_load n] removes all equations involving memory loads. +(** [kill_load n] removes all equations involving memory loads, + as well as those involving memory-dependent operators. It is used to reflect the effect of a memory store, which can potentially invalidate all such equations. *) Fixpoint kill_load_eqs (eqs: list (valnum * rhs)) : list (valnum * rhs) := match eqs with | nil => nil - | (_, Load _ _ _) :: rem => kill_load_eqs rem - | v_rh :: rem => v_rh :: kill_load_eqs rem + | eq :: rem => + match eq with + | (_, Op op _) => if op_depends_on_memory op then kill_load_eqs rem else eq :: kill_load_eqs rem + | (_, Load _ _ _) => kill_load_eqs rem + end end. Definition kill_loads (n: numbering) : numbering := @@ -252,7 +256,7 @@ Definition equation_holds (vres: valnum) (rh: rhs) : Prop := match rh with | Op op vl => - eval_operation ge sp op (List.map valuation vl) = + eval_operation ge sp op (List.map valuation vl) m = Some (valuation vres) | Load chunk addr vl => exists a, diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 275b9fd..53576ad 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -208,9 +208,10 @@ Lemma kill_load_eqs_incl: Proof. induction eqs; simpl; intros. apply incl_refl. - destruct a. destruct r. apply incl_same_head; auto. - auto. - apply incl_tl. auto. + destruct a. destruct r. + destruct (op_depends_on_memory o). auto with coqlib. + apply incl_same_head; auto. + auto with coqlib. Qed. Lemma wf_kill_loads: @@ -400,7 +401,7 @@ Definition rhs_evals_to (valu: valnum -> val) (rh: rhs) (v: val) : Prop := match rh with | Op op vl => - eval_operation ge sp op (List.map valu vl) = Some v + eval_operation ge sp op (List.map valu vl) m = Some v | Load chunk addr vl => exists a, eval_addressing ge sp addr (List.map valu vl) = Some a /\ @@ -481,7 +482,7 @@ Lemma add_op_satisfiable: forall n rs op args dst v, wf_numbering n -> numbering_satisfiable ge sp rs m n -> - eval_operation ge sp op rs##args = Some v -> + eval_operation ge sp op rs##args m = Some v -> numbering_satisfiable ge sp (rs#dst <- v) m (add_op n dst op args). Proof. intros. inversion H0. @@ -547,36 +548,22 @@ Proof. eauto. Qed. -(** Allocation of a fresh memory block preserves satisfiability. *) - -Lemma alloc_satisfiable: - forall lo hi b m' rs n, - Mem.alloc m lo hi = (m', b) -> - numbering_satisfiable ge sp rs m n -> - numbering_satisfiable ge sp rs m' n. -Proof. - intros. destruct H0 as [valu [A B]]. - exists valu; split; intros. - generalize (A _ _ H0). destruct rh; simpl. - auto. - intros [addr [C D]]. exists addr; split. auto. - destruct addr; simpl in *; try discriminate. - eapply Mem.load_alloc_other; eauto. - eauto. -Qed. - (** [kill_load] preserves satisfiability. Moreover, the resulting numbering is satisfiable in any concrete memory state. *) Lemma kill_load_eqs_ops: forall v rhs eqs, In (v, rhs) (kill_load_eqs eqs) -> - match rhs with Op _ _ => True | Load _ _ _ => False end. + match rhs with + | Op op _ => op_depends_on_memory op = false + | Load _ _ _ => False + end. Proof. induction eqs; simpl; intros. elim H. - destruct a. destruct r. - elim H; intros. inversion H0; subst v0; subst rhs. auto. + destruct a. destruct r. destruct (op_depends_on_memory o) as [] _eqn. + apply IHeqs; auto. + simpl in H; destruct H. inv H. auto. apply IHeqs. auto. apply IHeqs. auto. Qed. @@ -590,7 +577,9 @@ Proof. exists x. split; intros. generalize (H _ _ (H1 _ H2)). generalize (kill_load_eqs_ops _ _ _ H2). - destruct rh; simpl; tauto. + destruct rh; simpl. + intros. rewrite <- H4. apply op_depends_on_memory_correct; auto. + tauto. apply H0. auto. Qed. @@ -645,7 +634,7 @@ Lemma find_op_correct: wf_numbering n -> numbering_satisfiable ge sp rs m n -> find_op n op args = Some r -> - eval_operation ge sp op rs##args = Some rs#r. + eval_operation ge sp op rs##args m = Some rs#r. Proof. intros until r. intros WF [valu NH]. unfold find_op. caseEq (valnum_regs n args). intros n' vl VR FIND. @@ -834,14 +823,14 @@ Proof. (* Iop *) exists (State s' (transf_function f) sp pc' (rs#res <- v) m); split. - assert (eval_operation tge sp op rs##args = Some v). + assert (eval_operation tge sp op rs##args m = Some v). rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved. generalize C; clear C. case (is_trivial_op op). intro. eapply exec_Iop'; eauto. caseEq (find_op (analyze f)!!pc op args). intros r FIND CODE. eapply exec_Iop'; eauto. simpl. - assert (eval_operation ge sp op rs##args = Some rs#r). + assert (eval_operation ge sp op rs##args m = Some rs#r). eapply find_op_correct; eauto. eapply wf_analyze; eauto. congruence. diff --git a/backend/CastOptimproof.v b/backend/CastOptimproof.v index b04e061..ab04d0e 100644 --- a/backend/CastOptimproof.v +++ b/backend/CastOptimproof.v @@ -168,9 +168,9 @@ Proof. Qed. Lemma approx_operation_correct: - forall app rs (ge: genv) sp op args v, + forall app rs (ge: genv) sp op args m v, regs_match_approx app rs -> - eval_operation ge sp op rs##args = Some v -> + eval_operation ge sp op rs##args m = Some v -> val_match_approx (approx_operation op (approx_regs app args)) v. Proof. intros. destruct op; simpl; try (exact I). @@ -324,10 +324,10 @@ Qed. (** Correctness of [transf_operation]. *) Lemma transf_operation_correct: - forall (ge: genv) app rs sp op args v, + forall (ge: genv) app rs sp op args m v, regs_match_approx app rs -> - eval_operation ge sp op rs##args = Some v -> - eval_operation ge sp (transf_operation op (approx_regs app args)) rs##args = Some v. + eval_operation ge sp op rs##args m = Some v -> + eval_operation ge sp (transf_operation op (approx_regs app args)) rs##args m = Some v. Proof. intros until v. intro RMA. assert (A: forall a r, Approx.bge a (approx_reg app r) = true -> val_match_approx a rs#r). diff --git a/backend/Cminor.v b/backend/Cminor.v index a3a166c..45e060d 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -254,7 +254,7 @@ Definition eval_compare_null (c: comparison) (n: int) : option val := if Int.eq n Int.zero then eval_compare_mismatch c else None. Definition eval_binop - (op: binary_operation) (arg1 arg2: val): option val := + (op: binary_operation) (arg1 arg2: val) (m: mem): option val := match op, arg1, arg2 with | Oadd, Vint n1, Vint n2 => Some (Vint (Int.add n1 n2)) | Oadd, Vint n1, Vptr b2 n2 => Some (Vptr b2 (Int.add n2 n1)) @@ -287,16 +287,19 @@ Definition eval_binop | Odivf, Vfloat f1, Vfloat f2 => Some (Vfloat (Float.div f1 f2)) | Ocmp c, Vint n1, Vint n2 => Some (Val.of_bool(Int.cmp c n1 n2)) - | Ocmp c, Vptr b1 n1, Vptr b2 n2 => - if eq_block b1 b2 - then Some(Val.of_bool(Int.cmp c n1 n2)) - else eval_compare_mismatch c - | Ocmp c, Vptr b1 n1, Vint n2 => - eval_compare_null c n2 - | Ocmp c, Vint n1, Vptr b2 n2 => - eval_compare_null c n1 | Ocmpu c, Vint n1, Vint n2 => Some (Val.of_bool(Int.cmpu c n1 n2)) + | Ocmpu c, Vptr b1 n1, Vptr b2 n2 => + if Mem.valid_pointer m b1 (Int.unsigned n1) + && Mem.valid_pointer m b2 (Int.unsigned n2) then + if eq_block b1 b2 + then Some(Val.of_bool(Int.cmpu c n1 n2)) + else eval_compare_mismatch c + else None + | Ocmpu c, Vptr b1 n1, Vint n2 => + eval_compare_null c n2 + | Ocmpu c, Vint n1, Vptr b2 n2 => + eval_compare_null c n1 | Ocmpf c, Vfloat f1, Vfloat f2 => Some (Val.of_bool (Float.cmp c f1 f2)) | _, _, _ => None @@ -330,7 +333,7 @@ Inductive eval_expr: expr -> val -> Prop := | eval_Ebinop: forall op a1 a2 v1 v2 v, eval_expr a1 v1 -> eval_expr a2 v2 -> - eval_binop op v1 v2 = Some v -> + eval_binop op v1 v2 m = Some v -> eval_expr (Ebinop op a1 a2) v | eval_Eload: forall chunk addr vaddr v, eval_expr addr vaddr -> diff --git a/backend/CminorSel.v b/backend/CminorSel.v index 29f7178..8a82c42 100644 --- a/backend/CminorSel.v +++ b/backend/CminorSel.v @@ -164,7 +164,7 @@ Inductive eval_expr: letenv -> expr -> val -> Prop := eval_expr le (Evar id) v | eval_Eop: forall le op al vl v, eval_exprlist le al vl -> - eval_operation ge sp op vl = Some v -> + eval_operation ge sp op vl m = Some v -> eval_expr le (Eop op al) v | eval_Eload: forall le chunk addr al vl vaddr v, eval_exprlist le al vl -> @@ -190,7 +190,7 @@ with eval_condexpr: letenv -> condexpr -> bool -> Prop := eval_condexpr le CEfalse false | eval_CEcond: forall le cond al vl b, eval_exprlist le al vl -> - eval_condition cond vl = Some b -> + eval_condition cond vl m = Some b -> eval_condexpr le (CEcond cond al) b | eval_CEcondition: forall le a b c vb1 vb2, eval_condexpr le a vb1 -> diff --git a/backend/Constprop.v b/backend/Constprop.v index 47c40e3..39568a3 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -206,7 +206,7 @@ Definition transf_instr (app: D.t) (instr: instruction) := | Ijumptable arg tbl => match intval (approx_reg app) arg with | Some n => - match list_nth_z tbl (Int.signed n) with + match list_nth_z tbl (Int.unsigned n) with | Some s => Inop s | None => instr end diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index 1dad518..d534c75 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -283,13 +283,13 @@ Proof. exists (State s' (transf_function f) sp pc' (rs#res <- v) m); split. TransfInstr. caseEq (op_strength_reduction (approx_reg (analyze f)!!pc) op args); intros op' args' OSR. - assert (eval_operation tge sp op' rs##args' = Some v). + assert (eval_operation tge sp op' rs##args' m = Some v). rewrite (eval_operation_preserved _ _ symbols_preserved). - generalize (op_strength_reduction_correct ge (approx_reg (analyze f)!!pc) sp rs + generalize (op_strength_reduction_correct ge (approx_reg (analyze f)!!pc) sp rs m MATCH op args v). rewrite OSR; simpl. auto. generalize (eval_static_operation_correct ge op sp - (approx_regs (analyze f)!!pc args) rs##args v + (approx_regs (analyze f)!!pc args) rs##args m v (approx_regs_val_list _ _ _ args MATCH) H0). case (eval_static_operation op (approx_regs (analyze f)!!pc args)); intros; simpl in H2; @@ -370,14 +370,14 @@ Proof. exists (State s' (transf_function f) sp ifso rs m); split. caseEq (cond_strength_reduction (approx_reg (analyze f)!!pc) cond args); intros cond' args' CSR. - assert (eval_condition cond' rs##args' = Some true). + assert (eval_condition cond' rs##args' m = Some true). generalize (cond_strength_reduction_correct - ge (approx_reg (analyze f)!!pc) rs MATCH cond args). + ge (approx_reg (analyze f)!!pc) rs m MATCH cond args). rewrite CSR. intro. congruence. TransfInstr. rewrite CSR. caseEq (eval_static_condition cond (approx_regs (analyze f)!!pc args)). intros b ESC. - generalize (eval_static_condition_correct ge cond _ _ _ + generalize (eval_static_condition_correct ge cond _ _ m _ (approx_regs_val_list _ _ _ args MATCH) ESC); intro. replace b with true. intro; eapply exec_Inop; eauto. congruence. intros. eapply exec_Icond_true; eauto. @@ -390,14 +390,14 @@ Proof. exists (State s' (transf_function f) sp ifnot rs m); split. caseEq (cond_strength_reduction (approx_reg (analyze f)!!pc) cond args); intros cond' args' CSR. - assert (eval_condition cond' rs##args' = Some false). + assert (eval_condition cond' rs##args' m = Some false). generalize (cond_strength_reduction_correct - ge (approx_reg (analyze f)!!pc) rs MATCH cond args). + ge (approx_reg (analyze f)!!pc) rs m MATCH cond args). rewrite CSR. intro. congruence. TransfInstr. rewrite CSR. caseEq (eval_static_condition cond (approx_regs (analyze f)!!pc args)). intros b ESC. - generalize (eval_static_condition_correct ge cond _ _ _ + generalize (eval_static_condition_correct ge cond _ _ m _ (approx_regs_val_list _ _ _ args MATCH) ESC); intro. replace b with false. intro; eapply exec_Inop; eauto. congruence. intros. eapply exec_Icond_false; eauto. diff --git a/backend/Conventions.v b/backend/Conventions.v index 9778f6a..c11bf47 100644 --- a/backend/Conventions.v +++ b/backend/Conventions.v @@ -191,6 +191,22 @@ Proof. intros; simpl. tauto. Qed. +Lemma incoming_slot_in_parameters: + forall ofs ty sg, + In (S (Incoming ofs ty)) (loc_parameters sg) -> + In (S (Outgoing ofs ty)) (loc_arguments sg). +Proof. + intros. + unfold loc_parameters in H. + change (S (Incoming ofs ty)) with (parameter_of_argument (S (Outgoing ofs ty))) in H. + exploit list_in_map_inv. eexact H. intros [x [A B]]. simpl in A. + exploit loc_arguments_acceptable; eauto. unfold loc_argument_acceptable; intros. + destruct x; simpl in A; try discriminate. + destruct s; try contradiction. + inv A. auto. +Qed. + + (** * Tail calls *) (** A tail-call is possible for a signature if the corresponding diff --git a/backend/LTL.v b/backend/LTL.v index a68352f..6e3effd 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -168,7 +168,7 @@ Inductive step: state -> trace -> state -> Prop := | exec_Lop: forall s f sp pc rs m op args res pc' v, (fn_code f)!pc = Some(Lop op args res pc') -> - eval_operation ge sp op (map rs args) = Some v -> + eval_operation ge sp op (map rs args) m = Some v -> step (State s f sp pc rs m) E0 (State s f sp pc' (Locmap.set res v (undef_temps rs)) m) | exec_Lload: @@ -210,20 +210,20 @@ Inductive step: state -> trace -> state -> Prop := | exec_Lcond_true: forall s f sp pc rs m cond args ifso ifnot, (fn_code f)!pc = Some(Lcond cond args ifso ifnot) -> - eval_condition cond (map rs args) = Some true -> + eval_condition cond (map rs args) m = Some true -> step (State s f sp pc rs m) E0 (State s f sp ifso (undef_temps rs) m) | exec_Lcond_false: forall s f sp pc rs m cond args ifso ifnot, (fn_code f)!pc = Some(Lcond cond args ifso ifnot) -> - eval_condition cond (map rs args) = Some false -> + eval_condition cond (map rs args) m = Some false -> step (State s f sp pc rs m) E0 (State s f sp ifnot (undef_temps rs) m) | exec_Ljumptable: forall s f sp pc rs m arg tbl n pc', (fn_code f)!pc = Some(Ljumptable arg tbl) -> rs arg = Vint n -> - list_nth_z tbl (Int.signed n) = Some pc' -> + list_nth_z tbl (Int.unsigned n) = Some pc' -> step (State s f sp pc rs m) E0 (State s f sp pc' (undef_temps rs) m) | exec_Lreturn: diff --git a/backend/LTLin.v b/backend/LTLin.v index d6c5fa7..5f12390 100644 --- a/backend/LTLin.v +++ b/backend/LTLin.v @@ -158,7 +158,7 @@ Definition find_function (ros: loc + ident) (rs: locset) : option fundef := Inductive step: state -> trace -> state -> Prop := | exec_Lop: forall s f sp op args res b rs m v, - eval_operation ge sp op (map rs args) = Some v -> + eval_operation ge sp op (map rs args) m = Some v -> step (State s f sp (Lop op args res :: b) rs m) E0 (State s f sp b (Locmap.set res v (undef_temps rs)) m) | exec_Lload: @@ -203,19 +203,19 @@ Inductive step: state -> trace -> state -> Prop := E0 (State s f sp b' rs m) | exec_Lcond_true: forall s f sp cond args lbl b rs m b', - eval_condition cond (map rs args) = Some true -> + eval_condition cond (map rs args) m = Some true -> find_label lbl f.(fn_code) = Some b' -> step (State s f sp (Lcond cond args lbl :: b) rs m) E0 (State s f sp b' (undef_temps rs) m) | exec_Lcond_false: forall s f sp cond args lbl b rs m, - eval_condition cond (map rs args) = Some false -> + eval_condition cond (map rs args) m = Some false -> step (State s f sp (Lcond cond args lbl :: b) rs m) E0 (State s f sp b (undef_temps rs) m) | exec_Ljumptable: forall s f sp arg tbl b rs m n lbl b', rs arg = Vint n -> - list_nth_z tbl (Int.signed n) = Some lbl -> + list_nth_z tbl (Int.unsigned n) = Some lbl -> find_label lbl f.(fn_code) = Some b' -> step (State s f sp (Ljumptable arg tbl :: b) rs m) E0 (State s f sp b' (undef_temps rs) m) diff --git a/backend/LTLintyping.v b/backend/LTLintyping.v index ad3ad64..c928f3f 100644 --- a/backend/LTLintyping.v +++ b/backend/LTLintyping.v @@ -89,7 +89,7 @@ Inductive wt_instr : instruction -> Prop := forall arg tbl, Loc.type arg = Tint -> loc_acceptable arg -> - list_length_z tbl * 4 <= Int.max_signed -> + list_length_z tbl * 4 <= Int.max_unsigned -> wt_instr (Ljumptable arg tbl) | wt_Lreturn: forall optres, diff --git a/backend/LTLtyping.v b/backend/LTLtyping.v index 7afae2d..791c755 100644 --- a/backend/LTLtyping.v +++ b/backend/LTLtyping.v @@ -109,7 +109,7 @@ Inductive wt_instr : instruction -> Prop := Loc.type arg = Tint -> loc_acceptable arg -> (forall lbl, In lbl tbl -> valid_successor lbl) -> - list_length_z tbl * 4 <= Int.max_signed -> + list_length_z tbl * 4 <= Int.max_unsigned -> wt_instr (Ljumptable arg tbl) | wt_Lreturn: forall optres, diff --git a/backend/Linear.v b/backend/Linear.v index 40f7e41..31c3fed 100644 --- a/backend/Linear.v +++ b/backend/Linear.v @@ -123,7 +123,8 @@ Definition reglist (rs: locset) (rl: list mreg) : list val := [call_regs caller] returns the location set at function entry, as a function of the location set [caller] of the calling function. -- Machine registers have the same values as in the caller. +- Temporary registers are undefined. +- Other machine registers have the same values as in the caller. - Incoming stack slots (used for parameter passing) have the same values as the corresponding outgoing stack slots (used for argument passing) in the caller. @@ -133,7 +134,7 @@ Definition reglist (rs: locset) (rl: list mreg) : list val := Definition call_regs (caller: locset) : locset := fun (l: loc) => match l with - | R r => caller (R r) + | R r => if In_dec Loc.eq (R r) temporaries then Vundef else caller (R r) | S (Local ofs ty) => Vundef | S (Incoming ofs ty) => caller (S (Outgoing ofs ty)) | S (Outgoing ofs ty) => Vundef @@ -262,7 +263,7 @@ Inductive step: state -> trace -> state -> Prop := E0 (State s f sp b (Locmap.set (S sl) (rs (R r)) rs) m) | exec_Lop: forall s f sp op args res b rs m v, - eval_operation ge sp op (reglist rs args) = Some v -> + eval_operation ge sp op (reglist rs args) m = Some v -> step (State s f sp (Lop op args res :: b) rs m) E0 (State s f sp b (Locmap.set (R res) v (undef_op op rs)) m) | exec_Lload: @@ -306,19 +307,19 @@ Inductive step: state -> trace -> state -> Prop := E0 (State s f sp b' rs m) | exec_Lcond_true: forall s f sp cond args lbl b rs m b', - eval_condition cond (reglist rs args) = Some true -> + eval_condition cond (reglist rs args) m = Some true -> find_label lbl f.(fn_code) = Some b' -> step (State s f sp (Lcond cond args lbl :: b) rs m) E0 (State s f sp b' (undef_temps rs) m) | exec_Lcond_false: forall s f sp cond args lbl b rs m, - eval_condition cond (reglist rs args) = Some false -> + eval_condition cond (reglist rs args) m = Some false -> step (State s f sp (Lcond cond args lbl :: b) rs m) E0 (State s f sp b (undef_temps rs) m) | exec_Ljumptable: forall s f sp arg tbl b rs m n lbl b', rs (R arg) = Vint n -> - list_nth_z tbl (Int.signed n) = Some lbl -> + list_nth_z tbl (Int.unsigned n) = Some lbl -> find_label lbl f.(fn_code) = Some b' -> step (State s f sp (Ljumptable arg tbl :: b) rs m) E0 (State s f sp b' (undef_temps rs) m) diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index 4ea2ea9..ef6194c 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -16,10 +16,10 @@ Require Import Coqlib. Require Import Maps. Require Import AST. Require Import Integers. -Require Import Memdata. +Require Import Values. Require Import Op. -Require Import RTL. Require Import Locations. +Require Import LTL. Require Import Linear. Require Import Conventions. @@ -106,7 +106,7 @@ Inductive wt_instr : instruction -> Prop := | wt_Ljumptable: forall arg tbl, mreg_type arg = Tint -> - list_length_z tbl * 4 <= Int.max_signed -> + list_length_z tbl * 4 <= Int.max_unsigned -> wt_instr (Ljumptable arg tbl) | wt_Lreturn: wt_instr (Lreturn). @@ -129,3 +129,66 @@ Inductive wt_fundef: fundef -> Prop := Definition wt_program (p: program) : Prop := forall i f, In (i, f) (prog_funct p) -> wt_fundef f. +(** Typing the run-time state. These definitions are used in [Stackingproof]. *) + +Require Import Values. + +Definition wt_locset (ls: locset) : Prop := + forall l, Val.has_type (ls l) (Loc.type l). + +Lemma wt_setloc: + forall ls l v, + Val.has_type v (Loc.type l) -> wt_locset ls -> wt_locset (Locmap.set l v ls). +Proof. + intros; red; intros. + unfold Locmap.set. + destruct (Loc.eq l l0). congruence. + destruct (Loc.overlap l l0). red. auto. + auto. +Qed. + +Lemma wt_undef_temps: + forall ls, wt_locset ls -> wt_locset (undef_temps ls). +Proof. + unfold undef_temps. generalize temporaries. induction l; simpl; intros. + auto. + apply IHl. apply wt_setloc; auto. red; auto. +Qed. + +Lemma wt_undef_op: + forall op ls, wt_locset ls -> wt_locset (undef_op op ls). +Proof. + intros. generalize (wt_undef_temps ls H); intro. case op; simpl; auto. +Qed. + +Lemma wt_undef_getstack: + forall s ls, wt_locset ls -> wt_locset (undef_getstack s ls). +Proof. + intros. unfold undef_getstack. destruct s; auto. apply wt_setloc; auto. red; auto. +Qed. + +Lemma wt_call_regs: + forall ls, wt_locset ls -> wt_locset (call_regs ls). +Proof. + intros; red; intros. unfold call_regs. destruct l. auto. + destruct (in_dec Loc.eq (R m) temporaries). red; auto. auto. + destruct s. red; auto. + change (Loc.type (S (Incoming z t))) with (Loc.type (S (Outgoing z t))). auto. + red; auto. +Qed. + +Lemma wt_return_regs: + forall caller callee, + wt_locset caller -> wt_locset callee -> wt_locset (return_regs caller callee). +Proof. + intros; red; intros. + unfold return_regs. destruct l; auto. + destruct (in_dec Loc.eq (R m) temporaries); auto. + destruct (in_dec Loc.eq (R m) destroyed_at_call); auto. +Qed. + +Lemma wt_init: + wt_locset (Locmap.init Vundef). +Proof. + red; intros. unfold Locmap.init. red; auto. +Qed. diff --git a/backend/Mach.v b/backend/Mach.v index c6a692a..223d5ab 100644 --- a/backend/Mach.v +++ b/backend/Mach.v @@ -13,8 +13,7 @@ (** The Mach intermediate language: abstract syntax. Mach is the last intermediate language before generation of assembly - code. This file defines the abstract syntax for Mach; two dynamic - semantics are given in modules [Machabstr] and [Machconcr]. + code. *) Require Import Coqlib. @@ -25,6 +24,7 @@ Require Import Values. Require Import Memory. Require Import Events. Require Import Globalenvs. +Require Import Smallstep. Require Import Op. Require Import Locations. Require Import Conventions. @@ -40,7 +40,7 @@ Require Import Conventions. [Mgetstack] and [Msetstack] to read and write within the activation record for the current function, at a given word offset and with a given type; and [Mgetparam], to read within the activation record of - the caller. + the caller. These instructions implement a more concrete view of the activation record than the the [Lgetstack] and [Lsetstack] instructions of @@ -72,7 +72,6 @@ Record function: Type := mkfunction { fn_sig: signature; fn_code: code; fn_stacksize: Z; - fn_framesize: Z; fn_link_ofs: int; fn_retaddr_ofs: int }. diff --git a/backend/Machconcr.v b/backend/Machconcr.v index 5a98dd9..3f2a2e1 100644 --- a/backend/Machconcr.v +++ b/backend/Machconcr.v @@ -147,15 +147,15 @@ Inductive step: state -> trace -> state -> Prop := step (State s f sp (Msetstack src ofs ty :: c) rs m) E0 (State s f sp c rs m') | exec_Mgetparam: - forall s fb f sp parent ofs ty dst c rs m v, + forall s fb f sp ofs ty dst c rs m v, Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m sp Tint f.(fn_link_ofs) = Some parent -> - load_stack m parent ty ofs = Some v -> + load_stack m sp Tint f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (parent_sp s) ty ofs = Some v -> step (State s fb sp (Mgetparam ofs ty dst :: c) rs m) E0 (State s fb sp c (rs # IT1 <- Vundef # dst <- v) m) | exec_Mop: forall s f sp op args res c rs m v, - eval_operation ge sp op rs##args = Some v -> + eval_operation ge sp op rs##args m = Some v -> step (State s f sp (Mop op args res :: c) rs m) E0 (State s f sp c ((undef_op op rs)#res <- v) m) | exec_Mload: @@ -184,7 +184,7 @@ Inductive step: state -> trace -> state -> Prop := 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) -> - Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' -> + 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') | exec_Mbuiltin: @@ -200,20 +200,20 @@ Inductive step: state -> trace -> state -> Prop := E0 (State s fb sp c' rs m) | exec_Mcond_true: forall s fb f sp cond args lbl c rs m c', - eval_condition cond rs##args = Some true -> + eval_condition cond rs##args m = Some true -> Genv.find_funct_ptr ge fb = Some (Internal f) -> find_label lbl f.(fn_code) = Some c' -> step (State s fb sp (Mcond cond args lbl :: c) rs m) E0 (State s fb sp c' (undef_temps rs) m) | exec_Mcond_false: forall s f sp cond args lbl c rs m, - eval_condition cond rs##args = Some false -> + eval_condition cond rs##args m = Some false -> step (State s f sp (Mcond cond args lbl :: c) rs m) E0 (State s f sp c (undef_temps rs) m) | exec_Mjumptable: forall s fb f sp arg tbl c rs m n lbl c', rs arg = Vint n -> - list_nth_z tbl (Int.signed n) = Some lbl -> + list_nth_z tbl (Int.unsigned n) = Some lbl -> Genv.find_funct_ptr ge fb = Some (Internal f) -> find_label lbl f.(fn_code) = Some c' -> step (State s fb sp (Mjumptable arg tbl :: c) rs m) @@ -223,18 +223,18 @@ Inductive step: state -> trace -> state -> Prop := 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) -> - Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' -> + 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') | exec_function_internal: forall s fb rs m f m1 m2 m3 stk, Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mem.alloc m (- f.(fn_framesize)) f.(fn_stacksize) = (m1, stk) -> - let sp := Vptr stk (Int.repr (-f.(fn_framesize))) in + 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 -> step (Callstate s fb rs m) - E0 (State s fb sp f.(fn_code) rs m3) + E0 (State s fb sp f.(fn_code) (undef_temps rs) m3) | exec_function_external: forall s fb rs m t rs' ef args res m', Genv.find_funct_ptr ge fb = Some (External ef) -> diff --git a/backend/Machtyping.v b/backend/Machtyping.v index 93ac00c..95ceafe 100644 --- a/backend/Machtyping.v +++ b/backend/Machtyping.v @@ -87,7 +87,7 @@ Inductive wt_instr : instruction -> Prop := | wt_Mjumptable: forall arg tbl, mreg_type arg = Tint -> - list_length_z tbl * 4 <= Int.max_signed -> + list_length_z tbl * 4 <= Int.max_unsigned -> wt_instr (Mjumptable arg tbl) | wt_Mreturn: wt_instr Mreturn. @@ -96,24 +96,7 @@ Record wt_function (f: function) : Prop := mk_wt_function { wt_function_instrs: forall instr, In instr f.(fn_code) -> wt_instr instr; wt_function_stacksize: - f.(fn_stacksize) >= 0; - wt_function_framesize: - 0 <= f.(fn_framesize) <= -Int.min_signed; - wt_function_framesize_aligned: - (4 | f.(fn_framesize)); - wt_function_link: - 0 <= Int.signed f.(fn_link_ofs) - /\ Int.signed f.(fn_link_ofs) + 4 <= f.(fn_framesize); - wt_function_link_aligned: - (4 | Int.signed f.(fn_link_ofs)); - wt_function_retaddr: - 0 <= Int.signed f.(fn_retaddr_ofs) - /\ Int.signed f.(fn_retaddr_ofs) + 4 <= f.(fn_framesize); - wt_function_retaddr_aligned: - (4 | Int.signed f.(fn_retaddr_ofs)); - wt_function_link_retaddr: - Int.signed f.(fn_retaddr_ofs) + 4 <= Int.signed f.(fn_link_ofs) - \/ Int.signed f.(fn_link_ofs) + 4 <= Int.signed f.(fn_retaddr_ofs) + 0 <= f.(fn_stacksize) <= Int.max_unsigned }. Inductive wt_fundef: fundef -> Prop := @@ -125,227 +108,3 @@ Inductive wt_fundef: fundef -> Prop := Definition wt_program (p: program) : Prop := forall i f, In (i, f) (prog_funct p) -> wt_fundef f. - -(** * Type soundness *) - -Require Import Machabstr. - -(** We show a weak type soundness result for the abstract semantics - of Mach: for a well-typed Mach program, if a transition is taken - from a state where registers hold values of their static types, - registers in the final state hold values of their static types - as well. This is a subject reduction theorem for our type system. - It is used in the proof of implication from the abstract Mach - semantics to the concrete Mach semantics (file [Machabstr2concr]). -*) - -Definition wt_regset (rs: regset) : Prop := - forall r, Val.has_type (rs r) (mreg_type r). - -Definition wt_frame (fr: frame) : Prop := - forall ty ofs, Val.has_type (fr ty ofs) ty. - -Lemma wt_setreg: - forall (rs: regset) (r: mreg) (v: val), - Val.has_type v (mreg_type r) -> - wt_regset rs -> wt_regset (rs#r <- v). -Proof. - intros; red; intros. unfold Regmap.set. - case (RegEq.eq r0 r); intro. - subst r0; assumption. - apply H0. -Qed. - -Lemma wt_undef_temps: - forall rs, wt_regset rs -> wt_regset (undef_temps rs). -Proof. - unfold undef_temps. - generalize (int_temporaries ++ float_temporaries). - induction l; simpl; intros. auto. - apply IHl. red; intros. unfold Regmap.set. - destruct (RegEq.eq r a). constructor. auto. -Qed. - -Lemma wt_undef_op: - forall op rs, wt_regset rs -> wt_regset (undef_op op rs). -Proof. - intros. set (W := wt_undef_temps rs H). - destruct op; simpl; auto. -Qed. - -Lemma wt_undef_getparam: - forall rs, wt_regset rs -> wt_regset (rs#IT1 <- Vundef). -Proof. - intros; red; intros. unfold Regmap.set. - destruct (RegEq.eq r IT1). constructor. auto. -Qed. - -Lemma wt_get_slot: - forall f fr ty ofs v, - get_slot f fr ty ofs v -> - wt_frame fr -> - Val.has_type v ty. -Proof. - induction 1; intros. - subst v. apply H1. -Qed. - -Lemma wt_set_slot: - forall f fr ty ofs v fr', - set_slot f fr ty ofs v fr' -> - wt_frame fr -> - Val.has_type v ty -> - wt_frame fr'. -Proof. - intros. induction H. subst fr'; red; intros. unfold update. - destruct (zeq (ofs - f.(fn_framesize)) ofs0). - destruct (typ_eq ty ty0). congruence. exact I. - destruct (zle (ofs0 + AST.typesize ty0) (ofs - f.(fn_framesize))). - apply H0. - destruct (zle (ofs - f.(fn_framesize) + AST.typesize ty) ofs0). - apply H0. - exact I. -Qed. - -Lemma wt_empty_frame: - wt_frame empty_frame. -Proof. - intros; red; intros; exact I. -Qed. - -Lemma is_tail_find_label: - forall lbl c c', find_label lbl c = Some c' -> is_tail c' c. -Proof. - induction c; simpl. - intros; discriminate. - case (is_label lbl a); intros. - injection H; intro; subst c'. constructor. constructor. - constructor; auto. -Qed. - -Section SUBJECT_REDUCTION. - -Inductive wt_stackframe: stackframe -> Prop := - | wt_stackframe_intro: forall f sp c fr, - wt_function f -> - Val.has_type sp Tint -> - is_tail c f.(fn_code) -> - wt_frame fr -> - wt_stackframe (Stackframe f sp c fr). - -Inductive wt_state: state -> Prop := - | wt_state_intro: forall stk f sp c rs fr m - (STK: forall s, In s stk -> wt_stackframe s) - (WTF: wt_function f) - (WTSP: Val.has_type sp Tint) - (TAIL: is_tail c f.(fn_code)) - (WTRS: wt_regset rs) - (WTFR: wt_frame fr), - wt_state (State stk f sp c rs fr m) - | wt_state_call: forall stk f rs m, - (forall s, In s stk -> wt_stackframe s) -> - wt_fundef f -> - wt_regset rs -> - wt_state (Callstate stk f rs m) - | wt_state_return: forall stk rs m, - (forall s, In s stk -> wt_stackframe s) -> - wt_regset rs -> - wt_state (Returnstate stk rs m). - -Variable p: program. -Hypothesis wt_p: wt_program p. -Let ge := Genv.globalenv p. - -Lemma subject_reduction: - forall s1 t s2, step ge s1 t s2 -> - forall (WTS: wt_state s1), wt_state s2. -Proof. - induction 1; intros; inv WTS; - try (generalize (wt_function_instrs _ WTF _ (is_tail_in TAIL)); intro WTI; - eapply wt_state_intro; eauto with coqlib). - - apply wt_setreg; auto. inv WTI. eapply wt_get_slot; eauto. - - eapply wt_set_slot; eauto. inv WTI; auto. - - assert (mreg_type dst = ty). - inv WTI; auto. - assert (wt_frame (parent_frame s)). - destruct s; simpl. apply wt_empty_frame. - generalize (STK s (in_eq _ _)); intro. inv H1. auto. - apply wt_setreg; auto. - rewrite H0. eapply wt_get_slot; eauto. - apply wt_undef_getparam; auto. - -(* op *) - apply wt_setreg; auto. - inv WTI. - (* move *) - simpl in H. inv H. rewrite <- H1. apply WTRS. - (* not move *) - replace (mreg_type res) with (snd (type_of_operation op)). - apply type_of_operation_sound with fundef unit ge rs##args sp; auto. - rewrite <- H4; reflexivity. - apply wt_undef_op; auto. - -(* load *) - apply wt_setreg; auto. inv WTI. rewrite H6. eapply type_of_chunk_correct; eauto. - apply wt_undef_temps; auto. - -(* store *) - apply wt_undef_temps; auto. - -(* call *) - assert (WTFD: wt_fundef f'). - destruct ros; simpl in H. - apply (Genv.find_funct_prop wt_fundef _ _ wt_p H). - destruct (Genv.find_symbol ge i); try discriminate. - apply (Genv.find_funct_ptr_prop wt_fundef _ _ wt_p H). - econstructor; eauto. - intros. elim H0; intro. subst s0. econstructor; eauto with coqlib. - auto. - -(* tailcall *) - assert (WTFD: wt_fundef f'). - destruct ros; simpl in H. - apply (Genv.find_funct_prop wt_fundef _ _ wt_p H). - destruct (Genv.find_symbol ge i); try discriminate. - apply (Genv.find_funct_ptr_prop wt_fundef _ _ wt_p H). - econstructor; eauto. - -(* extcall *) - apply wt_setreg; auto. - inv WTI. rewrite H4. eapply external_call_well_typed; eauto. - apply wt_undef_temps; auto. - -(* goto *) - apply is_tail_find_label with lbl; congruence. -(* cond *) - apply is_tail_find_label with lbl; congruence. apply wt_undef_temps; auto. - apply wt_undef_temps; auto. -(* jumptable *) - apply is_tail_find_label with lbl; congruence. apply wt_undef_temps; auto. - -(* return *) - econstructor; eauto. - -(* internal function *) - econstructor; eauto with coqlib. inv H5; auto. exact I. - apply wt_empty_frame. - -(* external function *) - econstructor; eauto. apply wt_setreg; auto. - generalize (external_call_well_typed _ _ _ _ _ _ _ H). - unfold proj_sig_res, loc_result. - destruct (sig_res (ef_sig ef)). - destruct t0; simpl; auto. - simpl; auto. - -(* returnstate *) - generalize (H1 _ (in_eq _ _)); intro. inv H. - econstructor; eauto. - eauto with coqlib. -Qed. - -End SUBJECT_REDUCTION. - diff --git a/backend/RTL.v b/backend/RTL.v index 208c7b1..2cb2719 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -217,7 +217,7 @@ Inductive step: state -> trace -> state -> Prop := | exec_Iop: forall s f sp pc rs m op args res pc' v, (fn_code f)!pc = Some(Iop op args res pc') -> - eval_operation ge sp op rs##args = Some v -> + eval_operation ge sp op rs##args m = Some v -> step (State s f sp pc rs m) E0 (State s f sp pc' (rs#res <- v) m) | exec_Iload: @@ -258,20 +258,20 @@ Inductive step: state -> trace -> state -> Prop := | exec_Icond_true: forall s f sp pc rs m cond args ifso ifnot, (fn_code f)!pc = Some(Icond cond args ifso ifnot) -> - eval_condition cond rs##args = Some true -> + eval_condition cond rs##args m = Some true -> step (State s f sp pc rs m) E0 (State s f sp ifso rs m) | exec_Icond_false: forall s f sp pc rs m cond args ifso ifnot, (fn_code f)!pc = Some(Icond cond args ifso ifnot) -> - eval_condition cond rs##args = Some false -> + eval_condition cond rs##args m = Some false -> step (State s f sp pc rs m) E0 (State s f sp ifnot rs m) | exec_Ijumptable: forall s f sp pc rs m arg tbl n pc', (fn_code f)!pc = Some(Ijumptable arg tbl) -> rs#arg = Vint n -> - list_nth_z tbl (Int.signed n) = Some pc' -> + list_nth_z tbl (Int.unsigned n) = Some pc' -> step (State s f sp pc rs m) E0 (State s f sp pc' rs m) | exec_Ireturn: @@ -303,7 +303,7 @@ Inductive step: state -> trace -> state -> Prop := Lemma exec_Iop': forall s f sp pc rs m op args res pc' rs' v, (fn_code f)!pc = Some(Iop op args res pc') -> - eval_operation ge sp op rs##args = Some v -> + eval_operation ge sp op rs##args m = Some v -> rs' = (rs#res <- v) -> step (State s f sp pc rs m) E0 (State s f sp pc' rs' m). diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index 24f8c1a..e72b000 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -419,6 +419,7 @@ Lemma transl_switch_correct: nth_error nexits act = Some nd /\ match_env map e nil rs'. Proof. + Opaque Int.sub. induction 1; simpl; intros. (* action *) inv H3. exists n; exists rs; intuition. @@ -584,7 +585,7 @@ Lemma transl_expr_Eop_correct: (vargs : list val) (v : val), eval_exprlist ge sp e m le args vargs -> transl_exprlist_prop le args vargs -> - eval_operation ge sp op vargs = Some v -> + eval_operation ge sp op vargs m = Some v -> transl_expr_prop le (Eop op args) v. Proof. intros; red; intros. inv TE. @@ -730,7 +731,7 @@ Lemma transl_condition_CEcond_correct: (vargs : list val) (b : bool), eval_exprlist ge sp e m le args vargs -> transl_exprlist_prop le args vargs -> - eval_condition cond vargs = Some b -> + eval_condition cond vargs m = Some b -> transl_condition_prop le (CEcond cond args) b. Proof. intros; red; intros; inv TE. diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index 533c47a..a002746 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -123,7 +123,7 @@ Inductive wt_instr : instruction -> Prop := forall arg tbl, env arg = Tint -> (forall s, In s tbl -> valid_successor s) -> - list_length_z tbl * 4 <= Int.max_signed -> + list_length_z tbl * 4 <= Int.max_unsigned -> wt_instr (Ijumptable arg tbl) | wt_Ireturn: forall optres, @@ -245,7 +245,7 @@ Definition check_instr (i: instruction) : bool := | Ijumptable arg tbl => check_reg arg Tint && List.forallb check_successor tbl - && zle (list_length_z tbl * 4) Int.max_signed + && zle (list_length_z tbl * 4) Int.max_unsigned | Ireturn optres => match optres, funct.(fn_sig).(sig_res) with | None, None => true @@ -527,7 +527,7 @@ Proof. econstructor; eauto. apply wt_regset_assign. auto. replace (env res) with (snd (type_of_operation op)). - apply type_of_operation_sound with fundef unit ge rs##args sp; auto. + eapply type_of_operation_sound; eauto. rewrite <- H6. reflexivity. (* Iload *) econstructor; eauto. diff --git a/backend/Reloadproof.v b/backend/Reloadproof.v index a3ed303..09a9101 100644 --- a/backend/Reloadproof.v +++ b/backend/Reloadproof.v @@ -156,10 +156,10 @@ Proof. Qed. Lemma not_enough_temporaries_addr: - forall (ge: genv) sp addr src args ls v, + forall (ge: genv) sp addr src args ls v m, enough_temporaries (src :: args) = false -> eval_addressing ge sp addr (List.map ls args) = Some v -> - eval_operation ge sp (op_for_binary_addressing addr) (List.map ls args) = Some v. + eval_operation ge sp (op_for_binary_addressing addr) (List.map ls args) m = Some v. Proof. intros. apply eval_op_for_binary_addressing; auto. @@ -692,7 +692,8 @@ Proof. unfold call_regs, parameter_of_argument. generalize (loc_arguments_acceptable _ _ H). unfold loc_argument_acceptable. - destruct x. auto. + destruct x. + intros. destruct (in_dec Loc.eq (R m) temporaries). contradiction. auto. destruct s; intros; try contradiction. auto. Qed. @@ -1015,9 +1016,9 @@ Proof. exploit add_reloads_correct. eapply enough_temporaries_op_args; eauto. auto. intros [ls2 [A [B C]]]. instantiate (1 := ls) in B. - assert (exists tv, eval_operation tge sp op (reglist ls2 (regs_for args)) = Some tv + assert (exists tv, eval_operation tge sp op (reglist ls2 (regs_for args)) tm = Some tv /\ Val.lessdef v tv). - apply eval_operation_lessdef with (map rs args); auto. + apply eval_operation_lessdef with (map rs args) m; auto. rewrite B. eapply agree_locs; eauto. rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. destruct H1 as [tv [P Q]]. @@ -1291,7 +1292,7 @@ Proof. intros [ls2 [A [B C]]]. left; econstructor; split. eapply plus_right. eauto. eapply exec_Lcond_true; eauto. - rewrite B. apply eval_condition_lessdef with (map rs args); auto. + rewrite B. apply eval_condition_lessdef with (map rs args) m; auto. eapply agree_locs; eauto. apply find_label_transf_function; eauto. traceEq. @@ -1306,7 +1307,7 @@ Proof. intros [ls2 [A [B C]]]. left; econstructor; split. eapply plus_right. eauto. eapply exec_Lcond_false; eauto. - rewrite B. apply eval_condition_lessdef with (map rs args); auto. + rewrite B. apply eval_condition_lessdef with (map rs args) m; auto. eapply agree_locs; eauto. traceEq. econstructor; eauto with coqlib. diff --git a/backend/Selection.v b/backend/Selection.v index 68fb9ba..9e11bc3 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -78,7 +78,7 @@ Fixpoint condexpr_of_expr (e: expr) : condexpr := | Econdition ce e1 e2 => CEcondition ce (condexpr_of_expr e1) (condexpr_of_expr e2) | _ => - CEcond (Ccompimm Cne Int.zero) (e:::Enil) + CEcond (Ccompuimm Cne Int.zero) (e:::Enil) end. (** Conversion of loads and stores *) diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index d997015..d475f26 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -86,7 +86,7 @@ Lemma eval_base_condition_of_expr: eval_expr ge sp e m le a v -> Val.bool_of_val v b -> eval_condexpr ge sp e m le - (CEcond (Ccompimm Cne Int.zero) (a ::: Enil)) + (CEcond (Ccompuimm Cne Int.zero) (a ::: Enil)) b. Proof. intros. @@ -97,7 +97,7 @@ Qed. Lemma is_compare_neq_zero_correct: forall c v b, is_compare_neq_zero c = true -> - eval_condition c (v :: nil) = Some b -> + eval_condition c (v :: nil) m = Some b -> Val.bool_of_val v b. Proof. intros. @@ -107,17 +107,18 @@ Proof. simpl in H0. destruct v; inv H0. generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl. - subst i; constructor. constructor; auto. constructor. + subst i; constructor. constructor; auto. simpl in H0. destruct v; inv H0. generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl. subst i; constructor. constructor; auto. + constructor. Qed. Lemma is_compare_eq_zero_correct: forall c v b, is_compare_eq_zero c = true -> - eval_condition c (v :: nil) = Some b -> + eval_condition c (v :: nil) m = Some b -> Val.bool_of_val v (negb b). Proof. intros. apply is_compare_neq_zero_correct with (negate_condition c). @@ -145,8 +146,8 @@ Proof. eapply eval_base_condition_of_expr; eauto. inv H0. simpl in H7. - assert (eval_condition c vl = Some b). - destruct (eval_condition c vl); try discriminate. + assert (eval_condition c vl m = Some b). + destruct (eval_condition c vl m); try discriminate. destruct b0; inv H7; inversion H1; congruence. assert (eval_condexpr ge sp e m le (CEcond c e0) b). eapply eval_CEcond; eauto. @@ -230,7 +231,7 @@ Lemma eval_sel_binop: forall le op a1 a2 v1 v2 v, eval_expr ge sp e m le a1 v1 -> eval_expr ge sp e m le a2 v2 -> - eval_binop op v1 v2 = Some v -> + eval_binop op v1 v2 m = Some v -> eval_expr ge sp e m le (sel_binop op a1 a2) v. Proof. destruct op; simpl; intros; FuncInv; try subst v. @@ -263,13 +264,15 @@ Proof. apply eval_subf; auto. apply eval_mulf; auto. apply eval_divf; auto. - apply eval_comp_int; auto. - eapply eval_comp_int_ptr; eauto. - eapply eval_comp_ptr_int; eauto. + apply eval_comp; auto. + eapply eval_compu_int; eauto. + eapply eval_compu_int_ptr; eauto. + eapply eval_compu_ptr_int; eauto. + destruct (Mem.valid_pointer m b (Int.unsigned i) && + Mem.valid_pointer m b0 (Int.unsigned i0)) as [] _eqn; try congruence. destruct (eq_block b b0); inv H1. - eapply eval_comp_ptr_ptr; eauto. - eapply eval_comp_ptr_ptr_2; eauto. - eapply eval_compu; eauto. + eapply eval_compu_ptr_ptr; eauto. + eapply eval_compu_ptr_ptr_2; eauto. eapply eval_compf; eauto. Qed. diff --git a/backend/Stacking.v b/backend/Stacking.v index 2ea08be..09d98d6 100644 --- a/backend/Stacking.v +++ b/backend/Stacking.v @@ -118,19 +118,17 @@ Definition restore_callee_save (fe: frame_env) (k: Mach.code) := (** * Code transformation. *) (** Translation of operations and addressing mode. - In Linear, the stack pointer has offset 0, i.e. points to the - beginning of the Cminor stack data block. In Mach, the stack - pointer points to the bottom of the activation record, - at offset [- fe.(fe_size)] where [fe] is the frame environment. + The Cminor stack data block starts at offset 0 in Linear, + but at offset [fe.(fe_stack_data)] in Mach. Operations and addressing mode that are relative to the stack pointer - must therefore be offset by [fe.(fe_size)] to preserve their + must therefore be offset by [fe.(fe_stack_data)] to preserve their behaviour. *) Definition transl_op (fe: frame_env) (op: operation) := - shift_stack_operation (Int.repr fe.(fe_size)) op. + shift_stack_operation (Int.repr fe.(fe_stack_data)) op. Definition transl_addr (fe: frame_env) (addr: addressing) := - shift_stack_addressing (Int.repr fe.(fe_size)) addr. + shift_stack_addressing (Int.repr fe.(fe_stack_data)) addr. (** Translation of a Linear instruction. Prepends the corresponding Mach instructions to the given list of instructions. @@ -193,8 +191,8 @@ Definition transl_instr by the translation of the function body. Subtle point: the compiler must check that the frame is no - larger than [- Int.min_signed] bytes, otherwise arithmetic overflows - could occur during frame accesses using signed machine integers as + larger than [Int.max_unsigned] bytes, otherwise arithmetic overflows + could occur during frame accesses using unsigned machine integers as offsets. *) Definition transl_code @@ -208,15 +206,12 @@ Open Local Scope string_scope. Definition transf_function (f: Linear.function) : res Mach.function := let fe := make_env (function_bounds f) in - if zlt f.(Linear.fn_stacksize) 0 then - Error (msg "Stacking.transf_function") - else if zlt (- Int.min_signed) fe.(fe_size) then + if zlt Int.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) - f.(Linear.fn_stacksize) fe.(fe_size) (Int.repr fe.(fe_ofs_link)) (Int.repr fe.(fe_ofs_retaddr))). diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index 5b06c71..c32886c 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -12,13 +12,7 @@ (** Correctness proof for the translation from Linear to Mach. *) -(** This file proves semantic preservation for the [Stacking] pass. - For the target language Mach, we use the abstract semantics - given in file [Machabstr], where a part of the activation record - is not resident in memory. Combined with the semantic equivalence - result between the two Mach semantics (see file [Machabstr2concr]), - the proof in this file also shows semantic preservation with - respect to the concrete Mach semantics. *) +(** This file proves semantic preservation for the [Stacking] pass. *) Require Import Coqlib. Require Import Maps. @@ -36,15 +30,13 @@ Require LTL. Require Import Linear. Require Import Lineartyping. Require Import Mach. -Require Import Machabstr. +Require Import Machconcr. Require Import Bounds. Require Import Conventions. Require Import Stacklayout. Require Import Stacking. -(** * Properties of frames and frame accesses *) - -(** ``Good variable'' properties for frame accesses. *) +(** * Properties of frame offsets *) Lemma typesize_typesize: forall ty, AST.typesize ty = 4 * Locations.typesize ty. @@ -52,6 +44,12 @@ Proof. destruct ty; auto. Qed. +Remark size_type_chunk: + forall ty, size_chunk (chunk_of_type ty) = AST.typesize ty. +Proof. + destruct ty; reflexivity. +Qed. + Section PRESERVATION. Variable prog: Linear.program. @@ -63,7 +61,6 @@ Let tge := Genv.globalenv tprog. Section FRAME_PROPERTIES. -Variable stack: list Machabstr.stackframe. Variable f: Linear.function. Let b := function_bounds f. Let fe := make_env b. @@ -74,27 +71,30 @@ Lemma unfold_transf_function: tf = Mach.mkfunction f.(Linear.fn_sig) (transl_body f fe) - f.(Linear.fn_stacksize) fe.(fe_size) (Int.repr fe.(fe_ofs_link)) (Int.repr fe.(fe_ofs_retaddr)). Proof. generalize TRANSF_F. unfold transf_function. - case (zlt (Linear.fn_stacksize f) 0). intros; discriminate. - case (zlt (- Int.min_signed) (fe_size (make_env (function_bounds f)))). + destruct (zlt Int.max_unsigned (fe_size (make_env (function_bounds f)))). intros; discriminate. intros. unfold fe. unfold b. congruence. Qed. -Lemma size_no_overflow: fe.(fe_size) <= -Int.min_signed. +Lemma size_no_overflow: fe.(fe_size) <= Int.max_unsigned. Proof. generalize TRANSF_F. unfold transf_function. - case (zlt (Linear.fn_stacksize f) 0). intros; discriminate. - case (zlt (- Int.min_signed) (fe_size (make_env (function_bounds f)))). + destruct (zlt Int.max_unsigned (fe_size (make_env (function_bounds f)))). intros; discriminate. - intros. unfold fe, b. omega. + intros. unfold fe. unfold b. omega. Qed. +Remark bound_stack_data_stacksize: + f.(Linear.fn_stacksize) <= b.(bound_stack_data). +Proof. + unfold b, function_bounds, bound_stack_data. apply Zmax1. +Qed. + (** A frame index is valid if it lies within the resource bounds of the current function. *) @@ -135,18 +135,26 @@ Definition index_diff (idx1 idx2: frame_index) : Prop := | _, _ => True end. +Lemma index_diff_sym: + forall idx1 idx2, index_diff idx1 idx2 -> index_diff idx2 idx1. +Proof. + unfold index_diff; intros. + destruct idx1; destruct idx2; intuition. +Qed. + Ltac AddPosProps := generalize (bound_int_local_pos b); intro; generalize (bound_float_local_pos b); intro; generalize (bound_int_callee_save_pos b); intro; generalize (bound_float_callee_save_pos b); intro; generalize (bound_outgoing_pos b); intro; - generalize (align_float_part b); intro. + generalize (bound_stack_data_pos b); intro. -Lemma size_pos: fe.(fe_size) >= 0. +Lemma size_pos: 0 <= fe.(fe_size). Proof. + generalize (frame_env_separated b). intuition. AddPosProps. - unfold fe, make_env, fe_size. omega. + unfold fe. omega. Qed. Opaque function_bounds. @@ -155,61 +163,79 @@ Lemma offset_of_index_disj: forall idx1 idx2, index_valid idx1 -> index_valid idx2 -> index_diff idx1 idx2 -> - offset_of_index fe idx1 + 4 * typesize (type_of_index idx1) <= offset_of_index fe idx2 \/ - offset_of_index fe idx2 + 4 * typesize (type_of_index idx2) <= offset_of_index fe idx1. + offset_of_index fe idx1 + AST.typesize (type_of_index idx1) <= offset_of_index fe idx2 \/ + offset_of_index fe idx2 + AST.typesize (type_of_index idx2) <= offset_of_index fe idx1. Proof. + intros idx1 idx2 V1 V2 DIFF. + generalize (frame_env_separated b). intuition. fold fe in H. AddPosProps. - intros. destruct idx1; destruct idx2; try (destruct t); try (destruct t0); - unfold offset_of_index, fe, make_env, - fe_size, fe_ofs_int_local, fe_ofs_int_callee_save, - fe_ofs_float_local, fe_ofs_float_callee_save, - fe_ofs_link, fe_ofs_retaddr, fe_ofs_arg, - type_of_index, typesize; - simpl in H5; simpl in H6; simpl in H7; + unfold offset_of_index, type_of_index, AST.typesize; + simpl in V1; simpl in V2; simpl in DIFF; try omega. assert (z <> z0). intuition auto. omega. assert (z <> z0). intuition auto. omega. Qed. +Lemma offset_of_index_disj_stack_data_1: + forall idx, + index_valid idx -> + offset_of_index fe idx + AST.typesize (type_of_index idx) <= fe.(fe_stack_data) + \/ fe.(fe_stack_data) + b.(bound_stack_data) <= offset_of_index fe idx. +Proof. + intros idx V. + generalize (frame_env_separated b). intuition. fold fe in H. + AddPosProps. + destruct idx; try (destruct t); + unfold offset_of_index, type_of_index, AST.typesize; + simpl in V; + omega. +Qed. + +Lemma offset_of_index_disj_stack_data_2: + forall idx, + index_valid idx -> + offset_of_index fe idx + AST.typesize (type_of_index idx) <= fe.(fe_stack_data) + \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= offset_of_index fe idx. +Proof. + intros. + exploit offset_of_index_disj_stack_data_1; eauto. + generalize bound_stack_data_stacksize. + omega. +Qed. + +(** Alignment properties *) + Remark aligned_4_4x: forall x, (4 | 4 * x). Proof. intro. exists x; ring. Qed. Remark aligned_4_8x: forall x, (4 | 8 * x). Proof. intro. exists (x * 2); ring. Qed. -Remark aligned_4_align8: forall x, (4 | align x 8). -Proof. - intro. apply Zdivides_trans with 8. exists 2; auto. apply align_divides. omega. -Qed. - -Hint Resolve Zdivide_0 Zdivide_refl Zdivide_plus_r - aligned_4_4x aligned_4_8x aligned_4_align8: align_4. +Remark aligned_8_4: + forall x, (8 | x) -> (4 | x). +Proof. intros. apply Zdivides_trans with 8; auto. exists 2; auto. Qed. +Hint Resolve Zdivide_0 Zdivide_refl Zdivide_plus_r + aligned_4_4x aligned_4_8x aligned_8_4: align_4. Hint Extern 4 (?X | ?Y) => (exists (Y/X); reflexivity) : align_4. Lemma offset_of_index_aligned: forall idx, (4 | offset_of_index fe idx). Proof. intros. - destruct idx; - unfold offset_of_index, fe, make_env, - fe_size, fe_ofs_int_local, fe_ofs_int_callee_save, - fe_ofs_float_local, fe_ofs_float_callee_save, - fe_ofs_link, fe_ofs_retaddr, fe_ofs_arg; + generalize (frame_env_aligned b). intuition. fold fe in H. intuition. + destruct idx; try (destruct t); + unfold offset_of_index, type_of_index, AST.typesize; auto with align_4. - destruct t; auto with align_4. Qed. -Lemma frame_size_aligned: - (4 | fe_size fe). +Lemma fe_stack_data_aligned: + (4 | fe_stack_data fe). Proof. - unfold offset_of_index, fe, make_env, - fe_size, fe_ofs_int_local, fe_ofs_int_callee_save, - fe_ofs_float_local, fe_ofs_float_callee_save, - fe_ofs_link, fe_ofs_retaddr, fe_ofs_arg; - auto with align_4. + intros. + generalize (frame_env_aligned b). intuition. fold fe in H. intuition. Qed. (** The following lemmas give sufficient conditions for indices @@ -262,19 +288,26 @@ Lemma offset_of_index_valid: forall idx, index_valid idx -> 0 <= offset_of_index fe idx /\ - offset_of_index fe idx + 4 * typesize (type_of_index idx) <= fe.(fe_size). + offset_of_index fe idx + AST.typesize (type_of_index idx) <= fe.(fe_size). Proof. + intros idx V. + generalize (frame_env_separated b). intros [A B]. fold fe in A. fold fe in B. + AddPosProps. + destruct idx; try (destruct t); + unfold offset_of_index, type_of_index, AST.typesize; + simpl in V; + omega. +Qed. + +(** The image of the Linear stack data block lies within the bounds of the frame. *) + +Lemma stack_data_offset_valid: + 0 <= fe.(fe_stack_data) /\ fe.(fe_stack_data) + b.(bound_stack_data) <= fe.(fe_size). +Proof. + generalize (frame_env_separated b). intros [A B]. fold fe in A. fold fe in B. AddPosProps. - intros. - destruct idx; try destruct t; - unfold offset_of_index, fe, make_env, - fe_size, fe_ofs_int_local, fe_ofs_int_callee_save, - fe_ofs_float_local, fe_ofs_float_callee_save, - fe_ofs_link, fe_ofs_retaddr, fe_ofs_arg, - type_of_index, typesize; - unfold index_valid in H5; simpl typesize in H5; omega. -Qed. +Qed. (** Offsets for valid index are representable as signed machine integers without loss of precision. *) @@ -282,142 +315,248 @@ Qed. Lemma offset_of_index_no_overflow: forall idx, index_valid idx -> - Int.signed (Int.repr (offset_of_index fe idx)) = offset_of_index fe idx. + Int.unsigned (Int.repr (offset_of_index fe idx)) = offset_of_index fe idx. Proof. intros. generalize (offset_of_index_valid idx H). intros [A B]. - apply Int.signed_repr. - split. apply Zle_trans with 0; auto. compute; intro; discriminate. - assert (offset_of_index fe idx < fe_size fe). - generalize (typesize_pos (type_of_index idx)); intro. omega. - apply Zlt_succ_le. - change (Zsucc Int.max_signed) with (- Int.min_signed). - generalize size_no_overflow. omega. + apply Int.unsigned_repr. + generalize (AST.typesize_pos (type_of_index idx)). + generalize size_no_overflow. + omega. Qed. -(** Characterization of the [get_slot] and [set_slot] - operations in terms of the following [index_val] and [set_index_val] - frame access functions. *) +(** Likewise, for offsets within the Linear stack slot, after shifting. *) -Definition index_val (idx: frame_index) (fr: frame) := - fr (type_of_index idx) (offset_of_index fe idx - tf.(fn_framesize)). +Lemma shifted_stack_offset_no_overflow: + forall ofs, + 0 <= Int.unsigned ofs < Linear.fn_stacksize f -> + Int.unsigned (Int.add ofs (Int.repr fe.(fe_stack_data))) + = Int.unsigned ofs + fe.(fe_stack_data). +Proof. + intros. unfold Int.add. + generalize size_no_overflow stack_data_offset_valid bound_stack_data_stacksize; intros. + AddPosProps. + replace (Int.unsigned (Int.repr (fe_stack_data fe))) with (fe_stack_data fe). + apply Int.unsigned_repr. omega. + symmetry. apply Int.unsigned_repr. omega. +Qed. -Definition set_index_val (idx: frame_index) (v: val) (fr: frame) := - update (type_of_index idx) (offset_of_index fe idx - tf.(fn_framesize)) v fr. +(** * Contents of frame slots *) -Lemma slot_valid_index: - forall idx, - index_valid idx -> idx <> FI_link -> idx <> FI_retaddr -> - slot_valid tf (type_of_index idx) (offset_of_index fe idx). +Inductive index_contains (m: mem) (sp: block) (idx: frame_index) (v: val) : Prop := + | index_contains_intro: + index_valid idx -> + Mem.load (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) = Some v -> + index_contains m sp idx v. + +Lemma index_contains_load_stack: + forall m sp idx v, + index_contains m sp idx v -> + load_stack m (Vptr sp Int.zero) (type_of_index idx) + (Int.repr (offset_of_index fe idx)) = Some v. +Proof. + intros. inv H. + unfold load_stack, Mem.loadv, Val.add. rewrite Int.add_commut. rewrite Int.add_zero. + rewrite offset_of_index_no_overflow; auto. +Qed. + +(** Good variable properties for [index_contains] *) + +Lemma gss_index_contains_base: + forall idx m m' sp v, + Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m' -> + index_valid idx -> + exists v', + index_contains m' sp idx v' + /\ decode_encode_val v (chunk_of_type (type_of_index idx)) (chunk_of_type (type_of_index idx)) v'. +Proof. + intros. + exploit Mem.load_store_similar. eauto. reflexivity. + intros [v' [A B]]. + exists v'; split; auto. constructor; auto. +Qed. + +Lemma gss_index_contains: + forall idx m m' sp v, + Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m' -> + index_valid idx -> + Val.has_type v (type_of_index idx) -> + index_contains m' sp idx v. +Proof. + intros. exploit gss_index_contains_base; eauto. intros [v' [A B]]. + assert (v' = v). + destruct v; destruct (type_of_index idx); simpl in *; intuition congruence. + subst v'. auto. +Qed. + +Lemma gso_index_contains: + forall idx m m' sp v idx' v', + Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m' -> + index_valid idx -> + index_contains m sp idx' v' -> + index_diff idx idx' -> + index_contains m' sp idx' v'. +Proof. + intros. inv H1. constructor; auto. + rewrite <- H4. eapply Mem.load_store_other; eauto. + right. repeat rewrite size_type_chunk. + apply offset_of_index_disj; auto. apply index_diff_sym; auto. +Qed. + +Lemma store_other_index_contains: + forall chunk m blk ofs v' m' sp idx v, + Mem.store chunk m blk ofs v' = Some m' -> + blk <> sp \/ + (fe.(fe_stack_data) <= ofs /\ ofs + size_chunk chunk <= fe.(fe_stack_data) + f.(Linear.fn_stacksize)) -> + index_contains m sp idx v -> + index_contains m' sp idx v. +Proof. + intros. inv H1. constructor; auto. rewrite <- H3. + eapply Mem.load_store_other; eauto. + destruct H0. auto. right. + exploit offset_of_index_disj_stack_data_2; eauto. intros. + rewrite size_type_chunk. + omega. +Qed. + +Definition frame_perm_freeable (m: mem) (sp: block): Prop := + forall ofs, + 0 <= ofs < fe.(fe_size) -> + ofs < fe.(fe_stack_data) \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs -> + Mem.perm m sp ofs Freeable. + +Lemma offset_of_index_perm: + forall m sp idx, + index_valid idx -> + frame_perm_freeable m sp -> + Mem.range_perm m sp (offset_of_index fe idx) (offset_of_index fe idx + AST.typesize (type_of_index idx)) Freeable. Proof. intros. - destruct (offset_of_index_valid idx H) as [A B]. - rewrite <- typesize_typesize in B. - rewrite unfold_transf_function; constructor. - auto. unfold fn_framesize. auto. - unfold fn_link_ofs. change (fe_ofs_link fe) with (offset_of_index fe FI_link). - rewrite offset_of_index_no_overflow. - exploit (offset_of_index_disj idx FI_link). - auto. exact I. red. destruct idx; auto || congruence. - intro. rewrite typesize_typesize. assumption. - exact I. - unfold fn_retaddr_ofs. change (fe_ofs_retaddr fe) with (offset_of_index fe FI_retaddr). - rewrite offset_of_index_no_overflow. - exploit (offset_of_index_disj idx FI_retaddr). - auto. exact I. red. destruct idx; auto || congruence. - intro. rewrite typesize_typesize. assumption. - exact I. - apply offset_of_index_aligned. -Qed. - -Lemma get_slot_index: - forall fr idx ty v, - index_valid idx -> idx <> FI_link -> idx <> FI_retaddr -> - ty = type_of_index idx -> - v = index_val idx fr -> - get_slot tf fr ty (Int.signed (Int.repr (offset_of_index fe idx))) v. -Proof. - intros. subst v; subst ty. rewrite offset_of_index_no_overflow; auto. - unfold index_val. apply get_slot_intro; auto. - apply slot_valid_index; auto. -Qed. - -Lemma set_slot_index: - forall fr idx v, - index_valid idx -> idx <> FI_link -> idx <> FI_retaddr -> - set_slot tf fr (type_of_index idx) (Int.signed (Int.repr (offset_of_index fe idx))) - v (set_index_val idx v fr). -Proof. - intros. rewrite offset_of_index_no_overflow; auto. - apply set_slot_intro. - apply slot_valid_index; auto. - unfold set_index_val. auto. -Qed. - -(** ``Good variable'' properties for [index_val] and [set_index_val]. *) - -Lemma get_set_index_val_same: - forall fr idx v, - index_val idx (set_index_val idx v fr) = v. -Proof. - intros. unfold index_val, set_index_val. apply update_same. -Qed. - -Lemma get_set_index_val_other: - forall fr idx idx' v, - index_valid idx -> index_valid idx' -> index_diff idx idx' -> - index_val idx' (set_index_val idx v fr) = index_val idx' fr. -Proof. - intros. unfold index_val, set_index_val. apply update_other. - repeat rewrite typesize_typesize. - exploit (offset_of_index_disj idx idx'); auto. omega. -Qed. - -Lemma get_set_index_val_overlap: - forall ofs1 ty1 ofs2 ty2 v fr, - S (Outgoing ofs1 ty1) <> S (Outgoing ofs2 ty2) -> - Loc.overlap (S (Outgoing ofs1 ty1)) (S (Outgoing ofs2 ty2)) = true -> - index_val (FI_arg ofs2 ty2) (set_index_val (FI_arg ofs1 ty1) v fr) = Vundef. -Proof. - intros. unfold index_val, set_index_val, offset_of_index, type_of_index. - assert (~(ofs1 + typesize ty1 <= ofs2 \/ ofs2 + typesize ty2 <= ofs1)). - destruct (orb_prop _ _ H0). apply Loc.overlap_aux_true_1. auto. - apply Loc.overlap_aux_true_2. auto. - unfold update. - destruct (zeq (fe_ofs_arg + 4 * ofs1 - fn_framesize tf) - (fe_ofs_arg + 4 * ofs2 - fn_framesize tf)). - destruct (typ_eq ty1 ty2). - elim H. decEq. decEq. omega. auto. - auto. - repeat rewrite typesize_typesize. - rewrite zle_false. apply zle_false. omega. omega. + exploit offset_of_index_valid; eauto. intros [A B]. + exploit offset_of_index_disj_stack_data_2; eauto. intros. + red; intros. apply H0. omega. omega. Qed. -(** Accessing stack-based arguments in the caller's frame. *) +Lemma store_index_succeeds: + forall m sp idx v, + index_valid idx -> + frame_perm_freeable m sp -> + exists m', + Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m'. +Proof. + intros. + destruct (Mem.valid_access_store m (chunk_of_type (type_of_index idx)) sp (offset_of_index fe idx) v) as [m' ST]. + constructor. + rewrite size_type_chunk. + apply Mem.range_perm_implies with Freeable; auto with mem. + apply offset_of_index_perm; auto. + replace (align_chunk (chunk_of_type (type_of_index idx))) with 4. + apply offset_of_index_aligned; auto. + destruct (type_of_index idx); auto. + exists m'; auto. +Qed. -Definition get_parent_slot (cs: list stackframe) (ofs: Z) (ty: typ) (v: val) : Prop := - get_slot (parent_function cs) (parent_frame cs) - ty (Int.signed (Int.repr (fe_ofs_arg + 4 * ofs))) v. +Lemma store_stack_succeeds: + forall m sp idx v m', + index_valid idx -> + Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m' -> + store_stack m (Vptr sp Int.zero) (type_of_index idx) (Int.repr (offset_of_index fe idx)) v = Some m'. +Proof. + intros. unfold store_stack, Mem.storev, Val.add. + rewrite Int.add_commut. rewrite Int.add_zero. + rewrite offset_of_index_no_overflow; auto. +Qed. -(** * Agreement between location sets and Mach environments *) +(** A variant of [index_contains], up to a memory injection. *) -(** The following [agree] predicate expresses semantic agreement between: -- on the Linear side, the current location set [ls] and the location - set of the caller [ls0]; -- on the Mach side, a register set [rs], a frame [fr] and a call stack [cs]. -*) +Definition index_contains_inj (j: meminj) (m: mem) (sp: block) (idx: frame_index) (v: val) : Prop := + exists v', index_contains m sp idx v' /\ val_inject j v v'. -Record agree (ls ls0: locset) (rs: regset) (fr: frame) (cs: list stackframe): Prop := - mk_agree { - (** Machine registers have the same values on the Linear and Mach sides. *) - agree_reg: - forall r, ls (R r) = rs r; +Lemma gss_index_contains_inj: + forall j idx m m' sp v v', + Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v' = Some m' -> + index_valid idx -> + Val.has_type v (type_of_index idx) -> + val_inject j v v' -> + index_contains_inj j m' sp idx v. +Proof. + intros. exploit gss_index_contains_base; eauto. intros [v'' [A B]]. + exists v''; split; auto. + inv H2; destruct (type_of_index idx); simpl in *; try contradiction; subst; auto. + econstructor; eauto. +Qed. - (** Machine registers outside the bounds of the current function - have the same values they had at function entry. In other terms, - these registers are never assigned. *) +Lemma gso_index_contains_inj: + forall j idx m m' sp v idx' v', + Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m' -> + index_valid idx -> + index_contains_inj j m sp idx' v' -> + index_diff idx idx' -> + index_contains_inj j m' sp idx' v'. +Proof. + intros. destruct H1 as [v'' [A B]]. exists v''; split; auto. + eapply gso_index_contains; eauto. +Qed. + +Lemma store_other_index_contains_inj: + forall j chunk m b ofs v' m' sp idx v, + Mem.store chunk m b ofs v' = Some m' -> + b <> sp \/ + (fe.(fe_stack_data) <= ofs /\ ofs + size_chunk chunk <= fe.(fe_stack_data) + f.(Linear.fn_stacksize)) -> + index_contains_inj j m sp idx v -> + index_contains_inj j m' sp idx v. +Proof. + intros. destruct H1 as [v'' [A B]]. exists v''; split; auto. + eapply store_other_index_contains; eauto. +Qed. + +Lemma index_contains_inj_incr: + forall j m sp idx v j', + index_contains_inj j m sp idx v -> + inject_incr j j' -> + index_contains_inj j' m sp idx v. +Proof. + intros. destruct H as [v'' [A B]]. exists v''; split; auto. eauto. +Qed. + +Lemma index_contains_inj_undef: + forall j m sp idx, + index_valid idx -> + frame_perm_freeable m sp -> + index_contains_inj j m sp idx Vundef. +Proof. + intros. + exploit (Mem.valid_access_load m (chunk_of_type (type_of_index idx)) sp (offset_of_index fe idx)). + constructor. + rewrite size_type_chunk. + apply Mem.range_perm_implies with Freeable; auto with mem. + apply offset_of_index_perm; auto. + replace (align_chunk (chunk_of_type (type_of_index idx))) with 4. + apply offset_of_index_aligned. destruct (type_of_index idx); auto. + intros [v C]. + exists v; split; auto. constructor; auto. +Qed. + +Hint Resolve store_other_index_contains_inj index_contains_inj_incr: stacking. + +(** * Agreement between location sets and Mach states *) + +(** Agreement with Mach register states *) + +Definition agree_regs (j: meminj) (ls: locset) (rs: regset) : Prop := + forall r, val_inject j (ls (R r)) (rs r). + +(** Agreement over data stored in memory *) + +Record agree_frame (j: meminj) (ls ls0: locset) + (m: mem) (sp: block) + (m': mem) (sp': block) + (parent retaddr: val) : Prop := + mk_agree_frame { + + (** Unused registers have the same value as in the caller *) agree_unused_reg: - forall r, ~(mreg_within_bounds b r) -> rs r = ls0 (R r); + forall r, ~(mreg_within_bounds b r) -> ls (R r) = ls0 (R r); (** Local and outgoing stack slots (on the Linear side) have the same values as the one loaded from the current Mach frame @@ -425,244 +564,440 @@ Record agree (ls ls0: locset) (rs: regset) (fr: frame) (cs: list stackframe): Pr agree_locals: forall ofs ty, slot_within_bounds f b (Local ofs ty) -> - ls (S (Local ofs ty)) = index_val (FI_local ofs ty) fr; + index_contains_inj j m' sp' (FI_local ofs ty) (ls (S (Local ofs ty))); agree_outgoing: forall ofs ty, slot_within_bounds f b (Outgoing ofs ty) -> - ls (S (Outgoing ofs ty)) = index_val (FI_arg ofs ty) fr; + index_contains_inj j m' sp' (FI_arg ofs ty) (ls (S (Outgoing ofs ty))); - (** Incoming stack slots (on the Linear side) have - the same values as the one loaded from the parent Mach frame - at the corresponding offsets. *) + (** Incoming stack slots have the same value as the + corresponding Outgoing stack slots in the caller *) agree_incoming: - forall ofs ty, - In (S (Incoming ofs ty)) (loc_parameters f.(Linear.fn_sig)) -> - get_parent_slot cs ofs ty (ls (S (Incoming ofs ty))); + forall ofs ty, + In (S (Incoming ofs ty)) (loc_parameters f.(Linear.fn_sig)) -> + ls (S (Incoming ofs ty)) = ls0 (S (Outgoing ofs ty)); + + (** The back link and return address slots of the Mach frame contain + the [parent] and [retaddr] values, respectively. *) + agree_link: + index_contains m' sp' FI_link parent; + agree_retaddr: + index_contains m' sp' FI_retaddr retaddr; (** The areas of the frame reserved for saving used callee-save registers always contain the values that those registers had - on function entry. *) + in the caller. *) agree_saved_int: forall r, In r int_callee_save_regs -> index_int_callee_save r < b.(bound_int_callee_save) -> - index_val (FI_saved_int (index_int_callee_save r)) fr = ls0 (R r); + index_contains_inj j m' sp' (FI_saved_int (index_int_callee_save r)) (ls0 (R r)); agree_saved_float: forall r, In r float_callee_save_regs -> index_float_callee_save r < b.(bound_float_callee_save) -> - index_val (FI_saved_float (index_float_callee_save r)) fr = ls0 (R r) + index_contains_inj j m' sp' (FI_saved_float (index_float_callee_save r)) (ls0 (R r)); + + (** Mapping between the Linear stack pointer and the Mach stack pointer *) + agree_inj: + j sp = Some(sp', fe.(fe_stack_data)); + agree_inj_unique: + forall b delta, j b = Some(sp', delta) -> b = sp /\ delta = fe.(fe_stack_data); + + (** The Linear and Mach stack pointers are valid *) + agree_valid_linear: + Mem.valid_block m sp; + agree_valid_mach: + Mem.valid_block m' sp'; + + (** Bounds of the Linear stack data block *) + agree_bounds: + Mem.bounds m sp = (0, f.(Linear.fn_stacksize)); + + (** Permissions on the frame part of the Mach stack block *) + agree_perm: + frame_perm_freeable m' sp'; + + (** Current locset is well-typed *) + agree_wt_ls: + wt_locset ls }. -Hint Resolve agree_reg agree_unused_reg - agree_locals agree_outgoing agree_incoming - agree_saved_int agree_saved_float: stacking. +Hint Resolve agree_unused_reg agree_locals agree_outgoing agree_incoming + agree_link agree_retaddr agree_saved_int agree_saved_float + agree_valid_linear agree_valid_mach agree_perm + agree_wt_ls: stacking. -(** Values of registers and register lists. *) +(** Auxiliary predicate used at call points *) -Lemma agree_eval_reg: - forall ls ls0 rs fr cs r, - agree ls ls0 rs fr cs -> rs r = ls (R r). +Definition agree_callee_save (ls ls0: locset) : Prop := + forall l, + match l with + | R r => In r int_callee_save_regs \/ In r float_callee_save_regs + | S s => True + end -> + ls l = ls0 l. + +(** ** Properties of [agree_regs]. *) + +(** Values of registers *) + +Lemma agree_reg: + forall j ls rs r, + agree_regs j ls rs -> val_inject j (ls (R r)) (rs r). Proof. - intros. symmetry. eauto with stacking. + intros. auto. Qed. -Lemma agree_eval_regs: - forall ls ls0 rs fr cs rl, - agree ls ls0 rs cs fr -> rs##rl = reglist ls rl. +Lemma agree_reglist: + forall j ls rs rl, + agree_regs j ls rs -> val_list_inject j (reglist ls rl) (rs##rl). Proof. induction rl; simpl; intros. - auto. f_equal. eapply agree_eval_reg; eauto. auto. + auto. constructor. eauto with stacking. auto. Qed. -Hint Resolve agree_eval_reg agree_eval_regs: stacking. +Hint Resolve agree_reg agree_reglist: stacking. -(** Preservation of agreement under various assignments: - of machine registers, of local slots, of outgoing slots. *) +(** Preservation under assignments of machine registers. *) -Lemma agree_set_reg: - forall ls ls0 rs fr cs r v, - agree ls ls0 rs fr cs -> - mreg_within_bounds b r -> - agree (Locmap.set (R r) v ls) ls0 (Regmap.set r v rs) fr cs. -Proof. - intros. constructor; eauto with stacking. - intros. case (mreg_eq r r0); intro. - subst r0. rewrite Locmap.gss; rewrite Regmap.gss; auto. - rewrite Locmap.gso. rewrite Regmap.gso. eauto with stacking. - auto. red. auto. - intros. rewrite Regmap.gso. eauto with stacking. - red; intro; subst r0. contradiction. - intros. rewrite Locmap.gso. eauto with stacking. red. auto. - intros. rewrite Locmap.gso. eauto with stacking. red. auto. - intros. rewrite Locmap.gso. eauto with stacking. red. auto. -Qed. - -Lemma agree_set_local: - forall ls ls0 rs fr cs v ofs ty, - agree ls ls0 rs fr cs -> - slot_within_bounds f b (Local ofs ty) -> - exists fr', - set_slot tf fr ty (Int.signed (Int.repr (offset_of_index fe (FI_local ofs ty)))) v fr' /\ - agree (Locmap.set (S (Local ofs ty)) v ls) ls0 rs fr' cs. +Lemma agree_regs_set_reg: + forall j ls rs r v v', + agree_regs j ls rs -> + val_inject j v v' -> + agree_regs j (Locmap.set (R r) v ls) (Regmap.set r v' rs). Proof. - intros. - exists (set_index_val (FI_local ofs ty) v fr); split. - set (idx := FI_local ofs ty). - change ty with (type_of_index idx). - apply set_slot_index; unfold idx. auto with stacking. congruence. congruence. - constructor; eauto with stacking. - (* agree_reg *) - intros. rewrite Locmap.gso. eauto with stacking. red; auto. - (* agree_local *) - intros. case (slot_eq (Local ofs ty) (Local ofs0 ty0)); intro. - rewrite <- e. rewrite Locmap.gss. - replace (FI_local ofs0 ty0) with (FI_local ofs ty). - symmetry. apply get_set_index_val_same. congruence. - assert (ofs <> ofs0 \/ ty <> ty0). - case (zeq ofs ofs0); intro. compare ty ty0; intro. - congruence. tauto. tauto. - rewrite Locmap.gso. rewrite get_set_index_val_other; eauto with stacking. - red. auto. - (* agree_outgoing *) - intros. rewrite Locmap.gso. rewrite get_set_index_val_other; eauto with stacking. - red; auto. red; auto. - (* agree_incoming *) - intros. rewrite Locmap.gso. eauto with stacking. red. auto. - (* agree_saved_int *) - intros. rewrite get_set_index_val_other; eauto with stacking. - red; auto. - (* agree_saved_float *) - intros. rewrite get_set_index_val_other; eauto with stacking. - red; auto. + intros; red; intros. + unfold Regmap.set. destruct (RegEq.eq r0 r). subst r0. + rewrite Locmap.gss; auto. + rewrite Locmap.gso; auto. red. auto. Qed. -Lemma agree_set_outgoing: - forall ls ls0 rs fr cs v ofs ty, - agree ls ls0 rs fr cs -> - slot_within_bounds f b (Outgoing ofs ty) -> - exists fr', - set_slot tf fr ty (Int.signed (Int.repr (offset_of_index fe (FI_arg ofs ty)))) v fr' /\ - agree (Locmap.set (S (Outgoing ofs ty)) v ls) ls0 rs fr' cs. +Lemma agree_regs_undef_temps: + forall j ls rs, + agree_regs j ls rs -> + agree_regs j (LTL.undef_temps ls) (undef_temps rs). +Proof. + unfold LTL.undef_temps, undef_temps. + change temporaries with (List.map R (int_temporaries ++ float_temporaries)). + generalize (int_temporaries ++ float_temporaries). + induction l; simpl; intros. + auto. + apply IHl. apply agree_regs_set_reg; auto. +Qed. + +Lemma agree_regs_undef_op: + forall op j ls rs, + agree_regs j ls rs -> + agree_regs j (Linear.undef_op op ls) (undef_op (transl_op fe op) rs). Proof. intros. - exists (set_index_val (FI_arg ofs ty) v fr); split. - set (idx := FI_arg ofs ty). - change ty with (type_of_index idx). - apply set_slot_index; unfold idx. auto with stacking. congruence. congruence. - constructor; eauto with stacking. - (* agree_reg *) - intros. rewrite Locmap.gso. eauto with stacking. red; auto. - (* agree_local *) - intros. rewrite Locmap.gso. rewrite get_set_index_val_other; eauto with stacking. - red; auto. red; auto. - (* agree_outgoing *) - intros. unfold Locmap.set. - case (Loc.eq (S (Outgoing ofs ty)) (S (Outgoing ofs0 ty0))); intro. - (* same location *) - replace ofs0 with ofs by congruence. replace ty0 with ty by congruence. - symmetry. apply get_set_index_val_same. - (* overlapping locations *) - caseEq (Loc.overlap (S (Outgoing ofs ty)) (S (Outgoing ofs0 ty0))); intros. - symmetry. apply get_set_index_val_overlap; auto. - (* disjoint locations *) - rewrite get_set_index_val_other; eauto with stacking. - red. eapply Loc.overlap_aux_false_1; eauto. - (* agree_incoming *) - intros. rewrite Locmap.gso. eauto with stacking. red. auto. - (* saved ints *) - intros. rewrite get_set_index_val_other; eauto with stacking. red; auto. - (* saved floats *) - intros. rewrite get_set_index_val_other; eauto with stacking. red; auto. + generalize (agree_regs_undef_temps _ _ _ H). + destruct op; simpl; auto. Qed. -Lemma agree_undef_regs: - forall rl ls ls0 rs fr cs, - agree ls ls0 rs fr cs -> - (forall r, In r rl -> In (R r) temporaries) -> - agree (Locmap.undef (List.map R rl) ls) ls0 (undef_regs rl rs) fr cs. +(** Preservation under assignment of stack slot *) + +Lemma agree_regs_set_slot: + forall j ls rs ss v, + agree_regs j ls rs -> + agree_regs j (Locmap.set (S ss) v ls) rs. Proof. - induction rl; intros; simpl. + intros; red; intros. rewrite Locmap.gso; auto. red. destruct ss; auto. +Qed. + +(** Preservation by increasing memory injections *) + +Lemma agree_regs_inject_incr: + forall j ls rs j', + agree_regs j ls rs -> inject_incr j j' -> agree_regs j' ls rs. +Proof. + intros; red; intros; eauto with stacking. +Qed. + +(** Preservation at function entry. *) + +Lemma agree_regs_call_regs: + forall j ls rs, + agree_regs j ls rs -> + agree_regs j (call_regs ls) (undef_temps rs). +Proof. + intros. + assert (agree_regs j (LTL.undef_temps ls) (undef_temps rs)). + apply agree_regs_undef_temps; auto. + unfold call_regs; intros; red; intros. + destruct (in_dec Loc.eq (R r) temporaries). auto. - eapply IHrl; eauto. - apply agree_set_reg; auto with coqlib. - assert (In (R a) temporaries) by auto with coqlib. - red. destruct (mreg_type a). - destruct (zlt (index_int_callee_save a) 0). - generalize (bound_int_callee_save_pos b). omega. - elim (int_callee_save_not_destroyed a). auto. apply index_int_callee_save_pos2; auto. - destruct (zlt (index_float_callee_save a) 0). - generalize (bound_float_callee_save_pos b). omega. - elim (float_callee_save_not_destroyed a). auto. apply index_float_callee_save_pos2; auto. - intros. apply H0. auto with coqlib. -Qed. - -Lemma agree_undef_temps: - forall ls ls0 rs fr cs, - agree ls ls0 rs fr cs -> - agree (LTL.undef_temps ls) ls0 (Mach.undef_temps rs) fr cs. -Proof. - intros. unfold undef_temps, LTL.undef_temps. + generalize (H0 r). unfold LTL.undef_temps. rewrite Locmap.guo. auto. + apply Loc.reg_notin; auto. +Qed. + +(** ** Properties of [agree_frame] *) + +(** Preservation under assignment of machine register. *) + +Lemma agree_frame_set_reg: + forall j ls ls0 m sp m' sp' parent ra r v, + agree_frame j ls ls0 m sp m' sp' parent ra -> + mreg_within_bounds b r -> + Val.has_type v (Loc.type (R r)) -> + agree_frame j (Locmap.set (R r) v ls) ls0 m sp m' sp' parent ra. +Proof. + intros. inv H; constructor; auto; intros. + rewrite Locmap.gso. auto. red. intuition congruence. + rewrite Locmap.gso; auto. red; auto. + rewrite Locmap.gso; auto. red; auto. + rewrite Locmap.gso; auto. red; auto. + apply wt_setloc; auto. +Qed. + +Remark temporary_within_bounds: + forall r, In (R r) temporaries -> mreg_within_bounds b r. +Proof. + intros; red. destruct (mreg_type r). + destruct (zlt (index_int_callee_save r) 0). + generalize (bound_int_callee_save_pos b). omega. + exploit int_callee_save_not_destroyed. + left. eauto with coqlib. apply index_int_callee_save_pos2; auto. + contradiction. + destruct (zlt (index_float_callee_save r) 0). + generalize (bound_float_callee_save_pos b). omega. + exploit float_callee_save_not_destroyed. + left. eauto with coqlib. apply index_float_callee_save_pos2; auto. + contradiction. +Qed. + +Lemma agree_frame_undef_temps: + forall j ls ls0 m sp m' sp' parent ra, + agree_frame j ls ls0 m sp m' sp' parent ra -> + agree_frame j (LTL.undef_temps ls) ls0 m sp m' sp' parent ra. +Proof. + intros until ra. + assert (forall regs ls, + incl (List.map R regs) temporaries -> + agree_frame j ls ls0 m sp m' sp' parent ra -> + agree_frame j (Locmap.undef (List.map R regs) ls) ls0 m sp m' sp' parent ra). + induction regs; simpl; intros. + auto. + apply IHregs; eauto with coqlib. + apply agree_frame_set_reg; auto. + apply temporary_within_bounds; eauto with coqlib. + red; auto. + intros. unfold LTL.undef_temps. change temporaries with (List.map R (int_temporaries ++ float_temporaries)). - apply agree_undef_regs; auto. + apply H; auto. apply incl_refl. +Qed. + +Lemma agree_frame_undef_op: + forall j ls ls0 m sp m' sp' parent ra op, + agree_frame j ls ls0 m sp m' sp' parent ra -> + agree_frame j (Linear.undef_op op ls) ls0 m sp m' sp' parent ra. +Proof. intros. - change temporaries with (List.map R (int_temporaries ++ float_temporaries)). - apply List.in_map. auto. + exploit agree_frame_undef_temps; eauto. destruct op; simpl; auto. Qed. -Lemma agree_undef_op: - forall op env ls ls0 rs fr cs, - agree ls ls0 rs fr cs -> - agree (Linear.undef_op op ls) ls0 (Mach.undef_op (transl_op env op) rs) fr cs. +(** Preservation by assignment to local slot *) + +Lemma agree_frame_set_local: + forall j ls ls0 m sp m' sp' parent retaddr ofs ty v v' m'', + agree_frame j ls ls0 m sp m' sp' parent retaddr -> + slot_within_bounds f b (Local ofs ty) -> + val_inject j v v' -> + Val.has_type v ty -> + Mem.store (chunk_of_type ty) m' sp' (offset_of_index fe (FI_local ofs ty)) v' = Some m'' -> + agree_frame j (Locmap.set (S (Local ofs ty)) v ls) ls0 m sp m'' sp' parent retaddr. Proof. - intros. exploit agree_undef_temps; eauto. intro. - destruct op; simpl; auto. + intros. inv H. + change (chunk_of_type ty) with (chunk_of_type (type_of_index (FI_local ofs ty))) in H3. + constructor; auto; intros. +(* unused *) + rewrite Locmap.gso; auto. red; auto. +(* local *) + unfold Locmap.set. simpl. destruct (Loc.eq (S (Local ofs ty)) (S (Local ofs0 ty0))). + inv e. eapply gss_index_contains_inj; eauto. + eapply gso_index_contains_inj. eauto. simpl; auto. eauto with stacking. + simpl. destruct (zeq ofs ofs0); auto. destruct (typ_eq ty ty0); auto. congruence. +(* outgoing *) + rewrite Locmap.gso. eapply gso_index_contains_inj; eauto with stacking. + simpl; auto. red; auto. +(* incoming *) + rewrite Locmap.gso; auto. red; auto. +(* parent *) + eapply gso_index_contains; eauto. red; auto. +(* retaddr *) + eapply gso_index_contains; eauto. red; auto. +(* int callee save *) + eapply gso_index_contains_inj; eauto. simpl; auto. +(* float callee save *) + eapply gso_index_contains_inj; eauto. simpl; auto. +(* valid *) + eauto with mem. +(* perm *) + red; intros. eapply Mem.perm_store_1; eauto. +(* wt *) + apply wt_setloc; auto. +Qed. + +(** Preservation by assignment to outgoing slot *) + +Lemma agree_frame_set_outgoing: + forall j ls ls0 m sp m' sp' parent retaddr ofs ty v v' m'', + agree_frame j ls ls0 m sp m' sp' parent retaddr -> + slot_within_bounds f b (Outgoing ofs ty) -> + val_inject j v v' -> + Val.has_type v ty -> + Mem.store (chunk_of_type ty) m' sp' (offset_of_index fe (FI_arg ofs ty)) v' = Some m'' -> + agree_frame j (Locmap.set (S (Outgoing ofs ty)) v ls) ls0 m sp m'' sp' parent retaddr. +Proof. + intros. inv H. + change (chunk_of_type ty) with (chunk_of_type (type_of_index (FI_arg ofs ty))) in H3. + constructor; auto; intros. +(* unused *) + rewrite Locmap.gso; auto. red; auto. +(* local *) + rewrite Locmap.gso. eapply gso_index_contains_inj; eauto. simpl; auto. red; auto. +(* outgoing *) + unfold Locmap.set. simpl. destruct (Loc.eq (S (Outgoing ofs ty)) (S (Outgoing ofs0 ty0))). + inv e. eapply gss_index_contains_inj; eauto. + case_eq (Loc.overlap_aux ty ofs ofs0 || Loc.overlap_aux ty0 ofs0 ofs); intros. + apply index_contains_inj_undef. auto. + red; intros. eapply Mem.perm_store_1; eauto. + eapply gso_index_contains_inj; eauto. + red. eapply Loc.overlap_aux_false_1; eauto. +(* incoming *) + rewrite Locmap.gso; auto. red; auto. +(* parent *) + eapply gso_index_contains; eauto with stacking. red; auto. +(* retaddr *) + eapply gso_index_contains; eauto with stacking. red; auto. +(* int callee save *) + eapply gso_index_contains_inj; eauto with stacking. simpl; auto. +(* float callee save *) + eapply gso_index_contains_inj; eauto with stacking. simpl; auto. +(* valid *) + eauto with mem stacking. +(* perm *) + red; intros. eapply Mem.perm_store_1; eauto. +(* wt *) + apply wt_setloc; auto. Qed. -Lemma agree_undef_getparam: - forall ls ls0 rs fr cs, - agree ls ls0 rs fr cs -> - agree (Locmap.set (R IT1) Vundef ls) ls0 (rs#IT1 <- Vundef) fr cs. +(** General invariance property with respect to memory changes. *) + +Lemma agree_frame_invariant: + forall j ls ls0 m sp m' sp' parent retaddr m1 m1', + agree_frame j ls ls0 m sp m' sp' parent retaddr -> + (Mem.valid_block m sp -> Mem.valid_block m1 sp) -> + (Mem.bounds m1 sp = Mem.bounds m sp) -> + (Mem.valid_block m' sp' -> Mem.valid_block m1' sp') -> + (forall chunk ofs v, + ofs + size_chunk chunk <= fe.(fe_stack_data) \/ + fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs -> + Mem.load chunk m' sp' ofs = Some v -> + Mem.load chunk m1' sp' ofs = Some v) -> + (forall ofs p, + ofs < fe.(fe_stack_data) \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs -> + Mem.perm m' sp' ofs p -> Mem.perm m1' sp' ofs p) -> + agree_frame j ls ls0 m1 sp m1' sp' parent retaddr. Proof. - intros. exploit (agree_undef_regs (IT1 :: nil)); eauto. - simpl; intros. intuition congruence. + intros. + assert (IC: forall idx v, + index_contains m' sp' idx v -> index_contains m1' sp' idx v). + intros. inv H5. + exploit offset_of_index_disj_stack_data_2; eauto. intros. + constructor; eauto. apply H3; auto. rewrite size_type_chunk; auto. + assert (ICI: forall idx v, + index_contains_inj j m' sp' idx v -> index_contains_inj j m1' sp' idx v). + intros. destruct H5 as [v' [A B]]. exists v'; split; auto. + inv H; constructor; auto; intros. + rewrite H1; auto. + red; intros. apply H4; auto. Qed. -Lemma agree_return_regs: - forall ls ls0 rs fr cs rs', - agree ls ls0 rs fr cs -> - (forall r, - ~In r int_callee_save_regs -> ~In r float_callee_save_regs -> - rs' r = rs r) -> - (forall r, - In r int_callee_save_regs \/ In r float_callee_save_regs -> - rs' r = ls0 (R r)) -> - (forall r, return_regs ls0 ls (R r) = rs' r). +(** A variant of the latter, for use with external calls *) + +Lemma agree_frame_extcall_invariant: + forall j ls ls0 m sp m' sp' parent retaddr m1 m1', + agree_frame j ls ls0 m sp m' sp' parent retaddr -> + (Mem.valid_block m sp -> Mem.valid_block m1 sp) -> + (Mem.bounds m1 sp = Mem.bounds m sp) -> + (Mem.valid_block m' sp' -> Mem.valid_block m1' sp') -> + mem_unchanged_on (loc_out_of_reach j m) m' m1' -> + agree_frame j ls ls0 m1 sp m1' sp' parent retaddr. Proof. - intros; unfold return_regs. - case (In_dec Loc.eq (R r) temporaries); intro. - rewrite H0. eapply agree_reg; eauto. - apply int_callee_save_not_destroyed; auto. - apply float_callee_save_not_destroyed; auto. - case (In_dec Loc.eq (R r) destroyed_at_call); intro. - rewrite H0. eapply agree_reg; eauto. - apply int_callee_save_not_destroyed; auto. - apply float_callee_save_not_destroyed; auto. - symmetry; apply H1. - generalize (register_classification r); tauto. + intros. + assert (REACH: forall ofs, + ofs < fe.(fe_stack_data) \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs -> + loc_out_of_reach j m sp' ofs). + intros; red; intros. exploit agree_inj_unique; eauto. intros [EQ1 EQ2]; subst. + rewrite (agree_bounds _ _ _ _ _ _ _ _ _ H). unfold fst, snd. omega. + eapply agree_frame_invariant; eauto. + intros. apply H3. intros. apply REACH. omega. auto. + intros. apply H3; auto. Qed. -(** Agreement over callee-save registers and stack locations *) +(** Preservation by parallel stores in the Linear and Mach codes *) -Definition agree_callee_save (ls1 ls2: locset) : Prop := - forall l, - match l with - | R r => In r int_callee_save_regs \/ In r float_callee_save_regs - | S s => True - end -> - ls2 l = ls1 l. +Lemma agree_frame_parallel_stores: + forall j ls ls0 m sp m' sp' parent retaddr chunk addr addr' v v' m1 m1', + agree_frame j ls ls0 m sp m' sp' parent retaddr -> + Mem.inject j m m' -> + val_inject j addr addr' -> + Mem.storev chunk m addr v = Some m1 -> + Mem.storev chunk m' addr' v' = Some m1' -> + agree_frame j ls ls0 m1 sp m1' sp' parent retaddr. +Proof. +Opaque Int.add. + intros until m1'. intros AG MINJ VINJ STORE1 STORE2. + inv VINJ; simpl in *; try discriminate. + eapply agree_frame_invariant; eauto. + eauto with mem. + eapply Mem.bounds_store; eauto. + eauto with mem. + intros. rewrite <- H1. eapply Mem.load_store_other; eauto. + destruct (zeq sp' b2); auto. + subst b2. right. + exploit agree_inj_unique; eauto. intros [P Q]. subst b1 delta. + exploit Mem.store_valid_access_3. eexact STORE1. intros [A B]. + exploit Mem.range_perm_in_bounds. eexact A. generalize (size_chunk_pos chunk); omega. + rewrite (agree_bounds _ _ _ _ _ _ _ _ _ AG). unfold fst,snd. intros [C D]. + rewrite shifted_stack_offset_no_overflow. omega. + generalize (size_chunk_pos chunk); omega. + intros; eauto with mem. +Qed. + +(** Preservation by increasing memory injections (allocations and external calls) *) -Remark mreg_not_within_bounds: +Lemma agree_frame_inject_incr: + forall j ls ls0 m sp m' sp' parent retaddr m1 m1' j', + agree_frame j ls ls0 m sp m' sp' parent retaddr -> + inject_incr j j' -> inject_separated j j' m1 m1' -> + Mem.valid_block m1' sp' -> + agree_frame j' ls ls0 m sp m' sp' parent retaddr. +Proof. + intros. inv H. constructor; auto; intros; eauto with stacking. + case_eq (j b0). + intros [b' delta'] EQ. rewrite (H0 _ _ _ EQ) in H. inv H. auto. + intros EQ. exploit H1. eauto. eauto. intros [A B]. contradiction. +Qed. + +Remark inject_alloc_separated: + forall j m1 m2 j' b1 b2 delta, + inject_incr j j' -> + j' b1 = Some(b2, delta) -> + (forall b, b <> b1 -> j' b = j b) -> + ~Mem.valid_block m1 b1 -> ~Mem.valid_block m2 b2 -> + inject_separated j j' m1 m2. +Proof. + intros. red. intros. + destruct (eq_block b0 b1). subst b0. rewrite H0 in H5; inv H5. tauto. + rewrite H1 in H5. congruence. auto. +Qed. + +(** Preservation at return points (when [ls] is changed but not [ls0]). *) + +Remark mreg_not_within_bounds_callee_save: forall r, ~mreg_within_bounds b r -> In r int_callee_save_regs \/ In r float_callee_save_regs. Proof. @@ -674,19 +1009,38 @@ Proof. generalize (bound_float_callee_save_pos b). omega. Qed. -Lemma agree_callee_save_agree: - forall ls ls1 ls2 rs fr cs, - agree ls ls1 rs fr cs -> - agree_callee_save ls1 ls2 -> - agree ls ls2 rs fr cs. +Lemma agree_frame_return: + forall j ls ls0 m sp m' sp' parent retaddr ls', + agree_frame j ls ls0 m sp m' sp' parent retaddr -> + agree_callee_save ls' ls -> + wt_locset ls' -> + agree_frame j ls' ls0 m sp m' sp' parent retaddr. Proof. - intros. inv H. constructor; auto. - intros. rewrite agree_unused_reg0; auto. - symmetry. apply H0. apply mreg_not_within_bounds; auto. - intros. rewrite (H0 (R r)); auto. - intros. rewrite (H0 (R r)); auto. + intros. red in H0. inv H; constructor; auto; intros. + rewrite H0; auto. apply mreg_not_within_bounds_callee_save; auto. + rewrite H0; auto. + rewrite H0; auto. + rewrite H0; auto. Qed. +(** Preservation at tailcalls (when [ls0] is changed but not [ls]). *) + +Lemma agree_frame_tailcall: + forall j ls ls0 m sp m' sp' parent retaddr ls0', + agree_frame j ls ls0 m sp m' sp' parent retaddr -> + agree_callee_save ls0 ls0' -> + agree_frame j ls ls0' m sp m' sp' parent retaddr. +Proof. + intros. red in H0. inv H; constructor; auto; intros. + rewrite <- H0; auto. apply mreg_not_within_bounds_callee_save; auto. + rewrite <- H0; auto. + rewrite <- H0; auto. + rewrite <- H0; auto. +Qed. + + +(** Properties of [agree_callee_save]. *) + Lemma agree_callee_save_return_regs: forall ls1 ls2, agree_callee_save (return_regs ls1 ls2) ls1. @@ -705,33 +1059,11 @@ Lemma agree_callee_save_set_result: agree_callee_save ls1 ls2 -> agree_callee_save (Locmap.set (R (loc_result sg)) v ls1) ls2. Proof. - intros; red; intros. rewrite H; auto. - symmetry; apply Locmap.gso. destruct l; simpl; auto. + intros; red; intros. rewrite <- H; auto. + apply Locmap.gso. destruct l; simpl; auto. red; intro. subst m. elim (loc_result_not_callee_save _ H0). Qed. -(** A variant of [agree] used for return frames. *) - -Definition agree_frame (ls ls0: locset) (fr: frame) (cs: list stackframe): Prop := - exists rs, agree ls ls0 rs fr cs. - -Lemma agree_frame_agree: - forall ls1 ls2 rs fr cs ls0, - agree_frame ls1 ls0 fr cs -> - agree_callee_save ls2 ls1 -> - (forall r, rs r = ls2 (R r)) -> - agree ls2 ls0 rs fr cs. -Proof. - intros. destruct H as [rs' AG]. inv AG. - constructor; auto. - intros. rewrite <- agree_unused_reg0; auto. - rewrite <- agree_reg0. rewrite H1. symmetry; apply H0. - apply mreg_not_within_bounds; auto. - intros. rewrite <- H0; auto. - intros. rewrite <- H0; auto. - intros. rewrite <- H0; auto. -Qed. - (** * Correctness of saving and restoring of callee-save registers *) (** The following lemmas show the correctness of the register saving @@ -745,17 +1077,35 @@ Variable bound: frame_env -> Z. Variable number: mreg -> Z. Variable mkindex: Z -> frame_index. Variable ty: typ. -Variable sp: val. +Variable j: meminj. +Variable cs: list stackframe. +Variable fb: block. +Variable sp: block. Variable csregs: list mreg. +Variable ls: locset. +Variable rs: regset. + +Inductive stores_in_frame: mem -> mem -> Prop := + | stores_in_frame_refl: forall m, + stores_in_frame m m + | stores_in_frame_step: forall m1 chunk ofs v m2 m3, + ofs + size_chunk chunk <= fe.(fe_stack_data) + \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs -> + Mem.store chunk m1 sp ofs v = Some m2 -> + stores_in_frame m2 m3 -> + stores_in_frame m1 m3. + +Remark stores_in_frame_trans: + forall m1 m2, stores_in_frame m1 m2 -> + forall m3, stores_in_frame m2 m3 -> stores_in_frame m1 m3. +Proof. + induction 1; intros. auto. econstructor; eauto. +Qed. Hypothesis number_inj: forall r1 r2, In r1 csregs -> In r2 csregs -> r1 <> r2 -> number r1 <> number r2. Hypothesis mkindex_valid: forall r, In r csregs -> number r < bound fe -> index_valid (mkindex (number r)). -Hypothesis mkindex_not_link: - forall z, mkindex z <> FI_link. -Hypothesis mkindex_not_retaddr: - forall z, mkindex z <> FI_retaddr. Hypothesis mkindex_typ: forall z, type_of_index (mkindex z) = ty. Hypothesis mkindex_inj: @@ -763,170 +1113,350 @@ Hypothesis mkindex_inj: Hypothesis mkindex_diff: forall r idx, idx <> mkindex (number r) -> index_diff (mkindex (number r)) idx. +Hypothesis csregs_typ: + forall r, In r csregs -> mreg_type r = ty. + +Hypothesis agree: agree_regs j ls rs. +Hypothesis wt_ls: wt_locset ls. Lemma save_callee_save_regs_correct: - forall l k rs fr m, + forall l k m, incl l csregs -> list_norepet l -> - exists fr', + frame_perm_freeable m sp -> + exists m', star step tge - (State stack tf sp - (save_callee_save_regs bound number mkindex ty fe l k) rs fr m) - E0 (State stack tf sp k rs fr' m) + (State cs fb (Vptr sp Int.zero) + (save_callee_save_regs bound number mkindex ty fe l k) rs m) + E0 (State cs fb (Vptr sp Int.zero) k rs m') /\ (forall r, In r l -> number r < bound fe -> - index_val (mkindex (number r)) fr' = rs r) - /\ (forall idx, + index_contains_inj j m' sp (mkindex (number r)) (ls (R r))) + /\ (forall idx v, index_valid idx -> (forall r, In r l -> number r < bound fe -> idx <> mkindex (number r)) -> - index_val idx fr' = index_val idx fr). + index_contains m sp idx v -> + index_contains m' sp idx v) + /\ stores_in_frame m m' + /\ frame_perm_freeable m' sp. Proof. induction l; intros; simpl save_callee_save_regs. (* base case *) - exists fr. split. apply star_refl. - split. intros. elim H1. + exists m. split. apply star_refl. + split. intros. elim H2. + split. auto. + split. constructor. auto. (* inductive case *) - set (k1 := save_callee_save_regs bound number mkindex ty fe l k). assert (R1: incl l csregs). eauto with coqlib. assert (R2: list_norepet l). inversion H0; auto. unfold save_callee_save_reg. destruct (zlt (number a) (bound fe)). (* a store takes place *) - set (fr1 := set_index_val (mkindex (number a)) (rs a) fr). - exploit (IHl k rs fr1 m); auto. - fold k1. intros [fr' [A [B C]]]. - exists fr'. - split. eapply star_left. - apply exec_Msetstack. instantiate (1 := fr1). - unfold fr1. rewrite <- (mkindex_typ (number a)). - eapply set_slot_index; eauto with coqlib. - eexact A. + exploit store_index_succeeds. apply (mkindex_valid a); auto with coqlib. + eauto. instantiate (1 := rs a). intros [m1 ST]. + exploit (IHl k m1). auto with coqlib. auto. + red; eauto with mem. + intros [m' [A [B [C [D E]]]]]. + exists m'. + split. eapply star_left; eauto. constructor. + rewrite <- (mkindex_typ (number a)). + apply store_stack_succeeds; auto with coqlib. traceEq. - split. intros. simpl in H1. destruct H1. subst r. - rewrite C. unfold fr1. apply get_set_index_val_same. - apply mkindex_valid; auto with coqlib. - intros. apply mkindex_inj. apply number_inj; auto with coqlib. - inversion H0. congruence. - apply B; auto. - intros. rewrite C; auto with coqlib. - unfold fr1. apply get_set_index_val_other; auto with coqlib. + split; intros. + simpl in H2. destruct (mreg_eq a r). subst r. + assert (index_contains_inj j m1 sp (mkindex (number a)) (ls (R a))). + eapply gss_index_contains_inj; eauto. + rewrite mkindex_typ. rewrite <- (csregs_typ a). apply wt_ls. auto with coqlib. + destruct H4 as [v' [P Q]]. + exists v'; split; auto. apply C; auto. + intros. apply mkindex_inj. apply number_inj; auto with coqlib. + inv H0. intuition congruence. + apply B; auto with coqlib. + intuition congruence. + split. intros. + apply C; auto with coqlib. + eapply gso_index_contains; eauto with coqlib. + split. econstructor; eauto. + rewrite size_type_chunk. apply offset_of_index_disj_stack_data_2; eauto with coqlib. + auto. (* no store takes place *) - exploit (IHl k rs fr m); auto. intros [fr' [A [B C]]]. - exists fr'. - split. exact A. - split. intros. simpl in H1; destruct H1. subst r. omegaContradiction. - apply B; auto. - intros. apply C; auto with coqlib. + exploit (IHl k m); auto with coqlib. + intros [m' [A [B [C [D E]]]]]. + exists m'; intuition. + simpl in H2. destruct H2. subst r. omegaContradiction. apply B; auto. + apply C; auto with coqlib. + intros. eapply H3; eauto. auto with coqlib. Qed. -End SAVE_CALLEE_SAVE. +End SAVE_CALLEE_SAVE. -Lemma save_callee_save_int_correct: - forall k sp rs fr m, - exists fr', +Lemma save_callee_save_correct: + forall j ls rs sp cs fb k m, + agree_regs j ls rs -> wt_locset ls -> + frame_perm_freeable m sp -> + exists m', star step tge - (State stack tf sp - (save_callee_save_int fe k) rs fr m) - E0 (State stack tf sp k rs fr' m) + (State cs fb (Vptr sp Int.zero) (save_callee_save fe k) rs m) + E0 (State cs fb (Vptr sp Int.zero) k rs m') + /\ (forall r, + In r int_callee_save_regs -> index_int_callee_save r < b.(bound_int_callee_save) -> + index_contains_inj j m' sp (FI_saved_int (index_int_callee_save r)) (ls (R r))) /\ (forall r, - In r int_callee_save_regs -> - index_int_callee_save r < bound_int_callee_save b -> - index_val (FI_saved_int (index_int_callee_save r)) fr' = rs r) - /\ (forall idx, + In r float_callee_save_regs -> index_float_callee_save r < b.(bound_float_callee_save) -> + index_contains_inj j m' sp (FI_saved_float (index_float_callee_save r)) (ls (R r))) + /\ (forall idx v, index_valid idx -> - match idx with FI_saved_int _ => False | _ => True end -> - index_val idx fr' = index_val idx fr). + match idx with FI_saved_int _ => False | FI_saved_float _ => False | _ => True end -> + index_contains m sp idx v -> + index_contains m' sp idx v) + /\ stores_in_frame sp m m' + /\ frame_perm_freeable m' sp. Proof. intros. - exploit (save_callee_save_regs_correct fe_num_int_callee_save index_int_callee_save FI_saved_int - Tint sp int_callee_save_regs). - exact index_int_callee_save_inj. - intros. red. split; auto. generalize (index_int_callee_save_pos r H). omega. - intro; congruence. - intro; congruence. + exploit (save_callee_save_regs_correct + fe_num_int_callee_save + index_int_callee_save + FI_saved_int Tint + j cs fb sp int_callee_save_regs ls rs). + intros. apply index_int_callee_save_inj; auto. + intros. simpl. split. apply Zge_le. apply index_int_callee_save_pos; auto. assumption. auto. intros; congruence. - intros until idx. destruct idx; simpl; auto. congruence. - apply incl_refl. + intros; simpl. destruct idx; auto. congruence. + intros. apply int_callee_save_type. auto. + auto. + auto. + apply incl_refl. apply int_callee_save_norepet. - intros [fr' [A [B C]]]. - exists fr'; intuition. unfold save_callee_save_int; eauto. - apply C. auto. intros; subst idx. auto. + eauto. + intros [m1 [A [B [C [D E]]]]]. + exploit (save_callee_save_regs_correct + fe_num_float_callee_save + index_float_callee_save + FI_saved_float Tfloat + j cs fb sp float_callee_save_regs ls rs). + intros. apply index_float_callee_save_inj; auto. + intros. simpl. split. apply Zge_le. apply index_float_callee_save_pos; auto. assumption. + simpl; auto. + intros; congruence. + intros; simpl. destruct idx; auto. congruence. + intros. apply float_callee_save_type. auto. + auto. + auto. + apply incl_refl. + apply float_callee_save_norepet. + eexact E. + intros [m2 [P [Q [R [S T]]]]]. + exists m2. + split. unfold save_callee_save, save_callee_save_int, save_callee_save_float. + eapply star_trans; eauto. + split; intros. + destruct (B r H2 H3) as [v [X Y]]. exists v; split; auto. apply R. + apply index_saved_int_valid; auto. + intros. congruence. + auto. + split. intros. apply Q; auto. + split. intros. apply R. auto. + intros. destruct idx; contradiction||congruence. + apply C. auto. + intros. destruct idx; contradiction||congruence. + auto. + split. eapply stores_in_frame_trans; eauto. + auto. Qed. -Lemma save_callee_save_float_correct: - forall k sp rs fr m, - exists fr', - star step tge - (State stack tf sp - (save_callee_save_float fe k) rs fr m) - E0 (State stack tf sp k rs fr' m) - /\ (forall r, - In r float_callee_save_regs -> - index_float_callee_save r < bound_float_callee_save b -> - index_val (FI_saved_float (index_float_callee_save r)) fr' = rs r) - /\ (forall idx, - index_valid idx -> - match idx with FI_saved_float _ => False | _ => True end -> - index_val idx fr' = index_val idx fr). +(** Properties of sequences of stores in the frame. *) + +Lemma stores_in_frame_inject: + forall j sp sp' m, + (forall b delta, j b = Some(sp', delta) -> b = sp /\ delta = fe.(fe_stack_data)) -> + Mem.bounds m sp = (0, f.(Linear.fn_stacksize)) -> + forall m1 m2, stores_in_frame sp' m1 m2 -> Mem.inject j m m1 -> Mem.inject j m m2. Proof. - intros. - exploit (save_callee_save_regs_correct fe_num_float_callee_save index_float_callee_save FI_saved_float - Tfloat sp float_callee_save_regs). - exact index_float_callee_save_inj. - intros. red. split; auto. generalize (index_float_callee_save_pos r H). omega. - intro; congruence. - intro; congruence. + induction 3; intros. auto. - intros; congruence. - intros until idx. destruct idx; simpl; auto. congruence. - apply incl_refl. - apply float_callee_save_norepet. eauto. - intros [fr' [A [B C]]]. - exists fr'. split. unfold save_callee_save_float; eauto. - split. auto. - intros. apply C. auto. intros; subst. red; intros; subst idx. contradiction. + apply IHstores_in_frame. + intros. eapply Mem.store_outside_inject; eauto. + intros. exploit H; eauto. intros [A B]; subst. + rewrite H0; unfold fst, snd. omega. Qed. -Lemma save_callee_save_correct: - forall sp k rs m ls cs, - (forall r, rs r = ls (R r)) -> - (forall ofs ty, - In (S (Outgoing ofs ty)) (loc_arguments f.(Linear.fn_sig)) -> - get_parent_slot cs ofs ty (ls (S (Outgoing ofs ty)))) -> - exists fr', - star step tge - (State stack tf sp (save_callee_save fe k) rs empty_frame m) - E0 (State stack tf sp k rs fr' m) - /\ agree (call_regs ls) ls rs fr' cs. -Proof. - intros. unfold save_callee_save. - exploit save_callee_save_int_correct; eauto. - intros [fr1 [A1 [B1 C1]]]. - exploit save_callee_save_float_correct. - intros [fr2 [A2 [B2 C2]]]. - exists fr2. - split. eapply star_trans. eexact A1. eexact A2. traceEq. - constructor; unfold call_regs; auto. - (* agree_local *) - intros. rewrite C2; auto with stacking. - rewrite C1; auto with stacking. - (* agree_outgoing *) - intros. rewrite C2; auto with stacking. - rewrite C1; auto with stacking. - (* agree_incoming *) - intros. apply H0. unfold loc_parameters in H1. - exploit list_in_map_inv; eauto. intros [l [A B]]. - exploit loc_arguments_acceptable; eauto. intro C. - destruct l; simpl in A. discriminate. - simpl in C. destruct s; try contradiction. inv A. auto. - (* agree_saved_int *) - intros. rewrite C2; auto with stacking. - rewrite B1; auto with stacking. - (* agree_saved_float *) - intros. rewrite B2; auto with stacking. +Lemma stores_in_frame_valid: + forall b sp m m', stores_in_frame sp m m' -> Mem.valid_block m b -> Mem.valid_block m' b. +Proof. + induction 1; intros. auto. apply IHstores_in_frame. eauto with mem. +Qed. + +Lemma stores_in_frame_perm: + forall b ofs p sp m m', stores_in_frame sp m m' -> Mem.perm m b ofs p -> Mem.perm m' b ofs p. +Proof. + induction 1; intros. auto. apply IHstores_in_frame. eauto with mem. +Qed. + +Lemma stores_in_frame_contents: + forall chunk b ofs sp, b < sp -> + forall m m', stores_in_frame sp m m' -> + Mem.load chunk m' b ofs = Mem.load chunk m b ofs. +Proof. + induction 2. auto. + rewrite IHstores_in_frame. eapply Mem.load_store_other; eauto. + left; unfold block; omega. +Qed. + +(** As a corollary of the previous lemmas, we obtain the following + correctness theorem for the execution of a function prologue + (allocation of the frame + saving of the link and return address + + saving of the used callee-save registers). *) + +Lemma function_prologue_correct: + forall j ls ls0 rs m1 m1' m2 sp parent ra cs fb k, + agree_regs j ls rs -> + agree_callee_save ls ls0 -> + wt_locset ls -> + Mem.inject j m1 m1' -> + Mem.alloc m1 0 f.(Linear.fn_stacksize) = (m2, sp) -> + Val.has_type parent Tint -> Val.has_type ra Tint -> + exists j', 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' + /\ star step tge + (State cs fb (Vptr sp' Int.zero) (save_callee_save fe k) (undef_temps rs) m4') + E0 (State cs fb (Vptr sp' Int.zero) k (undef_temps rs) m5') + /\ agree_regs j' (call_regs ls) (undef_temps rs) + /\ agree_frame j' (call_regs ls) ls0 m2 sp m5' sp' parent ra + /\ inject_incr j j' + /\ inject_separated j j' m1 m1' + /\ Mem.inject j' m2 m5' + /\ stores_in_frame sp' m2' m5'. +Proof. + intros until k; intros AGREGS AGCS WTREGS INJ1 ALLOC TYPAR TYRA. + rewrite unfold_transf_function. + unfold fn_stacksize, fn_link_ofs, fn_retaddr_ofs. + (* Allocation step *) + caseEq (Mem.alloc m1' 0 (fe_size fe)). intros m2' sp' ALLOC'. + exploit Mem.alloc_left_mapped_inject. + eapply Mem.alloc_right_inject; eauto. + eauto. + instantiate (1 := sp'). eauto with mem. + instantiate (1 := fe_stack_data fe). + generalize stack_data_offset_valid (bound_stack_data_pos b) size_no_overflow; omega. + right. rewrite (Mem.bounds_alloc_same _ _ _ _ _ ALLOC'). unfold fst, snd. + split. omega. apply size_no_overflow. + intros. apply Mem.perm_implies with Freeable; auto with mem. + eapply Mem.perm_alloc_2; eauto. + generalize stack_data_offset_valid bound_stack_data_stacksize; omega. + red. intros. apply Zdivides_trans with 4. + destruct chunk; simpl; auto with align_4. + apply fe_stack_data_aligned. + intros. + assert (Mem.valid_block m1' sp'). eapply Mem.valid_block_inject_2; eauto. + assert (~Mem.valid_block m1' sp') by eauto with mem. + contradiction. + intros [j' [INJ2 [INCR [MAP1 MAP2]]]]. + assert (PERM: frame_perm_freeable m2' sp'). + red; intros. eapply Mem.perm_alloc_2; eauto. + (* Store of parent *) + exploit (store_index_succeeds m2' sp' FI_link parent). red; auto. auto. + intros [m3' STORE2]. + (* Store of retaddr *) + exploit (store_index_succeeds m3' sp' FI_retaddr ra). red; auto. red; eauto with mem. + intros [m4' STORE3]. + (* Saving callee-save registers *) + assert (PERM4: frame_perm_freeable m4' sp'). + red; intros. eauto with mem. + exploit save_callee_save_correct. + apply agree_regs_undef_temps. + eapply agree_regs_inject_incr; eauto. + apply wt_undef_temps. auto. + eexact PERM4. + intros [m5' [STEPS [ICS [FCS [OTHERS [STORES PERM5]]]]]]. + (* stores in frames *) + assert (SIF: stores_in_frame sp' m2' m5'). + econstructor; eauto. + rewrite size_type_chunk. apply offset_of_index_disj_stack_data_2; auto. red; auto. + econstructor; eauto. + rewrite size_type_chunk. apply offset_of_index_disj_stack_data_2; auto. red; auto. + (* separation *) + assert (SEP: forall b0 delta, j' b0 = Some(sp', delta) -> b0 = sp /\ delta = fe_stack_data fe). + intros. destruct (zeq b0 sp). + subst b0. rewrite MAP1 in H; inv H; auto. + rewrite MAP2 in H; auto. + assert (Mem.valid_block m1' sp'). eapply Mem.valid_block_inject_2; eauto. + assert (~Mem.valid_block m1' sp') by eauto with mem. + contradiction. + (* Conclusions *) + exists j'; exists m2'; exists sp'; exists m3'; exists m4'; exists m5'. + split. auto. + (* store parent *) + split. change Tint with (type_of_index FI_link). + change (fe_ofs_link fe) with (offset_of_index fe FI_link). + apply store_stack_succeeds; auto. red; auto. + (* store retaddr *) + split. change Tint with (type_of_index FI_retaddr). + change (fe_ofs_retaddr fe) with (offset_of_index fe FI_retaddr). + apply store_stack_succeeds; auto. red; auto. + (* saving of registers *) + split. eexact STEPS. + (* agree_regs *) + split. apply agree_regs_call_regs. apply agree_regs_inject_incr with j; auto. + (* agree frame *) + split. constructor; intros. + (* unused regs *) + unfold call_regs. destruct (in_dec Loc.eq (R r) temporaries). + elim H. apply temporary_within_bounds; auto. + apply AGCS. apply mreg_not_within_bounds_callee_save; auto. + (* locals *) + simpl. apply index_contains_inj_undef; auto. + (* outgoing *) + simpl. apply index_contains_inj_undef; auto. + (* incoming *) + unfold call_regs. apply AGCS. auto. + (* parent *) + apply OTHERS; auto. red; auto. + eapply gso_index_contains; eauto. red; auto. + eapply gss_index_contains; eauto. red; auto. + red; auto. + (* retaddr *) + apply OTHERS; auto. red; auto. + eapply gss_index_contains; eauto. red; auto. + (* int callee save *) + rewrite <- AGCS. replace (ls (R r)) with (LTL.undef_temps ls (R r)). + apply ICS; auto. + unfold LTL.undef_temps. apply Locmap.guo. apply Loc.reg_notin. + red; intros; exploit int_callee_save_not_destroyed; eauto. + auto. + (* float callee save *) + rewrite <- AGCS. replace (ls (R r)) with (LTL.undef_temps ls (R r)). + apply FCS; auto. + unfold LTL.undef_temps. apply Locmap.guo. apply Loc.reg_notin. + red; intros; exploit float_callee_save_not_destroyed; eauto. + auto. + (* inj *) + auto. + (* inj_unique *) + auto. + (* valid sp *) + eauto with mem. + (* valid sp' *) + eapply stores_in_frame_valid with (m := m2'); eauto with mem. + (* bounds *) + eapply Mem.bounds_alloc_same; eauto. + (* perms *) + auto. + (* wt *) + apply wt_call_regs; auto. + (* incr *) + split. auto. + (* separated *) + split. eapply inject_alloc_separated; eauto with mem. + (* inject *) + split. eapply stores_in_frame_inject; eauto. + eapply Mem.bounds_alloc_same; eauto. + (* stores in frame *) + auto. Qed. (** The following lemmas show the correctness of the register reloading @@ -940,165 +1470,436 @@ Variable bound: frame_env -> Z. Variable number: mreg -> Z. Variable mkindex: Z -> frame_index. Variable ty: typ. -Variable sp: val. Variable csregs: list mreg. +Variable j: meminj. +Variable cs: list stackframe. +Variable fb: block. +Variable sp: block. +Variable ls0: locset. +Variable m: mem. + Hypothesis mkindex_valid: forall r, In r csregs -> number r < bound fe -> index_valid (mkindex (number r)). -Hypothesis mkindex_not_link: - forall z, mkindex z <> FI_link. -Hypothesis mkindex_not_retaddr: - forall z, mkindex z <> FI_retaddr. Hypothesis mkindex_typ: forall z, type_of_index (mkindex z) = ty. Hypothesis number_within_bounds: forall r, In r csregs -> (number r < bound fe <-> mreg_within_bounds b r). Hypothesis mkindex_val: - forall ls ls0 rs fr cs r, - agree ls ls0 rs fr cs -> In r csregs -> number r < bound fe -> - index_val (mkindex (number r)) fr = ls0 (R r). + forall r, + In r csregs -> number r < bound fe -> + index_contains_inj j m sp (mkindex (number r)) (ls0 (R r)). + +Definition agree_unused (ls0: locset) (rs: regset) : Prop := + forall r, ~(mreg_within_bounds b r) -> val_inject j (ls0 (R r)) (rs r). Lemma restore_callee_save_regs_correct: - forall k fr m ls0 l ls rs cs, + forall l rs k, incl l csregs -> list_norepet l -> - agree ls ls0 rs fr cs -> - exists ls', exists rs', + agree_unused ls0 rs -> + exists rs', star step tge - (State stack tf sp - (restore_callee_save_regs bound number mkindex ty fe l k) rs fr m) - E0 (State stack tf sp k rs' fr m) - /\ (forall r, In r l -> rs' r = ls0 (R r)) + (State cs fb (Vptr sp Int.zero) + (restore_callee_save_regs bound number mkindex ty fe l k) rs m) + E0 (State cs fb (Vptr sp Int.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 ls' ls0 rs' fr cs. + /\ agree_unused ls0 rs'. Proof. induction l; intros; simpl restore_callee_save_regs. (* base case *) - exists ls. exists rs. - split. apply star_refl. - split. intros. elim H2. - split. auto. auto. + exists rs. intuition. apply star_refl. (* inductive case *) - set (k1 := restore_callee_save_regs bound number mkindex ty fe l k). assert (R0: In a csregs). apply H; auto with coqlib. assert (R1: incl l csregs). eauto with coqlib. assert (R2: list_norepet l). inversion H0; auto. unfold restore_callee_save_reg. destruct (zlt (number a) (bound fe)). - set (ls1 := Locmap.set (R a) (ls0 (R a)) ls). - set (rs1 := Regmap.set a (ls0 (R a)) rs). - assert (R3: agree ls1 ls0 rs1 fr cs). - unfold ls1, rs1. apply agree_set_reg. auto. - rewrite <- number_within_bounds; auto. - generalize (IHl ls1 rs1 cs R1 R2 R3). - intros [ls' [rs' [A [B [C D]]]]]. - exists ls'. exists rs'. split. - apply star_left with E0 (State stack tf sp k1 rs1 fr m) E0. - unfold rs1; apply exec_Mgetstack. apply get_slot_index; auto. - symmetry. eapply mkindex_val; eauto. - auto. traceEq. - split. intros. elim H2; intros. - subst r. rewrite C. unfold rs1. apply Regmap.gss. inversion H0; auto. + exploit (mkindex_val a); auto. intros [v [X Y]]. + set (rs1 := Regmap.set a v rs). + exploit (IHl rs1 k); eauto. + red; intros. unfold rs1. unfold Regmap.set. destruct (RegEq.eq r a). + subst r. auto. + auto. + intros [rs' [A [B [C D]]]]. + exists rs'. split. + eapply star_left. + constructor. rewrite <- (mkindex_typ (number a)). apply index_contains_load_stack. eauto. + eauto. traceEq. + split. intros. destruct H2. + subst r. rewrite C. unfold rs1. rewrite Regmap.gss. auto. inv H0; auto. auto. split. intros. simpl in H2. rewrite C. unfold rs1. apply Regmap.gso. apply sym_not_eq; tauto. tauto. - assumption. + auto. (* no load takes place *) - generalize (IHl ls rs cs R1 R2 H1). - intros [ls' [rs' [A [B [C D]]]]]. - exists ls'; exists rs'. split. assumption. - split. intros. elim H2; intros. - subst r. apply (agree_unused_reg _ _ _ _ _ D). + exploit (IHl rs k); auto. + intros [rs' [A [B [C D]]]]. + exists rs'. split. assumption. + split. intros. destruct H2. + subst r. apply D. rewrite <- number_within_bounds. auto. auto. auto. split. intros. simpl in H2. apply C. tauto. - assumption. -Qed. - -End RESTORE_CALLEE_SAVE. - -Lemma restore_int_callee_save_correct: - forall sp k fr m ls0 ls rs cs, - agree ls ls0 rs fr cs -> - exists ls', exists rs', - star step tge - (State stack tf sp - (restore_callee_save_int fe k) rs fr m) - E0 (State stack tf sp k rs' fr m) - /\ (forall r, In r int_callee_save_regs -> rs' r = ls0 (R r)) - /\ (forall r, ~(In r int_callee_save_regs) -> rs' r = rs r) - /\ agree ls' ls0 rs' fr cs. -Proof. - intros. unfold restore_callee_save_int. - apply restore_callee_save_regs_correct with int_callee_save_regs ls. - intros; simpl. split; auto. generalize (index_int_callee_save_pos r H0). omega. - intros; congruence. - intros; congruence. - auto. - intros. unfold mreg_within_bounds. - rewrite (int_callee_save_type r H0). tauto. - eauto with stacking. - apply incl_refl. - apply int_callee_save_norepet. auto. Qed. -Lemma restore_float_callee_save_correct: - forall sp k fr m ls0 ls rs cs, - agree ls ls0 rs fr cs -> - exists ls', exists rs', - star step tge - (State stack tf sp - (restore_callee_save_float fe k) rs fr m) - E0 (State stack tf sp k rs' fr m) - /\ (forall r, In r float_callee_save_regs -> rs' r = ls0 (R r)) - /\ (forall r, ~(In r float_callee_save_regs) -> rs' r = rs r) - /\ agree ls' ls0 rs' fr cs. -Proof. - intros. unfold restore_callee_save_float. - apply restore_callee_save_regs_correct with float_callee_save_regs ls. - intros; simpl. split; auto. generalize (index_float_callee_save_pos r H0). omega. - intros; congruence. - intros; congruence. - auto. - intros. unfold mreg_within_bounds. - rewrite (float_callee_save_type r H0). tauto. - eauto with stacking. - apply incl_refl. - apply float_callee_save_norepet. - auto. -Qed. +End RESTORE_CALLEE_SAVE. Lemma restore_callee_save_correct: - forall sp k fr m ls0 ls rs cs, - agree ls ls0 rs fr cs -> + forall j ls ls0 m sp m' sp' pa ra cs fb rs k, + agree_frame j ls ls0 m sp m' sp' pa ra -> + agree_unused j ls0 rs -> exists rs', star step tge - (State stack tf sp (restore_callee_save fe k) rs fr m) - E0 (State stack tf sp k rs' fr m) + (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') /\ (forall r, In r int_callee_save_regs \/ In r float_callee_save_regs -> - rs' r = ls0 (R r)) + val_inject j (ls0 (R r)) (rs' r)) /\ (forall r, ~(In r int_callee_save_regs) -> ~(In r float_callee_save_regs) -> rs' r = rs r). Proof. - intros. unfold restore_callee_save. - exploit restore_int_callee_save_correct; eauto. - intros [ls1 [rs1 [A [B [C D]]]]]. - exploit restore_float_callee_save_correct. eexact D. - intros [ls2 [rs2 [P [Q [R S]]]]]. - exists rs2. split. eapply star_trans. eexact A. eexact P. traceEq. - split. intros. elim H0; intros. - rewrite R. apply B. auto. apply list_disjoint_notin with int_callee_save_regs. - apply int_float_callee_save_disjoint. auto. - apply Q. auto. - intros. rewrite R. apply C. auto. auto. + intros. + exploit (restore_callee_save_regs_correct + fe_num_int_callee_save + index_int_callee_save + FI_saved_int + Tint + int_callee_save_regs + j cs fb sp' ls0 m'); auto. + intros. unfold mreg_within_bounds. rewrite (int_callee_save_type r H1). tauto. + eapply agree_saved_int; eauto. + apply incl_refl. + apply int_callee_save_norepet. + eauto. + intros [rs1 [A [B [C D]]]]. + exploit (restore_callee_save_regs_correct + fe_num_float_callee_save + index_float_callee_save + FI_saved_float + Tfloat + float_callee_save_regs + j cs fb sp' ls0 m'); auto. + intros. unfold mreg_within_bounds. rewrite (float_callee_save_type r H1). tauto. + eapply agree_saved_float; eauto. + apply incl_refl. + apply float_callee_save_norepet. + eexact D. + intros [rs2 [P [Q [R S]]]]. + exists rs2. + split. unfold restore_callee_save. eapply star_trans; eauto. + split. intros. destruct H1. + rewrite R. apply B; auto. red; intros. exploit int_float_callee_save_disjoint; eauto. + apply Q; auto. + intros. rewrite R; auto. +Qed. + +(** As a corollary, we obtain the following correctness result for + the execution of a function epilogue (reloading of used callee-save + registers + reloading of the link and return address + freeing + of the frame). *) + +Lemma function_epilogue_correct: + forall j ls ls0 m sp m' sp' pa ra cs fb rs k m1, + agree_regs j ls rs -> + agree_frame j ls ls0 m sp m' sp' pa ra -> + Mem.inject j m m' -> + 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 + /\ 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') + /\ agree_regs j (return_regs ls0 ls) rs1 + /\ agree_callee_save (return_regs ls0 ls) ls0 + /\ rs1 IT1 = rs IT1 + /\ Mem.inject j m1 m1'. +Proof. + intros. + (* can free *) + destruct (Mem.range_perm_free m' sp' 0 (fn_stacksize tf)) as [m1' FREE]. + rewrite unfold_transf_function; unfold fn_stacksize. red; intros. + assert (EITHER: fe_stack_data fe <= ofs < fe_stack_data fe + Linear.fn_stacksize f + \/ (ofs < fe_stack_data fe \/ fe_stack_data fe + Linear.fn_stacksize f <= ofs)) + by omega. + destruct EITHER. + replace ofs with ((ofs - fe_stack_data fe) + fe_stack_data fe) by omega. + eapply Mem.perm_inject with (f := j). eapply agree_inj; eauto. eauto. + eapply Mem.free_range_perm; eauto. omega. + eapply agree_perm; eauto. + (* inject after free *) + assert (INJ1: Mem.inject j m1 m1'). + eapply Mem.free_inject with (l := (sp, 0, f.(Linear.fn_stacksize)) :: nil); eauto. + simpl. rewrite H2. auto. + intros. exploit agree_inj_unique; eauto. intros [P Q]; subst b1 delta. + exists 0; exists (Linear.fn_stacksize f); split. auto with coqlib. + exploit Mem.perm_in_bounds; eauto. + rewrite (agree_bounds _ _ _ _ _ _ _ _ _ H0). auto. + (* can execute epilogue *) + exploit restore_callee_save_correct; eauto. + instantiate (1 := rs). red; intros. + rewrite <- (agree_unused_reg _ _ _ _ _ _ _ _ _ H0). auto. auto. + intros [rs1 [A [B C]]]. + (* conclusions *) + exists rs1; exists m1'. + split. rewrite unfold_transf_function; unfold fn_link_ofs. + eapply index_contains_load_stack with (idx := FI_link); eauto with stacking. + split. rewrite unfold_transf_function; unfold fn_retaddr_ofs. + eapply index_contains_load_stack with (idx := FI_retaddr); eauto with stacking. + split. auto. + split. eexact A. + split. red;intros. unfold return_regs. + generalize (register_classification r) (int_callee_save_not_destroyed r) (float_callee_save_not_destroyed r); intros. + destruct (in_dec Loc.eq (R r) temporaries). + rewrite C; auto. + destruct (in_dec Loc.eq (R r) destroyed_at_call). + rewrite C; auto. + intuition. + split. apply agree_callee_save_return_regs. + split. apply C. apply int_callee_save_not_destroyed. left; simpl; auto. + apply float_callee_save_not_destroyed. left; simpl; auto. + auto. Qed. End FRAME_PROPERTIES. -(** * Semantic preservation *) +(** * Call stack invariant *) + +Inductive match_globalenvs (j: meminj) (bound: Z) : Prop := + | match_globalenvs_intro + (POS: bound > 0) + (DOMAIN: forall b, b < bound -> j b = Some(b, 0)) + (IMAGE: forall b1 b2 delta, j b1 = Some(b2, delta) -> b2 < bound -> b1 = b2) + (SYMBOLS: forall id b, Genv.find_symbol ge id = Some b -> b < bound) + (INFOS: forall b gv, Genv.find_var_info ge b = Some gv -> b < bound). + +Inductive match_stacks (j: meminj) (m m': mem): + list Linear.stackframe -> list stackframe -> signature -> Z -> Z -> Prop := + | match_stacks_empty: forall sg hi bound bound', + hi <= bound -> hi <= bound' -> match_globalenvs j hi -> + tailcall_possible sg -> + match_stacks j m m' nil nil sg bound bound' + | match_stacks_cons: forall f sp ls c cs fb sp' ra c' cs' sg bound bound' trf + (TAIL: is_tail c (Linear.fn_code f)) + (WTF: wt_function f) + (FINDF: Genv.find_funct_ptr tge fb = Some (Internal trf)) + (TRF: transf_function f = OK trf) + (TRC: transl_code (make_env (function_bounds f)) c = c') + (TY_RA: Val.has_type ra Tint) + (FRM: agree_frame f j ls (parent_locset cs) m sp m' sp' (parent_sp cs') (parent_ra cs')) + (ARGS: forall ofs ty, + In (S (Outgoing ofs ty)) (loc_arguments sg) -> + slot_within_bounds f (function_bounds f) (Outgoing ofs ty)) + (STK: match_stacks j m m' cs cs' (Linear.fn_sig f) sp sp') + (BELOW: sp < bound) + (BELOW': sp' < bound'), + match_stacks j m m' + (Linear.Stackframe f (Vptr sp Int.zero) ls c :: cs) + (Stackframe fb (Vptr sp' Int.zero) ra c' :: cs') + sg bound bound'. + +(** Invariance with respect to change of bounds. *) + +Lemma match_stacks_change_bounds: + forall j m1 m' cs cs' sg bound bound', + match_stacks j m1 m' cs cs' sg bound bound' -> + forall xbound xbound', + bound <= xbound -> bound' <= xbound' -> + match_stacks j m1 m' cs cs' sg xbound xbound'. +Proof. + induction 1; intros. + apply match_stacks_empty with hi; auto. omega. omega. + econstructor; eauto. omega. omega. +Qed. + +(** Invariance with respect to change of [m]. *) + +Lemma match_stacks_change_linear_mem: + forall j m1 m2 m' cs cs' sg bound bound', + match_stacks j m1 m' cs cs' sg bound bound' -> + (forall b, b < bound -> Mem.valid_block m1 b -> Mem.valid_block m2 b) -> + (forall b, b < bound -> Mem.bounds m2 b = Mem.bounds m1 b) -> + match_stacks j m2 m' cs cs' sg bound bound'. +Proof. + induction 1; intros. + econstructor; eauto. + econstructor; eauto. + eapply agree_frame_invariant; eauto. + apply IHmatch_stacks. + intros. apply H0; auto. omega. + intros. apply H1. omega. +Qed. + +(** Invariance with respect to change of [m']. *) + +Lemma match_stacks_change_mach_mem: + forall j m m1' m2' cs cs' sg bound bound', + match_stacks j m m1' cs cs' sg bound bound' -> + (forall b, b < bound' -> Mem.valid_block m1' b -> Mem.valid_block m2' b) -> + (forall b ofs p, b < bound' -> Mem.perm m1' b ofs p -> Mem.perm m2' b ofs p) -> + (forall chunk b ofs v, b < bound' -> Mem.load chunk m1' b ofs = Some v -> Mem.load chunk m2' b ofs = Some v) -> + match_stacks j m m2' cs cs' sg bound bound'. +Proof. + induction 1; intros. + econstructor; eauto. + econstructor; eauto. + eapply agree_frame_invariant; eauto. + apply IHmatch_stacks. + intros; apply H0; auto; omega. + intros; apply H1; auto; omega. + intros; apply H2; auto. omega. +Qed. + +(** A variant of the latter, for use with external calls *) + +Lemma match_stacks_change_mem_extcall: + forall j m1 m2 m1' m2' cs cs' sg bound bound', + match_stacks j m1 m1' cs cs' sg bound bound' -> + (forall b, b < bound -> Mem.valid_block m1 b -> Mem.valid_block m2 b) -> + (forall b, b < bound -> Mem.bounds m2 b = Mem.bounds m1 b) -> + (forall b, b < bound' -> Mem.valid_block m1' b -> Mem.valid_block m2' b) -> + mem_unchanged_on (loc_out_of_reach j m1) m1' m2' -> + match_stacks j m2 m2' cs cs' sg bound bound'. +Proof. + induction 1; intros. + econstructor; eauto. + econstructor; eauto. + eapply agree_frame_extcall_invariant; eauto. + apply IHmatch_stacks. + intros; apply H0; auto; omega. + intros; apply H1; omega. + intros; apply H2; auto; omega. + auto. +Qed. + +(** Invariance with respect to change of [j]. *) + +Lemma match_stacks_change_meminj: + forall j j' m m' m1 m1', + inject_incr j j' -> + inject_separated j j' m1 m1' -> + forall cs cs' sg bound bound', + match_stacks j m m' cs cs' sg bound bound' -> + bound' <= Mem.nextblock m1' -> + match_stacks j' m m' cs cs' sg bound bound'. +Proof. + induction 3; intros. + apply match_stacks_empty with hi; auto. + inv H3. constructor; auto. + intros. red in H0. case_eq (j b1). + intros [b' delta'] EQ. rewrite (H _ _ _ EQ) in H3. inv H3. eauto. + intros EQ. exploit H0; eauto. intros [A B]. elim B. red. omega. + econstructor; eauto. + eapply agree_frame_inject_incr; eauto. red; omega. + apply IHmatch_stacks. omega. +Qed. + +(** Preservation by parallel stores in Linear and Mach. *) + +Lemma match_stacks_parallel_stores: + forall j m m' chunk addr addr' v v' m1 m1', + Mem.inject j m m' -> + val_inject j addr addr' -> + Mem.storev chunk m addr v = Some m1 -> + Mem.storev chunk m' addr' v' = Some m1' -> + forall cs cs' sg bound bound', + match_stacks j m m' cs cs' sg bound bound' -> + match_stacks j m1 m1' cs cs' sg bound bound'. +Proof. + intros until m1'. intros MINJ VINJ STORE1 STORE2. + induction 1. + econstructor; eauto. + econstructor; eauto. + eapply agree_frame_parallel_stores; eauto. +Qed. + +(** Invariance by external calls. *) + +Lemma match_stack_change_extcall: + forall ec args m1 res t m2 args' m1' res' t' m2' j j', + external_call ec ge args m1 t res m2 -> + external_call ec ge args' m1' t' res' m2' -> + inject_incr j j' -> + inject_separated j j' m1 m1' -> + mem_unchanged_on (loc_out_of_reach j m1) m1' m2' -> + forall cs cs' sg bound bound', + match_stacks j m1 m1' cs cs' sg bound bound' -> + bound <= Mem.nextblock m1 -> bound' <= Mem.nextblock m1' -> + match_stacks j' m2 m2' cs cs' sg bound bound'. +Proof. + intros. + eapply match_stacks_change_meminj; eauto. + eapply match_stacks_change_mem_extcall; eauto. + intros; eapply external_call_valid_block; eauto. + intros; eapply external_call_bounds; eauto. red; omega. + intros; eapply external_call_valid_block; eauto. +Qed. + +(** Invariance with respect to change of signature *) + +Lemma match_stacks_change_sig: + forall sg1 j m m' cs cs' sg bound bound', + match_stacks j m m' cs cs' sg bound bound' -> + tailcall_possible sg1 -> + match_stacks j m m' cs cs' sg1 bound bound'. +Proof. + induction 1; intros. econstructor; eauto. econstructor; eauto. + intros. elim (H0 _ H1). +Qed. + +(** [match_stacks] implies [match_globalenvs], which implies [meminj_preserves_globals]. *) + +Lemma match_stacks_globalenvs: + forall j m m' cs cs' sg bound bound', + match_stacks j m m' cs cs' sg bound bound' -> + exists hi, match_globalenvs j hi. +Proof. + induction 1. exists hi; auto. auto. +Qed. + +Lemma match_stacks_preserves_globals: + forall j m m' cs cs' sg bound bound', + match_stacks j m m' cs cs' sg bound bound' -> + meminj_preserves_globals ge j. +Proof. + intros. exploit match_stacks_globalenvs; eauto. intros [hi MG]. inv MG. + split. eauto. split. eauto. intros. symmetry. eauto. +Qed. + +(** Typing properties of [match_stacks]. *) + +Lemma match_stacks_wt_locset: + forall j m m' cs cs' sg bound bound', + match_stacks j m m' cs cs' sg bound bound' -> + wt_locset (parent_locset cs). +Proof. + induction 1; simpl. + unfold Locmap.init; red; intros; red; auto. + inv FRM; auto. +Qed. + +Lemma match_stacks_type_sp: + forall j m m' cs cs' sg bound bound', + match_stacks j m m' cs cs' sg bound bound' -> + Val.has_type (parent_sp cs') Tint. +Proof. + induction 1; simpl; auto. +Qed. + +Lemma match_stacks_type_retaddr: + forall j m m' cs cs' sg bound bound', + match_stacks j m m' cs cs' sg bound bound' -> + Val.has_type (parent_ra cs') Tint. +Proof. + induction 1; simpl; auto. +Qed. + +(** * Syntactic properties of the translation *) (** Preservation of code labels through the translation. *) @@ -1170,19 +1971,86 @@ Qed. End LABELS. -(** Code inclusion property for Linear executions. *) +(** Code tail property for Linear executions. *) -Lemma find_label_incl: +Lemma find_label_tail: forall lbl c c', - Linear.find_label lbl c = Some c' -> incl c' c. + Linear.find_label lbl c = Some c' -> is_tail c' c. Proof. induction c; simpl. intros; discriminate. intro c'. case (Linear.is_label lbl a); intros. - injection H; intro; subst c'. red; intros; auto with coqlib. - apply incl_tl. auto. + injection H; intro; subst c'. auto with coqlib. + auto with coqlib. Qed. +(** Code tail property for translations *) + +Lemma is_tail_save_callee_save_regs: + forall bound number mkindex ty fe csl k, + is_tail k (save_callee_save_regs bound number mkindex ty fe csl k). +Proof. + induction csl; intros; simpl. auto with coqlib. + unfold save_callee_save_reg. destruct (zlt (number a) (bound fe)). + constructor; auto. auto. +Qed. + +Lemma is_tail_save_callee_save: + forall fe k, + is_tail k (save_callee_save fe k). +Proof. + intros. unfold save_callee_save, save_callee_save_int, save_callee_save_float. + eapply is_tail_trans; apply is_tail_save_callee_save_regs. +Qed. + +Lemma is_tail_restore_callee_save_regs: + forall bound number mkindex ty fe csl k, + is_tail k (restore_callee_save_regs bound number mkindex ty fe csl k). +Proof. + induction csl; intros; simpl. auto with coqlib. + unfold restore_callee_save_reg. destruct (zlt (number a) (bound fe)). + constructor; auto. auto. +Qed. + +Lemma is_tail_restore_callee_save: + forall fe k, + is_tail k (restore_callee_save fe k). +Proof. + intros. unfold restore_callee_save, restore_callee_save_int, restore_callee_save_float. + eapply is_tail_trans; apply is_tail_restore_callee_save_regs. +Qed. + +Lemma is_tail_transl_instr: + forall fe i k, + is_tail k (transl_instr fe i k). +Proof. + intros. destruct i; unfold transl_instr; auto with coqlib. + destruct s; auto with coqlib. + destruct s; auto with coqlib. + eapply is_tail_trans. 2: apply is_tail_restore_callee_save. auto with coqlib. + eapply is_tail_trans. 2: apply is_tail_restore_callee_save. auto with coqlib. +Qed. + +Lemma is_tail_transl_code: + forall fe c1 c2, is_tail c1 c2 -> is_tail (transl_code fe c1) (transl_code fe c2). +Proof. + induction 1; simpl. auto with coqlib. + eapply is_tail_trans. eauto. apply is_tail_transl_instr. +Qed. + +Lemma is_tail_transf_function: + forall f tf c, + transf_function f = OK tf -> + is_tail c (Linear.fn_code f) -> + is_tail (transl_code (make_env (function_bounds f)) c) (fn_code tf). +Proof. + intros. rewrite (unfold_transf_function _ _ H). simpl. + unfold transl_body. eapply is_tail_trans. 2: apply is_tail_save_callee_save. + apply is_tail_transl_code; auto. +Qed. + +(** * Semantic preservation *) + (** Preservation / translation of global symbols and functions. *) Lemma symbols_preserved: @@ -1221,35 +2089,35 @@ Lemma sig_preserved: forall f tf, transf_fundef f = OK tf -> Mach.funsig tf = Linear.funsig f. Proof. intros until tf; unfold transf_fundef, transf_partial_fundef. - destruct f. unfold transf_function. - destruct (zlt (Linear.fn_stacksize f) 0). simpl; congruence. - destruct (zlt (- Int.min_signed) (fe_size (make_env (function_bounds f)))). simpl; congruence. - unfold bind. intros. inversion H; reflexivity. - intro. inversion H. reflexivity. -Qed. - -Lemma stacksize_preserved: - forall f tf, transf_function f = OK tf -> Mach.fn_stacksize tf = Linear.fn_stacksize f. -Proof. - intros until tf; unfold transf_function. - destruct (zlt (Linear.fn_stacksize f) 0). simpl; congruence. - destruct (zlt (- Int.min_signed) (fe_size (make_env (function_bounds f)))). simpl; congruence. - intros. inversion H; reflexivity. + destruct f; intros; monadInv H. + rewrite (unfold_transf_function _ _ EQ). auto. + auto. Qed. Lemma find_function_translated: - forall f0 tf0 ls ls0 rs fr cs ros f, - agree f0 tf0 ls ls0 rs fr cs -> + forall j ls rs m m' cs cs' sg bound bound' ros f, + agree_regs j ls rs -> + match_stacks j m m' cs cs' sg bound bound' -> Linear.find_function ge ros ls = Some f -> - exists tf, - find_function tge ros rs = Some tf /\ transf_fundef f = OK tf. + exists bf, exists tf, + find_function_ptr tge ros rs = Some bf + /\ Genv.find_funct_ptr tge bf = Some tf + /\ transf_fundef f = OK tf. Proof. - intros until f; intro AG. - destruct ros; simpl. - rewrite (agree_eval_reg _ _ _ _ _ _ _ m AG). intro. - apply functions_translated; auto. - rewrite symbols_preserved. destruct (Genv.find_symbol ge i); try congruence. - intro. apply function_ptr_translated; auto. + intros until f; intros AG MS FF. + exploit match_stacks_globalenvs; eauto. intros [hi MG]. + destruct ros; simpl in FF. + exploit Genv.find_funct_inv; eauto. intros [b EQ]. rewrite EQ in FF. + rewrite Genv.find_funct_find_funct_ptr in FF. + exploit function_ptr_translated; eauto. intros [tf [A B]]. + exists b; exists tf; split; auto. simpl. + generalize (AG m0). rewrite EQ. intro INJ. inv INJ. + exploit Genv.find_funct_ptr_negative. unfold ge in FF; eexact FF. intros. + inv MG. rewrite (DOMAIN b) in H2. inv H2. auto. omega. + revert FF. case_eq (Genv.find_symbol ge i); intros; try discriminate. + exploit function_ptr_translated; eauto. intros [tf [A B]]. + exists b; exists tf; split; auto. simpl. + rewrite symbols_preserved. auto. Qed. Hypothesis wt_prog: wt_program prog. @@ -1264,84 +2132,59 @@ Proof. intro. eapply Genv.find_funct_ptr_prop; eauto. Qed. -(** Correctness of stack pointer relocation in operations and - addressing modes. *) - -Definition shift_sp (tf: Mach.function) (sp: val) := - Val.add sp (Vint (Int.repr (-tf.(fn_framesize)))). - -Remark shift_sp_eq: - forall f tf sp, - transf_function f = OK tf -> - shift_sp tf sp = Val.sub sp (Vint (Int.repr (fe_size (make_env (function_bounds f))))). -Proof. - intros. unfold shift_sp. - replace (fe_size (make_env (function_bounds f))) with (fn_framesize tf). - rewrite <- Int.neg_repr. destruct sp; simpl; auto; rewrite Int.sub_add_opp; auto. - rewrite (unfold_transf_function _ _ H). auto. -Qed. - -Lemma shift_eval_operation: - forall f tf sp op args v, - transf_function f = OK tf -> - eval_operation ge sp op args = Some v -> - eval_operation tge (shift_sp tf sp) - (transl_op (make_env (function_bounds f)) op) args = Some v. -Proof. - intros. rewrite <- H0. rewrite (shift_sp_eq f tf sp H). unfold transl_op. - rewrite (eval_operation_preserved ge tge). - apply shift_stack_eval_operation. - exact symbols_preserved. -Qed. - -Lemma shift_eval_addressing: - forall f tf sp addr args v, - transf_function f = OK tf -> - eval_addressing ge sp addr args = Some v -> - eval_addressing tge (shift_sp tf sp) - (transl_addr (make_env (function_bounds f)) addr) args = - Some v. -Proof. - intros. rewrite <- H0. rewrite (shift_sp_eq f tf sp H). unfold transl_addr. - rewrite (eval_addressing_preserved ge tge). - apply shift_stack_eval_addressing. - exact symbols_preserved. -Qed. - (** Preservation of the arguments to an external call. *) Section EXTERNAL_ARGUMENTS. -Variable cs: list Machabstr.stackframe. +Variable j: meminj. +Variables m m': mem. +Variable cs: list Linear.stackframe. +Variable cs': list stackframe. +Variable sg: signature. +Variables bound bound': Z. +Hypothesis MS: match_stacks j m m' cs cs' sg bound bound'. Variable ls: locset. Variable rs: regset. -Variable sg: signature. +Hypothesis AGR: agree_regs j ls rs. +Hypothesis AGCS: agree_callee_save ls (parent_locset cs). -Hypothesis AG1: forall r, rs r = ls (R r). -Hypothesis AG2: forall (ofs : Z) (ty : typ), - In (S (Outgoing ofs ty)) (loc_arguments sg) -> - get_parent_slot cs ofs ty (ls (S (Outgoing ofs ty))). +Lemma transl_external_argument: + forall l, + In l (loc_arguments sg) -> + exists v, extcall_arg rs m' (parent_sp cs') l v /\ val_inject j (ls l) v. +Proof. + intros. + assert (loc_argument_acceptable l). apply loc_arguments_acceptable with sg; auto. + destruct l; red in H0. + exists (rs m0); split. constructor. auto. + destruct s; try contradiction. + inv MS. + elim (H4 _ H). + unfold parent_sp. + exploit agree_outgoing; eauto. intros [v [A B]]. + exists v; split. + constructor. + eapply index_contains_load_stack with (idx := FI_arg z t); eauto. + red in AGCS. rewrite AGCS; auto. +Qed. Lemma transl_external_arguments_rec: forall locs, incl locs (loc_arguments sg) -> - extcall_args (parent_function cs) rs (parent_frame cs) locs ls##locs. + exists vl, + extcall_args rs m' (parent_sp cs') locs vl /\ val_list_inject j ls##locs vl. Proof. induction locs; simpl; intros. - constructor. - constructor. - assert (loc_argument_acceptable a). - apply loc_arguments_acceptable with sg; auto with coqlib. - destruct a; red in H0. - rewrite <- AG1. constructor. - destruct s; try contradiction. - constructor. change (get_parent_slot cs z t (ls (S (Outgoing z t)))). -apply AG2. auto with coqlib. - apply IHlocs; eauto with coqlib. + exists (@nil val); split. constructor. constructor. + exploit transl_external_argument; eauto with coqlib. intros [v [A B]]. + exploit IHlocs; eauto with coqlib. intros [vl [C D]]. + exists (v :: vl); split; constructor; auto. Qed. Lemma transl_external_arguments: - extcall_arguments (parent_function cs) rs (parent_frame cs) sg (ls ## (loc_arguments sg)). + exists vl, + extcall_arguments rs m' (parent_sp cs') sg vl /\ + val_list_inject j (ls ## (loc_arguments sg)) vl. Proof. unfold extcall_arguments. apply transl_external_arguments_rec. @@ -1364,61 +2207,53 @@ End EXTERNAL_ARGUMENTS. below. It implies: - Agreement between, on the Linear side, the location sets [ls] and [parent_locset s] of the current function and its caller, - and on the Mach side the register set [rs], the frame [fr] - and the caller's frame [parent_frame ts]. -- Inclusion between the Linear code [c] and the code of the + and on the Mach side the register set [rs] and the contents of + the memory area corresponding to the stack frame. +- The Linear code [c] is a suffix of the code of the function [f] being executed. +- Memory injection between the Linear and the Mach memory states. - Well-typedness of [f]. *) -Inductive match_stacks: list Linear.stackframe -> list Machabstr.stackframe -> Prop := - | match_stacks_nil: - match_stacks nil nil - | match_stacks_cons: - forall f sp c ls tf fr s ts, - match_stacks s ts -> - transf_function f = OK tf -> - wt_function f -> - agree_frame f tf ls (parent_locset s) fr ts -> - incl c (Linear.fn_code f) -> - match_stacks - (Linear.Stackframe f sp ls c :: s) - (Machabstr.Stackframe tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) c) fr :: ts). - -Inductive match_states: Linear.state -> Machabstr.state -> Prop := +Inductive match_states: Linear.state -> Machconcr.state -> Prop := | match_states_intro: - forall s f sp c ls m ts tf rs fr - (STACKS: match_stacks s ts) + forall cs f sp c ls m cs' fb sp' rs m' j tf + (MINJ: Mem.inject j m m') + (STACKS: match_stacks j m m' cs cs' f.(Linear.fn_sig) sp sp') (TRANSL: transf_function f = OK tf) + (FIND: Genv.find_funct_ptr tge fb = Some (Internal tf)) (WTF: wt_function f) - (AG: agree f tf ls (parent_locset s) rs fr ts) - (INCL: incl c (Linear.fn_code f)), - match_states (Linear.State s f sp c ls m) - (Machabstr.State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) c) rs fr m) + (AGREGS: agree_regs j ls rs) + (AGFRAME: agree_frame f j ls (parent_locset cs) m sp m' sp' (parent_sp cs') (parent_ra cs')) + (TAIL: is_tail c (Linear.fn_code f)), + match_states (Linear.State cs f (Vptr sp Int.zero) c ls m) + (Machconcr.State cs' fb (Vptr sp' Int.zero) (transl_code (make_env (function_bounds f)) c) rs m') | match_states_call: - forall s f ls m ts tf rs - (STACKS: match_stacks s ts) + forall cs f ls m cs' fb rs m' j tf + (MINJ: Mem.inject j m m') + (STACKS: match_stacks j m m' cs cs' (Linear.funsig f) (Mem.nextblock m) (Mem.nextblock m')) (TRANSL: transf_fundef f = OK tf) + (FIND: Genv.find_funct_ptr tge fb = Some tf) (WTF: wt_fundef f) - (AG1: forall r, rs r = ls (R r)) - (AG2: forall ofs ty, - In (S (Outgoing ofs ty)) (loc_arguments (Linear.funsig f)) -> - get_parent_slot ts ofs ty (ls (S (Outgoing ofs ty)))) - (AG3: agree_callee_save ls (parent_locset s)), - match_states (Linear.Callstate s f ls m) - (Machabstr.Callstate ts tf rs m) + (WTLS: wt_locset ls) + (AGREGS: agree_regs j ls rs) + (AGLOCS: agree_callee_save ls (parent_locset cs)), + match_states (Linear.Callstate cs f ls m) + (Machconcr.Callstate cs' fb rs m') | match_states_return: - forall s ls m ts rs - (STACKS: match_stacks s ts) - (AG1: forall r, rs r = ls (R r)) - (AG2: agree_callee_save ls (parent_locset s)), - match_states (Linear.Returnstate s ls m) - (Machabstr.Returnstate ts rs m). + forall cs ls m cs' rs m' j sg + (MINJ: Mem.inject j m m') + (STACKS: match_stacks j m m' cs cs' sg (Mem.nextblock m) (Mem.nextblock m')) + (WTLS: wt_locset ls) + (AGREGS: agree_regs j ls rs) + (AGLOCS: agree_callee_save ls (parent_locset cs)), + match_states (Linear.Returnstate cs ls m) + (Machconcr.Returnstate cs' rs m'). Theorem transf_step_correct: forall s1 t s2, Linear.step ge s1 t s2 -> forall s1' (MS: match_states s1 s1'), - exists s2', plus step tge s1' t s2' /\ match_states s2 s2'. + exists s2', plus Machconcr.step tge s1' t s2' /\ match_states s2 s2'. Proof. assert (RED: forall f i c, transl_code (make_env (function_bounds f)) (i :: c) = @@ -1428,142 +2263,209 @@ Proof. induction 1; intros; try inv MS; try rewrite RED; - try (generalize (WTF _ (INCL _ (in_eq _ _))); intro WTI); - try (generalize (function_is_within_bounds f WTF _ (INCL _ (in_eq _ _))); + try (generalize (WTF _ (is_tail_in TAIL)); intro WTI); + try (generalize (function_is_within_bounds f WTF _ (is_tail_in TAIL)); intro BOUND; simpl in BOUND); unfold transl_instr. + (* Lgetstack *) inv WTI. destruct BOUND. unfold undef_getstack; destruct sl. (* Lgetstack, local *) - exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) - (rs0#r <- (rs (S (Local z t)))) fr m); split. - apply plus_one. apply exec_Mgetstack. - apply get_slot_index. auto. apply index_local_valid. auto. congruence. congruence. auto. - eapply agree_locals; eauto. - econstructor; eauto with coqlib. - apply agree_set_reg; auto. + exploit agree_locals; eauto. intros [v [A B]]. + econstructor; split. + apply plus_one. apply exec_Mgetstack. + eapply index_contains_load_stack; eauto. + econstructor; eauto with coqlib. + apply agree_regs_set_reg; auto. + apply agree_frame_set_reg; auto. simpl; rewrite <- H1. eapply agree_wt_ls; eauto. (* Lgetstack, incoming *) - exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) - (rs0 # IT1 <- Vundef # r <- (rs (S (Incoming z t)))) fr m); split. - apply plus_one. apply exec_Mgetparam. - change (get_parent_slot ts z t (rs (S (Incoming z t)))). - eapply agree_incoming; eauto. - econstructor; eauto with coqlib. - apply agree_set_reg; auto. apply agree_undef_getparam; auto. + red in H2. exploit incoming_slot_in_parameters; eauto. intros IN_ARGS. + inv STACKS. elim (H6 _ IN_ARGS). + exploit agree_outgoing. eexact FRM. eapply ARGS; eauto. + intros [v [A B]]. + econstructor; split. + apply plus_one. eapply exec_Mgetparam; eauto. + rewrite (unfold_transf_function _ _ TRANSL). unfold fn_link_ofs. + eapply index_contains_load_stack with (idx := FI_link). eauto. eapply agree_link; eauto. + simpl parent_sp. + change (offset_of_index (make_env (function_bounds f)) (FI_arg z t)) + with (offset_of_index (make_env (function_bounds f0)) (FI_arg z t)). + eapply index_contains_load_stack with (idx := FI_arg z t). eauto. eauto. + exploit agree_incoming; eauto. intros EQ; simpl in EQ. + econstructor; eauto with coqlib. econstructor; eauto. + apply agree_regs_set_reg. apply agree_regs_set_reg. auto. auto. congruence. + eapply agree_frame_set_reg; eauto. eapply agree_frame_set_reg; eauto. + apply temporary_within_bounds. unfold temporaries; auto with coqlib. + simpl; auto. simpl; rewrite <- H1. eapply agree_wt_ls; eauto. (* Lgetstack, outgoing *) - exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) - (rs0#r <- (rs (S (Outgoing z t)))) fr m); split. - apply plus_one. apply exec_Mgetstack. - apply get_slot_index. auto. apply index_arg_valid. auto. congruence. congruence. auto. - eapply agree_outgoing; eauto. - econstructor; eauto with coqlib. - apply agree_set_reg; auto. - - (* Lsetstack *) - inv WTI. destruct sl. - - (* Lsetstack, local *) - generalize (agree_set_local _ _ TRANSL _ _ _ _ _ (rs0 r) _ _ AG BOUND). - intros [fr' [SET AG']]. + exploit agree_outgoing; eauto. intros [v [A B]]. econstructor; split. - apply plus_one. eapply exec_Msetstack; eauto. + apply plus_one. apply exec_Mgetstack. + eapply index_contains_load_stack; eauto. econstructor; eauto with coqlib. - replace (rs (R r)) with (rs0 r). auto. - symmetry. eapply agree_reg; eauto. - (* Lsetstack, incoming *) - contradiction. - (* Lsetstack, outgoing *) - generalize (agree_set_outgoing _ _ TRANSL _ _ _ _ _ (rs0 r) _ _ AG BOUND). - intros [fr' [SET AG']]. + apply agree_regs_set_reg; auto. + apply agree_frame_set_reg; auto. simpl; rewrite <- H1; eapply agree_wt_ls; eauto. + + (* Lsetstack *) + inv WTI. + set (idx := match sl with + | Local ofs ty => FI_local ofs ty + | Incoming ofs ty => FI_link (*dummy*) + | Outgoing ofs ty => FI_arg ofs ty + end). + assert (index_valid f idx). + unfold idx; destruct sl. + apply index_local_valid; auto. + red; auto. + apply index_arg_valid; auto. + exploit store_index_succeeds; eauto. eapply agree_perm; eauto. + instantiate (1 := rs0 r). intros [m1' STORE]. econstructor; split. - apply plus_one. eapply exec_Msetstack; eauto. + apply plus_one. destruct sl; simpl in H3. + econstructor. eapply store_stack_succeeds with (idx := idx); eauto. + contradiction. + econstructor. eapply store_stack_succeeds with (idx := idx); eauto. econstructor; eauto with coqlib. - replace (rs (R r)) with (rs0 r). auto. - symmetry. eapply agree_reg; eauto. + eapply Mem.store_outside_inject; eauto. + intros. exploit agree_inj_unique; eauto. intros [EQ1 EQ2]; subst b' delta. + rewrite (agree_bounds _ _ _ _ _ _ _ _ _ _ AGFRAME). unfold fst, snd. rewrite Zplus_0_l. + rewrite size_type_chunk. + exploit offset_of_index_disj_stack_data_2; eauto. + omega. + apply match_stacks_change_mach_mem with m'; auto. + eauto with mem. eauto with mem. intros. rewrite <- H4; eapply Mem.load_store_other; eauto. left; unfold block; omega. + apply agree_regs_set_slot; auto. + destruct sl. + eapply agree_frame_set_local; eauto. simpl in H1; rewrite H1; eapply agree_wt_ls; eauto. + simpl in H3; contradiction. + eapply agree_frame_set_outgoing; eauto. simpl in H1; rewrite H1; eapply agree_wt_ls; eauto. (* Lop *) - set (op' := transl_op (make_env (function_bounds f)) op). - exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) ((undef_op op' rs0)#res <- v) fr m); split. - apply plus_one. apply exec_Mop. - apply shift_eval_operation. auto. - change mreg with RegEq.t. - rewrite (agree_eval_regs _ _ _ _ _ _ _ args AG). auto. + assert (Val.has_type v (mreg_type res)). + inv WTI. simpl in H. inv H. rewrite <- H1. eapply agree_wt_ls; eauto. + replace (mreg_type res) with (snd (type_of_operation op)). + eapply type_of_operation_sound; eauto. + rewrite <- H4; auto. + assert (exists v', + eval_operation ge (Vptr sp' Int.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 match_stacks_preserves_globals; eauto. + eapply agree_inj; eauto. eapply agree_reglist; eauto. + destruct H1 as [v' [A B]]. + econstructor; split. + apply plus_one. constructor. + instantiate (1 := v'). rewrite <- A. apply eval_operation_preserved. + exact symbols_preserved. econstructor; eauto with coqlib. - apply agree_set_reg; auto. apply agree_undef_op; auto. + apply agree_regs_set_reg; auto. apply agree_regs_undef_op; auto. + apply agree_frame_set_reg; auto. apply agree_frame_undef_op; auto. (* Lload *) - exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) ((undef_temps rs0)#dst <- v) fr m); split. - apply plus_one; eapply exec_Mload; eauto. - apply shift_eval_addressing; auto. - change mreg with RegEq.t. - rewrite (agree_eval_regs _ _ _ _ _ _ _ args AG). eauto. + assert (exists a', + eval_addressing ge (Vptr sp' Int.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a' + /\ val_inject j a a'). + eapply eval_addressing_inject; eauto. + eapply match_stacks_preserves_globals; eauto. + eapply agree_inj; eauto. eapply agree_reglist; eauto. + destruct H1 as [a' [A B]]. + exploit Mem.loadv_inject; eauto. intros [v' [C D]]. + econstructor; split. + apply plus_one. econstructor. + instantiate (1 := a'). rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. + eexact C. econstructor; eauto with coqlib. - apply agree_set_reg; auto. apply agree_undef_temps; auto. + apply agree_regs_set_reg; auto. apply agree_regs_undef_temps; auto. + apply agree_frame_set_reg; auto. apply agree_frame_undef_temps; auto. + simpl. inv WTI. rewrite H6. + inv B; simpl in H0; try discriminate. eapply Mem.load_type; eauto. (* Lstore *) + assert (exists a', + eval_addressing ge (Vptr sp' Int.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a' + /\ val_inject j a a'). + eapply eval_addressing_inject; eauto. + eapply match_stacks_preserves_globals; eauto. + eapply agree_inj; eauto. eapply agree_reglist; eauto. + destruct H1 as [a' [A B]]. + exploit Mem.storev_mapped_inject; eauto. intros [m1' [C D]]. + econstructor; split. + apply plus_one. econstructor. + instantiate (1 := a'). rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. + eexact C. + econstructor; eauto with coqlib. + eapply match_stacks_parallel_stores. eexact MINJ. eexact B. eauto. eauto. auto. + apply agree_regs_undef_temps; auto. + apply agree_frame_undef_temps; auto. + eapply agree_frame_parallel_stores; eauto. + + (* Lcall *) + exploit find_function_translated; eauto. intros [bf [tf' [A [B C]]]]. + exploit is_tail_transf_function; eauto. intros IST. simpl in IST. + exploit Asmgenretaddr.return_address_exists. eexact IST. + intros [ra D]. econstructor; split. - apply plus_one; eapply exec_Mstore; eauto. - apply shift_eval_addressing; eauto. - change mreg with RegEq.t. - rewrite (agree_eval_regs _ _ _ _ _ _ _ args AG). eauto. - rewrite (agree_eval_reg _ _ _ _ _ _ _ src AG). eauto. - econstructor; eauto with coqlib. apply agree_undef_temps; auto. - - (* Lcall *) - assert (WTF': wt_fundef f'). eapply find_function_well_typed; eauto. - exploit find_function_translated; eauto. - intros [tf' [FIND' TRANSL']]. - econstructor; split. - apply plus_one; eapply exec_Mcall; eauto. - econstructor; eauto. + apply plus_one. econstructor; eauto. + econstructor; eauto. econstructor; eauto with coqlib. - exists rs0; auto. - intro. symmetry. eapply agree_reg; eauto. - intros. - assert (slot_within_bounds f (function_bounds f) (Outgoing ofs ty)). - red. simpl. generalize (loc_arguments_bounded _ _ _ H0). - generalize (loc_arguments_acceptable _ _ H0). unfold loc_argument_acceptable. - omega. - unfold get_parent_slot, parent_function, parent_frame. - change (fe_ofs_arg + 4 * ofs) - with (offset_of_index (make_env (function_bounds f)) (FI_arg ofs ty)). - apply get_slot_index. auto. apply index_arg_valid. auto. congruence. congruence. auto. - eapply agree_outgoing; eauto. - simpl. red; auto. - - (* Ltailcall *) - assert (WTF': wt_fundef f'). eapply find_function_well_typed; eauto. - exploit find_function_translated; eauto. - intros [tf' [FIND' TRANSL']]. - generalize (restore_callee_save_correct ts _ _ TRANSL - (shift_sp tf (Vptr stk Int.zero)) - (Mtailcall (Linear.funsig f') ros :: transl_code (make_env (function_bounds f)) b) - _ m _ _ _ _ AG). - intros [rs2 [A [B C]]]. - assert (FIND'': find_function tge ros rs2 = Some tf'). - rewrite <- FIND'. destruct ros; simpl; auto. - inv WTI. rewrite C. auto. - simpl. intuition congruence. simpl. intuition congruence. + simpl; auto. + intros; red. split. + generalize (loc_arguments_acceptable _ _ H0). simpl. omega. + apply Zle_trans with (size_arguments (Linear.funsig f')); auto. + apply loc_arguments_bounded; auto. + eapply agree_valid_linear; eauto. + eapply agree_valid_mach; eauto. + eapply find_function_well_typed; eauto. + eapply agree_wt_ls; eauto. + simpl; red; auto. + + (* Ltailcall *) + exploit find_function_translated; eauto. intros [bf [tf' [A [B C]]]]. + exploit function_epilogue_correct; eauto. + intros [rs1 [m1' [P [Q [R [S [T [U [V W]]]]]]]]]. econstructor; split. - eapply plus_right. eexact A. - simpl shift_sp. eapply exec_Mtailcall; eauto. - rewrite (stacksize_preserved _ _ TRANSL); eauto. + eapply plus_right. eexact S. econstructor; eauto. + replace (find_function_ptr tge ros rs1) + with (find_function_ptr tge ros rs0). eauto. + destruct ros; simpl; auto. inv WTI. rewrite V; auto. traceEq. - econstructor; eauto. - intros; symmetry; eapply agree_return_regs; eauto. - intros. inv WTI. generalize (H4 _ H0). tauto. - apply agree_callee_save_return_regs. + econstructor; eauto. + inv WTI. apply match_stacks_change_sig with (Linear.fn_sig f); auto. + apply match_stacks_change_bounds with stk sp'. + apply match_stacks_change_linear_mem with m. + apply match_stacks_change_mach_mem with m'0. + auto. + eauto with mem. intros. eapply Mem.perm_free_1; eauto. left; unfold block; omega. + intros. rewrite <- H2. eapply Mem.load_free; eauto. left; unfold block; omega. + eauto with mem. intros. eapply Mem.bounds_free; eauto. + apply Zlt_le_weak. change (Mem.valid_block m' stk). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_linear; eauto. + apply Zlt_le_weak. change (Mem.valid_block m1' sp'). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_mach; eauto. + eapply find_function_well_typed; eauto. + apply wt_return_regs; auto. eapply match_stacks_wt_locset; eauto. eapply agree_wt_ls; eauto. (* Lbuiltin *) + exploit external_call_mem_inject; eauto. + eapply match_stacks_preserves_globals; eauto. + eapply agree_reglist; eauto. + intros [j' [res' [m1' [A [B [C [D [E [F G]]]]]]]]]. econstructor; split. - apply plus_one. apply exec_Mbuiltin. - change mreg with RegEq.t. - rewrite (agree_eval_regs _ _ _ _ _ _ _ args AG). + apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact varinfo_preserved. econstructor; eauto with coqlib. - apply agree_set_reg; auto. apply agree_undef_temps; auto. - + eapply match_stack_change_extcall; eauto. + apply Zlt_le_weak. change (Mem.valid_block m sp0). eapply agree_valid_linear; eauto. + apply Zlt_le_weak. change (Mem.valid_block m'0 sp'). eapply agree_valid_mach; eauto. + apply agree_regs_set_reg; auto. apply agree_regs_undef_temps; auto. eapply agree_regs_inject_incr; eauto. + apply agree_frame_set_reg; auto. apply agree_frame_undef_temps; auto. + eapply agree_frame_inject_incr; eauto. + apply agree_frame_extcall_invariant with m m'0; auto. + eapply external_call_valid_block; eauto. + eapply external_call_bounds; eauto. eapply agree_valid_linear; eauto. + eapply external_call_valid_block; eauto. + eapply agree_valid_mach; eauto. + inv WTI. simpl; rewrite H4. eapply external_call_well_typed; eauto. + (* Llabel *) econstructor; split. apply plus_one; apply exec_Mlabel. @@ -1571,124 +2473,160 @@ Proof. (* Lgoto *) econstructor; split. - apply plus_one; apply exec_Mgoto. + apply plus_one; eapply exec_Mgoto; eauto. apply transl_find_label; eauto. econstructor; eauto. - eapply find_label_incl; eauto. + eapply find_label_tail; eauto. (* Lcond, true *) econstructor; split. - apply plus_one; apply exec_Mcond_true. - rewrite <- (agree_eval_regs _ _ _ _ _ _ _ args AG) in H; eauto. - apply transl_find_label; eauto. - econstructor; eauto. apply agree_undef_temps; auto. - eapply find_label_incl; eauto. + apply plus_one. eapply exec_Mcond_true; eauto. + eapply eval_condition_inject; eauto. eapply agree_reglist; eauto. + eapply transl_find_label; eauto. + econstructor; eauto with coqlib. + apply agree_regs_undef_temps; auto. + apply agree_frame_undef_temps; auto. + eapply find_label_tail; eauto. (* Lcond, false *) econstructor; split. - apply plus_one; apply exec_Mcond_false. - rewrite <- (agree_eval_regs _ _ _ _ _ _ _ args AG) in H; auto. - econstructor; eauto with coqlib. apply agree_undef_temps; auto. + apply plus_one. eapply exec_Mcond_false; eauto. + eapply eval_condition_inject; eauto. eapply agree_reglist; eauto. + econstructor; eauto with coqlib. + apply agree_regs_undef_temps; auto. + apply agree_frame_undef_temps; auto. (* Ljumptable *) + assert (rs0 arg = Vint n). + generalize (AGREGS arg). rewrite H. intro IJ; inv IJ; auto. econstructor; split. - apply plus_one; eapply exec_Mjumptable. - rewrite <- (agree_eval_reg _ _ _ _ _ _ _ arg AG) in H; eauto. - eauto. + apply plus_one; eapply exec_Mjumptable; eauto. apply transl_find_label; eauto. - econstructor; eauto. apply agree_undef_temps; auto. - eapply find_label_incl; eauto. + econstructor; eauto. + apply agree_regs_undef_temps; auto. + apply agree_frame_undef_temps; auto. + eapply find_label_tail; eauto. (* Lreturn *) - exploit restore_callee_save_correct; eauto. - intros [ls' [A [B C]]]. + exploit function_epilogue_correct; eauto. + intros [rs1 [m1' [P [Q [R [S [T [U [V W]]]]]]]]]. econstructor; split. - eapply plus_right. eauto. - simpl shift_sp. econstructor; eauto. - rewrite (stacksize_preserved _ _ TRANSL); eauto. + eapply plus_right. eexact S. econstructor; eauto. traceEq. - econstructor; eauto. - intros. symmetry. eapply agree_return_regs; eauto. - apply agree_callee_save_return_regs. + econstructor; eauto. + apply match_stacks_change_bounds with stk sp'. + apply match_stacks_change_linear_mem with m. + apply match_stacks_change_mach_mem with m'0. + eauto. + eauto with mem. intros. eapply Mem.perm_free_1; eauto. left; unfold block; omega. + intros. rewrite <- H1. eapply Mem.load_free; eauto. left; unfold block; omega. + eauto with mem. intros. eapply Mem.bounds_free; eauto. + apply Zlt_le_weak. change (Mem.valid_block m' stk). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_linear; eauto. + apply Zlt_le_weak. change (Mem.valid_block m1' sp'). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_mach; eauto. + apply wt_return_regs; auto. eapply match_stacks_wt_locset; eauto. eapply agree_wt_ls; eauto. (* internal function *) - generalize TRANSL; clear TRANSL. - unfold transf_fundef, transf_partial_fundef. + revert TRANSL. unfold transf_fundef, transf_partial_fundef. caseEq (transf_function f); simpl; try congruence. intros tfn TRANSL EQ. inversion EQ; clear EQ; subst tf. inversion WTF as [|f' WTFN]. subst f'. - set (sp := Vptr stk Int.zero) in *. - set (tsp := shift_sp tfn sp). - set (fe := make_env (function_bounds f)). - exploit save_callee_save_correct; eauto. - intros [fr [EXP AG]]. + exploit function_prologue_correct; eauto. + eapply match_stacks_type_sp; eauto. + eapply match_stacks_type_retaddr; eauto. + intros [j' [m2' [sp' [m3' [m4' [m5' [A [B [C [D [E [F [G [J [K L]]]]]]]]]]]]]]]. econstructor; split. - eapply plus_left. - eapply exec_function_internal; eauto. - rewrite (unfold_transf_function f tfn TRANSL); simpl; eexact H. - replace (Mach.fn_code tfn) with - (transl_body f (make_env (function_bounds f))). - replace (Vptr stk (Int.repr (- fn_framesize tfn))) with tsp. - unfold transl_body. eexact EXP. - unfold tsp, shift_sp, sp. unfold Val.add. - rewrite Int.add_commut. rewrite Int.add_zero. auto. - rewrite (unfold_transf_function f tfn TRANSL). simpl. auto. - traceEq. - unfold tsp. econstructor; eauto with coqlib. - eapply agree_callee_save_agree; eauto. + eapply plus_left. econstructor; eauto. + rewrite (unfold_transf_function _ _ TRANSL). unfold fn_code. unfold transl_body. + eexact D. traceEq. + generalize (Mem.alloc_result _ _ _ _ _ H). intro SP_EQ. + generalize (Mem.alloc_result _ _ _ _ _ A). intro SP'_EQ. + econstructor; eauto. + apply match_stacks_change_mach_mem with m'0. + apply match_stacks_change_linear_mem with m. + rewrite SP_EQ; rewrite SP'_EQ. + eapply match_stacks_change_meminj; eauto. omega. + eauto with mem. intros. eapply Mem.bounds_alloc_other; eauto. unfold block; omega. + intros. eapply stores_in_frame_valid; eauto with mem. + intros. eapply stores_in_frame_perm; eauto with mem. + intros. rewrite <- H1. transitivity (Mem.load chunk m2' b ofs). eapply stores_in_frame_contents; eauto. + eapply Mem.load_alloc_unchanged; eauto. red. congruence. + auto with coqlib. (* external function *) simpl in TRANSL. inversion TRANSL; subst tf. inversion WTF. subst ef0. - exploit transl_external_arguments; eauto. intro EXTARGS. + exploit transl_external_arguments; eauto. intros [vl [ARGS VINJ]]. + exploit external_call_mem_inject; eauto. + eapply match_stacks_preserves_globals; eauto. + intros [j' [res' [m1' [A [B [C [D [E [F G]]]]]]]]]. econstructor; split. apply plus_one. eapply exec_function_external; eauto. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact varinfo_preserved. econstructor; eauto. - intros. unfold Regmap.set. case (RegEq.eq r (loc_result (ef_sig ef))); intro. - rewrite e. rewrite Locmap.gss; auto. rewrite Locmap.gso; auto. - red; auto. - apply agree_callee_save_set_result; auto. + apply match_stacks_change_bounds with (Mem.nextblock m) (Mem.nextblock m'0). + eapply match_stack_change_extcall; eauto. omega. omega. + exploit external_call_valid_block. eexact H. + instantiate (1 := (Mem.nextblock m - 1)). red; omega. unfold Mem.valid_block; omega. + exploit external_call_valid_block. eexact A. + instantiate (1 := (Mem.nextblock m'0 - 1)). red; omega. unfold Mem.valid_block; omega. + apply wt_setloc; auto. simpl. rewrite loc_result_type. + change (Val.has_type res (proj_sig_res (ef_sig ef))). + eapply external_call_well_typed; eauto. + apply agree_regs_set_reg; auto. apply agree_regs_inject_incr with j; auto. + apply agree_callee_save_set_result; auto. (* return *) - inv STACKS. + inv STACKS. simpl in AGLOCS. econstructor; split. apply plus_one. apply exec_return. - econstructor; eauto. simpl in AG2. - eapply agree_frame_agree; eauto. + econstructor; eauto. + apply agree_frame_return with rs0; auto. Qed. Lemma transf_initial_states: forall st1, Linear.initial_state prog st1 -> - exists st2, Machabstr.initial_state tprog st2 /\ match_states st1 st2. + exists st2, Machconcr.initial_state tprog st2 /\ match_states st1 st2. Proof. - intros. inversion H. + intros. inv H. exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. econstructor; split. econstructor. eapply Genv.init_mem_transf_partial; eauto. rewrite (transform_partial_program_main _ _ TRANSF). rewrite symbols_preserved. eauto. - eauto. - econstructor; eauto. constructor. - eapply Genv.find_funct_ptr_prop; eauto. - intros. rewrite H3 in H5. simpl in H5. contradiction. - simpl; red; auto. + econstructor; eauto. + eapply Genv.initmem_inject; eauto. + apply match_stacks_empty with (Mem.nextblock m0). omega. omega. + constructor. + apply Mem.nextblock_pos. + intros. unfold Mem.flat_inj. apply zlt_true; auto. + unfold Mem.flat_inj; intros. destruct (zlt b1 (Mem.nextblock m0)); congruence. + intros. change (Mem.valid_block m0 b0). eapply Genv.find_symbol_not_fresh; eauto. + intros. change (Mem.valid_block m0 b0). eapply Genv.find_var_info_not_fresh; eauto. + rewrite H3. red; intros. contradiction. + eapply Genv.find_funct_ptr_prop. eexact wt_prog. + fold ge0; eauto. + apply wt_init. + unfold Locmap.init. red; intros; auto. + unfold parent_locset. red; auto. Qed. Lemma transf_final_states: forall st1 st2 r, - match_states st1 st2 -> Linear.final_state st1 r -> Machabstr.final_state st2 r. + match_states st1 st2 -> Linear.final_state st1 r -> Machconcr.final_state st2 r. Proof. - intros. inv H0. inv H. inv STACKS. econstructor. rewrite AG1; auto. + intros. inv H0. inv H. inv STACKS. + constructor. + set (rres := loc_result {| sig_args := nil; sig_res := Some Tint |}) in *. + generalize (AGREGS rres). rewrite H1. intros IJ; inv IJ. auto. Qed. Theorem transf_program_correct: forall (beh: program_behavior), not_wrong beh -> - Linear.exec_program prog beh -> Machabstr.exec_program tprog beh. + Linear.exec_program prog beh -> Machconcr.exec_program tprog beh. Proof. - unfold Linear.exec_program, Machabstr.exec_program; intros. + unfold Linear.exec_program, Machconcr.exec_program; intros. eapply simulation_plus_preservation; eauto. eexact transf_initial_states. eexact transf_final_states. diff --git a/backend/Stackingtyping.v b/backend/Stackingtyping.v index b42dbbb..d00d1b2 100644 --- a/backend/Stackingtyping.v +++ b/backend/Stackingtyping.v @@ -204,42 +204,20 @@ Lemma wt_transf_function: wt_function tf. Proof. intros. - generalize H; unfold transf_function. - case (zlt (Linear.fn_stacksize f) 0); intro. - intros; discriminate. - case (zlt (- Int.min_signed) (fe_size (make_env (function_bounds f)))); intro. - intros; discriminate. intro EQ. - generalize (unfold_transf_function f tf H); intro. + exploit unfold_transf_function; eauto. intro EQ. set (b := function_bounds f) in *. set (fe := make_env b) in *. - assert (fn_framesize tf = fe_size fe). - subst tf; reflexivity. - assert (Int.signed tf.(fn_link_ofs) = offset_of_index fe FI_link). - rewrite H1; unfold fn_link_ofs. - change (fe_ofs_link fe) with (offset_of_index fe FI_link). - unfold fe, b; eapply offset_of_index_no_overflow. eauto. red; auto. - assert (Int.signed tf.(fn_retaddr_ofs) = offset_of_index fe FI_retaddr). - rewrite H1; unfold fn_retaddr_ofs. - change (fe_ofs_retaddr fe) with (offset_of_index fe FI_retaddr). - unfold fe, b; eapply offset_of_index_no_overflow. eauto. red; auto. constructor. change (wt_instrs (fn_code tf)). - rewrite H1; simpl; unfold transl_body. + rewrite EQ; simpl; unfold transl_body. unfold fe, b; apply wt_save_callee_save; auto. unfold transl_code. apply wt_fold_right. intros. eapply wt_transl_instr; eauto. - red; intros. elim H5. - subst tf; simpl; auto. - rewrite H2. generalize (size_pos f). fold b; fold fe; omega. - rewrite H1. change (4 | fe_size fe). unfold fe, b. apply frame_size_aligned. - rewrite H3; rewrite H2. change 4 with (4 * typesize (type_of_index FI_link)). - unfold fe, b; apply offset_of_index_valid. red; auto. - rewrite H3. unfold fe,b; apply offset_of_index_aligned. - rewrite H4; rewrite H2. change 4 with (4 * typesize (type_of_index FI_retaddr)). - unfold fe, b; apply offset_of_index_valid. red; auto. - rewrite H4. unfold fe,b; apply offset_of_index_aligned. - rewrite H3; rewrite H4. - apply (offset_of_index_disj f FI_retaddr FI_link); red; auto. + red; intros. elim H1. + rewrite EQ; unfold fn_stacksize. + generalize (size_pos f). + generalize (size_no_overflow _ _ H). + unfold fe, b. omega. Qed. Lemma wt_transf_fundef: diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index 11e6be2..ca8e915 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -512,14 +512,14 @@ Proof. TransfInstr. left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) ifso rs' m'); split. eapply exec_Icond_true; eauto. - apply eval_condition_lessdef with (rs##args); auto. apply regset_get_list; auto. + apply eval_condition_lessdef with (rs##args) m; auto. apply regset_get_list; auto. constructor; auto. (* cond false *) TransfInstr. left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) ifnot rs' m'); split. eapply exec_Icond_false; eauto. - apply eval_condition_lessdef with (rs##args); auto. apply regset_get_list; auto. + apply eval_condition_lessdef with (rs##args) m; auto. apply regset_get_list; auto. constructor; auto. (* jumptable *) diff --git a/cfrontend/Cminorgen.v b/cfrontend/Cminorgen.v index 22c3a5a..c293efb 100644 --- a/cfrontend/Cminorgen.v +++ b/cfrontend/Cminorgen.v @@ -489,7 +489,7 @@ Definition transl_funbody Definition transl_function (gce: compilenv) (f: Csharpminor.function): res function := let (cenv, stacksize) := build_compilenv gce f in - if zle stacksize Int.max_signed + if zle stacksize Int.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 480acbb..ba51310 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 gce f). - case (zle z Int.max_signed); simpl bind; try congruence. + case (zle z Int.max_unsigned); simpl bind; try congruence. intros. monadInv H. simpl. eapply sig_preserved_body; eauto. intro. inv H. reflexivity. Qed. @@ -1265,7 +1265,7 @@ Lemma eval_binop_compat: val_inject f v2 tv2 -> Mem.inject f m tm -> exists tv, - Cminor.eval_binop op tv1 tv2 = Some tv + Cminor.eval_binop op tv1 tv2 tm = Some tv /\ val_inject f v tv. Proof. destruct op; simpl; intros. @@ -1302,19 +1302,25 @@ Proof. inv H0; try discriminate; inv H1; inv H; TrivialOp. inv H0; try discriminate; inv H1; inv H; TrivialOp. inv H0; try discriminate; inv H1; inv H; TrivialOp. - exists v; split; auto. eapply val_inject_eval_compare_null; eauto. - exists v; split; auto. eapply val_inject_eval_compare_null; eauto. - (* cmp ptr ptr *) - caseEq (Mem.valid_pointer m b1 (Int.signed ofs1) && Mem.valid_pointer m b0 (Int.signed ofs0)); +(* cmpu *) + inv H0; try discriminate; inv H1; inv H; TrivialOp. + exists v; split; auto. eapply val_inject_eval_compare_null; eauto. + exists v; split; auto. eapply val_inject_eval_compare_null; eauto. + (* cmpu ptr ptr *) + caseEq (Mem.valid_pointer m b1 (Int.unsigned ofs1) && Mem.valid_pointer m b0 (Int.unsigned ofs0)); intro EQ; rewrite EQ in H4; try discriminate. elim (andb_prop _ _ EQ); intros. + exploit Mem.valid_pointer_inject_val. eauto. eexact H. econstructor; eauto. + intros V1. rewrite V1. + exploit Mem.valid_pointer_inject_val. eauto. eexact H1. econstructor; eauto. + intros V2. rewrite V2. simpl. destruct (eq_block b1 b0); inv H4. (* same blocks in source *) assert (b3 = b2) by congruence. subst b3. assert (delta0 = delta) by congruence. subst delta0. - exists (Val.of_bool (Int.cmp c ofs1 ofs0)); split. + exists (Val.of_bool (Int.cmpu c ofs1 ofs0)); split. unfold eq_block; rewrite zeq_true; simpl. - decEq. decEq. rewrite Int.translate_cmp. auto. + decEq. decEq. rewrite Int.translate_cmpu. auto. eapply Mem.valid_pointer_inject_no_overflow; eauto. eapply Mem.valid_pointer_inject_no_overflow; eauto. apply val_inject_val_of_bool. @@ -1323,13 +1329,11 @@ Proof. destruct (eq_block b2 b3); auto. exploit Mem.different_pointers_inject; eauto. intros [A|A]. congruence. - decEq. destruct c; simpl in H6; inv H6; unfold Int.cmp. + decEq. destruct c; simpl in H6; inv H6; unfold Int.cmpu. predSpec Int.eq Int.eq_spec (Int.add ofs1 (Int.repr delta)) (Int.add ofs0 (Int.repr delta0)). congruence. auto. predSpec Int.eq Int.eq_spec (Int.add ofs1 (Int.repr delta)) (Int.add ofs0 (Int.repr delta0)). congruence. auto. - (* cmpu *) - inv H0; try discriminate; inv H1; inv H; TrivialOp. (* cmpf *) inv H0; try discriminate; inv H1; inv H; TrivialOp. Qed. @@ -1831,7 +1835,7 @@ Lemma match_callstack_alloc_variable: Mem.valid_block tm sp -> Mem.bounds tm sp = (0, tf.(fn_stackspace)) -> Mem.range_perm tm sp 0 tf.(fn_stackspace) Freeable -> - tf.(fn_stackspace) <= Int.max_signed -> + tf.(fn_stackspace) <= Int.max_unsigned -> Mem.alloc m 0 (sizeof lv) = (m', b) -> match_callstack f m tm (Frame cenv tf e le te sp lo (Mem.nextblock m) :: cs) @@ -1862,9 +1866,8 @@ Proof. generalize (align_le sz (size_chunk chunk) SIZEPOS). fold ofs. intro SZOFS. exploit Mem.alloc_left_mapped_inject. eauto. eauto. eauto. - instantiate (1 := ofs). - generalize Int.min_signed_neg. omega. - right; rewrite BOUNDS; simpl. generalize Int.min_signed_neg. omega. + instantiate (1 := ofs). omega. + right; rewrite BOUNDS; simpl. omega. intros. apply Mem.perm_implies with Freeable; auto with mem. apply PERMS. rewrite LV in H1. simpl in H1. omega. rewrite LV; simpl. rewrite Zminus_0_r. unfold ofs. @@ -1923,7 +1926,7 @@ Lemma match_callstack_alloc_variables_rec: Mem.valid_block tm sp -> Mem.bounds tm sp = (0, tf.(fn_stackspace)) -> Mem.range_perm tm sp 0 tf.(fn_stackspace) Freeable -> - tf.(fn_stackspace) <= Int.max_signed -> + tf.(fn_stackspace) <= Int.max_unsigned -> forall e m vars e' m', alloc_variables e m vars e' m' -> forall f cenv sz, @@ -2016,7 +2019,7 @@ Qed. Lemma match_callstack_alloc_variables: forall fn cenv tf m e m' tm tm' sp f cs targs, build_compilenv gce fn = (cenv, tf.(fn_stackspace)) -> - tf.(fn_stackspace) <= Int.max_signed -> + tf.(fn_stackspace) <= Int.max_unsigned -> list_norepet (fn_params_names fn ++ fn_vars_names fn) -> alloc_variables Csharpminor.empty_env m (fn_variables fn) e m' -> Mem.alloc tm 0 tf.(fn_stackspace) = (tm', sp) -> @@ -2200,7 +2203,7 @@ Lemma function_entry_ok: bind_parameters e m1 fn.(Csharpminor.fn_params) vargs m2 -> match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm) -> build_compilenv gce fn = (cenv, tf.(fn_stackspace)) -> - tf.(fn_stackspace) <= Int.max_signed -> + tf.(fn_stackspace) <= Int.max_unsigned -> Mem.alloc tm 0 tf.(fn_stackspace) = (tm1, sp) -> let tparams := List.map for_var (fn_params_names fn) in let tvars := List.map for_var (fn_vars_names fn) in @@ -2924,7 +2927,7 @@ Proof. (* internal call *) monadInv TR. generalize EQ; clear EQ; unfold transl_function. caseEq (build_compilenv gce f). intros ce sz BC. - destruct (zle sz Int.max_signed); try congruence. + destruct (zle sz Int.max_unsigned); try congruence. intro TRBODY. generalize TRBODY; intro TMP. monadInv TMP. set (tf := mkfunction (Csharpminor.fn_sig f) diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index dff5fa2..3a3ba3b 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -413,19 +413,24 @@ Function sem_cmp (c:comparison) (v1: val) (t1: type) (v2: val) (t2: type) (m: mem): option val := match classify_cmp t1 t2 with - | cmp_case_iiu => + | cmp_case_ii Signed => + match v1,v2 with + | Vint n1, Vint n2 => Some (Val.of_bool (Int.cmp c n1 n2)) + | _, _ => None + end + | cmp_case_ii Unsigned => match v1,v2 with | Vint n1, Vint n2 => Some (Val.of_bool (Int.cmpu c n1 n2)) | _, _ => None end - | cmp_case_ipip => + | cmp_case_pp => match v1,v2 with - | Vint n1, Vint n2 => Some (Val.of_bool (Int.cmp c n1 n2)) + | Vint n1, Vint n2 => Some (Val.of_bool (Int.cmpu c n1 n2)) | Vptr b1 ofs1, Vptr b2 ofs2 => - if Mem.valid_pointer m b1 (Int.signed ofs1) - && Mem.valid_pointer m b2 (Int.signed ofs2) then + if Mem.valid_pointer m b1 (Int.unsigned ofs1) + && Mem.valid_pointer m b2 (Int.unsigned ofs2) then if zeq b1 b2 - then Some (Val.of_bool (Int.cmp c ofs1 ofs2)) + then Some (Val.of_bool (Int.cmpu c ofs1 ofs2)) else sem_cmp_mismatch c else None | Vptr b ofs, Vint n => diff --git a/cfrontend/Csharpminor.v b/cfrontend/Csharpminor.v index 2f05678..d2eb3c1 100644 --- a/cfrontend/Csharpminor.v +++ b/cfrontend/Csharpminor.v @@ -267,17 +267,7 @@ Definition eval_constant (cst: constant) : option val := Definition eval_unop := Cminor.eval_unop. -Definition eval_binop (op: binary_operation) - (arg1 arg2: val) (m: mem): option val := - match op, arg1, arg2 with - | Cminor.Ocmp c, Vptr b1 n1, Vptr b2 n2 => - if Mem.valid_pointer m b1 (Int.signed n1) - && Mem.valid_pointer m b2 (Int.signed n2) - then Cminor.eval_binop op arg1 arg2 - else None - | _, _, _ => - Cminor.eval_binop op arg1 arg2 - end. +Definition eval_binop := Cminor.eval_binop. (** Allocation of local variables at function entry. Each variable is bound to the reference to a fresh block of the appropriate size. *) diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index 87dfc87..f1f7c0a 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -199,8 +199,9 @@ Definition make_shr (e1: expr) (ty1: type) (e2: expr) (ty2: type) := Definition make_cmp (c: comparison) (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_cmp ty1 ty2 with - | cmp_case_iiu => OK (Ebinop (Ocmpu c) e1 e2) - | cmp_case_ipip => OK (Ebinop (Ocmp c) e1 e2) + | cmp_case_ii Signed => OK (Ebinop (Ocmp c) e1 e2) + | cmp_case_ii Unsigned => OK (Ebinop (Ocmpu c) e1 e2) + | cmp_case_pp => OK (Ebinop (Ocmpu c) e1 e2) | cmp_case_ff => OK (Ebinop (Ocmpf c) e1 e2) | cmp_case_if sg => OK (Ebinop (Ocmpf c) (make_floatofint e1 sg) e2) | cmp_case_fi sg => OK (Ebinop (Ocmpf c) e1 (make_floatofint e2 sg)) diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index 3f6aa62..457f0d1 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -585,19 +585,21 @@ Lemma make_cmp_correct: Proof. intros until m. intro SEM. unfold make_cmp. functional inversion SEM; rewrite H0; intros. - (* iiu *) + (** ii Signed *) + inversion H8; eauto with cshm. + (* ii Unsigned *) inversion H8. eauto with cshm. - (* ipip int int *) + (* pp int int *) inversion H8. eauto with cshm. - (* ipip ptr ptr *) + (* pp ptr ptr *) inversion H10. eapply eval_Ebinop; eauto with cshm. simpl. rewrite H3. unfold eq_block. rewrite H9. auto. inversion H10. eapply eval_Ebinop; eauto with cshm. simpl. rewrite H3. unfold eq_block. rewrite H9. auto. - (* ipip ptr int *) + (* pp ptr int *) inversion H9. eapply eval_Ebinop; eauto with cshm. simpl. unfold eval_compare_null. rewrite H8. auto. - (* ipip int ptr *) + (* pp int ptr *) inversion H9. eapply eval_Ebinop; eauto with cshm. simpl. unfold eval_compare_null. rewrite H8. auto. (* ff *) diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index 8560d5e..a199f33 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -893,8 +893,8 @@ Definition classify_shift (ty1: type) (ty2: type) := end. Inductive classify_cmp_cases : Type:= - | cmp_case_iiu (**r unsigned int, unsigned int *) - | cmp_case_ipip (**r int-or-pointer, int-or-pointer *) + | cmp_case_ii(s: signedness) (**r int, int *) + | cmp_case_pp (**r pointer, pointer *) | cmp_case_ff (**r float , float *) | cmp_case_if(s: signedness) (**r int, float *) | cmp_case_fi(s: signedness) (**r float, int *) @@ -902,15 +902,15 @@ Inductive classify_cmp_cases : Type:= Definition classify_cmp (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint I32 Unsigned , Tint _ _ => cmp_case_iiu - | Tint _ _ , Tint I32 Unsigned => cmp_case_iiu - | Tint _ _ , Tint _ _ => cmp_case_ipip + | Tint I32 Unsigned , Tint _ _ => cmp_case_ii Unsigned + | Tint _ _ , Tint I32 Unsigned => cmp_case_ii Unsigned + | Tint _ _ , Tint _ _ => cmp_case_ii Signed | Tfloat _ , Tfloat _ => cmp_case_ff | Tint _ sg, Tfloat _ => cmp_case_if sg | Tfloat _, Tint _ sg => cmp_case_fi sg - | Tpointer _ , Tpointer _ => cmp_case_ipip - | Tpointer _ , Tint _ _ => cmp_case_ipip - | Tint _ _, Tpointer _ => cmp_case_ipip + | Tpointer _ , Tpointer _ => cmp_case_pp + | Tpointer _ , Tint _ _ => cmp_case_pp + | Tint _ _, Tpointer _ => cmp_case_pp | _ , _ => cmp_default end. diff --git a/cfrontend/Initializersproof.v b/cfrontend/Initializersproof.v index e8f1f9f..10206af 100644 --- a/cfrontend/Initializersproof.v +++ b/cfrontend/Initializersproof.v @@ -336,13 +336,14 @@ Lemma sem_cmp_match: match_val v1 v1' -> match_val v2 v2' -> match_val v v'. Proof. +Opaque zeq. intros. unfold sem_cmp in *. - destruct (classify_cmp ty1 ty2); inv H1; inv H2; inv H; inv H0; auto with mval. + destruct (classify_cmp ty1 ty2); try (destruct s); inv H1; inv H2; inv H; inv H0; auto with mval. destruct (Int.eq n Int.zero); try discriminate. unfold sem_cmp_mismatch in *. destruct c; inv H3; inv H2; constructor. destruct (Int.eq n Int.zero); try discriminate. unfold sem_cmp_mismatch in *. destruct c; inv H2; inv H1; constructor. - rewrite (mem_empty_not_valid_pointer (Zpos id) (Int.signed ofs)) in H4. discriminate. + rewrite (mem_empty_not_valid_pointer (Zpos id) (Int.unsigned ofs)) in H4. discriminate. Qed. Lemma sem_binary_match: diff --git a/common/Events.v b/common/Events.v index f590573..b369d46 100644 --- a/common/Events.v +++ b/common/Events.v @@ -582,7 +582,7 @@ Inductive volatile_load_sem (chunk: memory_chunk) (F V: Type) (ge: Genv.t F V): (Val.load_result chunk v) m | volatile_load_sem_nonvol: forall b ofs m v, block_is_volatile ge b = false -> - Mem.load chunk m b (Int.signed ofs) = Some v -> + Mem.load chunk m b (Int.unsigned ofs) = Some v -> volatile_load_sem chunk ge (Vptr b ofs :: nil) m E0 @@ -675,7 +675,7 @@ Inductive volatile_store_sem (chunk: memory_chunk) (F V: Type) (ge: Genv.t F V): Vundef m | volatile_store_sem_nonvol: forall b ofs m v m', block_is_volatile ge b = false -> - Mem.store chunk m b (Int.signed ofs) v = Some m' -> + Mem.store chunk m b (Int.unsigned ofs) v = Some m' -> volatile_store_sem chunk ge (Vptr b ofs :: v :: nil) m E0 @@ -719,7 +719,7 @@ Proof. generalize (size_chunk_pos chunk0). intro E. generalize (size_chunk_pos chunk). intro G. apply (Intv.range_disjoint' (ofs0, ofs0 + size_chunk chunk0) - (Int.signed ofs, Int.signed ofs + size_chunk chunk)). + (Int.unsigned ofs, Int.unsigned ofs + size_chunk chunk)). red; intros. generalize (H x H5). unfold loc_out_of_bounds, Intv.In; simpl. omega. simpl; omega. simpl; omega. @@ -746,16 +746,16 @@ Proof. split; intros. eapply Mem.perm_store_1; eauto. rewrite <- H4. eapply Mem.load_store_other; eauto. destruct (eq_block b0 b2); auto. subst b0; right. - assert (EQ: Int.signed (Int.add ofs (Int.repr delta)) = Int.signed ofs + delta). + assert (EQ: Int.unsigned (Int.add ofs (Int.repr delta)) = Int.unsigned ofs + delta). eapply Mem.address_inject; eauto with mem. - simpl in A. rewrite EQ in A. rewrite EQ. + unfold Mem.storev in A. rewrite EQ in A. rewrite EQ. exploit Mem.valid_access_in_bounds. eapply Mem.store_valid_access_3. eexact H0. intros [C D]. generalize (size_chunk_pos chunk0). intro E. generalize (size_chunk_pos chunk). intro G. apply (Intv.range_disjoint' (ofs0, ofs0 + size_chunk chunk0) - (Int.signed ofs + delta, Int.signed ofs + delta + size_chunk chunk)). + (Int.unsigned ofs + delta, Int.unsigned ofs + delta + size_chunk chunk)). red; intros. exploit (H2 x H8). eauto. unfold Intv.In; simpl. omega. simpl; omega. simpl; omega. red; intros; congruence. @@ -772,7 +772,7 @@ Qed. Inductive extcall_malloc_sem (F V: Type) (ge: Genv.t F V): list val -> mem -> trace -> val -> mem -> Prop := | extcall_malloc_sem_intro: forall n m m' b m'', - Mem.alloc m (-4) (Int.signed n) = (m', b) -> + 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''. @@ -782,7 +782,7 @@ Lemma extcall_malloc_ok: Proof. assert (UNCHANGED: forall (P: block -> Z -> Prop) m n m' b m'', - Mem.alloc m (-4) (Int.signed n) = (m', b) -> + Mem.alloc m (-4) (Int.unsigned n) = (m', b) -> Mem.store Mint32 m' b (-4) (Vint n) = Some m'' -> mem_unchanged_on P m m''). intros; split; intros. @@ -840,9 +840,9 @@ Qed. Inductive extcall_free_sem (F V: Type) (ge: Genv.t F V): list val -> mem -> trace -> val -> mem -> Prop := | extcall_free_sem_intro: forall b lo sz m m', - Mem.load Mint32 m b (Int.signed lo - 4) = Some (Vint sz) -> - Int.signed sz > 0 -> - Mem.free m b (Int.signed lo - 4) (Int.signed lo + Int.signed sz) = Some 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' -> extcall_free_sem ge (Vptr b lo :: nil) m E0 Vundef m'. Lemma extcall_free_ok: @@ -889,13 +889,13 @@ Proof. 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.signed lo - 4) (Int.signed lo + Int.signed sz) Freeable). + assert (Mem.range_perm m1 b (Int.unsigned lo - 4) (Int.unsigned lo + Int.unsigned sz) 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. intro EQ. - assert (Mem.range_perm m1' b2 (Int.signed lo + delta - 4) (Int.signed lo + delta + Int.signed sz) Freeable). + assert (Mem.range_perm m1' b2 (Int.unsigned lo + delta - 4) (Int.unsigned lo + delta + Int.unsigned sz) Freeable). red; intros. replace ofs with ((ofs - delta) + delta) by omega. eapply Mem.perm_inject; eauto. apply H0. omega. @@ -903,16 +903,16 @@ Proof. exists f; exists Vundef; exists m2'; intuition. econstructor. - rewrite EQ. replace (Int.signed lo + delta - 4) with (Int.signed lo - 4 + delta) by omega. + rewrite EQ. replace (Int.unsigned lo + delta - 4) with (Int.unsigned lo - 4 + delta) by omega. eauto. auto. rewrite EQ. auto. - assert (Mem.free_list m1 ((b, Int.signed lo - 4, Int.signed lo + Int.signed sz) :: nil) = Some m2). + assert (Mem.free_list m1 ((b, Int.unsigned lo - 4, Int.unsigned lo + Int.unsigned sz) :: nil) = Some m2). simpl. rewrite H5. auto. eapply Mem.free_inject; eauto. intros. destruct (eq_block b b1). subst b. assert (delta0 = delta) by congruence. subst delta0. - exists (Int.signed lo - 4); exists (Int.signed lo + Int.signed sz); split. + exists (Int.unsigned lo - 4); exists (Int.unsigned lo + Int.unsigned sz); split. simpl; auto. omega. elimtype False. exploit Mem.inject_no_overlap. eauto. eauto. eauto. eauto. @@ -1111,3 +1111,16 @@ Proof. exploit H2; eauto. intros [g1 [A B]]. congruence. auto. Qed. + +(** Corollary of [external_call_valid_block]. *) + +Lemma external_call_nextblock: + forall ef (F V : Type) (ge : Genv.t F V) vargs m1 t vres m2, + external_call ef ge vargs m1 t vres m2 -> + Mem.nextblock m1 <= Mem.nextblock m2. +Proof. + intros. + exploit external_call_valid_block; eauto. + instantiate (1 := Mem.nextblock m1 - 1). red; omega. + unfold Mem.valid_block. omega. +Qed. diff --git a/common/Memory.v b/common/Memory.v index a6594e4..d7d1d7b 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -488,7 +488,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.signed ofs) + | Vptr b ofs => load chunk m b (Int.unsigned ofs) | _ => None end. @@ -608,7 +608,7 @@ Definition store (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val): op Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) : option mem := match addr with - | Vptr b ofs => store chunk m b (Int.signed ofs) v + | Vptr b ofs => store chunk m b (Int.unsigned ofs) v | _ => None end. @@ -2658,12 +2658,12 @@ Record inject' (f: meminj) (m1 m2: mem) : Prop := mi_range_offset: forall b b' delta, f b = Some(b', delta) -> - Int.min_signed <= delta <= Int.max_signed; + 0 <= delta <= Int.max_unsigned; mi_range_block: forall b b' delta, f b = Some(b', delta) -> delta = 0 \/ - (Int.min_signed <= low_bound m2 b' /\ high_bound m2 b' <= Int.max_signed) + (0 <= low_bound m2 b' /\ high_bound m2 b' <= Int.max_unsigned) }. Definition inject := inject'. @@ -2731,17 +2731,17 @@ Qed. Lemma address_inject: forall f m1 m2 b1 ofs1 b2 delta, inject f m1 m2 -> - perm m1 b1 (Int.signed ofs1) Nonempty -> + perm m1 b1 (Int.unsigned ofs1) Nonempty -> f b1 = Some (b2, delta) -> - Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta. + Int.unsigned (Int.add ofs1 (Int.repr delta)) = Int.unsigned ofs1 + delta. Proof. intros. exploit perm_inject; eauto. intro A. exploit perm_in_bounds. eexact A. intros [B C]. exploit mi_range_block; eauto. intros [D | [E F]]. subst delta. rewrite Int.add_zero. omega. - rewrite Int.add_signed. - repeat rewrite Int.signed_repr. auto. + unfold Int.add. + repeat rewrite Int.unsigned_repr. auto. eapply mi_range_offset; eauto. omega. eapply mi_range_offset; eauto. @@ -2750,9 +2750,9 @@ Qed. Lemma address_inject': forall f m1 m2 chunk b1 ofs1 b2 delta, inject f m1 m2 -> - valid_access m1 chunk b1 (Int.signed ofs1) Nonempty -> + valid_access m1 chunk b1 (Int.unsigned ofs1) Nonempty -> f b1 = Some (b2, delta) -> - Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta. + Int.unsigned (Int.add ofs1 (Int.repr delta)) = Int.unsigned ofs1 + delta. Proof. intros. destruct H0. eapply address_inject; eauto. apply H0. generalize (size_chunk_pos chunk). omega. @@ -2761,28 +2761,28 @@ Qed. Theorem valid_pointer_inject_no_overflow: forall f m1 m2 b ofs b' x, inject f m1 m2 -> - valid_pointer m1 b (Int.signed ofs) = true -> + valid_pointer m1 b (Int.unsigned ofs) = true -> f b = Some(b', x) -> - Int.min_signed <= Int.signed ofs + Int.signed (Int.repr x) <= Int.max_signed. + 0 <= Int.unsigned ofs + Int.unsigned (Int.repr x) <= Int.max_unsigned. Proof. intros. rewrite valid_pointer_valid_access in H0. exploit address_inject'; eauto. intros. - rewrite Int.signed_repr; eauto. - rewrite <- H2. apply Int.signed_range. + rewrite Int.unsigned_repr; eauto. + rewrite <- H2. apply Int.unsigned_range_2. eapply mi_range_offset; eauto. Qed. Theorem valid_pointer_inject_val: forall f m1 m2 b ofs b' ofs', inject f m1 m2 -> - valid_pointer m1 b (Int.signed ofs) = true -> + valid_pointer m1 b (Int.unsigned ofs) = true -> val_inject f (Vptr b ofs) (Vptr b' ofs') -> - valid_pointer m2 b' (Int.signed ofs') = true. + valid_pointer m2 b' (Int.unsigned ofs') = true. Proof. intros. inv H1. exploit valid_pointer_inject_no_overflow; eauto. intro NOOV. - rewrite Int.add_signed. rewrite Int.signed_repr; auto. - rewrite Int.signed_repr. + unfold Int.add. rewrite Int.unsigned_repr; auto. + rewrite Int.unsigned_repr. eapply valid_pointer_inject; eauto. eapply mi_range_offset; eauto. Qed. @@ -2804,13 +2804,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.signed ofs1) = true -> - valid_pointer m b2 (Int.signed ofs2) = true -> + valid_pointer m b1 (Int.unsigned ofs1) = true -> + valid_pointer m b2 (Int.unsigned ofs2) = true -> f b1 = Some (b1', delta1) -> f b2 = Some (b2', delta2) -> b1' <> b2' \/ - Int.signed (Int.add ofs1 (Int.repr delta1)) <> - Int.signed (Int.add ofs2 (Int.repr delta2)). + Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> + Int.unsigned (Int.add ofs2 (Int.repr delta2)). Proof. intros. rewrite valid_pointer_valid_access in H1. @@ -2820,8 +2820,8 @@ Proof. inv H1. simpl in H5. inv H2. simpl in H1. eapply meminj_no_overlap_perm. eapply mi_no_overlap; eauto. eauto. eauto. eauto. - apply (H5 (Int.signed ofs1)). omega. - apply (H1 (Int.signed ofs2)). omega. + apply (H5 (Int.unsigned ofs1)). omega. + apply (H1 (Int.unsigned ofs2)). omega. Qed. (** Preservation of loads *) @@ -2845,9 +2845,9 @@ Theorem loadv_inject: Proof. intros. inv H1; simpl in H0; try discriminate. exploit load_inject; eauto. intros [v2 [LOAD INJ]]. - exists v2; split; auto. simpl. - replace (Int.signed (Int.add ofs1 (Int.repr delta))) - with (Int.signed ofs1 + delta). + exists v2; split; auto. unfold loadv. + replace (Int.unsigned (Int.add ofs1 (Int.repr delta))) + with (Int.unsigned ofs1 + delta). auto. symmetry. eapply address_inject'; eauto with mem. Qed. @@ -2944,8 +2944,9 @@ Theorem storev_mapped_inject: storev chunk m2 a2 v2 = Some n2 /\ inject f n1 n2. Proof. intros. inv H1; simpl in H0; try discriminate. - simpl. replace (Int.signed (Int.add ofs1 (Int.repr delta))) - with (Int.signed ofs1 + delta). + unfold storev. + replace (Int.unsigned (Int.add ofs1 (Int.repr delta))) + with (Int.unsigned ofs1 + delta). eapply store_mapped_inject; eauto. symmetry. eapply address_inject'; eauto with mem. Qed. @@ -3026,8 +3027,8 @@ Theorem alloc_left_mapped_inject: inject f m1 m2 -> alloc m1 lo hi = (m1', b1) -> valid_block m2 b2 -> - Int.min_signed <= delta <= Int.max_signed -> - delta = 0 \/ Int.min_signed <= low_bound m2 b2 /\ high_bound m2 b2 <= Int.max_signed -> + 0 <= delta <= Int.max_unsigned -> + delta = 0 \/ 0 <= low_bound m2 b2 /\ high_bound m2 b2 <= Int.max_unsigned -> (forall ofs p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) p) -> inj_offset_aligned delta (hi-lo) -> (forall b ofs, @@ -3103,7 +3104,7 @@ Proof. eapply alloc_right_inject; eauto. eauto. instantiate (1 := b2). eauto with mem. - instantiate (1 := 0). generalize Int.min_signed_neg Int.max_signed_pos; omega. + instantiate (1 := 0). unfold Int.max_unsigned. generalize Int.modulus_pos; omega. auto. intros. apply perm_implies with Freeable; auto with mem. @@ -3260,7 +3261,7 @@ Proof. (* range *) unfold flat_inj; intros. destruct (zlt b (nextblock m)); inv H0. - generalize Int.min_signed_neg Int.max_signed_pos; omega. + unfold Int.max_unsigned. generalize Int.modulus_pos; omega. (* range *) unfold flat_inj; intros. destruct (zlt b (nextblock m)); inv H0. auto. diff --git a/common/Memtype.v b/common/Memtype.v index 050cc84..0973643 100644 --- a/common/Memtype.v +++ b/common/Memtype.v @@ -110,13 +110,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.signed ofs) + | Vptr b ofs => load chunk m b (Int.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.signed ofs) v + | Vptr b ofs => store chunk m b (Int.unsigned ofs) v | _ => None end. @@ -837,23 +837,23 @@ Axiom valid_pointer_inject: Axiom address_inject: forall f m1 m2 b1 ofs1 b2 delta, inject f m1 m2 -> - perm m1 b1 (Int.signed ofs1) Nonempty -> + perm m1 b1 (Int.unsigned ofs1) Nonempty -> f b1 = Some (b2, delta) -> - Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta. + Int.unsigned (Int.add ofs1 (Int.repr delta)) = Int.unsigned ofs1 + delta. Axiom valid_pointer_inject_no_overflow: forall f m1 m2 b ofs b' x, inject f m1 m2 -> - valid_pointer m1 b (Int.signed ofs) = true -> + valid_pointer m1 b (Int.unsigned ofs) = true -> f b = Some(b', x) -> - Int.min_signed <= Int.signed ofs + Int.signed (Int.repr x) <= Int.max_signed. + 0 <= Int.unsigned ofs + Int.unsigned (Int.repr x) <= Int.max_unsigned. Axiom valid_pointer_inject_val: forall f m1 m2 b ofs b' ofs', inject f m1 m2 -> - valid_pointer m1 b (Int.signed ofs) = true -> + valid_pointer m1 b (Int.unsigned ofs) = true -> val_inject f (Vptr b ofs) (Vptr b' ofs') -> - valid_pointer m2 b' (Int.signed ofs') = true. + valid_pointer m2 b' (Int.unsigned ofs') = true. Axiom inject_no_overlap: forall f m1 m2 b1 b2 b1' b2' delta1 delta2 ofs1 ofs2, @@ -869,13 +869,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.signed ofs1) = true -> - valid_pointer m b2 (Int.signed ofs2) = true -> + valid_pointer m b1 (Int.unsigned ofs1) = true -> + valid_pointer m b2 (Int.unsigned ofs2) = true -> f b1 = Some (b1', delta1) -> f b2 = Some (b2', delta2) -> b1' <> b2' \/ - Int.signed (Int.add ofs1 (Int.repr delta1)) <> - Int.signed (Int.add ofs2 (Int.repr delta2)). + Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> + Int.unsigned (Int.add ofs2 (Int.repr delta2)). Axiom load_inject: forall f m1 m2 chunk b1 ofs b2 delta v1, @@ -951,8 +951,8 @@ Axiom alloc_left_mapped_inject: inject f m1 m2 -> alloc m1 lo hi = (m1', b1) -> valid_block m2 b2 -> - Int.min_signed <= delta <= Int.max_signed -> - delta = 0 \/ Int.min_signed <= low_bound m2 b2 /\ high_bound m2 b2 <= Int.max_signed -> + 0 <= delta <= Int.max_unsigned -> + delta = 0 \/ 0 <= low_bound m2 b2 /\ high_bound m2 b2 <= Int.max_unsigned -> (forall ofs p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) p) -> inj_offset_aligned delta (hi-lo) -> (forall b ofs, diff --git a/common/Switch.v b/common/Switch.v index ee8f6aa..1b3ca9b 100644 --- a/common/Switch.v +++ b/common/Switch.v @@ -60,7 +60,7 @@ Fixpoint comptree_match (n: int) (t: comptree) {struct t}: option nat := if Int.ltu n key then comptree_match n t1 else comptree_match n t2 | CTjumptable ofs sz tbl t' => if Int.ltu (Int.sub n ofs) sz - then list_nth_z tbl (Int.signed (Int.sub n ofs)) + then list_nth_z tbl (Int.unsigned (Int.sub n ofs)) else comptree_match n t' end. @@ -231,23 +231,22 @@ Qed. Lemma validate_jumptable_correct_rec: forall cases default tbl base v, validate_jumptable cases default tbl base = true -> - 0 <= Int.signed v < list_length_z tbl -> Int.signed v <= Int.max_signed -> - list_nth_z tbl (Int.signed v) = + 0 <= Int.unsigned v < list_length_z tbl -> + list_nth_z tbl (Int.unsigned v) = Some(match IntMap.find (Int.add base v) cases with Some a => a | None => default end). Proof. induction tbl; intros until v; simpl. unfold list_length_z; simpl. intros. omegaContradiction. rewrite list_length_z_cons. intros. destruct (andb_prop _ _ H). clear H. - generalize (beq_nat_eq _ _ (sym_equal H2)). clear H2. intro. subst a. - destruct (zeq (Int.signed v) 0). - rewrite Int.add_signed. rewrite e. rewrite Zplus_0_r. rewrite Int.repr_signed. auto. - assert (Int.signed (Int.sub v Int.one) = Int.signed v - 1). - rewrite Int.sub_signed. change (Int.signed Int.one) with 1. - apply Int.signed_repr. split. apply Zle_trans with 0. - vm_compute; congruence. omega. omega. - replace (Int.add base v) with (Int.add (Int.add base Int.one) (Int.sub v Int.one)). + generalize (beq_nat_eq _ _ (sym_equal H1)). clear H1. intro. subst a. + destruct (zeq (Int.unsigned v) 0). + unfold Int.add. rewrite e. rewrite Zplus_0_r. rewrite Int.repr_unsigned. auto. + assert (Int.unsigned (Int.sub v Int.one) = Int.unsigned v - 1). + unfold Int.sub. change (Int.unsigned Int.one) with 1. + apply Int.unsigned_repr. split. omega. + generalize (Int.unsigned_range_2 v). omega. + replace (Int.add base v) with (Int.add (Int.add base Int.one) (Int.sub v Int.one)). rewrite <- IHtbl. rewrite H. auto. auto. rewrite H. omega. - rewrite H. omega. rewrite Int.sub_add_opp. rewrite Int.add_permut. rewrite Int.add_assoc. replace (Int.add Int.one (Int.neg Int.one)) with Int.zero. rewrite Int.add_zero. apply Int.add_commut. @@ -258,18 +257,17 @@ Lemma validate_jumptable_correct: forall cases default tbl ofs v sz, validate_jumptable cases default tbl ofs = true -> Int.ltu (Int.sub v ofs) sz = true -> - Int.unsigned sz <= list_length_z tbl <= Int.max_signed -> - list_nth_z tbl (Int.signed (Int.sub v ofs)) = + Int.unsigned sz <= list_length_z tbl -> + list_nth_z tbl (Int.unsigned (Int.sub v ofs)) = Some(match IntMap.find v cases with Some a => a | None => default end). Proof. intros. - exploit Int.ltu_range_test; eauto. omega. intros. + exploit Int.ltu_inv; eauto. intros. rewrite (validate_jumptable_correct_rec cases default tbl ofs). rewrite Int.sub_add_opp. rewrite Int.add_permut. rewrite <- Int.sub_add_opp. rewrite Int.sub_idem. rewrite Int.add_zero. auto. auto. omega. - omega. Qed. Lemma validate_correct_rec: @@ -278,6 +276,7 @@ Lemma validate_correct_rec: lo <= Int.unsigned v <= hi -> comptree_match v t = Some (switch_target v default cases). Proof. +Opaque Int.sub. induction t; simpl; intros until hi. (* base case *) destruct cases as [ | [key1 act1] cases1]; intros. @@ -320,7 +319,7 @@ Proof. rewrite (split_between_prop v _ _ _ _ _ _ EQ). case_eq (Int.ltu (Int.sub v i) i0); intros. eapply validate_jumptable_correct; eauto. - split; eapply proj_sumbool_true; eauto. + eapply proj_sumbool_true; eauto. eapply IHt; eauto. Qed. diff --git a/driver/Compiler.v b/driver/Compiler.v index b0dce15..025b8af 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -77,7 +77,6 @@ Require Reloadproof. Require Reloadtyping. Require Stackingproof. Require Stackingtyping. -Require Machabstr2concr. Require Asmgenproof. (** Pretty-printers (defined in Caml). *) Parameter print_Csyntax: Csyntax.program -> unit. @@ -310,7 +309,6 @@ Proof. Stackingtyping.program_typing_preserved; intros. eapply Asmgenproof.transf_program_correct; eauto 6. - eapply Machabstr2concr.exec_program_equiv; eauto 6. eapply Stackingproof.transf_program_correct; eauto. eapply Reloadproof.transf_program_correct; eauto. eapply Linearizeproof.transf_program_correct; eauto. @@ -184,8 +184,8 @@ Inductive instruction: Type := | Pret (** Pseudo-instructions *) | Plabel(l: label) - | Pallocframe(lo hi: Z)(ofs_ra ofs_link: int) - | Pfreeframe(lo hi: Z)(ofs_ra ofs_link: int) + | Pallocframe(sz: Z)(ofs_ra ofs_link: int) + | Pfreeframe(sz: Z)(ofs_ra ofs_link: int) | Pbuiltin(ef: external_function)(args: list preg)(res: preg). Definition code := list instruction. @@ -601,7 +601,7 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pjmptbl r tbl => match rs#r with | Vint n => - match list_nth_z tbl (Int.signed n) with + match list_nth_z tbl (Int.unsigned n) with | None => Stuck | Some lbl => goto_label c lbl (rs #ECX <- Vundef #EDX <- Vundef) m end @@ -616,18 +616,18 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome (** Pseudo-instructions *) | Plabel lbl => Next (nextinstr rs) m - | Pallocframe lo hi ofs_ra ofs_link => - let (m1, stk) := Mem.alloc m lo hi in - let sp := Vptr stk (Int.repr lo) in + | Pallocframe sz ofs_ra ofs_link => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := Vptr stk Int.zero in match Mem.storev Mint32 m1 (Val.add sp (Vint ofs_link)) rs#ESP with | None => Stuck | Some m2 => match Mem.storev Mint32 m2 (Val.add sp (Vint ofs_ra)) rs#RA with | None => Stuck - | Some m3 => Next (nextinstr (rs#ESP <- sp)) m3 + | Some m3 => Next (nextinstr (rs #EDX <- (rs#ESP) #ESP <- sp)) m3 end end - | Pfreeframe lo hi ofs_ra ofs_link => + | Pfreeframe sz ofs_ra ofs_link => match Mem.loadv Mint32 m (Val.add rs#ESP (Vint ofs_ra)) with | None => Stuck | Some ra => @@ -636,7 +636,7 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Some sp => match rs#ESP with | Vptr stk ofs => - match Mem.free m stk lo hi with + match Mem.free m stk 0 sz with | None => Stuck | Some m' => Next (nextinstr (rs#ESP <- sp #RA <- ra)) m' end diff --git a/ia32/Asmgen.v b/ia32/Asmgen.v index f53ec81..0e14dee 100644 --- a/ia32/Asmgen.v +++ b/ia32/Asmgen.v @@ -215,10 +215,10 @@ Definition transl_cond | Ccompu c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmp_rr r1 r2 :: k) | Ccompimm c n, a1 :: nil => - do r1 <- ireg_of a1; OK (Pcmp_ri r1 n :: k) - | Ccompuimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (if Int.eq_dec n Int.zero then Ptest_rr r1 r1 :: k else Pcmp_ri r1 n :: k) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; OK (Pcmp_ri r1 n :: k) | Ccompf cmp, a1 :: a2 :: nil => do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp cmp r1 r2 :: k) | Cnotcompf cmp, a1 :: a2 :: nil => @@ -443,15 +443,19 @@ Definition transl_store (chunk: memory_chunk) (** Translation of a Mach instruction. *) -Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := +Definition transl_instr (f: Mach.function) (i: Mach.instruction) + (edx_is_parent: bool) (k: code) := match i with | Mgetstack ofs ty dst => loadind ESP ofs ty dst k | Msetstack src ofs ty => storeind src ESP ofs ty k | Mgetparam ofs ty dst => - do k1 <- loadind EDX ofs ty dst k; - loadind ESP f.(fn_link_ofs) Tint IT1 k1 + if edx_is_parent then + loadind EDX ofs ty dst k + else + (do k1 <- loadind EDX ofs ty dst k; + loadind ESP f.(fn_link_ofs) Tint IT1 k1) | Mop op args res => transl_op op args res k | Mload chunk addr args dst => @@ -464,12 +468,10 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := OK (Pcall_s symb :: k) | Mtailcall sig (inl reg) => do r <- ireg_of reg; - OK (Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize) - f.(fn_retaddr_ofs) f.(fn_link_ofs) :: + OK (Pfreeframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) :: Pjmp_r r :: k) | Mtailcall sig (inr symb) => - OK (Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize) - f.(fn_retaddr_ofs) f.(fn_link_ofs) :: + OK (Pfreeframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) :: Pjmp_s symb :: k) | Mlabel lbl => OK(Plabel lbl :: k) @@ -480,17 +482,27 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := | Mjumptable arg tbl => do r <- ireg_of arg; OK (Pjmptbl r tbl :: k) | Mreturn => - OK (Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize) - f.(fn_retaddr_ofs) f.(fn_link_ofs) :: + OK (Pfreeframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) :: Pret :: k) | Mbuiltin ef args res => OK (Pbuiltin ef (List.map preg_of args) (preg_of res) :: k) end. -Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) := +(** Translation of a code sequence *) + +Definition edx_preserved (before: bool) (i: Mach.instruction) : bool := + match i with + | Msetstack src ofs ty => before + | Mgetparam ofs ty dst => negb (mreg_eq dst IT1) + | _ => false + end. + +Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (edx_is_parent: bool) := match il with | nil => OK nil - | i1 :: il' => do k <- transl_code f il'; transl_instr f i1 k + | i1 :: il' => + do k <- transl_code f il' (edx_preserved edx_is_parent i1); + transl_instr f i1 edx_is_parent k end. (** Translation of a whole function. Note that we must check @@ -499,10 +511,9 @@ Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) := around, leading to incorrect executions. *) Definition transf_function (f: Mach.function) : res Asm.code := - do c <- transl_code f f.(fn_code); + do c <- transl_code f f.(fn_code) true; if zlt (list_length_z c) Int.max_unsigned - then OK (Pallocframe (- f.(fn_framesize)) f.(fn_stacksize) - f.(fn_retaddr_ofs) f.(fn_link_ofs) :: c) + then OK (Pallocframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) :: c) else Error (msg "code size exceeded"). Definition transf_fundef (f: Mach.fundef) : res Asm.fundef := diff --git a/ia32/Asmgenproof.v b/ia32/Asmgenproof.v index 543028f..f596f66 100644 --- a/ia32/Asmgenproof.v +++ b/ia32/Asmgenproof.v @@ -10,7 +10,7 @@ (* *) (* *********************************************************************) -(** Correctness proof for PPC generation: main proof. *) +(** Correctness proof for x86 generation: main proof. *) Require Import Coqlib. Require Import Maps. @@ -150,15 +150,15 @@ Qed. and [c] is the tail of the generated code at the position corresponding to the code pointer [pc]. *) -Inductive transl_code_at_pc: val -> block -> Mach.function -> Mach.code -> +Inductive transl_code_at_pc: val -> block -> Mach.function -> Mach.code -> bool -> Asm.code -> Asm.code -> Prop := transl_code_at_pc_intro: - forall b ofs f c tf tc, + forall b ofs f c ep tf tc, Genv.find_funct_ptr ge b = Some (Internal f) -> transf_function f = OK tf -> - transl_code f c = OK tc -> + transl_code f c ep = OK tc -> code_tail (Int.unsigned ofs) tf tc -> - transl_code_at_pc (Vptr b ofs) b f c tf tc. + transl_code_at_pc (Vptr b ofs) b f c ep tf tc. (** The following lemmas show that straight-line executions (predicate [exec_straight]) correspond to correct PPC executions @@ -210,8 +210,8 @@ Proof. Qed. Lemma exec_straight_exec: - forall fb f c tf tc c' rs m rs' m', - transl_code_at_pc (rs PC) fb f c tf tc -> + forall fb f c ep tf tc c' rs m rs' m', + transl_code_at_pc (rs PC) fb f c ep tf tc -> exec_straight tge tf tc rs m c' rs' m' -> plus step tge (State rs m) E0 (State rs' m'). Proof. @@ -222,11 +222,11 @@ Proof. Qed. Lemma exec_straight_at: - forall fb f c tf tc c' tc' rs m rs' m', - transl_code_at_pc (rs PC) fb f c tf tc -> - transl_code f c' = OK tc' -> + forall fb f c ep tf tc c' ep' tc' rs m rs' m', + transl_code_at_pc (rs PC) fb f c ep tf tc -> + transl_code f c' ep' = OK tc' -> exec_straight tge tf tc rs m tc' rs' m' -> - transl_code_at_pc (rs' PC) fb f c' tf tc'. + transl_code_at_pc (rs' PC) fb f c' ep' tf tc'. Proof. intros. inv H. exploit exec_straight_steps_2; eauto. @@ -257,12 +257,12 @@ Qed. Lemma return_address_offset_correct: forall b ofs fb f c tf tc ofs', - transl_code_at_pc (Vptr b ofs) fb f c tf tc -> + transl_code_at_pc (Vptr b ofs) fb f c false tf tc -> return_address_offset f c ofs' -> ofs' = ofs. Proof. intros. inv H0. inv H. - exploit code_tail_unique. eexact H11. eapply H1; eauto. intro. + exploit code_tail_unique. eexact H12. eapply H1; eauto. intro. subst ofs0. apply Int.repr_unsigned. Qed. @@ -461,8 +461,8 @@ Proof. Qed. Lemma transl_instr_label: - forall f i k c, - transl_instr f i k = OK c -> + forall f i ep k c, + transl_instr f i ep k = OK c -> find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k. Proof. intros. generalize (Mach.is_label_correct lbl i). @@ -472,7 +472,7 @@ Opaque loadind. destruct i; simpl in H. eapply loadind_label; eauto. eapply storeind_label; eauto. - monadInv H. eapply trans_eq; eapply loadind_label; eauto. + destruct ep. eapply loadind_label; eauto. monadInv H. eapply trans_eq; eapply loadind_label; eauto. eapply transl_op_label; eauto. eapply transl_load_label; eauto. eapply transl_store_label; eauto. @@ -487,17 +487,20 @@ Opaque loadind. Qed. Lemma transl_code_label: - forall f c tc, - transl_code f c = OK tc -> + forall f c ep tc, + transl_code f c ep = OK tc -> match Mach.find_label lbl c with | None => find_label lbl tc = None - | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' = OK tc' + | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc' end. Proof. induction c; simpl; intros. inv H. auto. - monadInv H. rewrite (transl_instr_label _ _ _ _ EQ0). - destruct (Mach.is_label lbl a). exists x; auto. apply IHc. auto. + monadInv H. rewrite (transl_instr_label _ _ _ _ _ EQ0). + generalize (Mach.is_label_correct lbl a). + destruct (Mach.is_label lbl a); intros. + subst a. simpl in EQ. exists x; auto. + eapply IHc; eauto. Qed. Lemma transl_find_label: @@ -505,11 +508,11 @@ Lemma transl_find_label: transf_function f = OK tf -> match Mach.find_label lbl f.(fn_code) with | None => find_label lbl tf = None - | Some c => exists tc, find_label lbl tf = Some tc /\ transl_code f c = OK tc + | Some c => exists tc, find_label lbl tf = Some tc /\ transl_code f c false = OK tc end. Proof. intros. monadInv H. destruct (zlt (list_length_z x) Int.max_unsigned); inv EQ0. - simpl. apply transl_code_label; auto. + simpl. eapply transl_code_label; eauto. Qed. End TRANSL_LABEL. @@ -525,7 +528,7 @@ Lemma find_label_goto_label: Mach.find_label lbl f.(fn_code) = Some c' -> exists tc', exists rs', goto_label tf lbl rs m = Next rs' m - /\ transl_code_at_pc (rs' PC) b f c' tf tc' + /\ transl_code_at_pc (rs' PC) b f c' false tf tc' /\ forall r, r <> PC -> rs'#r = rs#r. Proof. intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. @@ -564,19 +567,20 @@ Inductive match_stack: list Machconcr.stackframe -> Prop := match_stack nil | match_stack_cons: forall fb sp ra c s f tf tc, Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc ra fb f c tf tc -> + transl_code_at_pc ra fb f c false tf tc -> sp <> Vundef -> ra <> Vundef -> match_stack s -> match_stack (Stackframe fb sp ra c :: s). Inductive match_states: Machconcr.state -> Asm.state -> Prop := | match_states_intro: - forall s fb sp c ms m m' rs f tf tc + forall s fb sp c ep ms m m' rs f tf tc (STACKS: match_stack s) (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) (MEXT: Mem.extends m m') - (AT: transl_code_at_pc (rs PC) fb f c tf tc) - (AG: agree ms sp rs), + (AT: transl_code_at_pc (rs PC) fb f c ep tf tc) + (AG: agree ms sp rs) + (DXP: ep = true -> rs#EDX = parent_sp s), match_states (Machconcr.State s fb sp c ms m) (Asm.State rs m') | match_states_call: @@ -598,19 +602,22 @@ Inductive match_states: Machconcr.state -> Asm.state -> Prop := (Asm.State rs m'). Lemma exec_straight_steps: - forall s fb f rs1 i c tf tc m1' m2 m2' sp ms2, + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2, match_stack s -> Mem.extends m2 m2' -> Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc (rs1 PC) fb f (i :: c) tf tc -> - (forall k c, transl_instr f i k = OK c -> - exists rs2, exec_straight tge tf c rs1 m1' k rs2 m2' /\ agree ms2 sp rs2) -> + transl_code_at_pc (rs1 PC) fb f (i :: c) ep tf tc -> + (forall k c, transl_instr f i ep k = OK c -> + exists rs2, + exec_straight tge tf c rs1 m1' k rs2 m2' + /\ agree ms2 sp rs2 + /\ (edx_preserved ep i = true -> rs2#EDX = parent_sp s)) -> exists st', plus step tge (State rs1 m1') E0 st' /\ match_states (Machconcr.State s fb sp c ms2 m2) st'. Proof. intros. inversion H2. subst. monadInv H7. - exploit H3; eauto. intros [rs2 [A B]]. + exploit H3; eauto. intros [rs2 [A [B C]]]. exists (State rs2 m2'); split. eapply exec_straight_exec; eauto. econstructor; eauto. eapply exec_straight_at; eauto. @@ -671,7 +678,7 @@ Proof. intros; red; intros; inv MS. left; eapply exec_straight_steps; eauto; intros. monadInv H. econstructor; split. apply exec_straight_one. simpl; eauto. auto. - apply agree_nextinstr; auto. + split. apply agree_nextinstr; auto. simpl; congruence. Qed. Lemma exec_Mgetstack_prop: @@ -688,7 +695,9 @@ Proof. rewrite (sp_val _ _ _ AG) in A. left; eapply exec_straight_steps; eauto. intros. simpl in H0. exploit loadind_correct; eauto. intros [rs' [P [Q R]]]. - exists rs'; split. eauto. eapply agree_set_mreg; eauto. congruence. + exists rs'; split. eauto. + split. eapply agree_set_mreg; eauto. congruence. + simpl; congruence. Qed. Lemma exec_Msetstack_prop: @@ -706,16 +715,18 @@ Proof. rewrite (sp_val _ _ _ AG) in A. left; eapply exec_straight_steps; eauto. intros. simpl in H1. exploit storeind_correct; eauto. intros [rs' [P Q]]. - exists rs'; split. eauto. eapply agree_exten; eauto. + exists rs'; split. eauto. + split. eapply agree_exten; eauto. + simpl; intros. rewrite Q; auto with ppcgen. Qed. Lemma exec_Mgetparam_prop: - forall (s : list stackframe) (fb : block) (f: Mach.function) (sp parent : val) + forall (s : list stackframe) (fb : block) (f: Mach.function) (sp : val) (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (v : val), Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m sp Tint f.(fn_link_ofs) = Some parent -> - load_stack m parent ty ofs = Some v -> + load_stack m sp Tint f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (parent_sp s) ty ofs = Some v -> exec_instr_prop (Machconcr.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0 (Machconcr.State s fb sp c (Regmap.set dst v (Regmap.set IT1 Vundef ms)) m). Proof. @@ -724,38 +735,55 @@ Proof. unfold load_stack in *. exploit Mem.loadv_extends. eauto. eexact H0. auto. intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. - assert (parent' = parent). inv B. auto. simpl in H1. congruence. + assert (parent' = parent_sp s). inv B. auto. rewrite <- H3 in H1. simpl in H1. congruence. subst parent'. exploit Mem.loadv_extends. eauto. eexact H1. auto. intros [v' [C D]]. Opaque loadind. - left; eapply exec_straight_steps; eauto; intros. monadInv H2. + left; eapply exec_straight_steps; eauto; intros. + assert (DIFF: negb (mreg_eq dst IT1) = true -> IR EDX <> preg_of dst). + intros. change (IR EDX) with (preg_of IT1). red; intros. + exploit preg_of_injective; eauto. intros. subst dst. + unfold proj_sumbool in H3. rewrite dec_eq_true in H3. simpl in H3. congruence. + destruct ep; simpl in H2. +(* EDX contains parent *) + exploit loadind_correct. eexact H2. + instantiate (2 := rs). rewrite DXP; eauto. + intros [rs1 [P [Q R]]]. + exists rs1; split. eauto. + split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto. + simpl; intros. rewrite R; auto. +(* EDX does not contain parent *) + monadInv H2. exploit loadind_correct. eexact EQ0. eauto. intros [rs1 [P [Q R]]]. simpl in Q. exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. intros [rs2 [S [T U]]]. exists rs2; split. eapply exec_straight_trans; eauto. - eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto. + split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto. + simpl; intros. rewrite U; auto. Qed. Lemma exec_Mop_prop: forall (s : list stackframe) (fb : block) (sp : val) (op : operation) (args : list mreg) (res : mreg) (c : list Mach.instruction) (ms : mreg -> val) (m : mem) (v : val), - eval_operation ge sp op ms ## args = Some v -> + eval_operation ge sp op ms ## args m = Some v -> exec_instr_prop (Machconcr.State s fb sp (Mop op args res :: c) ms m) E0 (Machconcr.State s fb sp c (Regmap.set res v (undef_op op ms)) m). Proof. intros; red; intros; inv MS. - assert (eval_operation tge sp op ms##args = Some v). + assert (eval_operation tge sp op ms##args m = Some v). rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. - exploit eval_operation_lessdef. eapply preg_vals; eauto. eexact H0. + exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0. intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. left; eapply exec_straight_steps; eauto; intros. simpl in H1. exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. exists rs2; split. eauto. - rewrite <- Q in B. + split. rewrite <- Q in B. unfold undef_op. - destruct op; try (eapply agree_set_undef_mreg; eauto). eapply agree_set_mreg; eauto. + destruct op; try (eapply agree_set_undef_mreg; eauto). + eapply agree_set_mreg; eauto. + simpl; congruence. Qed. Lemma exec_Mload_prop: @@ -776,7 +804,9 @@ Proof. exploit Mem.loadv_extends; eauto. intros [v' [C D]]. left; eapply exec_straight_steps; eauto; intros. simpl in H2. exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]]. - exists rs2; split. eauto. eapply agree_set_undef_mreg; eauto. congruence. + exists rs2; split. eauto. + split. eapply agree_set_undef_mreg; eauto. congruence. + simpl; congruence. Qed. Lemma exec_Mstore_prop: @@ -798,7 +828,9 @@ Proof. exploit Mem.storev_extends; eauto. intros [m2' [C D]]. left; eapply exec_straight_steps; eauto; intros. simpl in H3. exploit transl_store_correct; eauto. intros [rs2 [P Q]]. - exists rs2; split. eauto. eapply agree_exten_temps; eauto. + exists rs2; split. eauto. + split. eapply agree_exten_temps; eauto. + simpl; congruence. Qed. Lemma exec_Mcall_prop: @@ -824,7 +856,7 @@ Proof. generalize (Int.eq_spec i Int.zero); destruct (Int.eq i Int.zero); congruence. clear H. generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc (Vptr fb (Int.add ofs Int.one)) fb f c tf x). + assert (TCA: transl_code_at_pc (Vptr fb (Int.add ofs Int.one)) fb f c false tf x). econstructor; eauto. exploit return_address_offset_correct; eauto. intros; subst ra. left; econstructor; split. @@ -838,7 +870,7 @@ Proof. rewrite <- H2. auto. (* Direct call *) generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc (Vptr fb (Int.add ofs Int.one)) fb f c tf x). + assert (TCA: transl_code_at_pc (Vptr fb (Int.add ofs Int.one)) fb f c false tf x). econstructor; eauto. exploit return_address_offset_correct; eauto. intros; subst ra. left; econstructor; split. @@ -868,7 +900,7 @@ Lemma exec_Mtailcall_prop: 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) -> - Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0 (Callstate s f' ms m'). @@ -942,6 +974,7 @@ Proof. simpl; eauto. econstructor; eauto. eapply agree_exten; eauto with ppcgen. + congruence. Qed. Lemma exec_Mbuiltin_prop: @@ -968,11 +1001,12 @@ Proof. instantiate (2 := tf); instantiate (1 := x). unfold nextinstr_nf, nextinstr. rewrite Pregmap.gss. simpl undef_regs. repeat rewrite Pregmap.gso; auto with ppcgen. - rewrite <- H0. simpl. constructor; auto. + rewrite <- H0. simpl. econstructor; eauto. eapply code_tail_next_int; eauto. apply agree_nextinstr_nf. eapply agree_set_undef_mreg; eauto. rewrite Pregmap.gss. auto. - intros. repeat rewrite Pregmap.gso; auto with ppcgen. + intros. repeat rewrite Pregmap.gso; auto with ppcgen. + congruence. Qed. Lemma exec_Mcond_true_prop: @@ -980,14 +1014,14 @@ Lemma exec_Mcond_true_prop: (cond : condition) (args : list mreg) (lbl : Mach.label) (c : list Mach.instruction) (ms : mreg -> val) (m : mem) (c' : Mach.code), - eval_condition cond ms ## args = Some true -> + eval_condition cond ms ## args m = Some true -> Genv.find_funct_ptr ge fb = Some (Internal f) -> Mach.find_label lbl (fn_code f) = Some c' -> exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0 (Machconcr.State s fb sp c' (undef_temps ms) m). Proof. intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. intros EC. + exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. inv AT. monadInv H5. exploit transl_cond_correct; eauto. intros [rs' [A [B C]]]. generalize (functions_transl _ _ _ FIND H4); intro FN. @@ -1003,24 +1037,26 @@ Proof. eapply find_instr_tail. eauto. simpl. rewrite B. eauto. traceEq. econstructor; eauto. eapply agree_exten_temps; eauto. intros. rewrite INV3; auto with ppcgen. + congruence. Qed. Lemma exec_Mcond_false_prop: forall (s : list stackframe) (fb : block) (sp : val) (cond : condition) (args : list mreg) (lbl : Mach.label) (c : list Mach.instruction) (ms : mreg -> val) (m : mem), - eval_condition cond ms ## args = Some false -> + eval_condition cond ms ## args m = Some false -> exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0 (Machconcr.State s fb sp c (undef_temps ms) m). Proof. intros; red; intros; inv MS. - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. intros EC. + exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. left; eapply exec_straight_steps; eauto. intros. simpl in H0. exploit transl_cond_correct; eauto. intros [rs' [A [B C]]]. econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl. rewrite B. eauto. auto. - apply agree_nextinstr. eapply agree_exten_temps; eauto. + split. apply agree_nextinstr. eapply agree_exten_temps; eauto. + simpl; congruence. Qed. Lemma exec_Mjumptable_prop: @@ -1029,7 +1065,7 @@ Lemma exec_Mjumptable_prop: (rs : mreg -> val) (m : mem) (n : int) (lbl : Mach.label) (c' : Mach.code), rs arg = Vint n -> - list_nth_z tbl (Int.signed n) = Some lbl -> + list_nth_z tbl (Int.unsigned n) = Some lbl -> Genv.find_funct_ptr ge fb = Some (Internal f) -> Mach.find_label lbl (fn_code f) = Some c' -> exec_instr_prop @@ -1052,6 +1088,7 @@ Proof. econstructor; eauto. eapply agree_exten_temps; eauto. intros. rewrite C; auto with ppcgen. repeat rewrite Pregmap.gso; auto with ppcgen. + congruence. Qed. Lemma exec_Mreturn_prop: @@ -1060,7 +1097,7 @@ Lemma exec_Mreturn_prop: 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) -> - Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0 (Returnstate s ms m'). Proof. @@ -1094,12 +1131,12 @@ Lemma exec_function_internal_prop: forall (s : list stackframe) (fb : block) (ms : Mach.regset) (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block), Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mem.alloc m (- fn_framesize f) (fn_stacksize f) = (m1, stk) -> - let sp := Vptr stk (Int.repr (- fn_framesize f)) in + Mem.alloc m 0 (fn_stacksize f) = (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 -> exec_instr_prop (Machconcr.Callstate s fb ms m) E0 - (Machconcr.State s fb sp (fn_code f) ms m3). + (Machconcr.State s fb sp (fn_code f) (undef_temps ms) m3). Proof. intros; red; intros; inv MS. exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. @@ -1118,11 +1155,17 @@ Proof. simpl. rewrite C. simpl in E. rewrite (sp_val _ _ _ AG) in E. rewrite E. rewrite ATLR. simpl in P. rewrite P. eauto. econstructor; eauto. - unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso; auto with ppcgen. + unfold nextinstr. rewrite Pregmap.gss. repeat rewrite Pregmap.gso; auto with ppcgen. rewrite ATPC. simpl. constructor; eauto. subst x. eapply code_tail_next_int. rewrite list_length_z_cons. omega. constructor. - apply agree_nextinstr. eapply agree_change_sp; eauto. congruence. + apply agree_nextinstr. eapply agree_change_sp; eauto. + apply agree_exten_temps with rs; eauto. + intros. apply Pregmap.gso; auto with ppcgen. + congruence. + intros. rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gso; auto with ppcgen. + rewrite Pregmap.gss. eapply agree_sp; eauto. Qed. Lemma exec_function_external_prop: @@ -1163,6 +1206,7 @@ Proof. intros; red; intros; inv MS. inv STACKS. simpl in *. right. split. omega. split. auto. econstructor; eauto. rewrite ATPC; eauto. + congruence. Qed. Theorem transf_instr_correct: diff --git a/ia32/Asmgenproof1.v b/ia32/Asmgenproof1.v index aef03db..81154f9 100644 --- a/ia32/Asmgenproof1.v +++ b/ia32/Asmgenproof1.v @@ -1009,10 +1009,29 @@ Proof. destruct (Int.lt n1 n2); auto. Qed. -Lemma testcond_for_signed_comparison_correct_pi: +Lemma testcond_for_unsigned_comparison_correct_ii: + forall c n1 n2 rs, + eval_testcond (testcond_for_unsigned_comparison c) + (nextinstr (compare_ints (Vint n1) (Vint n2) rs)) = + Some(Int.cmpu c n1 n2). +Proof. + intros. generalize (compare_ints_spec rs (Vint n1) (Vint n2)). + set (rs' := nextinstr (compare_ints (Vint n1) (Vint n2) rs)). + intros [A [B [C D]]]. + unfold eval_testcond. rewrite A; rewrite B; rewrite C. + destruct c; simpl. + destruct (Int.eq n1 n2); auto. + destruct (Int.eq n1 n2); auto. + destruct (Int.ltu n1 n2); auto. + rewrite int_not_ltu. destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto. + rewrite (int_ltu_not n1 n2). destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto. + destruct (Int.ltu n1 n2); auto. +Qed. + +Lemma testcond_for_unsigned_comparison_correct_pi: forall c blk n1 n2 rs b, eval_compare_null c n2 = Some b -> - eval_testcond (testcond_for_signed_comparison c) + eval_testcond (testcond_for_unsigned_comparison c) (nextinstr (compare_ints (Vptr blk n1) (Vint n2) rs)) = Some b. Proof. intros. @@ -1028,10 +1047,10 @@ Proof. rewrite <- H0; auto. Qed. -Lemma testcond_for_signed_comparison_correct_ip: +Lemma testcond_for_unsigned_comparison_correct_ip: forall c blk n1 n2 rs b, eval_compare_null c n1 = Some b -> - eval_testcond (testcond_for_signed_comparison c) + eval_testcond (testcond_for_unsigned_comparison c) (nextinstr (compare_ints (Vint n1) (Vptr blk n2) rs)) = Some b. Proof. intros. @@ -1047,14 +1066,18 @@ Proof. rewrite <- H0; auto. Qed. -Lemma testcond_for_signed_comparison_correct_pp: - forall c b1 n1 b2 n2 rs b, - (if eq_block b1 b2 then Some (Int.cmp c n1 n2) else eval_compare_mismatch c) = Some b -> - eval_testcond (testcond_for_signed_comparison c) +Lemma testcond_for_unsigned_comparison_correct_pp: + forall c b1 n1 b2 n2 rs m b, + (if Mem.valid_pointer m b1 (Int.unsigned n1) && Mem.valid_pointer m b2 (Int.unsigned n2) + then if eq_block b1 b2 then Some (Int.cmpu c n1 n2) else eval_compare_mismatch c + else None) = Some b -> + eval_testcond (testcond_for_unsigned_comparison c) (nextinstr (compare_ints (Vptr b1 n1) (Vptr b2 n2) rs)) = Some b. Proof. - intros. generalize (compare_ints_spec rs (Vptr b1 n1) (Vptr b2 n2)). + intros. + destruct (Mem.valid_pointer m b1 (Int.unsigned n1) && Mem.valid_pointer m b2 (Int.unsigned n2)); try discriminate. + generalize (compare_ints_spec rs (Vptr b1 n1) (Vptr b2 n2)). set (rs' := nextinstr (compare_ints (Vptr b1 n1) (Vptr b2 n2) rs)). intros [A [B [C D]]]. unfold eq_block in H. unfold eval_testcond. rewrite A; rewrite B; rewrite C. @@ -1063,37 +1086,18 @@ Proof. rewrite <- H; auto. destruct (zeq b1 b2). inversion H. destruct (Int.eq n1 n2); auto. rewrite <- H; auto. - destruct (zeq b1 b2). inversion H. destruct (Int.lt n1 n2); auto. + destruct (zeq b1 b2). inversion H. destruct (Int.ltu n1 n2); auto. discriminate. destruct (zeq b1 b2). inversion H. - rewrite int_not_lt. destruct (Int.lt n1 n2); destruct (Int.eq n1 n2); auto. + rewrite int_not_ltu. destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto. discriminate. destruct (zeq b1 b2). inversion H. - rewrite (int_lt_not n1 n2). destruct (Int.lt n1 n2); destruct (Int.eq n1 n2); auto. + rewrite (int_ltu_not n1 n2). destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto. discriminate. - destruct (zeq b1 b2). inversion H. destruct (Int.lt n1 n2); auto. + destruct (zeq b1 b2). inversion H. destruct (Int.ltu n1 n2); auto. discriminate. Qed. -Lemma testcond_for_unsigned_comparison_correct: - forall c n1 n2 rs, - eval_testcond (testcond_for_unsigned_comparison c) - (nextinstr (compare_ints (Vint n1) (Vint n2) rs)) = - Some(Int.cmpu c n1 n2). -Proof. - intros. generalize (compare_ints_spec rs (Vint n1) (Vint n2)). - set (rs' := nextinstr (compare_ints (Vint n1) (Vint n2) rs)). - intros [A [B [C D]]]. - unfold eval_testcond. rewrite A; rewrite B; rewrite C. - destruct c; simpl. - destruct (Int.eq n1 n2); auto. - destruct (Int.eq n1 n2); auto. - destruct (Int.ltu n1 n2); auto. - rewrite int_not_ltu. destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto. - rewrite (int_ltu_not n1 n2). destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto. - destruct (Int.ltu n1 n2); auto. -Qed. - Lemma compare_floats_spec: forall rs n1 n2, let rs' := nextinstr (compare_floats (Vfloat n1) (Vfloat n2) rs) in @@ -1214,7 +1218,7 @@ Qed. Lemma transl_cond_correct: forall cond args k c rs m b, transl_cond cond args k = OK c -> - eval_condition cond (map rs (map preg_of args)) = Some b -> + eval_condition cond (map rs (map preg_of args)) m = Some b -> exists rs', exec_straight c rs m k rs' m /\ eval_testcond (testcond_for_condition cond) rs' = Some b @@ -1227,32 +1231,33 @@ Proof. econstructor. split. apply exec_straight_one. simpl. eauto. auto. split. simpl in H0. FuncInv. subst b. apply testcond_for_signed_comparison_correct_ii. - apply testcond_for_signed_comparison_correct_ip; auto. - apply testcond_for_signed_comparison_correct_pi; auto. - apply testcond_for_signed_comparison_correct_pp; auto. intros. unfold compare_ints. repeat SOther. (* compu *) - simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. rewrite (ireg_of_eq _ _ EQ1) in H0. + simpl map in H0. + rewrite (ireg_of_eq _ _ EQ) in H0. rewrite (ireg_of_eq _ _ EQ1) in H0. econstructor. split. apply exec_straight_one. simpl. eauto. auto. split. simpl in H0. FuncInv. - subst b. apply testcond_for_unsigned_comparison_correct. + subst b. apply testcond_for_unsigned_comparison_correct_ii. + apply testcond_for_unsigned_comparison_correct_ip; auto. + apply testcond_for_unsigned_comparison_correct_pi; auto. + eapply testcond_for_unsigned_comparison_correct_pp; eauto. intros. unfold compare_ints. repeat SOther. (* compimm *) simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. - econstructor. split. apply exec_straight_one. simpl; eauto. auto. - split. simpl in H0. FuncInv. - subst b. apply testcond_for_signed_comparison_correct_ii. - apply testcond_for_signed_comparison_correct_pi; auto. - intros. unfold compare_ints. repeat SOther. -(* compuimm *) - simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. exists (nextinstr (compare_ints (rs x) (Vint i) rs)). split. destruct (Int.eq_dec i Int.zero). apply exec_straight_one. subst i. simpl. simpl in H0. FuncInv. simpl. rewrite Int.and_idem. auto. auto. apply exec_straight_one; auto. split. simpl in H0. FuncInv. - subst b. apply testcond_for_unsigned_comparison_correct. + subst b. apply testcond_for_signed_comparison_correct_ii. + intros. unfold compare_ints. repeat SOther. +(* compuimm *) + simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. + econstructor. split. apply exec_straight_one. simpl; eauto. auto. + split. simpl in H0. FuncInv. + subst b. apply testcond_for_unsigned_comparison_correct_ii. + apply testcond_for_unsigned_comparison_correct_pi; auto. intros. unfold compare_ints. repeat SOther. (* compf *) simpl map in H0. rewrite (freg_of_eq _ _ EQ) in H0. rewrite (freg_of_eq _ _ EQ1) in H0. @@ -1333,7 +1338,7 @@ Ltac TranslOp := Lemma transl_op_correct: forall op args res k c (rs: regset) m v, transl_op op args res k = OK c -> - eval_operation ge (rs#ESP) op (map rs (map preg_of args)) = Some v -> + eval_operation ge (rs#ESP) op (map rs (map preg_of args)) m = Some v -> exists rs', exec_straight c rs m k rs' m /\ rs'#(preg_of res) = v @@ -1342,7 +1347,7 @@ Lemma transl_op_correct: r <> preg_of res -> rs' r = rs r. Proof. intros until v; intros TR EV. - rewrite <- (eval_operation_weaken _ _ _ _ EV). + rewrite <- (eval_operation_weaken _ _ _ _ _ EV). destruct op; simpl in TR; ArgsInv; try (TranslOp; fail). (* move *) exploit mk_mov_correct; eauto. intros [rs2 [A [B C]]]. @@ -1383,8 +1388,8 @@ Proof. rewrite (eval_addressing_weaken _ _ _ _ EV). rewrite <- EA. TranslOp. (* condition *) - remember (eval_condition c0 rs ## (preg_of ## args)) as ob. destruct ob; inv EV. - rewrite (eval_condition_weaken _ _ (sym_equal Heqob)). + remember (eval_condition c0 rs ## (preg_of ## args) m) as ob. destruct ob; inv EV. + rewrite (eval_condition_weaken _ _ _ (sym_equal Heqob)). exploit transl_cond_correct; eauto. intros [rs2 [P [Q R]]]. exists (nextinstr (rs2#ECX <- Vundef #EDX <- Vundef #x <- v)). split. eapply exec_straight_trans. eauto. diff --git a/ia32/Asmgenretaddr.v b/ia32/Asmgenretaddr.v index 048f5a2..95df712 100644 --- a/ia32/Asmgenretaddr.v +++ b/ia32/Asmgenretaddr.v @@ -71,7 +71,7 @@ Inductive return_address_offset: Mach.function -> Mach.code -> int -> Prop := forall f c ofs, (forall tf tc, transf_function f = OK tf -> - transl_code f c = OK tc -> + transl_code f c false = OK tc -> code_tail ofs tf tc) -> return_address_offset f c (Int.repr ofs). @@ -202,7 +202,7 @@ Proof. Qed. Lemma transl_instr_tail: - forall f i k c, transl_instr f i k = OK c -> is_tail k c. + forall f i ep k c, transl_instr f i ep k = OK c -> is_tail k c. Proof. unfold transl_instr; intros. destruct i; IsTail. eapply is_tail_trans; eapply loadind_tail; eauto. @@ -213,32 +213,40 @@ Proof. destruct s0; IsTail. eapply is_tail_trans. 2: eapply transl_cond_tail; eauto. IsTail. Qed. - + Lemma transl_code_tail: forall f c1 c2, is_tail c1 c2 -> - forall tc1 tc2, transl_code f c1 = OK tc1 -> transl_code f c2 = OK tc2 -> - is_tail tc1 tc2. + forall tc2 ep2, transl_code f c2 ep2 = OK tc2 -> + exists tc1, exists ep1, transl_code f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. Proof. induction 1; simpl; intros. - replace tc2 with tc1 by congruence. constructor. - IsTail. apply is_tail_trans with x. eauto. eapply transl_instr_tail; eauto. + exists tc2; exists ep2; split; auto with coqlib. + monadInv H0. exploit IHis_tail; eauto. intros [tc1 [ep1 [A B]]]. + exists tc1; exists ep1; split. auto. + apply is_tail_trans with x. auto. eapply transl_instr_tail; eauto. Qed. Lemma return_address_exists: - forall f c, is_tail c f.(fn_code) -> + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(fn_code) -> exists ra, return_address_offset f c ra. Proof. intros. - caseEq (transf_function f). intros tf TF. - caseEq (transl_code f c). intros tc TC. - assert (is_tail tc tf). - unfold transf_function in TF. monadInv TF. - destruct (zlt (list_length_z x) Int.max_unsigned); monadInv EQ0. - IsTail. eapply transl_code_tail; eauto. - destruct (is_tail_code_tail _ _ H0) as [ofs A]. + caseEq (transf_function f). intros tf TF. + assert (exists tc1, transl_code f (fn_code f) true = OK tc1 /\ is_tail tc1 tf). + monadInv TF. + destruct (zlt (list_length_z x) Int.max_unsigned); monadInv EQ0. + econstructor; eauto with coqlib. + destruct H0 as [tc2 [A B]]. + exploit transl_code_tail; eauto. intros [tc1 [ep [C D]]]. +Opaque transl_instr. + monadInv C. + assert (is_tail x tf). + apply is_tail_trans with tc2; auto. + apply is_tail_trans with tc1; auto. + eapply transl_instr_tail; eauto. + exploit is_tail_code_tail. eexact H0. intros [ofs C]. exists (Int.repr ofs). constructor; intros. congruence. intros. exists (Int.repr 0). constructor; intros; congruence. - intros. exists (Int.repr 0). constructor; intros; congruence. Qed. diff --git a/ia32/ConstpropOpproof.v b/ia32/ConstpropOpproof.v index 105a7bd..79e1537 100644 --- a/ia32/ConstpropOpproof.v +++ b/ia32/ConstpropOpproof.v @@ -88,10 +88,10 @@ Ltac InvVLMA := approximations returned by [eval_static_operation]. *) Lemma eval_static_condition_correct: - forall cond al vl b, + forall cond al vl m b, val_list_match_approx al vl -> eval_static_condition cond al = Some b -> - eval_condition cond vl = Some b. + eval_condition cond vl m = Some b. Proof. intros until b. unfold eval_static_condition. @@ -120,9 +120,9 @@ Proof. Qed. Lemma eval_static_operation_correct: - forall op sp al vl v, + forall op sp al vl m v, val_list_match_approx al vl -> - eval_operation ge sp op vl = Some v -> + eval_operation ge sp op vl m = Some v -> val_match_approx (eval_static_operation op al) v. Proof. intros until v. @@ -181,7 +181,7 @@ Proof. inv H4. destruct (Float.intoffloat f); inv H0. red; auto. caseEq (eval_static_condition c vl0). - intros. generalize (eval_static_condition_correct _ _ _ _ H H1). + intros. generalize (eval_static_condition_correct _ _ _ m _ H H1). intro. rewrite H2 in H0. destruct b; injection H0; intro; subst v; simpl; auto. intros; simpl; auto. @@ -202,6 +202,7 @@ Section STRENGTH_REDUCTION. Variable app: reg -> approx. Variable sp: val. Variable rs: regset. +Variable m: mem. Hypothesis MATCH: forall r, val_match_approx (app r) rs#r. Lemma intval_correct: @@ -217,20 +218,20 @@ Qed. Lemma cond_strength_reduction_correct: forall cond args, let (cond', args') := cond_strength_reduction app cond args in - eval_condition cond' rs##args' = eval_condition cond rs##args. + eval_condition cond' rs##args' m = eval_condition cond rs##args m. Proof. intros. unfold cond_strength_reduction. case (cond_strength_reduction_match cond args); intros. caseEq (intval app r1); intros. simpl. rewrite (intval_correct _ _ H). destruct (rs#r2); auto. rewrite Int.swap_cmp. auto. - destruct c; reflexivity. caseEq (intval app r2); intros. simpl. rewrite (intval_correct _ _ H0). auto. auto. caseEq (intval app r1); intros. simpl. rewrite (intval_correct _ _ H). destruct (rs#r2); auto. rewrite Int.swap_cmpu. auto. + destruct c; reflexivity. caseEq (intval app r2); intros. simpl. rewrite (intval_correct _ _ H0). auto. auto. @@ -303,8 +304,8 @@ Qed. Lemma make_shlimm_correct: forall n r v, let (op, args) := make_shlimm n r in - eval_operation ge sp Oshl (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oshl (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_shlimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -315,8 +316,8 @@ Qed. Lemma make_shrimm_correct: forall n r v, let (op, args) := make_shrimm n r in - eval_operation ge sp Oshr (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oshr (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_shrimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -327,8 +328,8 @@ Qed. Lemma make_shruimm_correct: forall n r v, let (op, args) := make_shruimm n r in - eval_operation ge sp Oshru (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oshru (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_shruimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -339,8 +340,8 @@ Qed. Lemma make_mulimm_correct: forall n r v, let (op, args) := make_mulimm n r in - eval_operation ge sp Omul (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Omul (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_mulimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -348,8 +349,8 @@ Proof. generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros. subst n. simpl in H1. simpl. FuncInv. rewrite Int.mul_one in H0. congruence. caseEq (Int.is_power2 n); intros. - replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil)) - with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil)). + replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil) m) + with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil) m). apply make_shlimm_correct. simpl. generalize (Int.is_power2_range _ _ H1). change (Z_of_nat Int.wordsize) with 32. intro. rewrite H2. @@ -360,8 +361,8 @@ Qed. Lemma make_andimm_correct: forall n r v, let (op, args) := make_andimm n r in - eval_operation ge sp Oand (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oand (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_andimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -374,8 +375,8 @@ Qed. Lemma make_orimm_correct: forall n r v, let (op, args) := make_orimm n r in - eval_operation ge sp Oor (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oor (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_orimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -388,8 +389,8 @@ Qed. Lemma make_xorimm_correct: forall n r v, let (op, args) := make_xorimm n r in - eval_operation ge sp Oxor (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oxor (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_xorimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -400,8 +401,8 @@ Qed. Lemma op_strength_reduction_correct: forall op args v, let (op', args') := op_strength_reduction app op args in - eval_operation ge sp op rs##args = Some v -> - eval_operation ge sp op' rs##args' = Some v. + eval_operation ge sp op rs##args m = Some v -> + eval_operation ge sp op' rs##args' m = Some v. Proof. intros; unfold op_strength_reduction; case (op_strength_reduction_match op args); intros; simpl List.map. @@ -432,8 +433,8 @@ Proof. caseEq (intval app r2); intros. caseEq (Int.is_power2 i); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil)). + replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil) m). apply make_shruimm_correct. simpl. destruct rs#r1; auto. rewrite (Int.is_power2_range _ _ H0). @@ -32,6 +32,7 @@ Require Import Values. Require Import Memdata. Require Import Memory. Require Import Globalenvs. +Require Import Events. Set Implicit Arguments. @@ -147,27 +148,30 @@ Definition eval_compare_mismatch (c: comparison) : option bool := Definition eval_compare_null (c: comparison) (n: int) : option bool := if Int.eq n Int.zero then eval_compare_mismatch c else None. -Definition eval_condition (cond: condition) (vl: list val): +Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := match cond, vl with | Ccomp c, Vint n1 :: Vint n2 :: nil => Some (Int.cmp c n1 n2) - | Ccomp c, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if eq_block b1 b2 - then Some (Int.cmp c n1 n2) - else eval_compare_mismatch c - | Ccomp c, Vptr b1 n1 :: Vint n2 :: nil => - eval_compare_null c n2 - | Ccomp c, Vint n1 :: Vptr b2 n2 :: nil => - eval_compare_null c n1 | Ccompu c, Vint n1 :: Vint n2 :: nil => Some (Int.cmpu c n1 n2) + | Ccompu c, Vptr b1 n1 :: Vptr b2 n2 :: nil => + if Mem.valid_pointer m b1 (Int.unsigned n1) + && Mem.valid_pointer m b2 (Int.unsigned n2) then + if eq_block b1 b2 + then Some (Int.cmpu c n1 n2) + else eval_compare_mismatch c + else None + | Ccompu c, Vptr b1 n1 :: Vint n2 :: nil => + eval_compare_null c n2 + | Ccompu c, Vint n1 :: Vptr b2 n2 :: nil => + eval_compare_null c n1 | Ccompimm c n, Vint n1 :: nil => Some (Int.cmp c n1 n) - | Ccompimm c n, Vptr b1 n1 :: nil => - eval_compare_null c n | Ccompuimm c n, Vint n1 :: nil => Some (Int.cmpu c n1 n) + | Ccompuimm c n, Vptr b1 n1 :: nil => + eval_compare_null c n | Ccompf c, Vfloat f1 :: Vfloat f2 :: nil => Some (Float.cmp c f1 f2) | Cnotcompf c, Vfloat f1 :: Vfloat f2 :: nil => @@ -228,7 +232,7 @@ Definition eval_addressing Definition eval_operation (F V: Type) (genv: Genv.t F V) (sp: val) - (op: operation) (vl: list val): option val := + (op: operation) (vl: list val) (m: mem): option val := match op, vl with | Omove, v1::nil => Some v1 | Ointconst n, nil => Some (Vint n) @@ -289,7 +293,7 @@ Definition eval_operation | Ofloatofint, Vint n1 :: nil => Some (Vfloat (Float.floatofint n1)) | Ocmp c, _ => - match eval_condition c vl with + match eval_condition c vl m with | None => None | Some false => Some Vfalse | Some true => Some Vtrue @@ -340,21 +344,24 @@ Proof. Qed. Lemma eval_negate_condition: - forall (cond: condition) (vl: list val) (b: bool), - eval_condition cond vl = Some b -> - eval_condition (negate_condition cond) vl = Some (negb b). + forall (cond: condition) (vl: list val) (b: bool) (m: mem), + eval_condition cond vl m = Some b -> + eval_condition (negate_condition cond) vl m = Some (negb b). Proof. intros. destruct cond; simpl in H; FuncInv; try subst b; simpl. rewrite Int.negate_cmp. auto. + rewrite Int.negate_cmpu. auto. apply eval_negate_compare_null; auto. apply eval_negate_compare_null; auto. - destruct (eq_block b0 b1). rewrite Int.negate_cmp. congruence. + destruct (Mem.valid_pointer m b0 (Int.unsigned i) && + Mem.valid_pointer m b1 (Int.unsigned i0)); try discriminate. + destruct (eq_block b0 b1); try discriminate. + rewrite Int.negate_cmpu. congruence. apply eval_negate_compare_mismatch; auto. - rewrite Int.negate_cmpu. auto. rewrite Int.negate_cmp. auto. - apply eval_negate_compare_null; auto. rewrite Int.negate_cmpu. auto. + apply eval_negate_compare_null; auto. auto. rewrite negb_elim. auto. auto. @@ -384,8 +391,8 @@ Proof. Qed. Lemma eval_operation_preserved: - forall sp op vl, - eval_operation ge2 sp op vl = eval_operation ge1 sp op vl. + forall sp op vl m, + eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. Proof. intros. unfold eval_operation; destruct op; try rewrite agree_on_symbols; auto. @@ -507,9 +514,9 @@ Proof. Qed. Lemma type_of_operation_sound: - forall op vl sp v, + forall op vl sp v m, op <> Omove -> - eval_operation genv sp op vl = Some v -> + eval_operation genv sp op vl m = Some v -> Val.has_type v (snd (type_of_operation op)). Proof. intros. @@ -570,7 +577,7 @@ End SOUNDNESS. (** Alternate definition of [eval_condition], [eval_op], [eval_addressing] as total functions that return [Vundef] when not applicable - (instead of [None]). Used in the proof of [PPCgen]. *) + (instead of [None]). Used in the proof of [Asmgen]. *) Section EVAL_OP_TOTAL. @@ -675,14 +682,16 @@ Proof. Qed. Lemma eval_condition_weaken: - forall c vl b, - eval_condition c vl = Some b -> + forall c vl b m, + eval_condition c vl m = Some b -> eval_condition_total c vl = Val.of_bool b. Proof. intros. unfold eval_condition in H; destruct c; FuncInv; try subst b; try reflexivity; simpl; try (apply eval_compare_null_weaken; auto). + destruct (Mem.valid_pointer m b0 (Int.unsigned i) && + Mem.valid_pointer m b1 (Int.unsigned i0)); try discriminate. unfold eq_block in H. destruct (zeq b0 b1). congruence. apply eval_compare_mismatch_weaken; auto. @@ -705,8 +714,8 @@ Proof. Qed. Lemma eval_operation_weaken: - forall sp op vl v, - eval_operation genv sp op vl = Some v -> + forall sp op vl v m, + eval_operation genv sp op vl m = Some v -> eval_operation_total sp op vl = v. Proof. intros. @@ -729,7 +738,7 @@ Proof. destruct (Int.ltu i Int.iwordsize); congruence. apply eval_addressing_weaken; auto. destruct (Float.intoffloat f); simpl in H; inv H. auto. - caseEq (eval_condition c vl); intros; rewrite H0 in H. + caseEq (eval_condition c vl m); intros; rewrite H0 in H. replace v with (Val.of_bool b). eapply eval_condition_weaken; eauto. destruct b; simpl; congruence. @@ -779,12 +788,20 @@ Ltac InvLessdef := end. Lemma eval_condition_lessdef: - forall cond vl1 vl2 b, + forall cond vl1 vl2 b m1 m2, Val.lessdef_list vl1 vl2 -> - eval_condition cond vl1 = Some b -> - eval_condition cond vl2 = Some b. + Mem.extends m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. Proof. intros. destruct cond; simpl in *; FuncInv; InvLessdef; auto. + destruct (Mem.valid_pointer m1 b0 (Int.unsigned i) && + Mem.valid_pointer m1 b1 (Int.unsigned i0)) as [] _eqn; try discriminate. + destruct (andb_prop _ _ Heqb2) as [A B]. + assert (forall b ofs, Mem.valid_pointer m1 b ofs = true -> Mem.valid_pointer m2 b ofs = true). + intros until ofs. repeat rewrite Mem.valid_pointer_nonempty_perm. + apply Mem.perm_extends; auto. + rewrite (H _ _ A). rewrite (H _ _ B). auto. Qed. Ltac TrivialExists := @@ -808,10 +825,11 @@ Proof. Qed. Lemma eval_operation_lessdef: - forall sp op vl1 vl2 v1, + forall sp op vl1 vl2 v1 m1 m2, Val.lessdef_list vl1 vl2 -> - eval_operation genv sp op vl1 = Some v1 -> - exists v2, eval_operation genv sp op vl2 = Some v2 /\ Val.lessdef v1 v2. + Mem.extends m1 m2 -> + eval_operation genv sp op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. Proof. intros. destruct op; simpl in *; FuncInv; InvLessdef; TrivialExists. exists v2; auto. @@ -819,30 +837,182 @@ Proof. exists (Val.zero_ext 8 v2); split. auto. apply Val.zero_ext_lessdef; auto. exists (Val.sign_ext 16 v2); split. auto. apply Val.sign_ext_lessdef; auto. exists (Val.zero_ext 16 v2); split. auto. apply Val.zero_ext_lessdef; auto. - destruct (eq_block b b0); inv H0. TrivialExists. - destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. - destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. - destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. - destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. - destruct (Int.ltu i0 Int.iwordsize); inv H0; TrivialExists. - destruct (Int.ltu i Int.iwordsize); inv H0; TrivialExists. - destruct (Int.ltu i0 Int.iwordsize); inv H0; TrivialExists. - destruct (Int.ltu i Int.iwordsize); inv H0; TrivialExists. - destruct (Int.ltu i (Int.repr 31)); inv H0; TrivialExists. - destruct (Int.ltu i0 Int.iwordsize); inv H0; TrivialExists. - destruct (Int.ltu i Int.iwordsize); inv H0; TrivialExists. - destruct (Int.ltu i Int.iwordsize); inv H0; TrivialExists. + destruct (eq_block b b0); inv H1. TrivialExists. + destruct (Int.eq i0 Int.zero); inv H1; TrivialExists. + destruct (Int.eq i0 Int.zero); inv H1; TrivialExists. + destruct (Int.eq i0 Int.zero); inv H1; TrivialExists. + destruct (Int.eq i0 Int.zero); inv H1; TrivialExists. + destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialExists. + destruct (Int.ltu i Int.iwordsize); inv H1; TrivialExists. + destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialExists. + destruct (Int.ltu i Int.iwordsize); inv H1; TrivialExists. + destruct (Int.ltu i (Int.repr 31)); inv H1; TrivialExists. + destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialExists. + destruct (Int.ltu i Int.iwordsize); inv H1; TrivialExists. + destruct (Int.ltu i Int.iwordsize); inv H1; TrivialExists. eapply eval_addressing_lessdef; eauto. exists (Val.singleoffloat v2); split. auto. apply Val.singleoffloat_lessdef; auto. exists v1; split; auto. - caseEq (eval_condition c vl1); intros. rewrite H1 in H0. - rewrite (eval_condition_lessdef c H H1). - destruct b; inv H0; TrivialExists. - rewrite H1 in H0. discriminate. + destruct (eval_condition c vl1 m1) as [] _eqn. + rewrite (eval_condition_lessdef c H H0 Heqo). + destruct b; inv H1; TrivialExists. + discriminate. Qed. End EVAL_LESSDEF. +(** Shifting stack-relative references. This is used in [Stacking]. *) + +Definition shift_stack_addressing (delta: int) (addr: addressing) := + match addr with + | Ainstack ofs => Ainstack (Int.add delta ofs) + | _ => addr + end. + +Definition shift_stack_operation (delta: int) (op: operation) := + match op with + | Olea addr => Olea (shift_stack_addressing delta addr) + | _ => op + end. + +Lemma type_shift_stack_addressing: + forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. +Proof. + intros. destruct addr; auto. +Qed. + +Lemma type_shift_stack_operation: + forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. +Proof. + intros. destruct op; auto. simpl. decEq. apply type_shift_stack_addressing. +Qed. + +(** Compatibility of the evaluation functions with memory injections. *) + +Section EVAL_INJECT. + +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. +Hypothesis globals: meminj_preserves_globals genv f. +Variable sp1: block. +Variable sp2: block. +Variable delta: Z. +Hypothesis sp_inj: f sp1 = Some(sp2, delta). + +Ltac InvInject := + match goal with + | [ H: val_inject _ (Vint _) _ |- _ ] => + inv H; InvInject + | [ H: val_inject _ (Vfloat _) _ |- _ ] => + inv H; InvInject + | [ H: val_inject _ (Vptr _ _) _ |- _ ] => + inv H; InvInject + | [ H: val_list_inject _ nil _ |- _ ] => + inv H; InvInject + | [ H: val_list_inject _ (_ :: _) _ |- _ ] => + inv H; InvInject + | _ => idtac + end. + +Lemma eval_condition_inject: + forall cond vl1 vl2 b m1 m2, + val_list_inject f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. destruct cond; simpl in *; FuncInv; InvInject; auto. + destruct (Mem.valid_pointer m1 b0 (Int.unsigned i)) as [] _eqn; try discriminate. + destruct (Mem.valid_pointer m1 b1 (Int.unsigned i0)) as [] _eqn; try discriminate. + simpl in H1. + exploit Mem.valid_pointer_inject_val. eauto. eexact Heqb0. econstructor; eauto. + intros V1. rewrite V1. + exploit Mem.valid_pointer_inject_val. eauto. eexact Heqb2. econstructor; eauto. + intros V2. rewrite V2. + simpl. + destruct (eq_block b0 b1); inv H1. + rewrite H3 in H5; inv H5. rewrite dec_eq_true. + decEq. apply Int.translate_cmpu. + eapply Mem.valid_pointer_inject_no_overflow; eauto. + eapply Mem.valid_pointer_inject_no_overflow; eauto. + exploit Mem.different_pointers_inject; eauto. intros P. + destruct (eq_block b3 b4); auto. + destruct P. contradiction. + destruct c; unfold eval_compare_mismatch in *; inv H2. + unfold Int.cmpu. rewrite Int.eq_false; auto. congruence. + unfold Int.cmpu. rewrite Int.eq_false; auto. congruence. +Qed. + +Ltac TrivialExists2 := + match goal with + | [ |- exists v2, Some ?v1 = Some v2 /\ val_inject _ _ v2 ] => + exists v1; split; [auto | econstructor; eauto] + | _ => idtac + end. + +Lemma eval_addressing_inject: + forall addr vl1 vl2 v1, + val_list_inject f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Int.zero) addr vl1 = Some v1 -> + exists v2, + eval_addressing genv (Vptr sp2 Int.zero) (shift_stack_addressing (Int.repr delta) addr) vl2 = Some v2 + /\ val_inject f v1 v2. +Proof. + intros. destruct addr; simpl in *; FuncInv; InvInject; TrivialExists2. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. rewrite Int.add_commut. apply Int.add_assoc. + repeat rewrite Int.add_assoc. decEq. rewrite Int.add_commut. apply Int.add_assoc. + repeat rewrite Int.add_assoc. decEq. rewrite Int.add_commut. apply Int.add_assoc. + destruct (Genv.find_symbol genv i) as [] _eqn; inv H0. + TrivialExists2. eapply (proj1 globals); eauto. rewrite Int.add_zero; auto. + destruct (Genv.find_symbol genv i) as [] _eqn; inv H0. + TrivialExists2. eapply (proj1 globals); eauto. rewrite Int.add_zero; auto. + destruct (Genv.find_symbol genv i0) as [] _eqn; inv H0. + TrivialExists2. eapply (proj1 globals); eauto. rewrite Int.add_zero; auto. + rewrite Int.add_assoc. decEq. apply Int.add_commut. +Qed. + +Lemma eval_operation_inject: + forall op vl1 vl2 v1 m1 m2, + val_list_inject f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_operation genv (Vptr sp1 Int.zero) op vl1 m1 = Some v1 -> + exists v2, + eval_operation genv (Vptr sp2 Int.zero) (shift_stack_operation (Int.repr delta) op) vl2 m2 = Some v2 + /\ val_inject f v1 v2. +Proof. + intros. destruct op; simpl in *; FuncInv; InvInject; TrivialExists2. + exists v'; auto. + exists (Val.sign_ext 8 v'); split; auto. inv H4; simpl; auto. + exists (Val.zero_ext 8 v'); split; auto. inv H4; simpl; auto. + exists (Val.sign_ext 16 v'); split; auto. inv H4; simpl; auto. + exists (Val.zero_ext 16 v'); split; auto. inv H4; simpl; auto. + rewrite Int.sub_add_l. auto. + destruct (eq_block b b0); inv H1. rewrite H3 in H5; inv H5. rewrite dec_eq_true. + rewrite Int.sub_shifted. TrivialExists2. + destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. + destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. + destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. + destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. + destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialExists2. + destruct (Int.ltu i Int.iwordsize); inv H1. TrivialExists2. + destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialExists2. + destruct (Int.ltu i Int.iwordsize); inv H1. TrivialExists2. + destruct (Int.ltu i (Int.repr 31)); inv H1. TrivialExists2. + destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialExists2. + destruct (Int.ltu i Int.iwordsize); inv H1. TrivialExists2. + destruct (Int.ltu i Int.iwordsize); inv H1. TrivialExists2. + eapply eval_addressing_inject; eauto. + exists (Val.singleoffloat v'); split; auto. inv H4; simpl; auto. + destruct (Float.intoffloat f0); simpl in *; inv H1. TrivialExists2. + destruct (eval_condition c vl1 m1) as [] _eqn; try discriminate. + exploit eval_condition_inject; eauto. intros EQ; rewrite EQ. + destruct b; inv H1; TrivialExists2. +Qed. + +End EVAL_INJECT. + (** Transformation of addressing modes with two operands or more into an equivalent arithmetic operation. This is used in the [Reload] pass when a store instruction cannot be reloaded directly because @@ -851,10 +1021,10 @@ End EVAL_LESSDEF. Definition op_for_binary_addressing (addr: addressing) : operation := Olea addr. Lemma eval_op_for_binary_addressing: - forall (F V: Type) (ge: Genv.t F V) sp addr args v, + forall (F V: Type) (ge: Genv.t F V) sp addr args v m, (length args >= 2)%nat -> eval_addressing ge sp addr args = Some v -> - eval_operation ge sp (op_for_binary_addressing addr) args = Some v. + eval_operation ge sp (op_for_binary_addressing addr) args m = Some v. Proof. intros. simpl. auto. Qed. @@ -925,53 +1095,21 @@ Definition is_trivial_op (op: operation) : bool := | _ => false end. -(** Shifting stack-relative references. This is used in [Stacking]. *) +(** Operations that depend on the memory state. *) -Definition shift_stack_addressing (delta: int) (addr: addressing) := - match addr with - | Ainstack ofs => Ainstack (Int.add delta ofs) - | _ => addr - end. - -Definition shift_stack_operation (delta: int) (op: operation) := +Definition op_depends_on_memory (op: operation) : bool := match op with - | Olea addr => Olea (shift_stack_addressing delta addr) - | _ => op + | Ocmp (Ccompu _) => true + | _ => false end. -Lemma shift_stack_eval_addressing: - forall (F V: Type) (ge: Genv.t F V) sp addr args delta, - eval_addressing ge (Val.sub sp (Vint delta)) (shift_stack_addressing delta addr) args = - eval_addressing ge sp addr args. +Lemma op_depends_on_memory_correct: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + op_depends_on_memory op = false -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. - intros. destruct addr; simpl; auto. - destruct args; auto. unfold offset_sp. destruct sp; simpl; auto. - decEq. decEq. rewrite <- Int.add_assoc. decEq. - rewrite Int.sub_add_opp. rewrite Int.add_assoc. - rewrite (Int.add_commut (Int.neg delta)). rewrite <- Int.sub_add_opp. - rewrite Int.sub_idem. apply Int.add_zero. + intros until m2. destruct op; simpl; try congruence. + destruct c; simpl; congruence. Qed. -Lemma shift_stack_eval_operation: - forall (F V: Type) (ge: Genv.t F V) sp op args delta, - eval_operation ge (Val.sub sp (Vint delta)) (shift_stack_operation delta op) args = - eval_operation ge sp op args. -Proof. - intros. destruct op; simpl; auto. - apply shift_stack_eval_addressing. -Qed. - -Lemma type_shift_stack_addressing: - forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. -Proof. - intros. destruct addr; auto. -Qed. - -Lemma type_shift_stack_operation: - forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. -Proof. - intros. destruct op; auto. simpl. decEq. apply type_shift_stack_addressing. -Qed. - - diff --git a/ia32/PrintAsm.ml b/ia32/PrintAsm.ml index e4c2ea1..e4de2a3 100644 --- a/ia32/PrintAsm.ml +++ b/ia32/PrintAsm.ml @@ -165,12 +165,12 @@ let int32_align n a = then Int32.logand (Int32.add n (Int32.of_int (a-1))) (Int32.of_int (-a)) else Int32.logand n (Int32.of_int (-a)) -let sp_adjustment lo hi = - let lo = camlint_of_coqint lo and hi = camlint_of_coqint hi in - let sz = Int32.sub hi lo in -(* Enforce stack alignment, noting that 4 bytes are already allocated - by the call *) - let sz = Int32.sub (int32_align (Int32.add sz 4l) stack_alignment) 4l in +let sp_adjustment sz = + let sz = camlint_of_coqint sz in + (* Preserve proper alignment of the stack *) + let sz = int32_align sz stack_alignment in + (* The top 4 bytes have already been allocated by the "call" instruction. *) + let sz = Int32.sub sz 4l in assert (sz >= 0l); sz @@ -549,14 +549,14 @@ let print_instruction oc labels = function | Plabel(l) -> if Labelset.mem l labels then fprintf oc "%a:\n" label (transl_label l) - | Pallocframe(lo, hi, ofs_ra, ofs_link) -> - let sz = sp_adjustment lo hi in + | Pallocframe(sz, ofs_ra, ofs_link) -> + let sz = sp_adjustment sz in let ofs_link = camlint_of_coqint ofs_link in fprintf oc " subl $%ld, %%esp\n" sz; fprintf oc " leal %ld(%%esp), %%edx\n" (Int32.add sz 4l); fprintf oc " movl %%edx, %ld(%%esp)\n" ofs_link - | Pfreeframe(lo, hi, ofs_ra, ofs_link) -> - let sz = sp_adjustment lo hi in + | Pfreeframe(sz, ofs_ra, ofs_link) -> + let sz = sp_adjustment sz in fprintf oc " addl $%ld, %%esp\n" sz | Pbuiltin(ef, args, res) -> let name = extern_atom ef.ef_id in diff --git a/ia32/SelectOp.v b/ia32/SelectOp.v index 4a4d9e1..c1f5703 100644 --- a/ia32/SelectOp.v +++ b/ia32/SelectOp.v @@ -61,7 +61,7 @@ Definition addrstack (ofs: int) := (** ** Boolean negation *) Definition notbool_base (e: expr) := - Eop (Ocmp (Ccompimm Ceq Int.zero)) (e ::: Enil). + Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil). Fixpoint notbool (e: expr) {struct e} : expr := match e with diff --git a/ia32/SelectOpproof.v b/ia32/SelectOpproof.v index 3d6a667..82bca26 100644 --- a/ia32/SelectOpproof.v +++ b/ia32/SelectOpproof.v @@ -64,13 +64,13 @@ Ltac InvEval1 := Ltac InvEval2 := match goal with - | [ H: (eval_operation _ _ _ nil = Some _) |- _ ] => + | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => simpl in H; inv H - | [ H: (eval_operation _ _ _ (_ :: nil) = Some _) |- _ ] => + | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: nil) = Some _) |- _ ] => + | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) = Some _) |- _ ] => + | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => simpl in H; FuncInv | _ => idtac @@ -150,12 +150,12 @@ Proof. eapply eval_notbool_base; eauto. inv H. eapply eval_Eop; eauto. - simpl. assert (eval_condition c vl = Some b). + simpl. assert (eval_condition c vl m = Some b). generalize H6. simpl. case (eval_condition c vl); intros. destruct b0; inv H1; inversion H0; auto; congruence. congruence. - rewrite (Op.eval_negate_condition _ _ H). + rewrite (Op.eval_negate_condition _ _ _ H). destruct b; reflexivity. inv H. eapply eval_Econdition; eauto. @@ -667,7 +667,7 @@ Proof. EvalOp. simpl. rewrite H1. auto. Qed. -Theorem eval_comp_int: +Theorem eval_comp: forall le c a x b y, eval_expr ge sp e m le a (Vint x) -> eval_expr ge sp e m le b (Vint y) -> @@ -680,6 +680,19 @@ Proof. EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. Qed. +Theorem eval_compu_int: + forall le c a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)). +Proof. + intros until y. + unfold compu; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. +Qed. + Remark eval_compare_null_transf: forall c x v, Cminor.eval_compare_null c x = Some v -> @@ -694,15 +707,15 @@ Proof. destruct c; try discriminate; auto. Qed. -Theorem eval_comp_ptr_int: +Theorem eval_compu_ptr_int: forall le c a x1 x2 b y v, eval_expr ge sp e m le a (Vptr x1 x2) -> eval_expr ge sp e m le b (Vint y) -> Cminor.eval_compare_null c y = Some v -> - eval_expr ge sp e m le (comp c a b) v. + eval_expr ge sp e m le (compu c a b) v. Proof. intros until v. - unfold comp; case (comp_match a b); intros; InvEval. + unfold compu; case (comp_match a b); intros; InvEval. EvalOp. simpl. apply eval_compare_null_transf; auto. EvalOp. simpl. apply eval_compare_null_transf; auto. Qed. @@ -716,58 +729,49 @@ Proof. destruct (Int.eq x Int.zero). destruct c; auto. auto. Qed. -Theorem eval_comp_int_ptr: +Theorem eval_compu_int_ptr: forall le c a x b y1 y2 v, eval_expr ge sp e m le a (Vint x) -> eval_expr ge sp e m le b (Vptr y1 y2) -> Cminor.eval_compare_null c x = Some v -> - eval_expr ge sp e m le (comp c a b) v. + eval_expr ge sp e m le (compu c a b) v. Proof. intros until v. - unfold comp; case (comp_match a b); intros; InvEval. + unfold compu; case (comp_match a b); intros; InvEval. EvalOp. simpl. apply eval_compare_null_transf. rewrite eval_compare_null_swap; auto. EvalOp. simpl. apply eval_compare_null_transf. auto. Qed. -Theorem eval_comp_ptr_ptr: +Theorem eval_compu_ptr_ptr: forall le c a x1 x2 b y1 y2, eval_expr ge sp e m le a (Vptr x1 x2) -> eval_expr ge sp e m le b (Vptr y1 y2) -> + Mem.valid_pointer m x1 (Int.unsigned x2) + && Mem.valid_pointer m y1 (Int.unsigned y2) = true -> x1 = y1 -> - eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x2 y2)). + eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x2 y2)). Proof. intros until y2. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. subst y1. rewrite dec_eq_true. - destruct (Int.cmp c x2 y2); reflexivity. + unfold compu; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite H1. subst y1. rewrite dec_eq_true. + destruct (Int.cmpu c x2 y2); reflexivity. Qed. -Theorem eval_comp_ptr_ptr_2: +Theorem eval_compu_ptr_ptr_2: forall le c a x1 x2 b y1 y2 v, eval_expr ge sp e m le a (Vptr x1 x2) -> eval_expr ge sp e m le b (Vptr y1 y2) -> + Mem.valid_pointer m x1 (Int.unsigned x2) + && Mem.valid_pointer m y1 (Int.unsigned y2) = true -> x1 <> y1 -> Cminor.eval_compare_mismatch c = Some v -> - eval_expr ge sp e m le (comp c a b) v. + eval_expr ge sp e m le (compu c a b) v. Proof. intros until y2. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite dec_eq_false; auto. - destruct c; simpl in H2; inv H2; auto. -Qed. - -Theorem eval_compu: - forall le c a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)). -Proof. - intros until y. unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto. + destruct c; simpl in H3; inv H3; auto. Qed. Theorem eval_compf: diff --git a/ia32/standard/Conventions1.v b/ia32/standard/Conventions1.v index a2d7aba..781617e 100644 --- a/ia32/standard/Conventions1.v +++ b/ia32/standard/Conventions1.v @@ -62,7 +62,7 @@ Definition dummy_float_reg := X0. (**r Used in [Coloring]. *) Definition index_int_callee_save (r: mreg) := match r with - | BX => 1 | SI => 2 | DI => 3 | BP => 4 | _ => -1 + | BX => 0 | SI => 1 | DI => 2 | BP => 3 | _ => -1 end. Definition index_float_callee_save (r: mreg) := -1. diff --git a/ia32/standard/Stacklayout.v b/ia32/standard/Stacklayout.v index 135aba1..1fa3fb3 100644 --- a/ia32/standard/Stacklayout.v +++ b/ia32/standard/Stacklayout.v @@ -19,21 +19,15 @@ Require Import Bounds. from bottom (lowest offsets) to top: - Space for outgoing arguments to function calls. - Back link to parent frame -- Return address (formally; it's actually pushed elsewhere) - Local stack slots of integer type. - Saved values of integer callee-save registers used by the function. - Local stack slots of float type. - Saved values of float callee-save registers used by the function. -- Space for the stack-allocated data declared in Cminor. - -To facilitate some of the proofs, the Cminor stack-allocated data -starts at offset 0; the preceding areas in the activation record -therefore have negative offsets. This part (with negative offsets) -is called the ``frame'', by opposition with the ``Cminor stack data'' -which is the part with positive offsets. +- Space for the stack-allocated data declared in Cminor +- Return address. The [frame_env] compilation environment records the positions of -the boundaries between areas in the frame part. +the boundaries between these areas of the activation record. *) Definition fe_ofs_arg := 0. @@ -47,7 +41,8 @@ Record frame_env : Type := mk_frame_env { fe_num_int_callee_save: Z; fe_ofs_float_local: Z; fe_ofs_float_callee_save: Z; - fe_num_float_callee_save: Z + fe_num_float_callee_save: Z; + fe_stack_data: Z }. (** Computation of the frame environment from the bounds of the current @@ -55,22 +50,101 @@ Record frame_env : Type := mk_frame_env { Definition make_env (b: bounds) := let olink := 4 * b.(bound_outgoing) in (* back link *) - let oretaddr := olink + 4 in (* return address *) - let oil := oretaddr + 4 in (* integer locals *) + let oil := olink + 4 in (* integer locals *) let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *) let oendi := oics + 4 * b.(bound_int_callee_save) in let ofl := align oendi 8 in (* float locals *) let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *) - let sz := ofcs + 8 * b.(bound_float_callee_save) in (* total frame size *) + let ostkdata := ofcs + 8 * b.(bound_float_callee_save) in (* stack data *) + let oretaddr := align (ostkdata + b.(bound_stack_data)) 4 in (* return address *) + let sz := oretaddr + 4 in (* total size *) mk_frame_env sz olink oretaddr oil oics b.(bound_int_callee_save) - ofl ofcs b.(bound_float_callee_save). + ofl ofcs b.(bound_float_callee_save) + ostkdata. + +(** Separation property *) + +Remark frame_env_separated: + forall b, + let fe := make_env b in + 0 <= fe_ofs_arg + /\ fe_ofs_arg + 4 * b.(bound_outgoing) <= fe.(fe_ofs_link) + /\ fe.(fe_ofs_link) + 4 <= fe.(fe_ofs_int_local) + /\ fe.(fe_ofs_int_local) + 4 * b.(bound_int_local) <= fe.(fe_ofs_int_callee_save) + /\ fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save) <= fe.(fe_ofs_float_local) + /\ fe.(fe_ofs_float_local) + 8 * b.(bound_float_local) <= fe.(fe_ofs_float_callee_save) + /\ fe.(fe_ofs_float_callee_save) + 8 * b.(bound_float_callee_save) <= fe.(fe_stack_data) + /\ fe.(fe_stack_data) + b.(bound_stack_data) <= fe.(fe_ofs_retaddr) + /\ fe.(fe_ofs_retaddr) + 4 <= fe.(fe_size). +Proof. + intros. + generalize (align_le (fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save)) 8 (refl_equal _)). + generalize (align_le (fe.(fe_stack_data) + b.(bound_stack_data)) 4 (refl_equal _)). + unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr, + fe_ofs_int_local, fe_ofs_int_callee_save, + fe_num_int_callee_save, + fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save, + fe_stack_data, fe_ofs_arg. + intros. + generalize (bound_int_local_pos b); intro; + generalize (bound_float_local_pos b); intro; + generalize (bound_int_callee_save_pos b); intro; + generalize (bound_float_callee_save_pos b); intro; + generalize (bound_outgoing_pos b); intro; + generalize (bound_stack_data_pos b); intro. + omega. +Qed. +(** Alignment property *) +Remark frame_env_aligned: + forall b, + let fe := make_env b in + (4 | fe.(fe_ofs_link)) + /\ (4 | fe.(fe_ofs_int_local)) + /\ (4 | fe.(fe_ofs_int_callee_save)) + /\ (8 | fe.(fe_ofs_float_local)) + /\ (8 | fe.(fe_ofs_float_callee_save)) + /\ (4 | fe.(fe_ofs_retaddr)) + /\ (4 | fe.(fe_stack_data)) + /\ (4 | fe.(fe_size)). +Proof. + intros. + unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr, + fe_ofs_int_local, fe_ofs_int_callee_save, + fe_num_int_callee_save, + fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save, + fe_stack_data. + set (x1 := 4 * bound_outgoing b). + assert (4 | x1). unfold x1; exists (bound_outgoing b); ring. + set (x2 := x1 + 4). + assert (4 | x2). unfold x2; apply Zdivide_plus_r; auto. exists 1; auto. + set (x3 := x2 + 4 * bound_int_local b). + assert (4 | x3). unfold x2; apply Zdivide_plus_r; auto. exists (bound_int_local b); ring. + set (x4 := x3 + 4 * bound_int_callee_save b). + set (x5 := align x4 8). + assert (8 | x5). unfold x5. apply align_divides. omega. + set (x6 := x5 + 8 * bound_float_local b). + assert (8 | x6). unfold x6. apply Zdivide_plus_r; auto. exists (bound_float_local b); ring. + set (x7 := x6 + 8 * bound_float_callee_save b). + assert (4 | x7). + apply Zdivides_trans with 8. exists 2; auto. + unfold x7. apply Zdivide_plus_r; auto. exists (bound_float_callee_save b); ring. + set (x8 := align (x7 + bound_stack_data b) 4). + assert (4 | x8). apply align_divides. omega. + set (x9 := x8 + 4). + assert (4 | x9). unfold x8; apply Zdivide_plus_r; auto. exists 1; auto. + tauto. +Qed. + +(* Remark align_float_part: forall b, 4 * bound_outgoing b + 4 + 4 + 4 * bound_int_local b + 4 * bound_int_callee_save b <= align (4 * bound_outgoing b + 4 + 4 + 4 * bound_int_local b + 4 * bound_int_callee_save b) 8. + Proof. intros. apply align_le. omega. Qed. +*)
\ No newline at end of file diff --git a/lib/Integers.v b/lib/Integers.v index 1087728..4ed1396 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -1287,29 +1287,6 @@ Proof. intros. apply (bitwise_binop_idem andb). destruct a; auto. Qed. -Theorem add_and: - forall x y z, - and y z = zero -> - add (and x y) (and x z) = and x (or y z). -Proof. - intros. unfold add, and, bitwise_binop. - repeat rewrite unsigned_repr; auto with ints. decEq. - apply Z_of_bits_excl; intros. - assert (forall a b c, a && b && (a && c) = a && (b && c)). - destruct a; destruct b; destruct c; reflexivity. - rewrite H1. - replace (bits_of_Z wordsize (unsigned y) i && - bits_of_Z wordsize (unsigned z) i) - with (bits_of_Z wordsize (unsigned (and y z)) i). - rewrite H. rewrite unsigned_zero. - rewrite bits_of_Z_zero. apply andb_b_false. - unfold and, bitwise_binop. rewrite unsigned_repr; auto with ints. - rewrite bits_of_Z_of_bits. reflexivity. auto. - rewrite <- demorgan1. - unfold or, bitwise_binop. rewrite unsigned_repr; auto with ints. - rewrite bits_of_Z_of_bits; auto. -Qed. - Theorem or_commut: forall x y, or x y = or y x. Proof (bitwise_binop_commut orb orb_comm). @@ -1393,12 +1370,129 @@ Proof. auto. Qed. +(** Properties of bitwise complement.*) + Theorem not_involutive: forall (x: int), not (not x) = x. Proof. intros. unfold not. rewrite xor_assoc. rewrite xor_idem. apply xor_zero. Qed. +Theorem not_zero: + not zero = mone. +Proof. + unfold not. rewrite xor_commut. apply xor_zero. +Qed. + +Theorem not_mone: + not mone = zero. +Proof. + rewrite <- (not_involutive zero). symmetry. decEq. apply not_zero. +Qed. + +Theorem not_or_and_not: + forall x y, not (or x y) = and (not x) (not y). +Proof. + intros; unfold not, xor, and, or, bitwise_binop. + repeat rewrite unsigned_repr; auto with ints. + decEq; apply Z_of_bits_exten; intros. + repeat rewrite bits_of_Z_of_bits; repeat rewrite Zplus_0_r; auto. + rewrite unsigned_mone. rewrite bits_of_Z_mone; auto. + assert (forall a b, xorb (a || b) true = xorb a true && xorb b true). + destruct a; destruct b; reflexivity. + auto. +Qed. + +Theorem not_and_or_not: + forall x y, not (and x y) = or (not x) (not y). +Proof. + intros. rewrite <- (not_involutive x) at 1. rewrite <- (not_involutive y) at 1. + rewrite <- not_or_and_not. apply not_involutive. +Qed. + +Theorem and_not_self: + forall x, and x (not x) = zero. +Proof. + intros. unfold not. rewrite and_xor_distrib. + rewrite and_idem. rewrite and_mone. apply xor_idem. +Qed. + +Theorem or_not_self: + forall x, or x (not x) = mone. +Proof. + intros. rewrite <- (not_involutive x) at 1. rewrite or_commut. + rewrite <- not_and_or_not. rewrite and_not_self. apply not_zero. +Qed. + +Theorem xor_not_self: + forall x, xor x (not x) = mone. +Proof. + intros. unfold not. rewrite <- xor_assoc. rewrite xor_idem. apply not_zero. +Qed. + +(** Connections between [add] and bitwise logical operations. *) + +Theorem add_is_or: + forall x y, + and x y = zero -> + add x y = or x y. +Proof. + intros. unfold add, or, bitwise_binop. + apply eqm_samerepr. eapply eqm_trans. apply eqm_add. + apply eqm_sym. apply Z_of_bits_of_Z. + apply eqm_sym. apply Z_of_bits_of_Z. + apply eqm_refl2. + apply Z_of_bits_excl. + intros. + replace (bits_of_Z wordsize (unsigned x) i && + bits_of_Z wordsize (unsigned y) i) + with (bits_of_Z wordsize (unsigned (and x y)) i). + rewrite H. rewrite unsigned_zero. rewrite bits_of_Z_zero. auto. + unfold and, bitwise_binop. rewrite unsigned_repr; auto with ints. + rewrite bits_of_Z_of_bits. reflexivity. auto. + auto. +Qed. + +Theorem xor_is_or: + forall x y, and x y = zero -> xor x y = or x y. +Proof. + intros. unfold xor, or, bitwise_binop. + decEq. apply Z_of_bits_exten; intros. + set (bitx := bits_of_Z wordsize (unsigned x) (i + 0)). + set (bity := bits_of_Z wordsize (unsigned y) (i + 0)). + assert (bitx && bity = false). + replace (bitx && bity) + with (bits_of_Z wordsize (unsigned (and x y)) (i + 0)). + rewrite H. rewrite unsigned_zero. apply bits_of_Z_zero. + unfold and, bitwise_binop. rewrite unsigned_repr; auto with ints. + unfold bitx, bity. rewrite bits_of_Z_of_bits. reflexivity. + omega. + destruct bitx; destruct bity; auto; simpl in H1; congruence. +Qed. + +Theorem add_is_xor: + forall x y, + and x y = zero -> + add x y = xor x y. +Proof. + intros. rewrite xor_is_or; auto. apply add_is_or; auto. +Qed. + +Theorem add_and: + forall x y z, + and y z = zero -> + add (and x y) (and x z) = and x (or y z). +Proof. + intros. rewrite add_is_or. + rewrite and_or_distrib; auto. + rewrite (and_commut x y). + rewrite and_assoc. + repeat rewrite <- (and_assoc x). + rewrite (and_commut (and x x)). + rewrite <- and_assoc. + rewrite H. rewrite and_commut. apply and_zero. +Qed. + (** ** Properties of shifts *) Theorem shl_zero: forall x, shl x zero = x. @@ -2685,6 +2779,28 @@ Proof. omega. omega. Qed. +Lemma translate_ltu: + forall x y d, + 0 <= unsigned x + unsigned d <= max_unsigned -> + 0 <= unsigned y + unsigned d <= max_unsigned -> + ltu (add x d) (add y d) = ltu x y. +Proof. + intros. unfold add. unfold ltu. + repeat rewrite unsigned_repr; auto. case (zlt (unsigned x) (unsigned y)); intro. + apply zlt_true. omega. + apply zlt_false. omega. +Qed. + +Theorem translate_cmpu: + forall c x y d, + 0 <= unsigned x + unsigned d <= max_unsigned -> + 0 <= unsigned y + unsigned d <= max_unsigned -> + cmpu c (add x d) (add y d) = cmpu c x y. +Proof. + intros. unfold cmpu. + rewrite translate_eq. repeat rewrite translate_ltu; auto. +Qed. + Lemma translate_lt: forall x y d, min_signed <= signed x + signed d <= max_signed -> diff --git a/powerpc/Asm.v b/powerpc/Asm.v index e49986f..d698524 100644 --- a/powerpc/Asm.v +++ b/powerpc/Asm.v @@ -130,7 +130,7 @@ Inductive instruction : Type := | Paddi: ireg -> ireg -> constant -> instruction (**r add immediate *) | Paddis: ireg -> ireg -> constant -> instruction (**r add immediate high *) | Paddze: ireg -> ireg -> instruction (**r add Carry bit *) - | Pallocframe: Z -> Z -> int -> instruction (**r allocate new stack frame *) + | Pallocframe: Z -> int -> instruction (**r allocate new stack frame *) | Pand_: ireg -> ireg -> ireg -> instruction (**r bitwise and *) | Pandc: ireg -> ireg -> ireg -> instruction (**r bitwise and-complement *) | Pandi_: ireg -> ireg -> constant -> instruction (**r and immediate and set conditions *) @@ -154,7 +154,7 @@ Inductive instruction : Type := | Peqv: ireg -> ireg -> ireg -> instruction (**r bitwise not-xor *) | Pextsb: ireg -> ireg -> instruction (**r 8-bit sign extension *) | Pextsh: ireg -> ireg -> instruction (**r 16-bit sign extension *) - | Pfreeframe: Z -> Z -> int -> instruction (**r deallocate stack frame and restore previous frame *) + | Pfreeframe: Z -> int -> instruction (**r deallocate stack frame and restore previous frame *) | Pfabs: freg -> freg -> instruction (**r float absolute value *) | Pfadd: freg -> freg -> freg -> instruction (**r float addition *) | Pfcmpu: freg -> freg -> instruction (**r float comparison *) @@ -249,19 +249,19 @@ lbl: .double floatcst lfd rdst, 0(r1) addi r1, r1, 8 >> -- [Pallocframe lo hi ofs]: in the formal semantics, this pseudo-instruction - allocates a memory block with bounds [lo] and [hi], stores the value +- [Pallocframe sz ofs]: in the formal semantics, this pseudo-instruction + allocates a memory block with bounds [0] and [sz], stores the value of register [r1] (the stack pointer, by convention) at offset [ofs] in this block, and sets [r1] to a pointer to the bottom of this block. In the printed PowerPC assembly code, this allocation is just a store-decrement of register [r1], assuming that [ofs = 0]: << - stwu r1, (lo - hi)(r1) + stwu r1, -sz(r1) >> This cannot be expressed in our memory model, which does not reflect the fact that stack frames are adjacent and allocated/freed following a stack discipline. -- [Pfreeframe lo hi ofs]: in the formal semantics, this pseudo-instruction +- [Pfreeframe sz ofs]: in the formal semantics, this pseudo-instruction reads the word at offset [ofs] in the block pointed by [r1] (the stack pointer), frees this block, and sets [r1] to the value of the word at offset [ofs]. In the printed PowerPC assembly code, this @@ -527,9 +527,9 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_high cst)))) m | Paddze rd r1 => OK (nextinstr (rs#rd <- (Val.add rs#r1 rs#CARRY))) m - | Pallocframe lo hi ofs => - let (m1, stk) := Mem.alloc m lo hi in - let sp := Vptr stk (Int.repr lo) in + | Pallocframe sz ofs => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := Vptr stk Int.zero in match Mem.storev Mint32 m1 (Val.add sp (Vint ofs)) rs#GPR1 with | None => Error | Some m2 => OK (nextinstr (rs#GPR1 <- sp #GPR0 <- Vundef)) m2 @@ -570,7 +570,7 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pbtbl r tbl => match gpr_or_zero rs r with | Vint n => - let pos := Int.signed n in + let pos := Int.unsigned n in if zeq (Zmod pos 4) 0 then match list_nth_z tbl (pos / 4) with | None => Error @@ -599,13 +599,13 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome OK (nextinstr (rs#rd <- (Val.sign_ext 8 rs#r1))) m | Pextsh rd r1 => OK (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m - | Pfreeframe lo hi ofs => + | Pfreeframe sz ofs => match Mem.loadv Mint32 m (Val.add rs#GPR1 (Vint ofs)) with | None => Error | Some v => match rs#GPR1 with | Vptr stk ofs => - match Mem.free m stk lo hi with + match Mem.free m stk 0 sz with | None => Error | Some m' => OK (nextinstr (rs#GPR1 <- v)) m' end diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v index 9c37c42..5e3d39b 100644 --- a/powerpc/Asmgen.v +++ b/powerpc/Asmgen.v @@ -466,12 +466,12 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := Pmtctr (ireg_of r) :: Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 :: Pmtlr GPR0 :: - Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: + Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbctr :: k | Mtailcall sig (inr symb) => Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 :: Pmtlr GPR0 :: - Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: + Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbs symb :: k | Mbuiltin ef args res => Pbuiltin ef (map preg_of args) (preg_of res) :: k @@ -489,7 +489,7 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := | Mreturn => Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 :: Pmtlr GPR0 :: - Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: + Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pblr :: k end. @@ -502,7 +502,7 @@ Definition transl_code (f: Mach.function) (il: list Mach.instruction) := around, leading to incorrect executions. *) Definition transl_function (f: Mach.function) := - Pallocframe (- f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: + Pallocframe f.(fn_stacksize) f.(fn_link_ofs) :: Pmflr GPR0 :: Pstw GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 :: transl_code f f.(fn_code). diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v index 54e454e..8319363 100644 --- a/powerpc/Asmgenproof.v +++ b/powerpc/Asmgenproof.v @@ -750,12 +750,12 @@ Proof. Qed. Lemma exec_Mgetparam_prop: - forall (s : list stackframe) (fb : block) (f: Mach.function) (sp parent : val) + forall (s : list stackframe) (fb : block) (f: Mach.function) (sp : val) (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (v : val), Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m sp Tint f.(fn_link_ofs) = Some parent -> - load_stack m parent ty ofs = Some v -> + load_stack m sp Tint f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (parent_sp s) ty ofs = Some v -> exec_instr_prop (Machconcr.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0 (Machconcr.State s fb sp c (Regmap.set dst v (Regmap.set IT1 Vundef ms)) m). Proof. @@ -792,7 +792,7 @@ Lemma exec_Mop_prop: forall (s : list stackframe) (fb : block) (sp : val) (op : operation) (args : list mreg) (res : mreg) (c : list Mach.instruction) (ms : mreg -> val) (m : mem) (v : val), - eval_operation ge sp op ms ## args = Some v -> + eval_operation ge sp op ms ## args m = Some v -> exec_instr_prop (Machconcr.State s fb sp (Mop op args res :: c) ms m) E0 (Machconcr.State s fb sp c (Regmap.set res v (undef_op op ms)) m). Proof. @@ -800,7 +800,7 @@ Proof. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI. left; eapply exec_straight_steps; eauto with coqlib. - simpl. eapply transl_op_correct; auto. + simpl. eapply transl_op_correct; eauto. rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. Qed. @@ -810,8 +810,8 @@ Remark loadv_8_signed_unsigned: exists v', Mem.loadv Mint8unsigned m a = Some v' /\ v = Val.sign_ext 8 v'. Proof. unfold Mem.loadv; intros. destruct a; try congruence. - generalize (Mem.load_int8_signed_unsigned m b (Int.signed i)). - rewrite H. destruct (Mem.load Mint8unsigned m b (Int.signed i)). + generalize (Mem.load_int8_signed_unsigned m b (Int.unsigned i)). + rewrite H. destruct (Mem.load Mint8unsigned m b (Int.unsigned i)). simpl; intros. exists v0; split; congruence. simpl; congruence. Qed. @@ -987,7 +987,7 @@ Lemma exec_Mtailcall_prop: 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) -> - Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0 (Callstate s f' ms m'). @@ -1155,7 +1155,7 @@ Lemma exec_Mcond_true_prop: (cond : condition) (args : list mreg) (lbl : Mach.label) (c : list Mach.instruction) (ms : mreg -> val) (m : mem) (c' : Mach.code), - eval_condition cond ms ## args = Some true -> + eval_condition cond ms ## args m = Some true -> Genv.find_funct_ptr ge fb = Some (Internal f) -> Mach.find_label lbl (fn_code f) = Some c' -> exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0 @@ -1168,8 +1168,7 @@ Proof. if snd (crbit_for_cond cond) then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c). - generalize (transl_cond_correct tge (transl_function f) - cond args k1 ms sp rs m' true H3 AG H). + exploit transl_cond_correct; eauto. simpl. intros [rs2 [EX [RES AG2]]]. inv AT. simpl in H5. generalize (functions_transl _ _ H4); intro FN. @@ -1198,29 +1197,22 @@ Lemma exec_Mcond_false_prop: forall (s : list stackframe) (fb : block) (sp : val) (cond : condition) (args : list mreg) (lbl : Mach.label) (c : list Mach.instruction) (ms : mreg -> val) (m : mem), - eval_condition cond ms ## args = Some false -> + eval_condition cond ms ## args m = Some false -> exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0 (Machconcr.State s fb sp c (undef_temps ms) m). Proof. intros; red; intros; inv MS. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI. inversion WTI. - pose (k1 := - if snd (crbit_for_cond cond) - then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c - else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c). - generalize (transl_cond_correct tge (transl_function f) - cond args k1 ms sp rs m' false H1 AG H). + exploit transl_cond_correct; eauto. simpl. intros [rs2 [EX [RES AG2]]]. left; eapply exec_straight_steps; eauto with coqlib. exists (nextinstr rs2); split. simpl. eapply exec_straight_trans. eexact EX. caseEq (snd (crbit_for_cond cond)); intro ISSET; rewrite ISSET in RES. - unfold k1; rewrite ISSET; apply exec_straight_one. - simpl. rewrite RES. reflexivity. + apply exec_straight_one. simpl. rewrite RES. reflexivity. reflexivity. - unfold k1; rewrite ISSET; apply exec_straight_one. - simpl. rewrite RES. reflexivity. + apply exec_straight_one. simpl. rewrite RES. reflexivity. reflexivity. auto with ppcgen. Qed. @@ -1231,7 +1223,7 @@ Lemma exec_Mjumptable_prop: (rs : mreg -> val) (m : mem) (n : int) (lbl : Mach.label) (c' : Mach.code), rs arg = Vint n -> - list_nth_z tbl (Int.signed n) = Some lbl -> + list_nth_z tbl (Int.unsigned n) = Some lbl -> Genv.find_funct_ptr ge fb = Some (Internal f) -> Mach.find_label lbl (fn_code f) = Some c' -> exec_instr_prop @@ -1243,13 +1235,10 @@ Proof. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI. inv WTI. exploit list_nth_z_range; eauto. intro RANGE. - assert (SHIFT: Int.signed (Int.rolm n (Int.repr 2) (Int.repr (-4))) = Int.signed n * 4). + assert (SHIFT: Int.unsigned (Int.rolm n (Int.repr 2) (Int.repr (-4))) = Int.unsigned n * 4). replace (Int.repr (-4)) with (Int.shl Int.mone (Int.repr 2)). rewrite <- Int.shl_rolm. rewrite Int.shl_mul. - rewrite Int.mul_signed. - apply Int.signed_repr. - split. apply Zle_trans with 0. compute; congruence. omega. - omega. + unfold Int.mul. apply Int.unsigned_repr. omega. compute. reflexivity. apply Int.mkint_eq. compute. reflexivity. inv AT. simpl in H7. @@ -1274,11 +1263,10 @@ Proof. eapply exec_straight_steps_1; eauto. econstructor; eauto. eapply find_instr_tail. unfold k1 in CT1. eauto. - unfold exec_instr. + unfold exec_instr. rewrite gpr_or_zero_not_zero; auto with ppcgen. change (rs1 GPR12) with (Vint (Int.rolm n (Int.repr 2) (Int.repr (-4)))). -Opaque Zmod. Opaque Zdiv. - simpl. rewrite SHIFT. rewrite Z_mod_mult. rewrite zeq_true. - rewrite Z_div_mult. + lazy iota beta. rewrite SHIFT. rewrite Z_mod_mult. rewrite zeq_true. + rewrite Z_div_mult. change label with Mach.label; rewrite H0. exact GOTO. omega. traceEq. econstructor; eauto. eapply Mach.find_label_incl; eauto. @@ -1295,7 +1283,7 @@ Lemma exec_Mreturn_prop: 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) -> - Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0 (Returnstate s ms m'). Proof. @@ -1356,12 +1344,12 @@ Lemma exec_function_internal_prop: forall (s : list stackframe) (fb : block) (ms : Mach.regset) (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block), Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mem.alloc m (- fn_framesize f) (fn_stacksize f) = (m1, stk) -> - let sp := Vptr stk (Int.repr (- fn_framesize f)) in + Mem.alloc m 0 (fn_stacksize f) = (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 -> exec_instr_prop (Machconcr.Callstate s fb ms m) E0 - (Machconcr.State s fb sp (fn_code f) ms m3). + (Machconcr.State s fb sp (fn_code f) (undef_temps ms) m3). Proof. intros; red; intros; inv MS. assert (WTF: wt_function f). @@ -1405,7 +1393,7 @@ Proof. assert (AG2: agree ms sp rs2). split. reflexivity. unfold sp. congruence. intros. unfold rs2. rewrite nextinstr_inv. - repeat (rewrite Pregmap.gso). elim AG; auto. + repeat (rewrite Pregmap.gso). inv AG; auto. auto with ppcgen. auto with ppcgen. auto with ppcgen. assert (AG4: agree ms sp rs4). unfold rs4, rs3; auto with ppcgen. @@ -1414,7 +1402,7 @@ Proof. eapply exec_straight_steps_1; eauto. change (Int.unsigned Int.zero) with 0. constructor. (* match states *) - econstructor; eauto with coqlib. + econstructor; eauto with coqlib. auto with ppcgen. Qed. Lemma exec_function_external_prop: diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v index d428543..16dd923 100644 --- a/powerpc/Asmgenproof1.v +++ b/powerpc/Asmgenproof1.v @@ -1110,12 +1110,13 @@ Proof. Qed. Lemma transl_cond_correct: - forall cond args k ms sp rs m b, + forall cond args k ms sp rs m m' b, map mreg_type args = type_of_condition cond -> agree ms sp rs -> - eval_condition cond (map ms args) = Some b -> + eval_condition cond (map ms args) m = Some b -> + Mem.extends m m' -> exists rs', - exec_straight (transl_cond cond args k) rs m k rs' m + exec_straight (transl_cond cond args k) rs m' k rs' m' /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) = (if snd (crbit_for_cond cond) then Val.of_bool b @@ -1124,9 +1125,9 @@ Lemma transl_cond_correct: Proof. intros. assert (eval_condition_total cond rs ## (preg_of ## args) = Val.of_bool b). - apply eval_condition_weaken. eapply eval_condition_lessdef; eauto. + apply eval_condition_weaken with m'. eapply eval_condition_lessdef; eauto. eapply preg_vals; eauto. - rewrite <- H2. eapply transl_cond_correct_aux; eauto. + rewrite <- H3. eapply transl_cond_correct_aux; eauto. Qed. (** Translation of arithmetic operations. *) @@ -1155,21 +1156,22 @@ Ltac TranslOpSimpl := *) Lemma transl_op_correct: - forall op args res k ms sp rs m v, + forall op args res k ms sp rs m v m', wt_instr (Mop op args res) -> agree ms sp rs -> - eval_operation ge sp op (map ms args) = Some v -> + eval_operation ge sp op (map ms args) m = Some v -> + Mem.extends m m' -> exists rs', - exec_straight (transl_op op args res k) rs m k rs' m + exec_straight (transl_op op args res k) rs m' k rs' m' /\ agree (Regmap.set res v (undef_op op ms)) sp rs'. Proof. intros. assert (exists v', Val.lessdef v v' /\ eval_operation_total ge sp op (map rs (map preg_of args)) = v'). - exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. + exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eauto. intros [v' [A B]]. exists v'; split; auto. - apply eval_operation_weaken; eauto. - destruct H2 as [v' [LD EQ]]. clear H1. + eapply eval_operation_weaken; eauto. + destruct H3 as [v' [LD EQ]]. clear H1 H2. inv H. (* Omove *) simpl in *. @@ -1183,7 +1185,7 @@ Proof. (* Omove again *) congruence. (* Ointconst *) - destruct (loadimm_correct (ireg_of res) i k rs m) + destruct (loadimm_correct (ireg_of res) i k rs m') as [rs' [A [B C]]]. exists rs'. split. auto. rewrite <- B in LD. eauto with ppcgen. @@ -1198,7 +1200,7 @@ Proof. set (v' := symbol_offset ge i i0) in *. pose (rs1 := nextinstr (rs#GPR12 <- (high_half v'))). exists (nextinstr (rs1#(ireg_of res) <- v')). - split. apply exec_straight_two with rs1 m. + split. apply exec_straight_two with rs1 m'. unfold exec_instr. rewrite gpr_or_zero_zero. unfold const_high. rewrite Val.add_commut. rewrite high_half_zero. reflexivity. @@ -1213,7 +1215,7 @@ Proof. intros. apply Pregmap.gso; auto. (* Oaddrstack *) assert (GPR1 <> GPR0). discriminate. - generalize (addimm_correct (ireg_of res) GPR1 i k rs m (ireg_of_not_GPR0 res) H1). + generalize (addimm_correct (ireg_of res) GPR1 i k rs m' (ireg_of_not_GPR0 res) H1). intros [rs' [EX [RES OTH]]]. exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto with ppcgen. @@ -1235,7 +1237,7 @@ Proof. unfold Val.rolm, Val.zero_ext. destruct (rs (ireg_of m0)); auto. rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto. (* Oaddimm *) - generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m + generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m' (ireg_of_not_GPR0 res) (ireg_of_not_GPR0 m0)). intros [rs' [A [B C]]]. exists rs'. split. auto. @@ -1245,7 +1247,7 @@ Proof. econstructor; split. apply exec_straight_one. simpl; eauto. auto. auto 7 with ppcgen. - generalize (loadimm_correct GPR0 i (Psubfc (ireg_of res) (ireg_of m0) GPR0 :: k) rs m). + generalize (loadimm_correct GPR0 i (Psubfc (ireg_of res) (ireg_of m0) GPR0 :: k) rs m'). intros [rs1 [EX [RES OTH]]]. econstructor; split. eapply exec_straight_trans. eexact EX. @@ -1258,7 +1260,7 @@ Proof. econstructor; split. apply exec_straight_one. simpl; eauto. auto. auto with ppcgen. - generalize (loadimm_correct GPR0 i (Pmullw (ireg_of res) (ireg_of m0) GPR0 :: k) rs m). + generalize (loadimm_correct GPR0 i (Pmullw (ireg_of res) (ireg_of m0) GPR0 :: k) rs m'). intros [rs1 [EX [RES OTH]]]. assert (agree (undef_temps ms) sp rs1). eauto with ppcgen. econstructor; split. @@ -1275,22 +1277,22 @@ Proof. apply agree_exten_2 with rs1. unfold rs1; auto with ppcgen. auto. (* Oandimm *) - generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m + generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m' (ireg_of_not_GPR0 m0)). intros [rs' [A [B [C D]]]]. exists rs'. split. auto. rewrite <- B in LD. eauto with ppcgen. (* Oorimm *) - generalize (orimm_correct (ireg_of res) (ireg_of m0) i k rs m). + generalize (orimm_correct (ireg_of res) (ireg_of m0) i k rs m'). intros [rs' [A [B C]]]. exists rs'. split. auto. rewrite <- B in LD. eauto with ppcgen. (* Oxorimm *) - generalize (xorimm_correct (ireg_of res) (ireg_of m0) i k rs m). + generalize (xorimm_correct (ireg_of res) (ireg_of m0) i k rs m'). intros [rs' [A [B C]]]. exists rs'. split. auto. rewrite <- B in LD. eauto with ppcgen. (* Oxhrximm *) pose (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shr (rs (ireg_of m0)) (Vint i)) #CARRY <- (Val.shr_carry (rs (ireg_of m0)) (Vint i)))). exists (nextinstr (rs1#(ireg_of res) <- (Val.shrx (rs (ireg_of m0)) (Vint i)))). - split. apply exec_straight_two with rs1 m. + split. apply exec_straight_two with rs1 m'. auto. simpl. decEq. decEq. decEq. unfold rs1. repeat (rewrite nextinstr_inv; try discriminate). rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss. @@ -1312,7 +1314,7 @@ Proof. set (rs1 := nextinstr (rs#(ireg_of res) <- (Val.rolm (rs (ireg_of r)) Int.one Int.one))). set (rs2 := nextinstr (rs1#(ireg_of res) <- (Val.xor (rs1#(ireg_of res)) (Vint Int.one)))). exists rs2. - split. apply exec_straight_two with rs1 m; auto. + split. apply exec_straight_two with rs1 m'; auto. rewrite <- Val.rolm_ge_zero in LD. unfold rs2. apply agree_nextinstr. unfold rs1. apply agree_nextinstr_commut. fold rs1. @@ -1334,19 +1336,19 @@ Proof. (if isset then k else Pxori (ireg_of res) (ireg_of res) (Cint Int.one) :: k)). - generalize (transl_cond_correct_aux c0 rl k1 ms sp rs m H1 H0). + generalize (transl_cond_correct_aux c0 rl k1 ms sp rs m' H1 H0). fold bit; fold isset. intros [rs1 [EX1 [RES1 AG1]]]. set (rs2 := nextinstr (rs1#(ireg_of res) <- (rs1#(reg_of_crbit bit)))). destruct isset. exists rs2. - split. apply exec_straight_trans with k1 rs1 m. assumption. + split. apply exec_straight_trans with k1 rs1 m'. assumption. unfold k1. apply exec_straight_one. reflexivity. reflexivity. unfold rs2. rewrite RES1. auto with ppcgen. econstructor. - split. apply exec_straight_trans with k1 rs1 m. assumption. - unfold k1. apply exec_straight_two with rs2 m. + split. apply exec_straight_trans with k1 rs1 m'. assumption. + unfold k1. apply exec_straight_two with rs2 m'. reflexivity. simpl. eauto. auto. auto. apply agree_nextinstr. unfold rs2 at 1. rewrite nextinstr_inv. rewrite Pregmap.gss. diff --git a/powerpc/Asmgenretaddr.v b/powerpc/Asmgenretaddr.v index ae3c2bd..a15bf73 100644 --- a/powerpc/Asmgenretaddr.v +++ b/powerpc/Asmgenretaddr.v @@ -179,11 +179,11 @@ Proof. Qed. Lemma return_address_exists: - forall f c, is_tail c f.(fn_code) -> + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(fn_code) -> exists ra, return_address_offset f c ra. Proof. intros. assert (is_tail (transl_code f c) (transl_function f)). - unfold transl_function. IsTail. apply transl_code_tail; auto. + unfold transl_function. IsTail. apply transl_code_tail; eauto with coqlib. destruct (is_tail_code_tail _ _ H0) as [ofs A]. exists (Int.repr ofs). constructor. auto. Qed. diff --git a/powerpc/ConstpropOpproof.v b/powerpc/ConstpropOpproof.v index ac15c0d..bf065b7 100644 --- a/powerpc/ConstpropOpproof.v +++ b/powerpc/ConstpropOpproof.v @@ -88,10 +88,10 @@ Ltac InvVLMA := approximations returned by [eval_static_operation]. *) Lemma eval_static_condition_correct: - forall cond al vl b, + forall cond al vl m b, val_list_match_approx al vl -> eval_static_condition cond al = Some b -> - eval_condition cond vl = Some b. + eval_condition cond vl m = Some b. Proof. intros until b. unfold eval_static_condition. @@ -100,9 +100,9 @@ Proof. Qed. Lemma eval_static_operation_correct: - forall op sp al vl v, + forall op sp al vl m v, val_list_match_approx al vl -> - eval_operation ge sp op vl = Some v -> + eval_operation ge sp op vl m = Some v -> val_match_approx (eval_static_operation op al) v. Proof. intros until v. @@ -150,7 +150,7 @@ Proof. inv H4. destruct (Float.intoffloat f); simpl in H0; inv H0. red; auto. caseEq (eval_static_condition c vl0). - intros. generalize (eval_static_condition_correct _ _ _ _ H H1). + intros. generalize (eval_static_condition_correct _ _ _ m _ H H1). intro. rewrite H2 in H0. destruct b; injection H0; intro; subst v; simpl; auto. intros; simpl; auto. @@ -174,6 +174,7 @@ Section STRENGTH_REDUCTION. Variable app: reg -> approx. Variable sp: val. Variable rs: regset. +Variable m: mem. Hypothesis MATCH: forall r, val_match_approx (app r) rs#r. Lemma intval_correct: @@ -189,20 +190,20 @@ Qed. Lemma cond_strength_reduction_correct: forall cond args, let (cond', args') := cond_strength_reduction app cond args in - eval_condition cond' rs##args' = eval_condition cond rs##args. + eval_condition cond' rs##args' m = eval_condition cond rs##args m. Proof. intros. unfold cond_strength_reduction. case (cond_strength_reduction_match cond args); intros. caseEq (intval app r1); intros. simpl. rewrite (intval_correct _ _ H). destruct (rs#r2); auto. rewrite Int.swap_cmp. auto. - destruct c; reflexivity. caseEq (intval app r2); intros. simpl. rewrite (intval_correct _ _ H0). auto. auto. caseEq (intval app r1); intros. simpl. rewrite (intval_correct _ _ H). destruct (rs#r2); auto. rewrite Int.swap_cmpu. auto. + destruct c; reflexivity. caseEq (intval app r2); intros. simpl. rewrite (intval_correct _ _ H0). auto. auto. @@ -212,8 +213,8 @@ Qed. Lemma make_addimm_correct: forall n r v, let (op, args) := make_addimm n r in - eval_operation ge sp Oadd (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oadd (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_addimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -225,8 +226,8 @@ Qed. Lemma make_shlimm_correct: forall n r v, let (op, args) := make_shlimm n r in - eval_operation ge sp Oshl (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oshl (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_shlimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -239,8 +240,8 @@ Qed. Lemma make_shrimm_correct: forall n r v, let (op, args) := make_shrimm n r in - eval_operation ge sp Oshr (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oshr (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_shrimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -251,8 +252,8 @@ Qed. Lemma make_shruimm_correct: forall n r v, let (op, args) := make_shruimm n r in - eval_operation ge sp Oshru (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oshru (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_shruimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -265,8 +266,8 @@ Qed. Lemma make_mulimm_correct: forall n r v, let (op, args) := make_mulimm n r in - eval_operation ge sp Omul (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Omul (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_mulimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -274,8 +275,8 @@ Proof. generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros. subst n. simpl in H1. simpl. FuncInv. rewrite Int.mul_one in H0. congruence. caseEq (Int.is_power2 n); intros. - replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil)) - with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil)). + replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil) m) + with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil) m). apply make_shlimm_correct. simpl. generalize (Int.is_power2_range _ _ H1). change (Z_of_nat Int.wordsize) with 32. intro. rewrite H2. @@ -286,8 +287,8 @@ Qed. Lemma make_andimm_correct: forall n r v, let (op, args) := make_andimm n r in - eval_operation ge sp Oand (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oand (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_andimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -300,8 +301,8 @@ Qed. Lemma make_orimm_correct: forall n r v, let (op, args) := make_orimm n r in - eval_operation ge sp Oor (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oor (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_orimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -314,8 +315,8 @@ Qed. Lemma make_xorimm_correct: forall n r v, let (op, args) := make_xorimm n r in - eval_operation ge sp Oxor (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oxor (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_xorimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -326,16 +327,16 @@ Qed. Lemma op_strength_reduction_correct: forall op args v, let (op', args') := op_strength_reduction app op args in - eval_operation ge sp op rs##args = Some v -> - eval_operation ge sp op' rs##args' = Some v. + eval_operation ge sp op rs##args m = Some v -> + eval_operation ge sp op' rs##args' m = Some v. Proof. intros; unfold op_strength_reduction; case (op_strength_reduction_match op args); intros; simpl List.map. (* Oadd *) caseEq (intval app r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oadd (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Oadd (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Oadd (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oadd (rs # r2 :: Vint i :: nil) m). apply make_addimm_correct. simpl. destruct rs#r2; auto. rewrite Int.add_commut; auto. caseEq (intval app r2); intros. @@ -346,16 +347,16 @@ Proof. rewrite (intval_correct _ _ H) in H0. assumption. caseEq (intval app r2); intros. rewrite (intval_correct _ _ H0). - replace (eval_operation ge sp Osub (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg i) :: nil)). + replace (eval_operation ge sp Osub (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg i) :: nil) m). apply make_addimm_correct. simpl. destruct rs#r1; auto; rewrite Int.sub_add_opp; auto. assumption. (* Omul *) caseEq (intval app r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Omul (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Omul (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Omul (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Omul (rs # r2 :: Vint i :: nil) m). apply make_mulimm_correct. simpl. destruct rs#r2; auto. rewrite Int.mul_commut; auto. caseEq (intval app r2); intros. @@ -375,8 +376,8 @@ Proof. caseEq (intval app r2); intros. caseEq (Int.is_power2 i); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil)). + replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil) m). apply make_shruimm_correct. simpl. destruct rs#r1; auto. change 32 with (Z_of_nat Int.wordsize). @@ -389,8 +390,8 @@ Proof. (* Oand *) caseEq (intval app r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oand (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Oand (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Oand (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oand (rs # r2 :: Vint i :: nil) m). apply make_andimm_correct. simpl. destruct rs#r2; auto. rewrite Int.and_commut; auto. caseEq (intval app r2); intros. @@ -399,8 +400,8 @@ Proof. (* Oor *) caseEq (intval app r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oor (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Oor (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Oor (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oor (rs # r2 :: Vint i :: nil) m). apply make_orimm_correct. simpl. destruct rs#r2; auto. rewrite Int.or_commut; auto. caseEq (intval app r2); intros. @@ -409,8 +410,8 @@ Proof. (* Oxor *) caseEq (intval app r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oxor (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Oxor (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Oxor (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oxor (rs # r2 :: Vint i :: nil) m). apply make_xorimm_correct. simpl. destruct rs#r2; auto. rewrite Int.xor_commut; auto. caseEq (intval app r2); intros. diff --git a/powerpc/Op.v b/powerpc/Op.v index 6f05e55..d466961 100644 --- a/powerpc/Op.v +++ b/powerpc/Op.v @@ -32,6 +32,7 @@ Require Import Values. Require Import Memdata. Require Import Memory. Require Import Globalenvs. +Require Import Events. Set Implicit Arguments. @@ -141,27 +142,30 @@ Definition eval_compare_mismatch (c: comparison) : option bool := Definition eval_compare_null (c: comparison) (n: int) : option bool := if Int.eq n Int.zero then eval_compare_mismatch c else None. -Definition eval_condition (cond: condition) (vl: list val): +Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := match cond, vl with | Ccomp c, Vint n1 :: Vint n2 :: nil => Some (Int.cmp c n1 n2) - | Ccomp c, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if eq_block b1 b2 - then Some (Int.cmp c n1 n2) - else eval_compare_mismatch c - | Ccomp c, Vptr b1 n1 :: Vint n2 :: nil => - eval_compare_null c n2 - | Ccomp c, Vint n1 :: Vptr b2 n2 :: nil => - eval_compare_null c n1 | Ccompu c, Vint n1 :: Vint n2 :: nil => Some (Int.cmpu c n1 n2) + | Ccompu c, Vptr b1 n1 :: Vptr b2 n2 :: nil => + if Mem.valid_pointer m b1 (Int.unsigned n1) + && Mem.valid_pointer m b2 (Int.unsigned n2) then + if eq_block b1 b2 + then Some (Int.cmpu c n1 n2) + else eval_compare_mismatch c + else None + | Ccompu c, Vptr b1 n1 :: Vint n2 :: nil => + eval_compare_null c n2 + | Ccompu c, Vint n1 :: Vptr b2 n2 :: nil => + eval_compare_null c n1 | Ccompimm c n, Vint n1 :: nil => Some (Int.cmp c n1 n) - | Ccompimm c n, Vptr b1 n1 :: nil => - eval_compare_null c n | Ccompuimm c n, Vint n1 :: nil => Some (Int.cmpu c n1 n) + | Ccompuimm c n, Vptr b1 n1 :: nil => + eval_compare_null c n | Ccompf c, Vfloat f1 :: Vfloat f2 :: nil => Some (Float.cmp c f1 f2) | Cnotcompf c, Vfloat f1 :: Vfloat f2 :: nil => @@ -182,7 +186,7 @@ Definition offset_sp (sp: val) (delta: int) : option val := Definition eval_operation (F V: Type) (genv: Genv.t F V) (sp: val) - (op: operation) (vl: list val): option val := + (op: operation) (vl: list val) (m: mem): option val := match op, vl with | Omove, v1::nil => Some v1 | Ointconst n, nil => Some (Vint n) @@ -251,7 +255,7 @@ Definition eval_operation | Ofloatofwords, Vint i1 :: Vint i2 :: nil => Some (Vfloat (Float.from_words i1 i2)) | Ocmp c, _ => - match eval_condition c vl with + match eval_condition c vl m with | None => None | Some false => Some Vfalse | Some true => Some Vtrue @@ -327,21 +331,23 @@ Proof. Qed. Lemma eval_negate_condition: - forall (cond: condition) (vl: list val) (b: bool), - eval_condition cond vl = Some b -> - eval_condition (negate_condition cond) vl = Some (negb b). + forall cond vl m b, + eval_condition cond vl m = Some b -> + eval_condition (negate_condition cond) vl m = Some (negb b). Proof. intros. destruct cond; simpl in H; FuncInv; try subst b; simpl. rewrite Int.negate_cmp. auto. + rewrite Int.negate_cmpu. auto. apply eval_negate_compare_null; auto. apply eval_negate_compare_null; auto. - destruct (eq_block b0 b1). rewrite Int.negate_cmp. congruence. + destruct (Mem.valid_pointer m b0 (Int.unsigned i) && + Mem.valid_pointer m b1 (Int.unsigned i0)); try congruence. + destruct (eq_block b0 b1). rewrite Int.negate_cmpu. congruence. apply eval_negate_compare_mismatch; auto. - rewrite Int.negate_cmpu. auto. rewrite Int.negate_cmp. auto. - apply eval_negate_compare_null; auto. rewrite Int.negate_cmpu. auto. + apply eval_negate_compare_null; auto. auto. rewrite negb_elim. auto. auto. @@ -362,8 +368,8 @@ Hypothesis agree_on_symbols: forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. Lemma eval_operation_preserved: - forall sp op vl, - eval_operation ge2 sp op vl = eval_operation ge1 sp op vl. + forall sp op vl m, + eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. Proof. intros. unfold eval_operation; destruct op; try rewrite agree_on_symbols; @@ -483,9 +489,9 @@ Variable A V: Type. Variable genv: Genv.t A V. Lemma type_of_operation_sound: - forall op vl sp v, + forall op vl sp v m, op <> Omove -> - eval_operation genv sp op vl = Some v -> + eval_operation genv sp op vl m = Some v -> Val.has_type v (snd (type_of_operation op)). Proof. intros. @@ -643,14 +649,16 @@ Proof. Qed. Lemma eval_condition_weaken: - forall c vl b, - eval_condition c vl = Some b -> + forall c vl b m, + eval_condition c vl m = Some b -> eval_condition_total c vl = Val.of_bool b. Proof. intros. unfold eval_condition in H; destruct c; FuncInv; try subst b; try reflexivity; simpl; try (apply eval_compare_null_weaken; auto). + destruct (Mem.valid_pointer m b0 (Int.unsigned i) && + Mem.valid_pointer m b1 (Int.unsigned i0)); try congruence. unfold eq_block in H. destruct (zeq b0 b1). congruence. apply eval_compare_mismatch_weaken; auto. @@ -659,8 +667,8 @@ Proof. Qed. Lemma eval_operation_weaken: - forall sp op vl v, - eval_operation genv sp op vl = Some v -> + forall sp op vl v m, + eval_operation genv sp op vl m = Some v -> eval_operation_total sp op vl = v. Proof. intros. @@ -680,7 +688,7 @@ Proof. destruct (Int.ltu i Int.iwordsize); congruence. destruct (Int.ltu i0 Int.iwordsize); congruence. destruct (Float.intoffloat f); inv H. auto. - caseEq (eval_condition c vl); intros; rewrite H0 in H. + caseEq (eval_condition c vl m); intros; rewrite H0 in H. replace v with (Val.of_bool b). eapply eval_condition_weaken; eauto. destruct b; simpl; congruence. @@ -746,12 +754,20 @@ Ltac InvLessdef := end. Lemma eval_condition_lessdef: - forall cond vl1 vl2 b, + forall cond vl1 vl2 b m1 m2, Val.lessdef_list vl1 vl2 -> - eval_condition cond vl1 = Some b -> - eval_condition cond vl2 = Some b. + Mem.extends m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. Proof. intros. destruct cond; simpl in *; FuncInv; InvLessdef; auto. + destruct (Mem.valid_pointer m1 b0 (Int.unsigned i) && + Mem.valid_pointer m1 b1 (Int.unsigned i0)) as [] _eqn; try discriminate. + destruct (andb_prop _ _ Heqb2) as [A B]. + assert (forall b ofs, Mem.valid_pointer m1 b ofs = true -> Mem.valid_pointer m2 b ofs = true). + intros until ofs. repeat rewrite Mem.valid_pointer_nonempty_perm. + apply Mem.perm_extends; auto. + rewrite (H _ _ A). rewrite (H _ _ B). auto. Qed. Ltac TrivialExists := @@ -762,33 +778,34 @@ Ltac TrivialExists := end. Lemma eval_operation_lessdef: - forall sp op vl1 vl2 v1, + forall sp op vl1 vl2 v1 m1 m2, Val.lessdef_list vl1 vl2 -> - eval_operation genv sp op vl1 = Some v1 -> - exists v2, eval_operation genv sp op vl2 = Some v2 /\ Val.lessdef v1 v2. + Mem.extends m1 m2 -> + eval_operation genv sp op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. Proof. intros. destruct op; simpl in *; FuncInv; InvLessdef; TrivialExists. exists v2; auto. - destruct (Genv.find_symbol genv i); inv H0. TrivialExists. + destruct (Genv.find_symbol genv i); inv H1. TrivialExists. exists v1; auto. exists (Val.sign_ext 8 v2); split. auto. apply Val.sign_ext_lessdef; auto. exists (Val.zero_ext 8 v2); split. auto. apply Val.zero_ext_lessdef; auto. exists (Val.sign_ext 16 v2); split. auto. apply Val.sign_ext_lessdef; auto. exists (Val.zero_ext 16 v2); split. auto. apply Val.zero_ext_lessdef; auto. - destruct (eq_block b b0); inv H0. TrivialExists. - destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. - destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. - destruct (Int.ltu i0 Int.iwordsize); inv H0; TrivialExists. - destruct (Int.ltu i0 Int.iwordsize); inv H0; TrivialExists. - destruct (Int.ltu i Int.iwordsize); inv H0; TrivialExists. - destruct (Int.ltu i Int.iwordsize); inv H0; TrivialExists. - destruct (Int.ltu i0 Int.iwordsize); inv H0; TrivialExists. + destruct (eq_block b b0); inv H1. TrivialExists. + destruct (Int.eq i0 Int.zero); inv H1; TrivialExists. + destruct (Int.eq i0 Int.zero); inv H1; TrivialExists. + destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialExists. + destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialExists. + destruct (Int.ltu i Int.iwordsize); inv H1; TrivialExists. + destruct (Int.ltu i Int.iwordsize); inv H1; TrivialExists. + destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialExists. exists (Val.singleoffloat v2); split. auto. apply Val.singleoffloat_lessdef; auto. - destruct (Float.intoffloat f); simpl in *; inv H0. TrivialExists. - caseEq (eval_condition c vl1); intros. rewrite H1 in H0. - rewrite (eval_condition_lessdef c H H1). - destruct b; inv H0; TrivialExists. - rewrite H1 in H0. discriminate. + destruct (Float.intoffloat f); simpl in *; inv H1. TrivialExists. + caseEq (eval_condition c vl1 m1); intros. rewrite H2 in H1. + rewrite (eval_condition_lessdef c H H0 H2). + destruct b; inv H1; TrivialExists. + rewrite H2 in H1. discriminate. Qed. Lemma eval_addressing_lessdef: @@ -805,6 +822,159 @@ Qed. End EVAL_LESSDEF. +(** Shifting stack-relative references. This is used in [Stacking]. *) + +Definition shift_stack_addressing (delta: int) (addr: addressing) := + match addr with + | Ainstack ofs => Ainstack (Int.add delta ofs) + | _ => addr + end. + +Definition shift_stack_operation (delta: int) (op: operation) := + match op with + | Oaddrstack ofs => Oaddrstack (Int.add delta ofs) + | _ => op + end. + +Lemma type_shift_stack_addressing: + forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. +Proof. + intros. destruct addr; auto. +Qed. + +Lemma type_shift_stack_operation: + forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. +Proof. + intros. destruct op; auto. +Qed. + +(** Compatibility of the evaluation functions with memory injections. *) + +Section EVAL_INJECT. + +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. +Hypothesis globals: meminj_preserves_globals genv f. +Variable sp1: block. +Variable sp2: block. +Variable delta: Z. +Hypothesis sp_inj: f sp1 = Some(sp2, delta). + +Ltac InvInject := + match goal with + | [ H: val_inject _ (Vint _) _ |- _ ] => + inv H; InvInject + | [ H: val_inject _ (Vfloat _) _ |- _ ] => + inv H; InvInject + | [ H: val_inject _ (Vptr _ _) _ |- _ ] => + inv H; InvInject + | [ H: val_list_inject _ nil _ |- _ ] => + inv H; InvInject + | [ H: val_list_inject _ (_ :: _) _ |- _ ] => + inv H; InvInject + | _ => idtac + end. + +Lemma eval_condition_inject: + forall cond vl1 vl2 b m1 m2, + val_list_inject f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. destruct cond; simpl in *; FuncInv; InvInject; auto. + destruct (Mem.valid_pointer m1 b0 (Int.unsigned i)) as [] _eqn; try discriminate. + destruct (Mem.valid_pointer m1 b1 (Int.unsigned i0)) as [] _eqn; try discriminate. + simpl in H1. + exploit Mem.valid_pointer_inject_val. eauto. eexact Heqb0. econstructor; eauto. + intros V1. rewrite V1. + exploit Mem.valid_pointer_inject_val. eauto. eexact Heqb2. econstructor; eauto. + intros V2. rewrite V2. + simpl. + destruct (eq_block b0 b1); inv H1. + rewrite H3 in H5; inv H5. rewrite dec_eq_true. + decEq. apply Int.translate_cmpu. + eapply Mem.valid_pointer_inject_no_overflow; eauto. + eapply Mem.valid_pointer_inject_no_overflow; eauto. + exploit Mem.different_pointers_inject; eauto. intros P. + destruct (eq_block b3 b4); auto. + destruct P. contradiction. + destruct c; unfold eval_compare_mismatch in *; inv H2. + unfold Int.cmpu. rewrite Int.eq_false; auto. congruence. + unfold Int.cmpu. rewrite Int.eq_false; auto. congruence. +Qed. + +Ltac TrivialExists2 := + match goal with + | [ |- exists v2, Some ?v1 = Some v2 /\ val_inject _ _ v2 ] => + exists v1; split; [auto | econstructor; eauto] + | _ => idtac + end. + +Lemma eval_addressing_inject: + forall addr vl1 vl2 v1, + val_list_inject f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Int.zero) addr vl1 = Some v1 -> + exists v2, + eval_addressing genv (Vptr sp2 Int.zero) (shift_stack_addressing (Int.repr delta) addr) vl2 = Some v2 + /\ val_inject f v1 v2. +Proof. + intros. destruct addr; simpl in *; FuncInv; InvInject; TrivialExists2. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + destruct (Genv.find_symbol genv i) as [] _eqn; inv H0. + TrivialExists2. eapply (proj1 globals); eauto. rewrite Int.add_zero; auto. + destruct (Genv.find_symbol genv i) as [] _eqn; inv H0. + TrivialExists2. eapply (proj1 globals); eauto. rewrite Int.add_zero; auto. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. +Qed. + +Lemma eval_operation_inject: + forall op vl1 vl2 v1 m1 m2, + val_list_inject f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_operation genv (Vptr sp1 Int.zero) op vl1 m1 = Some v1 -> + exists v2, + eval_operation genv (Vptr sp2 Int.zero) (shift_stack_operation (Int.repr delta) op) vl2 m2 = Some v2 + /\ val_inject f v1 v2. +Proof. + intros. destruct op; simpl in *; FuncInv; InvInject; TrivialExists2. + exists v'; auto. + destruct (Genv.find_symbol genv i) as [] _eqn; inv H1. + TrivialExists2. eapply (proj1 globals); eauto. rewrite Int.add_zero; auto. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + exists (Val.sign_ext 8 v'); split; auto. inv H4; simpl; auto. + exists (Val.zero_ext 8 v'); split; auto. inv H4; simpl; auto. + exists (Val.sign_ext 16 v'); split; auto. inv H4; simpl; auto. + exists (Val.zero_ext 16 v'); split; auto. inv H4; simpl; auto. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + rewrite Int.sub_add_l. auto. + destruct (eq_block b b0); inv H1. rewrite H3 in H5; inv H5. rewrite dec_eq_true. + rewrite Int.sub_shifted. TrivialExists2. + destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. + destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. + destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. + destruct (Int.ltu i0 Int.iwordsize); inv H2. TrivialExists2. + destruct (Int.ltu i0 Int.iwordsize); inv H2. TrivialExists2. + destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialExists2. + destruct (Int.ltu i Int.iwordsize); inv H1. TrivialExists2. + destruct (Int.ltu i (Int.repr 31)); inv H1. TrivialExists2. + destruct (Int.ltu i Int.iwordsize); inv H2. TrivialExists2. + destruct (Int.ltu i Int.iwordsize); inv H2. TrivialExists2. + destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialExists2. + exists (Val.singleoffloat v'); split; auto. inv H4; simpl; auto. + destruct (Float.intoffloat f0); simpl in *; inv H1. TrivialExists2. + destruct (eval_condition c vl1 m1) as [] _eqn; try discriminate. + exploit eval_condition_inject; eauto. intros EQ; rewrite EQ. + destruct b; inv H1; TrivialExists2. +Qed. + +End EVAL_INJECT. + (** Transformation of addressing modes with two operands or more into an equivalent arithmetic operation. This is used in the [Reload] pass when a store instruction cannot be reloaded directly because @@ -816,10 +986,10 @@ End EVAL_LESSDEF. Definition op_for_binary_addressing (addr: addressing) : operation := Oadd. Lemma eval_op_for_binary_addressing: - forall (F V: Type) (ge: Genv.t F V) sp addr args v, + forall (F V: Type) (ge: Genv.t F V) sp addr args v m, (length args >= 2)%nat -> eval_addressing ge sp addr args = Some v -> - eval_operation ge sp (op_for_binary_addressing addr) args = Some v. + eval_operation ge sp (op_for_binary_addressing addr) args m = Some v. Proof. intros. unfold eval_addressing in H0; destruct addr; FuncInv; simpl in H; try omegaContradiction; @@ -849,57 +1019,20 @@ Definition is_trivial_op (op: operation) : bool := | _ => false end. -(** Shifting stack-relative references. This is used in [Stacking]. *) -Definition shift_stack_addressing (delta: int) (addr: addressing) := - match addr with - | Ainstack ofs => Ainstack (Int.add delta ofs) - | _ => addr - end. +(** Operations that depend on the memory state. *) -Definition shift_stack_operation (delta: int) (op: operation) := +Definition op_depends_on_memory (op: operation) : bool := match op with - | Oaddrstack ofs => Oaddrstack (Int.add delta ofs) - | _ => op + | Ocmp (Ccompu _) => true + | _ => false end. -Lemma shift_stack_eval_addressing: - forall (F V: Type) (ge: Genv.t F V) sp addr args delta, - eval_addressing ge (Val.sub sp (Vint delta)) (shift_stack_addressing delta addr) args = - eval_addressing ge sp addr args. -Proof. - intros. destruct addr; simpl; auto. - destruct args; auto. unfold offset_sp. destruct sp; simpl; auto. - decEq. decEq. rewrite <- Int.add_assoc. decEq. - rewrite Int.sub_add_opp. rewrite Int.add_assoc. - rewrite (Int.add_commut (Int.neg delta)). rewrite <- Int.sub_add_opp. - rewrite Int.sub_idem. apply Int.add_zero. -Qed. - -Lemma shift_stack_eval_operation: - forall (F V: Type) (ge: Genv.t F V) sp op args delta, - eval_operation ge (Val.sub sp (Vint delta)) (shift_stack_operation delta op) args = - eval_operation ge sp op args. +Lemma op_depends_on_memory_correct: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + op_depends_on_memory op = false -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. - intros. destruct op; simpl; auto. - destruct args; auto. unfold offset_sp. destruct sp; simpl; auto. - decEq. decEq. rewrite <- Int.add_assoc. decEq. - rewrite Int.sub_add_opp. rewrite Int.add_assoc. - rewrite (Int.add_commut (Int.neg delta)). rewrite <- Int.sub_add_opp. - rewrite Int.sub_idem. apply Int.add_zero. + intros until m2. destruct op; simpl; try congruence. + destruct c; simpl; congruence. Qed. - -Lemma type_shift_stack_addressing: - forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. -Proof. - intros. destruct addr; auto. -Qed. - -Lemma type_shift_stack_operation: - forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. -Proof. - intros. destruct op; auto. -Qed. - - - diff --git a/powerpc/PrintAsm.ml b/powerpc/PrintAsm.ml index 6074197..c0f9294 100644 --- a/powerpc/PrintAsm.ml +++ b/powerpc/PrintAsm.ml @@ -433,14 +433,11 @@ let print_instruction oc labels = function fprintf oc " addis %a, %a, %a\n" ireg r1 ireg_or_zero r2 constant c | Paddze(r1, r2) -> fprintf oc " addze %a, %a\n" ireg r1 ireg r2 - | Pallocframe(lo, hi, ofs) -> - let lo = camlint_of_coqint lo - and hi = camlint_of_coqint hi + | Pallocframe(sz, ofs) -> + let sz = camlint_of_coqint sz and ofs = camlint_of_coqint ofs in - let sz = Int32.sub hi lo in assert (ofs = 0l); - (* Keep stack 16-aligned *) - let adj = Int32.neg (Int32.logand (Int32.add sz 15l) 0xFFFF_FFF0l) in + let adj = Int32.neg sz in if adj >= -0x8000l then fprintf oc " stwu %a, %ld(%a)\n" ireg GPR1 adj ireg GPR1 else begin @@ -509,8 +506,8 @@ let print_instruction oc labels = function fprintf oc " extsb %a, %a\n" ireg r1 ireg r2 | Pextsh(r1, r2) -> fprintf oc " extsh %a, %a\n" ireg r1 ireg r2 - | Pfreeframe(lo, hi, ofs) -> - (* Note: could also do an add on GPR1 using lo and hi *) + | Pfreeframe(sz, ofs) -> + (* Note: could also do an add on GPR1 using sz *) fprintf oc " lwz %a, %ld(%a)\n" ireg GPR1 (camlint_of_coqint ofs) ireg GPR1 | Pfabs(r1, r2) -> fprintf oc " fabs %a, %a\n" freg r1 freg r2 diff --git a/powerpc/SelectOp.v b/powerpc/SelectOp.v index c421cdc..b735fad 100644 --- a/powerpc/SelectOp.v +++ b/powerpc/SelectOp.v @@ -146,7 +146,7 @@ Definition notint (e: expr) := (** ** Boolean negation *) Definition notbool_base (e: expr) := - Eop (Ocmp (Ccompimm Ceq Int.zero)) (e ::: Enil). + Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil). Fixpoint notbool (e: expr) {struct e} : expr := match e with diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v index 1f2c736..6d1e3c5 100644 --- a/powerpc/SelectOpproof.v +++ b/powerpc/SelectOpproof.v @@ -64,13 +64,13 @@ Ltac InvEval1 := Ltac InvEval2 := match goal with - | [ H: (eval_operation _ _ _ nil = Some _) |- _ ] => + | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => simpl in H; inv H - | [ H: (eval_operation _ _ _ (_ :: nil) = Some _) |- _ ] => + | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: nil) = Some _) |- _ ] => + | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) = Some _) |- _ ] => + | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => simpl in H; FuncInv | _ => idtac @@ -167,12 +167,12 @@ Proof. eapply eval_notbool_base; eauto. inv H. eapply eval_Eop; eauto. - simpl. assert (eval_condition c vl = Some b). + simpl. assert (eval_condition c vl m = Some b). generalize H6. simpl. - case (eval_condition c vl); intros. + case (eval_condition c vl m); intros. destruct b0; inv H1; inversion H0; auto; congruence. congruence. - rewrite (Op.eval_negate_condition _ _ H). + rewrite (Op.eval_negate_condition _ _ _ H). destruct b; reflexivity. inv H. eapply eval_Econdition; eauto. @@ -542,9 +542,9 @@ Qed. Lemma eval_mod_aux: forall divop semdivop, - (forall sp x y, + (forall sp x y m, y <> Int.zero -> - eval_operation ge sp divop (Vint x :: Vint y :: nil) = + eval_operation ge sp divop (Vint x :: Vint y :: nil) m = Some (Vint (semdivop x y))) -> forall le a b x y, eval_expr ge sp e m le a (Vint x) -> @@ -715,7 +715,7 @@ Theorem eval_singleoffloat: eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v). Proof. TrivialOp singleoffloat. Qed. -Theorem eval_comp_int: +Theorem eval_comp: forall le c a x b y, eval_expr ge sp e m le a (Vint x) -> eval_expr ge sp e m le b (Vint y) -> @@ -728,6 +728,19 @@ Proof. EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. Qed. +Theorem eval_compu_int: + forall le c a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)). +Proof. + intros until y. + unfold compu; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. +Qed. + Remark eval_compare_null_transf: forall c x v, Cminor.eval_compare_null c x = Some v -> @@ -742,15 +755,15 @@ Proof. destruct c; try discriminate; auto. Qed. -Theorem eval_comp_ptr_int: +Theorem eval_compu_ptr_int: forall le c a x1 x2 b y v, eval_expr ge sp e m le a (Vptr x1 x2) -> eval_expr ge sp e m le b (Vint y) -> Cminor.eval_compare_null c y = Some v -> - eval_expr ge sp e m le (comp c a b) v. + eval_expr ge sp e m le (compu c a b) v. Proof. intros until v. - unfold comp; case (comp_match a b); intros; InvEval. + unfold compu; case (comp_match a b); intros; InvEval. EvalOp. simpl. apply eval_compare_null_transf; auto. EvalOp. simpl. apply eval_compare_null_transf; auto. Qed. @@ -764,58 +777,49 @@ Proof. destruct (Int.eq x Int.zero). destruct c; auto. auto. Qed. -Theorem eval_comp_int_ptr: +Theorem eval_compu_int_ptr: forall le c a x b y1 y2 v, eval_expr ge sp e m le a (Vint x) -> eval_expr ge sp e m le b (Vptr y1 y2) -> Cminor.eval_compare_null c x = Some v -> - eval_expr ge sp e m le (comp c a b) v. + eval_expr ge sp e m le (compu c a b) v. Proof. intros until v. - unfold comp; case (comp_match a b); intros; InvEval. + unfold compu; case (comp_match a b); intros; InvEval. EvalOp. simpl. apply eval_compare_null_transf. rewrite eval_compare_null_swap; auto. EvalOp. simpl. apply eval_compare_null_transf. auto. Qed. -Theorem eval_comp_ptr_ptr: +Theorem eval_compu_ptr_ptr: forall le c a x1 x2 b y1 y2, eval_expr ge sp e m le a (Vptr x1 x2) -> eval_expr ge sp e m le b (Vptr y1 y2) -> + Mem.valid_pointer m x1 (Int.unsigned x2) + && Mem.valid_pointer m y1 (Int.unsigned y2) = true -> x1 = y1 -> - eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x2 y2)). + eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x2 y2)). Proof. intros until y2. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. subst y1. rewrite dec_eq_true. - destruct (Int.cmp c x2 y2); reflexivity. + unfold compu; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite H1. subst y1. rewrite dec_eq_true. + destruct (Int.cmpu c x2 y2); reflexivity. Qed. -Theorem eval_comp_ptr_ptr_2: +Theorem eval_compu_ptr_ptr_2: forall le c a x1 x2 b y1 y2 v, eval_expr ge sp e m le a (Vptr x1 x2) -> eval_expr ge sp e m le b (Vptr y1 y2) -> + Mem.valid_pointer m x1 (Int.unsigned x2) + && Mem.valid_pointer m y1 (Int.unsigned y2) = true -> x1 <> y1 -> Cminor.eval_compare_mismatch c = Some v -> - eval_expr ge sp e m le (comp c a b) v. + eval_expr ge sp e m le (compu c a b) v. Proof. intros until y2. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite dec_eq_false; auto. - destruct c; simpl in H2; inv H2; auto. -Qed. - -Theorem eval_compu: - forall le c a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)). -Proof. - intros until y. unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto. + destruct c; simpl in H3; inv H3; auto. Qed. Theorem eval_compf: diff --git a/powerpc/eabi/Stacklayout.v b/powerpc/eabi/Stacklayout.v index 0de1ccd..22a2826 100644 --- a/powerpc/eabi/Stacklayout.v +++ b/powerpc/eabi/Stacklayout.v @@ -33,12 +33,6 @@ Require Import Bounds. - Saved values of float callee-save registers used by the function. - Space for the stack-allocated data declared in Cminor. -To facilitate some of the proofs, the Cminor stack-allocated data -starts at offset 0; the preceding areas in the activation record -therefore have negative offsets. This part (with negative offsets) -is called the ``frame'', by opposition with the ``Cminor stack data'' -which is the part with positive offsets. - The [frame_env] compilation environment records the positions of the boundaries between areas in the frame part. *) @@ -54,7 +48,8 @@ Record frame_env : Type := mk_frame_env { fe_num_int_callee_save: Z; fe_ofs_float_local: Z; fe_ofs_float_callee_save: Z; - fe_num_float_callee_save: Z + fe_num_float_callee_save: Z; + fe_stack_data: Z }. (** Computation of the frame environment from the bounds of the current @@ -67,17 +62,81 @@ Definition make_env (b: bounds) := let oendi := oics + 4 * b.(bound_int_callee_save) in let ofl := align oendi 8 in (* float locals *) let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *) - let sz := ofcs + 8 * b.(bound_float_callee_save) in (* total frame size *) + let ostkdata := ofcs + 8 * b.(bound_float_callee_save) in (* stack data *) + let sz := align (ostkdata + b.(bound_stack_data)) 16 in mk_frame_env sz 0 ora oil oics b.(bound_int_callee_save) - ofl ofcs b.(bound_float_callee_save). + ofl ofcs b.(bound_float_callee_save) + ostkdata. +(** Separation property *) -Remark align_float_part: +Remark frame_env_separated: forall b, - 8 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 + 4 * bound_int_callee_save b <= - align (8 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 + 4 * bound_int_callee_save b) 8. + let fe := make_env b in + 0 <= fe.(fe_ofs_link) + /\ fe.(fe_ofs_link) + 4 <= fe_ofs_arg + /\ fe_ofs_arg + 4 * b.(bound_outgoing) <= fe.(fe_ofs_int_local) + /\ fe.(fe_ofs_int_local) + 4 * b.(bound_int_local) <= fe.(fe_ofs_retaddr) + /\ fe.(fe_ofs_retaddr) + 4 <= fe.(fe_ofs_int_callee_save) + /\ fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save) <= fe.(fe_ofs_float_local) + /\ fe.(fe_ofs_float_local) + 8 * b.(bound_float_local) <= fe.(fe_ofs_float_callee_save) + /\ fe.(fe_ofs_float_callee_save) + 8 * b.(bound_float_callee_save) <= fe.(fe_stack_data) + /\ fe.(fe_stack_data) + b.(bound_stack_data) <= fe.(fe_size). Proof. - intros. apply align_le. omega. + intros. + generalize (align_le (fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save)) 8 (refl_equal _)). + generalize (align_le (fe.(fe_stack_data) + b.(bound_stack_data)) 16 (refl_equal _)). + unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr, + fe_ofs_int_local, fe_ofs_int_callee_save, + fe_num_int_callee_save, + fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save, + fe_stack_data, fe_ofs_arg. + intros. + generalize (bound_int_local_pos b); intro; + generalize (bound_float_local_pos b); intro; + generalize (bound_int_callee_save_pos b); intro; + generalize (bound_float_callee_save_pos b); intro; + generalize (bound_outgoing_pos b); intro; + generalize (bound_stack_data_pos b); intro. + omega. Qed. +(** Alignment property *) + +Remark frame_env_aligned: + forall b, + let fe := make_env b in + (4 | fe.(fe_ofs_link)) + /\ (4 | fe.(fe_ofs_int_local)) + /\ (4 | fe.(fe_ofs_int_callee_save)) + /\ (8 | fe.(fe_ofs_float_local)) + /\ (8 | fe.(fe_ofs_float_callee_save)) + /\ (4 | fe.(fe_ofs_retaddr)) + /\ (4 | fe.(fe_stack_data)) + /\ (16 | fe.(fe_size)). +Proof. + intros. + unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr, + fe_ofs_int_local, fe_ofs_int_callee_save, + fe_num_int_callee_save, + fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save, + fe_stack_data. + set (x1 := 8 + 4 * bound_outgoing b). + assert (4 | x1). unfold x1; apply Zdivide_plus_r. exists 2; auto. exists (bound_outgoing b); ring. + set (x2 := x1 + 4 * bound_int_local b). + assert (4 | x2). unfold x2; apply Zdivide_plus_r; auto. exists (bound_int_local b); ring. + set (x3 := x2 + 4). + assert (4 | x3). unfold x3; apply Zdivide_plus_r; auto. exists 1; auto. + set (x4 := align (x3 + 4 * bound_int_callee_save b) 8). + assert (8 | x4). unfold x4. apply align_divides. omega. + set (x5 := x4 + 8 * bound_float_local b). + assert (8 | x5). unfold x5. apply Zdivide_plus_r; auto. exists (bound_float_local b); ring. + set (x6 := x5 + 8 * bound_float_callee_save b). + assert (4 | x6). + apply Zdivides_trans with 8. exists 2; auto. + unfold x6. apply Zdivide_plus_r; auto. exists (bound_float_callee_save b); ring. + set (x7 := align (x6 + bound_stack_data b) 16). + assert (16 | x7). unfold x7; apply align_divides. omega. + intuition. +Qed. diff --git a/powerpc/macosx/Stacklayout.v b/powerpc/macosx/Stacklayout.v index c57f3f9..57592a8 100644 --- a/powerpc/macosx/Stacklayout.v +++ b/powerpc/macosx/Stacklayout.v @@ -30,12 +30,6 @@ Require Import Bounds. - Saved values of float callee-save registers used by the function. - Space for the stack-allocated data declared in Cminor. -To facilitate some of the proofs, the Cminor stack-allocated data -starts at offset 0; the preceding areas in the activation record -therefore have negative offsets. This part (with negative offsets) -is called the ``frame'', by opposition with the ``Cminor stack data'' -which is the part with positive offsets. - The [frame_env] compilation environment records the positions of the boundaries between areas in the frame part. *) @@ -51,7 +45,8 @@ Record frame_env : Type := mk_frame_env { fe_num_int_callee_save: Z; fe_ofs_float_local: Z; fe_ofs_float_callee_save: Z; - fe_num_float_callee_save: Z + fe_num_float_callee_save: Z; + fe_stack_data: Z }. (** Computation of the frame environment from the bounds of the current @@ -63,17 +58,81 @@ Definition make_env (b: bounds) := let oendi := oics + 4 * b.(bound_int_callee_save) in let ofl := align oendi 8 in (* float locals *) let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *) - let sz := ofcs + 8 * b.(bound_float_callee_save) in (* total frame size *) + let ostkdata := ofcs + 8 * b.(bound_float_callee_save) in (* stack data *) + let sz := align (ostkdata + b.(bound_stack_data)) 16 in mk_frame_env sz 0 12 oil oics b.(bound_int_callee_save) - ofl ofcs b.(bound_float_callee_save). + ofl ofcs b.(bound_float_callee_save) + ostkdata. +(** Separation property *) -Remark align_float_part: +Remark frame_env_separated: forall b, - 24 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b <= - align (24 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b) 8. + let fe := make_env b in + 0 <= fe.(fe_ofs_link) + /\ fe.(fe_ofs_link) + 4 <= fe.(fe_ofs_retaddr) + /\ fe.(fe_ofs_retaddr) + 4 <= fe_ofs_arg + /\ fe_ofs_arg + 4 * b.(bound_outgoing) <= fe.(fe_ofs_int_local) + /\ fe.(fe_ofs_int_local) + 4 * b.(bound_int_local) <= fe.(fe_ofs_int_callee_save) + /\ fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save) <= fe.(fe_ofs_float_local) + /\ fe.(fe_ofs_float_local) + 8 * b.(bound_float_local) <= fe.(fe_ofs_float_callee_save) + /\ fe.(fe_ofs_float_callee_save) + 8 * b.(bound_float_callee_save) <= fe.(fe_stack_data) + /\ fe.(fe_stack_data) + b.(bound_stack_data) <= fe.(fe_size). Proof. - intros. apply align_le. omega. + intros. + generalize (align_le (fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save)) 8 (refl_equal _)). + generalize (align_le (fe.(fe_stack_data) + b.(bound_stack_data)) 16 (refl_equal _)). + unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr, + fe_ofs_int_local, fe_ofs_int_callee_save, + fe_num_int_callee_save, + fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save, + fe_stack_data, fe_ofs_arg. + intros. + generalize (bound_int_local_pos b); intro; + generalize (bound_float_local_pos b); intro; + generalize (bound_int_callee_save_pos b); intro; + generalize (bound_float_callee_save_pos b); intro; + generalize (bound_outgoing_pos b); intro; + generalize (bound_stack_data_pos b); intro. + omega. Qed. +(** Alignment property *) + +Remark frame_env_aligned: + forall b, + let fe := make_env b in + (4 | fe.(fe_ofs_link)) + /\ (4 | fe.(fe_ofs_int_local)) + /\ (4 | fe.(fe_ofs_int_callee_save)) + /\ (8 | fe.(fe_ofs_float_local)) + /\ (8 | fe.(fe_ofs_float_callee_save)) + /\ (4 | fe.(fe_ofs_retaddr)) + /\ (4 | fe.(fe_stack_data)) + /\ (16 | fe.(fe_size)). +Proof. + intros. + unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr, + fe_ofs_int_local, fe_ofs_int_callee_save, + fe_num_int_callee_save, + fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save, + fe_stack_data. + set (x1 := 24 + 4 * bound_outgoing b). + assert (4 | x1). unfold x1; apply Zdivide_plus_r. exists 6; auto. exists (bound_outgoing b); ring. + set (x2 := x1 + 4 * bound_int_local b). + assert (4 | x2). unfold x2; apply Zdivide_plus_r; auto. exists (bound_int_local b); ring. + set (x3 := x2 + 4 * bound_int_callee_save b). + set (x4 := align x3 8). + assert (8 | x4). unfold x4. apply align_divides. omega. + set (x5 := x4 + 8 * bound_float_local b). + assert (8 | x5). unfold x5. apply Zdivide_plus_r; auto. exists (bound_float_local b); ring. + set (x6 := x5 + 8 * bound_float_callee_save b). + assert (4 | x6). + apply Zdivides_trans with 8. exists 2; auto. + unfold x6. apply Zdivide_plus_r; auto. exists (bound_float_callee_save b); ring. + set (x7 := align (x6 + bound_stack_data b) 16). + assert (16 | x7). unfold x7; apply align_divides. omega. + intuition. + exists 3; auto. +Qed. |