diff options
| author |  xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e> | 2012-01-14 14:23:26 +0000 |
|---|---|---|
| committer | xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e> | 2012-01-14 14:23:26 +0000 |
| commit | a82c9c0e4a0b8e37c9c3ea5ae99714982563606f (patch) | |
| tree | 93b9999698a4cd47ec4cb5fcdcdfd215d62f8e9e | |
| parent | bb8f49c419eb8205ef541edcbe17f4d14aa99564 (diff) | |
Merge of the nonstrict-ops branch:
- Most RTL operators now evaluate to Some Vundef instead of None
when undefined behavior occurs.
- More aggressive instruction selection.
- "Bertotization" of pattern-matchings now implemented by a proper preprocessor.
- Cast optimization moved to cfrontend/Cminorgen; removed backend/CastOptim.
git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1790 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e
65 files changed, 9933 insertions, 12566 deletions
@@ -38,8 +38,6 @@ backend/Tailcall.vo backend/Tailcall.glob: backend/Tailcall.v lib/Coqlib.vo lib/ backend/Tailcallproof.vo backend/Tailcallproof.glob: backend/Tailcallproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Registers.vo backend/RTL.vo backend/Conventions.vo backend/Tailcall.vo backend/RTLtyping.vo backend/RTLtyping.glob: backend/RTLtyping.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo common/Globalenvs.vo common/Values.vo common/Memory.vo lib/Integers.vo common/Events.vo common/Smallstep.vo backend/RTL.vo backend/Conventions.vo backend/Kildall.vo backend/Kildall.glob: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo lib/Heaps.vo -backend/CastOptim.vo backend/CastOptim.glob: backend/CastOptim.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo -backend/CastOptimproof.vo backend/CastOptimproof.glob: backend/CastOptimproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/CastOptim.vo $(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOp.glob: $(ARCH)/ConstpropOp.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo $(ARCH)/Op.vo backend/Registers.vo backend/Constprop.vo backend/Constprop.glob: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo $(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOpproof.vo $(ARCH)/ConstpropOpproof.glob: $(ARCH)/ConstpropOpproof.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo $(ARCH)/ConstpropOp.vo backend/Constprop.vo @@ -88,9 +86,9 @@ backend/Stackingtyping.vo backend/Stackingtyping.glob: backend/Stackingtyping.v backend/Machsem.vo backend/Machsem.glob: backend/Machsem.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 $(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 -$(ARCH)/Asmgenproof1.vo $(ARCH)/Asmgenproof1.glob: $(ARCH)/Asmgenproof1.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 backend/Machsem.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Conventions.vo -$(ARCH)/Asmgenproof.vo $(ARCH)/Asmgenproof.glob: $(ARCH)/Asmgenproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machsem.vo backend/Machtyping.vo backend/Conventions.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo $(ARCH)/Asmgenretaddr.vo $(ARCH)/Asmgenproof1.vo +$(ARCH)/Asmgenretaddr.vo $(ARCH)/Asmgenretaddr.glob: $(ARCH)/Asmgenretaddr.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 $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo +$(ARCH)/Asmgenproof1.vo $(ARCH)/Asmgenproof1.glob: $(ARCH)/Asmgenproof1.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 $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machsem.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Conventions.vo +$(ARCH)/Asmgenproof.vo $(ARCH)/Asmgenproof.glob: $(ARCH)/Asmgenproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo backend/Machsem.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo $(ARCH)/Asmgenretaddr.vo $(ARCH)/Asmgenproof1.vo cfrontend/Csyntax.vo cfrontend/Csyntax.glob: cfrontend/Csyntax.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo 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 cfrontend/Csyntax.vo cfrontend/Csem.vo @@ -104,7 +102,7 @@ cfrontend/Clight.vo cfrontend/Clight.glob: cfrontend/Clight.v lib/Coqlib.vo comm cfrontend/Cshmgen.vo cfrontend/Cshmgen.glob: cfrontend/Cshmgen.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo cfrontend/Csyntax.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgenproof.vo cfrontend/Cshmgenproof.glob: cfrontend/Cshmgenproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo 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/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 lib/Floats.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/Cexec.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 backend/Machsem.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/CleanupLabels.vo backend/Reload.vo backend/RRE.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/CleanupLabelsproof.vo backend/CleanupLabelstyping.vo backend/Reloadproof.vo backend/Reloadtyping.vo backend/RREproof.vo backend/RREtyping.vo backend/Stackingproof.vo backend/Stackingtyping.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/Cexec.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 backend/Machsem.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/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Reload.vo backend/RRE.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/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/CleanupLabelsproof.vo backend/CleanupLabelstyping.vo backend/Reloadproof.vo backend/Reloadtyping.vo backend/RREproof.vo backend/RREtyping.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/Behaviors.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo backend/Cminor.vo backend/RTL.vo $(ARCH)/Asm.vo driver/Compiler.vo common/Errors.vo @@ -52,7 +52,6 @@ BACKEND=\ Tailcall.v Tailcallproof.v \ RTLtyping.v \ Kildall.v \ - CastOptim.v CastOptimproof.v \ ConstpropOp.v Constprop.v ConstpropOpproof.v Constpropproof.v \ CSE.v CSEproof.v \ Machregs.v Locations.v Conventions1.v Conventions.v LTL.v LTLtyping.v \ @@ -70,6 +69,8 @@ BACKEND=\ Machsem.v \ Asm.v Asmgen.v Asmgenretaddr.v Asmgenproof1.v Asmgenproof.v +# CastOptim.v CastOptimproof.v \ + # C front-end modules (in cfrontend/) CFRONTEND=Csyntax.v Csem.v Cstrategy.v Cexec.v \ @@ -136,16 +137,23 @@ doc/coq2html: doc/coq2html.ml doc/coq2html.ml: doc/coq2html.mll ocamllex doc/coq2html.mll +tools/ndfun: tools/ndfun.ml + ocamlopt -o tools/ndfun str.cmxa tools/ndfun.ml + latexdoc: cd doc; $(COQDOC) --latex -o doc/doc.tex -g $(FILES) -.SUFFIXES: .v .vo - -.v.vo: +%.vo: %.v @rm -f doc/glob/$(*F).glob @echo "COQC $*.v" @$(COQC) -dump-glob doc/$(*F).glob $*.v +%.v: %.vp tools/ndfun + @rm -f $*.v + @echo "Preprocessing $*.vp" + @tools/ndfun $*.vp > $*.v || { rm -f $*.v; exit 2; } + @chmod -w $*.v + driver/Configuration.ml: Makefile.config (echo let stdlib_path = "\"$(LIBDIR)\""; \ echo let prepro = "\"$(CPREPRO)\""; \ @@ -355,15 +355,15 @@ Definition exec_store (chunk: memory_chunk) (addr: val) (r: preg) (** Operations over condition bits. *) -Definition compare_int (rs: regset) (v1 v2: val) := - rs#CReq <- (Val.cmp Ceq v1 v2) - #CRne <- (Val.cmp Cne v1 v2) - #CRhs <- (Val.cmpu Cge v1 v2) - #CRlo <- (Val.cmpu Clt v1 v2) +Definition compare_int (rs: regset) (v1 v2: val) (m: mem) := + rs#CReq <- (Val.cmpu (Mem.valid_pointer m) Ceq v1 v2) + #CRne <- (Val.cmpu (Mem.valid_pointer m) Cne v1 v2) + #CRhs <- (Val.cmpu (Mem.valid_pointer m) Cge v1 v2) + #CRlo <- (Val.cmpu (Mem.valid_pointer m) Clt v1 v2) #CRmi <- Vundef #CRpl <- Vundef - #CRhi <- (Val.cmpu Cgt v1 v2) - #CRls <- (Val.cmpu Cle v1 v2) + #CRhi <- (Val.cmpu (Mem.valid_pointer m) Cgt v1 v2) + #CRls <- (Val.cmpu (Mem.valid_pointer m) Cle v1 v2) #CRge <- (Val.cmp Cge v1 v2) #CRlt <- (Val.cmp Clt v1 v2) #CRgt <- (Val.cmp Cgt v1 v2) @@ -434,7 +434,7 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pbic r1 r2 so => OK (nextinstr (rs#r1 <- (Val.and rs#r2 (Val.notint (eval_shift_op so rs))))) m | Pcmp r1 so => - OK (nextinstr (compare_int rs rs#r1 (eval_shift_op so rs))) m + OK (nextinstr (compare_int rs rs#r1 (eval_shift_op so rs) m)) m | Peor r1 r2 so => OK (nextinstr (rs#r1 <- (Val.xor rs#r2 (eval_shift_op so rs)))) m | Pldr r1 r2 sa => @@ -454,7 +454,7 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Vint n => if Int.eq n Int.zero then OK (nextinstr rs) m else OK (nextinstr (rs#r1 <- (eval_shift_op so rs))) m - | _ => Error + | _ => OK (nextinstr (rs#r1 <- Vundef)) m end | Pmul r1 r2 r3 => OK (nextinstr (rs#r1 <- (Val.mul rs#r2 rs#r3))) m @@ -471,11 +471,17 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pstrh r1 r2 sa => exec_store Mint16unsigned (Val.add rs#r2 (eval_shift_addr sa rs)) r1 rs m | Psdiv rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.divs rs#r1 rs#r2))) m + match Val.divs rs#r1 rs#r2 with + | Some v => OK (nextinstr (rs#rd <- v)) m + | None => Error + end | Psub r1 r2 so => OK (nextinstr (rs#r1 <- (Val.sub rs#r2 (eval_shift_op so rs)))) m | Pudiv rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.divu rs#r1 rs#r2))) m + match Val.divu rs#r1 rs#r2 with + | Some v => OK (nextinstr (rs#rd <- v)) m + | None => Error + end (* Floating-point coprocessor instructions *) | Pfcpyd r1 r2 => OK (nextinstr (rs#r1 <- (rs#r2))) m @@ -496,13 +502,13 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pfcmpd r1 r2 => OK (nextinstr (compare_float rs rs#r1 rs#r2)) m | Pfsitod r1 r2 => - OK (nextinstr (rs#r1 <- (Val.floatofint rs#r2))) m + OK (nextinstr (rs#r1 <- (Val.maketotal (Val.floatofint rs#r2)))) m | Pfuitod r1 r2 => - OK (nextinstr (rs#r1 <- (Val.floatofintu rs#r2))) m + OK (nextinstr (rs#r1 <- (Val.maketotal (Val.floatofintu rs#r2)))) m | Pftosizd r1 r2 => - OK (nextinstr (rs#r1 <- (Val.intoffloat rs#r2))) m + OK (nextinstr (rs#r1 <- (Val.maketotal (Val.intoffloat rs#r2)))) m | Pftouizd r1 r2 => - OK (nextinstr (rs#r1 <- (Val.intuoffloat rs#r2))) m + OK (nextinstr (rs#r1 <- (Val.maketotal (Val.intuoffloat rs#r2)))) m | Pfcvtsd r1 r2 => OK (nextinstr (rs#r1 <- (Val.singleoffloat rs#r2))) m | Pfldd r1 r2 n => diff --git a/arm/Asmgen.v b/arm/Asmgen.v index 4d36f91..c727db9 100644 --- a/arm/Asmgen.v +++ b/arm/Asmgen.v @@ -230,17 +230,6 @@ Definition transl_op Ploadsymbol (ireg_of r) s ofs :: k | Oaddrstack n, nil => addimm (ireg_of r) IR13 n k - | Ocast8signed, a1 :: nil => - Pmov (ireg_of r) (SOlslimm (ireg_of a1) (Int.repr 24)) :: - Pmov (ireg_of r) (SOasrimm (ireg_of r) (Int.repr 24)) :: k - | Ocast8unsigned, a1 :: nil => - Pand (ireg_of r) (ireg_of a1) (SOimm (Int.repr 255)) :: k - | Ocast16signed, a1 :: nil => - Pmov (ireg_of r) (SOlslimm (ireg_of a1) (Int.repr 16)) :: - Pmov (ireg_of r) (SOasrimm (ireg_of r) (Int.repr 16)) :: k - | Ocast16unsigned, a1 :: nil => - Pmov (ireg_of r) (SOlslimm (ireg_of a1) (Int.repr 16)) :: - Pmov (ireg_of r) (SOlsrimm (ireg_of r) (Int.repr 16)) :: k | Oadd, a1 :: a2 :: nil => Padd (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k | Oaddshift s, a1 :: a2 :: nil => diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v index 48f265b..a888aae 100644 --- a/arm/Asmgenproof.v +++ b/arm/Asmgenproof.v @@ -791,10 +791,9 @@ Proof. exists m'; split; auto. exists rs'; split. simpl. eexact P. assert (agree (Regmap.set res v ms) sp rs'). - apply agree_set_mreg with rs; auto. congruence. - auto with ppcgen. + apply agree_set_mreg with rs; auto. eapply Val.lessdef_trans; eauto. assert (agree (Regmap.set res v (undef_temps ms)) sp rs'). - apply agree_set_undef_mreg with rs; auto. congruence. + apply agree_set_undef_mreg with rs; auto. eapply Val.lessdef_trans; eauto. auto with ppcgen. destruct op; assumption. Qed. @@ -1086,7 +1085,8 @@ Proof. exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros A. exploit transl_cond_correct. eauto. eauto. - intros [rs2 [EX [RES OTH]]]. + instantiate (1 := rs). instantiate (1 := m'). unfold PregEq.t. rewrite A. + intros [rs2 [EX [RES OTH]]]. inv AT. simpl in H5. generalize (functions_transl _ _ H4); intro FN. generalize (functions_transl_no_overflow _ _ H4); intro NOOV. @@ -1120,7 +1120,8 @@ Proof. intro WTI. inv WTI. exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros A. - exploit transl_cond_correct. eauto. eauto. + exploit transl_cond_correct. eauto. + instantiate (1 := rs). instantiate (1 := m'). unfold PregEq.t. rewrite A. intros [rs2 [EX [RES OTH]]]. left; eapply exec_straight_steps; eauto with coqlib. exists m'; split; auto. diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v index 8f6b337..629a615 100644 --- a/arm/Asmgenproof1.v +++ b/arm/Asmgenproof1.v @@ -12,6 +12,7 @@ (** Correctness proof for ARM code generation: auxiliary results. *) +Require Import Axioms. Require Import Coqlib. Require Import Maps. Require Import AST. @@ -907,33 +908,29 @@ Qed. Lemma transl_shift_correct: forall s (r: ireg) (rs: regset), - eval_shift_op (transl_shift s r) rs = eval_shift_total s (rs#r). + eval_shift_op (transl_shift s r) rs = eval_shift s (rs#r). Proof. - intros. destruct s; simpl; - unfold eval_shift_total, eval_shift, Val.shl, Val.shr, Val.shru, Val.ror; - rewrite (s_amount_ltu s); auto. + intros. destruct s; simpl; auto. Qed. Lemma transl_shift_addr_correct: forall s (r: ireg) (rs: regset), - eval_shift_addr (transl_shift_addr s r) rs = eval_shift_total s (rs#r). + eval_shift_addr (transl_shift_addr s r) rs = eval_shift s (rs#r). Proof. - intros. destruct s; simpl; - unfold eval_shift_total, eval_shift, Val.shl, Val.shr, Val.shru, Val.ror; - rewrite (s_amount_ltu s); auto. + intros. destruct s; simpl; auto. Qed. (** Translation of conditions *) Lemma compare_int_spec: - forall rs v1 v2, - let rs1 := nextinstr (compare_int rs v1 v2) in - rs1#CReq = (Val.cmp Ceq v1 v2) - /\ rs1#CRne = (Val.cmp Cne v1 v2) - /\ rs1#CRhs = (Val.cmpu Cge v1 v2) - /\ rs1#CRlo = (Val.cmpu Clt v1 v2) - /\ rs1#CRhi = (Val.cmpu Cgt v1 v2) - /\ rs1#CRls = (Val.cmpu Cle v1 v2) + forall rs v1 v2 m, + let rs1 := nextinstr (compare_int rs v1 v2 m) in + rs1#CReq = (Val.cmpu (Mem.valid_pointer m) Ceq v1 v2) + /\ rs1#CRne = (Val.cmpu (Mem.valid_pointer m) Cne v1 v2) + /\ rs1#CRhs = (Val.cmpu (Mem.valid_pointer m) Cge v1 v2) + /\ rs1#CRlo = (Val.cmpu (Mem.valid_pointer m) Clt v1 v2) + /\ rs1#CRhi = (Val.cmpu (Mem.valid_pointer m) Cgt v1 v2) + /\ rs1#CRls = (Val.cmpu (Mem.valid_pointer m) Cle v1 v2) /\ rs1#CRge = (Val.cmp Cge v1 v2) /\ rs1#CRlt = (Val.cmp Clt v1 v2) /\ rs1#CRgt = (Val.cmp Cgt v1 v2) @@ -984,92 +981,106 @@ Ltac TypeInv2 := Ltac TypeInv := TypeInv1; simpl in *; unfold preg_of in *; TypeInv2. Lemma transl_cond_correct: - forall cond args k rs m b, + forall cond args k rs m, map mreg_type args = type_of_condition cond -> - 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 + /\ match eval_condition cond (map rs (map preg_of args)) m with + | Some b => rs'#(CR (crbit_for_cond cond)) = Val.of_bool b + | None => True + end /\ forall r, important_preg r = true -> rs'#r = rs r. Proof. - intros until b; intros TY EV. - rewrite <- (eval_condition_weaken _ _ _ EV). clear EV. - destruct cond; simpl in TY; TypeInv. + intros until m; intros TY. + assert (MATCH: forall v ob, + v = Val.of_optbool ob -> + match ob with Some b => v = Val.of_bool b | None => True end). + intros. subst v. destruct ob; auto. + assert (MATCH2: forall cmp v1 v2 v, + v = Val.cmpu (Mem.valid_pointer m) cmp v1 v2 -> + cmp = Ceq \/ cmp = Cne -> + match Val.cmp_bool cmp v1 v2 with + | Some b => v = Val.of_bool b + | None => True + end). + intros. destruct v1; simpl; auto; destruct v2; simpl; auto. + unfold Val.cmpu, Val.cmpu_bool in H. subst v. destruct H0; subst cmp; auto. + + destruct cond; simpl in TY; TypeInv; simpl. (* Ccomp *) - generalize (compare_int_spec rs (rs (ireg_of m0)) (rs (ireg_of m1))). + generalize (compare_int_spec rs (rs (ireg_of m0)) (rs (ireg_of m1)) m). intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. case c; assumption. + split. destruct c; (apply MATCH; assumption) || (apply MATCH2; auto). auto. (* Ccompu *) - generalize (compare_int_spec rs (rs (ireg_of m0)) (rs (ireg_of m1))). + generalize (compare_int_spec rs (rs (ireg_of m0)) (rs (ireg_of m1)) m). intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. case c; assumption. + split. destruct c; apply MATCH; assumption. auto. (* Ccompshift *) - generalize (compare_int_spec rs (rs (ireg_of m0)) (eval_shift_total s (rs (ireg_of m1)))). + generalize (compare_int_spec rs (rs (ireg_of m0)) (eval_shift s (rs (ireg_of m1))) m). intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. rewrite transl_shift_correct. case c; assumption. + split. rewrite transl_shift_correct. destruct c; (apply MATCH; assumption) || (apply MATCH2; auto). rewrite transl_shift_correct. auto. (* Ccompushift *) - generalize (compare_int_spec rs (rs (ireg_of m0)) (eval_shift_total s (rs (ireg_of m1)))). + generalize (compare_int_spec rs (rs (ireg_of m0)) (eval_shift s (rs (ireg_of m1))) m). intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. rewrite transl_shift_correct. case c; assumption. + split. rewrite transl_shift_correct. destruct c; apply MATCH; assumption. rewrite transl_shift_correct. auto. (* Ccompimm *) destruct (is_immed_arith i). - generalize (compare_int_spec rs (rs (ireg_of m0)) (Vint i)). + generalize (compare_int_spec rs (rs (ireg_of m0)) (Vint i) m). intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. case c; assumption. + split. destruct c; (apply MATCH; assumption) || (apply MATCH2; auto). auto. exploit (loadimm_correct IR14). intros [rs' [P [Q R]]]. - generalize (compare_int_spec rs' (rs (ireg_of m0)) (Vint i)). + generalize (compare_int_spec rs' (rs (ireg_of m0)) (Vint i) m). intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. econstructor. split. eapply exec_straight_trans. eexact P. apply exec_straight_one. simpl. rewrite Q. rewrite R; eauto with ppcgen. auto. - split. case c; assumption. + split. destruct c; (apply MATCH; assumption) || (apply MATCH2; auto). intros. rewrite K; auto with ppcgen. (* Ccompuimm *) destruct (is_immed_arith i). - generalize (compare_int_spec rs (rs (ireg_of m0)) (Vint i)). + generalize (compare_int_spec rs (rs (ireg_of m0)) (Vint i) m). intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. case c; assumption. + split. destruct c; apply MATCH; assumption. auto. exploit (loadimm_correct IR14). intros [rs' [P [Q R]]]. - generalize (compare_int_spec rs' (rs (ireg_of m0)) (Vint i)). + generalize (compare_int_spec rs' (rs (ireg_of m0)) (Vint i) m). intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. econstructor. split. eapply exec_straight_trans. eexact P. apply exec_straight_one. simpl. rewrite Q. rewrite R; eauto with ppcgen. auto. - split. case c; assumption. + split. destruct c; apply MATCH; assumption. intros. rewrite K; auto with ppcgen. (* Ccompf *) generalize (compare_float_spec rs (rs (freg_of m0)) (rs (freg_of m1))). intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. case c; assumption. + split. case c; apply MATCH; assumption. auto. (* Cnotcompf *) generalize (compare_float_spec rs (rs (freg_of m0)) (rs (freg_of m1))). intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. case c; try assumption. - rewrite Val.negate_cmpf_ne. auto. - rewrite Val.negate_cmpf_eq. auto. + split. rewrite <- Val.negate_cmpf_ne in B. rewrite <- Val.negate_cmpf_eq in A. + destruct c; apply MATCH; simpl; rewrite Val.notbool_negb_3; auto. auto. Qed. @@ -1089,27 +1100,26 @@ Ltac TranslOpSimpl := [ apply exec_straight_one; [simpl; eauto | reflexivity ] | split; [try rewrite transl_shift_correct; repeat Simpl | intros; repeat Simpl] ]. -Lemma transl_op_correct: +Lemma transl_op_correct_same: 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)) m = Some v -> + match op with Ocmp _ => False | _ => True end -> 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. inv H. (* Omove *) - simpl. + simpl in *. inv H0. exists (nextinstr (rs#(preg_of res) <- (rs#(preg_of r1)))). - split. unfold preg_of; rewrite <- H2. + split. unfold preg_of; rewrite <- H3. destruct (mreg_type r1); apply exec_straight_one; auto. split. Simpl. Simpl. intros. Simpl. Simpl. (* Other instructions *) - destruct op; simpl in H5; inv H5; TypeInv; try (TranslOpSimpl; fail). - (* Omove again *) - congruence. + destruct op; simpl in H6; inv H6; TypeInv; simpl in H0; inv H0; try (TranslOpSimpl; fail). (* Ointconst *) generalize (loadimm_correct (ireg_of res) i k rs m). intros [rs' [A [B C]]]. exists rs'. split. auto. split. rewrite B; auto. intros. auto with ppcgen. @@ -1117,35 +1127,6 @@ Proof. generalize (addimm_correct (ireg_of res) IR13 i k rs m). intros [rs' [EX [RES OTH]]]. exists rs'. split. auto. split. auto. auto with ppcgen. - (* Ocast8signed *) - econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - 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. auto. - compute; auto. - intros. repeat Simpl. - (* Ocast16signed *) - econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - 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. Simpl. Simpl. - destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.zero_ext_shru_shl; auto. - compute; auto. - intros. repeat Simpl. (* Oaddimm *) generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m). intros [rs' [A [B C]]]. @@ -1154,8 +1135,7 @@ Proof. 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. - destruct (rs (ireg_of m0)); auto. + split. eauto. split. rewrite B. auto. auto with ppcgen. (* Omul *) destruct (ireg_eq (ireg_of res) (ireg_of m0) || ireg_eq (ireg_of res) (ireg_of m1)). @@ -1164,6 +1144,12 @@ Proof. split. repeat Simpl. intros. repeat Simpl. TranslOpSimpl. + (* divs *) + econstructor. split. apply exec_straight_one. simpl. rewrite H2. reflexivity. auto. + split. repeat Simpl. intros. repeat Simpl. + (* divu *) + econstructor. split. apply exec_straight_one. simpl. rewrite H2. reflexivity. auto. + split. repeat Simpl. intros. repeat Simpl. (* Oandimm *) generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m (ireg_of_not_IR14 m0)). @@ -1178,19 +1164,12 @@ Proof. intros [rs' [A [B C]]]. 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. - exists i0; split; auto. destruct (Int.ltu i (Int.repr 31)); discriminate || auto. - destruct H as [n [ARG1 LTU]]. clear H0. - assert (LTU': Int.ltu i Int.iwordsize = true). - exploit Int.ltu_inv. eexact LTU. intro. - unfold Int.ltu. apply zlt_true. - assert (Int.unsigned (Int.repr 31) < Int.unsigned Int.iwordsize). compute; auto. - omega. - set (islt := Int.lt n Int.zero). - set (rs1 := nextinstr (compare_int rs (Vint n) (Vint Int.zero))). + exploit Val.shrx_shr; eauto. intros [n [i' [ARG1 [ARG2 RES]]]]. + injection ARG2; intro ARG2'; subst i'; clear ARG2. + set (islt := Int.lt n Int.zero) in *. + set (rs1 := nextinstr (compare_int rs (Vint n) (Vint Int.zero) m)). assert (OTH1: forall r', important_preg r' = true -> rs1#r' = rs#r'). - generalize (compare_int_spec rs (Vint n) (Vint Int.zero)). + generalize (compare_int_spec rs (Vint n) (Vint Int.zero) m). fold rs1. intros [A B]. intuition. exploit (addimm_correct IR14 (ireg_of m0) (Int.sub (Int.shl Int.one i) Int.one)). intros [rs2 [EXEC2 [RES2 OTH2]]]. @@ -1202,46 +1181,78 @@ Proof. eapply exec_straight_trans. eexact EXEC2. apply exec_straight_two with rs3 m. simpl. rewrite OTH2. change (rs1 CRge) with (Val.cmp Cge (Vint n) (Vint Int.zero)). - unfold Val.cmp. change (Int.cmp Cge n Int.zero) with (negb islt). + unfold Val.cmp, Val.cmp_bool. change (Int.cmp Cge n Int.zero) with (negb islt). rewrite OTH2. rewrite OTH1. rewrite ARG1. unfold rs3. case islt; reflexivity. destruct m0; reflexivity. auto with ppcgen. auto with ppcgen. discriminate. discriminate. simpl. auto. 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. - rewrite Pregmap.gss. simpl. rewrite LTU'. auto. - assumption. + split. unfold rs4. repeat Simpl. unfold rs3. Simpl. destruct islt. + rewrite RES2. change (rs1 (IR (ireg_of m0))) with (rs (IR (ireg_of m0))). auto. + Simpl. rewrite <- ARG1; auto. intros. unfold rs4; repeat Simpl. unfold rs3; repeat Simpl. transitivity (rs2 r). destruct islt; auto. Simpl. rewrite OTH2; auto with ppcgen. + (* intoffloat *) + econstructor; split. apply exec_straight_one; simpl. rewrite H2; simpl. eauto. auto. + split; intros; repeat Simpl. + (* intuoffloat *) + econstructor; split. apply exec_straight_one; simpl. rewrite H2; simpl. eauto. auto. + split; intros; repeat Simpl. + (* floatofint *) + econstructor; split. apply exec_straight_one; simpl. rewrite H2; simpl. eauto. auto. + split; intros; repeat Simpl. + (* floatofintu *) + econstructor; split. apply exec_straight_one; simpl. rewrite H2; simpl. eauto. auto. + split; intros; repeat Simpl. + (* Ocmp *) + contradiction. +Qed. + +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)) m = Some v -> + exists rs', + exec_straight (transl_op op args res k) rs m k rs' m + /\ Val.lessdef v rs'#(preg_of res) + /\ forall r, important_preg r = true -> r <> preg_of res -> rs'#r = rs#r. +Proof. + intros. + assert (EITHER: match op with Ocmp _ => False | _ => True end \/ exists cmp, op = Ocmp cmp). + destruct op; auto. right; exists c; auto. + destruct EITHER as [A | [c A]]. + exploit transl_op_correct_same; eauto. intros [rs' [P [Q R]]]. + subst v. exists rs'; eauto. (* Ocmp *) - fold preg_of in *. - 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). + subst op. inv H. simpl in H5. inv H5. simpl in H0. inv H0. 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) - rs m b H1 EVC) + rs m H1) as [rs1 [A [B C]]]. set (rs2 := nextinstr (rs1#(ireg_of res) <- (Vint Int.zero))). - set (rs3 := nextinstr (if b then (rs2#(ireg_of res) <- Vtrue) else rs2)). - exists rs3. - split. eapply exec_straight_trans. eauto. + set (v := match rs2#(crbit_for_cond c) with + | Vint n => if Int.eq n Int.zero then Vint Int.zero else Vint Int.one + | _ => Vundef + end). + set (rs3 := nextinstr (rs2#(ireg_of res) <- v)). + exists rs3; split. + eapply exec_straight_trans. eauto. apply exec_straight_two with rs2 m; auto. - simpl. replace (rs2 (crbit_for_cond c)) with (Val.of_bool b). - unfold rs3. destruct b; auto. - unfold rs3. destruct b; auto. - split. unfold rs3. Simpl. destruct b. Simpl. unfold rs2. repeat Simpl. - intros. unfold rs3. Simpl. transitivity (rs2 r). - destruct b; auto; Simpl. unfold rs2. repeat Simpl. + simpl. unfold rs3, v. + destruct (rs2 (crbit_for_cond c)) as []_eqn; auto. + destruct (Int.eq i Int.zero); auto. + decEq. decEq. apply extensionality; intros. unfold Pregmap.set. + destruct (PregEq.eq x (ireg_of res)); auto. subst. + unfold rs2. Simpl. Simpl. + replace (preg_of res) with (IR (ireg_of res)). + split. unfold rs3. Simpl. Simpl. + destruct (eval_condition c rs ## (preg_of ## args) m); simpl; auto. + unfold v. unfold rs2. Simpl. Simpl. rewrite B. + destruct b; simpl; auto. + intros. unfold rs3. repeat Simpl. unfold rs2. repeat Simpl. + unfold preg_of; rewrite H2; auto. Qed. Remark val_add_add_zero: @@ -1256,7 +1267,7 @@ Lemma transl_load_store_correct: (is_immed: int -> bool) addr args k ms sp rs m ms' m', (forall (r1: ireg) (rs1: regset) n k, - eval_addressing_total sp addr (map rs (map preg_of args)) = Val.add rs1#r1 (Vint n) -> + eval_addressing ge sp addr (map rs (map preg_of args)) = Some(Val.add rs1#r1 (Vint n)) -> (forall (r: preg), r <> PC -> r <> IR14 -> rs1 r = rs r) -> exists rs', exec_straight (mk_instr_imm r1 n :: k) rs1 m k rs' m' /\ @@ -1265,7 +1276,7 @@ Lemma transl_load_store_correct: | None => True | Some mk => (forall (r1: ireg) (sa: shift_addr) (rs1: regset) k, - eval_addressing_total sp addr (map rs (map preg_of args)) = Val.add rs1#r1 (eval_shift_addr sa rs1) -> + eval_addressing ge sp addr (map rs (map preg_of args)) = Some(Val.add rs1#r1 (eval_shift_addr sa rs1)) -> (forall (r: preg), r <> PC -> r <> IR14 -> rs1 r = rs r) -> exists rs', exec_straight (mk r1 sa :: k) rs1 m k rs' m' /\ @@ -1299,7 +1310,7 @@ Proof. set (rs' := nextinstr (rs#IR14 <- (Val.add (rs (ireg_of m0)) (rs (ireg_of m1))))). exploit (H IR14 rs' Int.zero); eauto. unfold rs'. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - apply val_add_add_zero. + decEq. apply val_add_add_zero. unfold rs'. intros. repeat Simpl. intros [rs'' [A B]]. exists rs''; split. @@ -1310,10 +1321,10 @@ Proof. (* binary form available *) apply H0; auto. rewrite transl_shift_addr_correct. auto. (* binary form not available *) - set (rs' := nextinstr (rs#IR14 <- (Val.add (rs (ireg_of m0)) (eval_shift_total s (rs (ireg_of m1)))))). + set (rs' := nextinstr (rs#IR14 <- (Val.add (rs (ireg_of m0)) (eval_shift s (rs (ireg_of m1)))))). exploit (H IR14 rs' Int.zero); eauto. unfold rs'. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - apply val_add_add_zero. + decEq. apply val_add_add_zero. unfold rs'; intros; repeat Simpl. intros [rs'' [A B]]. exists rs''; split. @@ -1356,7 +1367,6 @@ Proof. exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto. intros [a' [A B]]. exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - exploit eval_addressing_weaken. eexact A. intros E. apply transl_load_store_correct with ms; auto. intros. assert (Val.add (rs1 r1) (Vint n) = a') by congruence. @@ -1398,7 +1408,6 @@ Proof. exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto. intros [a' [A B]]. exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - exploit eval_addressing_weaken. eexact A. intros E. apply transl_load_store_correct with ms; auto. intros. assert (Val.add (rs1 r1) (Vint n) = a') by congruence. @@ -1435,7 +1444,6 @@ Proof. intros [a' [A B]]. exploit preg_val; eauto. instantiate (1 := rd). intros C. exploit Mem.storev_extends; eauto. unfold preg_of; rewrite H2. intros [m2' [D E]]. - exploit eval_addressing_weaken. eexact A. intros F. exists m2'; split; auto. apply transl_load_store_correct with ms; auto. intros. @@ -1479,7 +1487,6 @@ Proof. intros [a' [A B]]. exploit preg_val; eauto. instantiate (1 := rd). intros C. exploit Mem.storev_extends; eauto. unfold preg_of; rewrite H2. intros [m2' [D E]]. - exploit eval_addressing_weaken. eexact A. intros F. exists m2'; split; auto. apply transl_load_store_correct with ms; auto. intros. diff --git a/arm/ConstpropOp.v b/arm/ConstpropOp.v index 86b6d66..9e51e25 100644 --- a/arm/ConstpropOp.v +++ b/arm/ConstpropOp.v @@ -32,9 +32,11 @@ Inductive approx : Type := no compile-time information is available. *) | I: int -> approx (** A known integer value. *) | F: float -> approx (** A known floating-point value. *) - | S: ident -> int -> approx. + | G: ident -> int -> approx (** The value is the address of the given global symbol plus the given integer offset. *) + | S: int -> approx. (** The value is the stack pointer plus the offset. *) + (** We now define the abstract interpretations of conditions and operators over this set of approximations. For instance, the abstract interpretation @@ -44,140 +46,140 @@ Inductive approx : Type := The static approximations are defined by large pattern-matchings over the approximations of the results. We write these matchings in the - indirect style described in file [Selection] to avoid excessive + indirect style described in file [SelectOp] to avoid excessive duplication of cases in proofs. *) -(* -Definition eval_static_condition (cond: condition) (vl: list approx) := +Definition eval_static_shift (s: shift) (n: int) : int := + match s with + | Slsl x => Int.shl n x + | Slsr x => Int.shru n x + | Sasr x => Int.shr n x + | Sror x => Int.ror n x + end. + +(** Original definition: +<< +Nondetfunction eval_static_condition (cond: condition) (vl: list approx) := match cond, vl with | Ccomp c, I n1 :: I n2 :: nil => Some(Int.cmp c n1 n2) | Ccompu c, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 n2) - | Ccompshift c s, I n1 :: I n2 :: nil => Some(Int.cmp c n1 (eval_shift s n2)) - | Ccompushift c s, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 (eval_shift s n2)) + | Ccompshift c s, I n1 :: I n2 :: nil => Some(Int.cmp c n1 (eval_static_shift s n2)) + | Ccompushift c s, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 (eval_static_shift s n2)) | Ccompimm c n, I n1 :: nil => Some(Int.cmp c n1 n) | Ccompuimm c n, I n1 :: nil => Some(Int.cmpu c n1 n) | Ccompf c, F n1 :: F n2 :: nil => Some(Float.cmp c n1 n2) | Cnotcompf c, F n1 :: F n2 :: nil => Some(negb(Float.cmp c n1 n2)) | _, _ => None end. +>> *) Inductive eval_static_condition_cases: forall (cond: condition) (vl: list approx), Type := - | eval_static_condition_case1: - forall c n1 n2, - eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil) - | eval_static_condition_case2: - forall c n1 n2, - eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil) - | eval_static_condition_case3: - forall c s n1 n2, - eval_static_condition_cases (Ccompshift c s) (I n1 :: I n2 :: nil) - | eval_static_condition_case4: - forall c s n1 n2, - eval_static_condition_cases (Ccompushift c s) (I n1 :: I n2 :: nil) - | eval_static_condition_case5: - forall c n n1, - eval_static_condition_cases (Ccompimm c n) (I n1 :: nil) - | eval_static_condition_case6: - forall c n n1, - eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil) - | eval_static_condition_case7: - forall c n1 n2, - eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil) - | eval_static_condition_case8: - forall c n1 n2, - eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil) - | eval_static_condition_default: - forall (cond: condition) (vl: list approx), - eval_static_condition_cases cond vl. + | eval_static_condition_case1: forall c n1 n2, eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil) + | eval_static_condition_case2: forall c n1 n2, eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil) + | eval_static_condition_case3: forall c s n1 n2, eval_static_condition_cases (Ccompshift c s) (I n1 :: I n2 :: nil) + | eval_static_condition_case4: forall c s n1 n2, eval_static_condition_cases (Ccompushift c s) (I n1 :: I n2 :: nil) + | eval_static_condition_case5: forall c n n1, eval_static_condition_cases (Ccompimm c n) (I n1 :: nil) + | eval_static_condition_case6: forall c n n1, eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil) + | eval_static_condition_case7: forall c n1 n2, eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil) + | eval_static_condition_case8: forall c n1 n2, eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil) + | eval_static_condition_default: forall (cond: condition) (vl: list approx), eval_static_condition_cases cond vl. Definition eval_static_condition_match (cond: condition) (vl: list approx) := - match cond as z1, vl as z2 return eval_static_condition_cases z1 z2 with - | Ccomp c, I n1 :: I n2 :: nil => - eval_static_condition_case1 c n1 n2 - | Ccompu c, I n1 :: I n2 :: nil => - eval_static_condition_case2 c n1 n2 - | Ccompshift c s, I n1 :: I n2 :: nil => - eval_static_condition_case3 c s n1 n2 - | Ccompushift c s, I n1 :: I n2 :: nil => - eval_static_condition_case4 c s n1 n2 - | Ccompimm c n, I n1 :: nil => - eval_static_condition_case5 c n n1 - | Ccompuimm c n, I n1 :: nil => - eval_static_condition_case6 c n n1 - | Ccompf c, F n1 :: F n2 :: nil => - eval_static_condition_case7 c n1 n2 - | Cnotcompf c, F n1 :: F n2 :: nil => - eval_static_condition_case8 c n1 n2 - | cond, vl => - eval_static_condition_default cond vl + match cond as zz1, vl as zz2 return eval_static_condition_cases zz1 zz2 with + | Ccomp c, I n1 :: I n2 :: nil => eval_static_condition_case1 c n1 n2 + | Ccompu c, I n1 :: I n2 :: nil => eval_static_condition_case2 c n1 n2 + | Ccompshift c s, I n1 :: I n2 :: nil => eval_static_condition_case3 c s n1 n2 + | Ccompushift c s, I n1 :: I n2 :: nil => eval_static_condition_case4 c s n1 n2 + | Ccompimm c n, I n1 :: nil => eval_static_condition_case5 c n n1 + | Ccompuimm c n, I n1 :: nil => eval_static_condition_case6 c n n1 + | Ccompf c, F n1 :: F n2 :: nil => eval_static_condition_case7 c n1 n2 + | Cnotcompf c, F n1 :: F n2 :: nil => eval_static_condition_case8 c n1 n2 + | cond, vl => eval_static_condition_default cond vl end. Definition eval_static_condition (cond: condition) (vl: list approx) := match eval_static_condition_match cond vl with - | eval_static_condition_case1 c n1 n2 => + | eval_static_condition_case1 c n1 n2 => (* Ccomp c, I n1 :: I n2 :: nil *) Some(Int.cmp c n1 n2) - | eval_static_condition_case2 c n1 n2 => + | eval_static_condition_case2 c n1 n2 => (* Ccompu c, I n1 :: I n2 :: nil *) Some(Int.cmpu c n1 n2) - | eval_static_condition_case3 c s n1 n2 => - Some(Int.cmp c n1 (eval_shift s n2)) - | eval_static_condition_case4 c s n1 n2 => - Some(Int.cmpu c n1 (eval_shift s n2)) - | eval_static_condition_case5 c n n1 => + | eval_static_condition_case3 c s n1 n2 => (* Ccompshift c s, I n1 :: I n2 :: nil *) + Some(Int.cmp c n1 (eval_static_shift s n2)) + | eval_static_condition_case4 c s n1 n2 => (* Ccompushift c s, I n1 :: I n2 :: nil *) + Some(Int.cmpu c n1 (eval_static_shift s n2)) + | eval_static_condition_case5 c n n1 => (* Ccompimm c n, I n1 :: nil *) Some(Int.cmp c n1 n) - | eval_static_condition_case6 c n n1 => + | eval_static_condition_case6 c n n1 => (* Ccompuimm c n, I n1 :: nil *) Some(Int.cmpu c n1 n) - | eval_static_condition_case7 c n1 n2 => + | eval_static_condition_case7 c n1 n2 => (* Ccompf c, F n1 :: F n2 :: nil *) Some(Float.cmp c n1 n2) - | eval_static_condition_case8 c n1 n2 => + | eval_static_condition_case8 c n1 n2 => (* Cnotcompf c, F n1 :: F n2 :: nil *) Some(negb(Float.cmp c n1 n2)) | eval_static_condition_default cond vl => None end. -(* -Definition eval_static_operation (op: operation) (vl: list approx) := + +Definition eval_static_condition_val (cond: condition) (vl: list approx) := + match eval_static_condition cond vl with + | None => Unknown + | Some b => I(if b then Int.one else Int.zero) + end. + +Definition eval_static_intoffloat (f: float) := + match Float.intoffloat f with Some x => I x | None => Unknown end. + +Definition eval_static_intuoffloat (f: float) := + match Float.intuoffloat f with Some x => I x | None => Unknown end. + +(** Original definition: +<< +Nondetfunction eval_static_operation (op: operation) (vl: list approx) := match op, vl with | Omove, v1::nil => v1 | Ointconst n, nil => I n | Ofloatconst n, nil => F n - | Oaddrsymbol s n, nil => S s n - | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n) - | Ocast8unsigned, I n1 :: nil => I(Int.zero_ext 8 n) - | Ocast16signed, I n1 :: nil => I(Int.sign_ext 16 n) - | Ocast16unsigned, I n1 :: nil => I(Int.zero_ext 16 n) + | Oaddrsymbol s n, nil => G s n + | Oaddrstack n, nil => S n | Oadd, I n1 :: I n2 :: nil => I(Int.add n1 n2) - | Oaddshift s, I n1 :: I n2 :: nil => I(Int.add n1 (eval_shift s n2)) - | Oadd, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 n2) - | Oaddshift s, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 (eval_shift s n2)) + | Oaddshift s, I n1 :: I n2 :: nil => I(Int.add n1 (eval_static_shift s n2)) + | Oadd, G s1 n1 :: I n2 :: nil => G s1 (Int.add n1 n2) + | Oaddshift s, G s1 n1 :: I n2 :: nil => G s1 (Int.add n1 (eval_static_shift s n2)) + | Oadd, S n1 :: I n2 :: nil => S (Int.add n1 n2) + | Oaddshift s, S n1 :: I n2 :: nil => S (Int.add n1 (eval_static_shift s n2)) + | Oadd, I n1 :: G s2 n2 :: nil => G s2 (Int.add n1 n2) + | Oadd, I n1 :: S n2 :: nil => S (Int.add n1 n2) | Oaddimm n, I n1 :: nil => I (Int.add n1 n) - | Oaddimm n, S s1 n1 :: nil => S s1 (Int.add n1 n) + | Oaddimm n, G s1 n1 :: nil => G s1 (Int.add n1 n) + | Oaddimm n, S n1 :: nil => S (Int.add n1 n) | Osub, I n1 :: I n2 :: nil => I(Int.sub n1 n2) - | Osubshift s, I n1 :: I n2 :: nil => I(Int.sub n1 (eval_shift s n2)) - | Osub, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 n2) - | Osubshift s, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 (eval_shift s n2)) - | Orsubshift s, I n1 :: I n2 :: nil => I(Int.sub (eval_shift s n2) n1) + | Osubshift s, I n1 :: I n2 :: nil => I(Int.sub n1 (eval_static_shift s n2)) + | Osub, G s1 n1 :: I n2 :: nil => G s1 (Int.sub n1 n2) + | Osub, S n1 :: I n2 :: nil => S (Int.sub n1 n2) + | Osubshift s, G s1 n1 :: I n2 :: nil => G s1 (Int.sub n1 (eval_static_shift s n2)) + | Orsubshift s, I n1 :: I n2 :: nil => I(Int.sub (eval_static_shift s n2) n1) | Orsubimm n, I n1 :: nil => I (Int.sub n n1) | Omul, I n1 :: I n2 :: nil => I(Int.mul n1 n2) | Odiv, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) | Odivu, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) | Oand, I n1 :: I n2 :: nil => I(Int.and n1 n2) - | Oandshift s, I n1 :: I n2 :: nil => I(Int.and n1 (eval_shift s n2)) + | Oandshift s, I n1 :: I n2 :: nil => I(Int.and n1 (eval_static_shift s n2)) | Oandimm n, I n1 :: nil => I(Int.and n1 n) | Oor, I n1 :: I n2 :: nil => I(Int.or n1 n2) - | Oorshift s, I n1 :: I n2 :: nil => I(Int.or n1 (eval_shift s n2)) + | Oorshift s, I n1 :: I n2 :: nil => I(Int.or n1 (eval_static_shift s n2)) | Oorimm n, I n1 :: nil => I(Int.or n1 n) | Oxor, I n1 :: I n2 :: nil => I(Int.xor n1 n2) - | Oxorshift s, I n1 :: I n2 :: nil => I(Int.xor n1 (eval_shift s n2)) + | Oxorshift s, I n1 :: I n2 :: nil => I(Int.xor n1 (eval_static_shift s n2)) | Oxorimm n, I n1 :: nil => I(Int.xor n1 n) | Obic, I n1 :: I n2 :: nil => I(Int.and n1 (Int.not n2)) - | Obicshift s, I n1 :: I n2 :: nil => I(Int.and n1 (Int.not (eval_shift s n2))) + | Obicshift s, I n1 :: I n2 :: nil => I(Int.and n1 (Int.not (eval_static_shift s n2))) | Onot, I n1 :: nil => I(Int.not n1) - | Onotshift s, I n1 :: nil => I(Int.not (eval_shift s n1)) + | Onotshift s, I n1 :: nil => I(Int.not (eval_static_shift s n1)) | Oshl, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shl n1 n2) else Unknown | Oshr, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shr n1 n2) else Unknown | Oshru, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shru n1 n2) else Unknown - | Oshift s, I n1 :: nil => I(eval_shift s n1) + | Oshift s, I n1 :: nil => I(eval_static_shift s n1) | Onegf, F n1 :: nil => F(Float.neg n1) | Oabsf, F n1 :: nil => F(Float.abs n1) | Oaddf, F n1 :: F n2 :: nil => F(Float.add n1 n2) @@ -185,409 +187,251 @@ Definition eval_static_operation (op: operation) (vl: list approx) := | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2) | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2) | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) - | Ointoffloat, F n1 :: nil => match Float.intoffloat n1 with Some x => I x | None => Unknown end + | Ointoffloat, F n1 :: nil => eval_static_intoffloat n1 + | Ointuoffloat, F n1 :: nil => eval_static_intuoffloat n1 | Ofloatofint, I n1 :: nil => F(Float.floatofint n1) | Ofloatofintu, I n1 :: nil => F(Float.floatofintu n1) - | Ocmp c, vl => - match eval_static_condition c vl with - | None => Unknown - | Some b => I(if b then Int.one else Int.zero) - end + | Ocmp c, vl => eval_static_condition_val c vl | _, _ => Unknown end. +>> *) Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx), Type := - | eval_static_operation_case1: - forall v1, - eval_static_operation_cases (Omove) (v1::nil) - | eval_static_operation_case2: - forall n, - eval_static_operation_cases (Ointconst n) (nil) - | eval_static_operation_case3: - forall n, - eval_static_operation_cases (Ofloatconst n) (nil) - | eval_static_operation_case4: - forall s n, - eval_static_operation_cases (Oaddrsymbol s n) (nil) - | eval_static_operation_case5: - forall n1, - eval_static_operation_cases (Ocast8signed) (I n1 :: nil) - | eval_static_operation_case6: - forall n1, - eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil) - | eval_static_operation_case7: - forall n1, - eval_static_operation_cases (Ocast16signed) (I n1 :: nil) - | eval_static_operation_case8: - forall n1, - eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil) - | eval_static_operation_case9: - forall n1 n2, - eval_static_operation_cases (Oadd) (I n1 :: I n2 :: nil) - | eval_static_operation_case10: - forall s n1 n2, - eval_static_operation_cases (Oaddshift s) (I n1 :: I n2 :: nil) - | eval_static_operation_case11: - forall s1 n1 n2, - eval_static_operation_cases (Oadd) (S s1 n1 :: I n2 :: nil) - | eval_static_operation_case12: - forall s s1 n1 n2, - eval_static_operation_cases (Oaddshift s) (S s1 n1 :: I n2 :: nil) - | eval_static_operation_case13: - forall n n1, - eval_static_operation_cases (Oaddimm n) (I n1 :: nil) - | eval_static_operation_case14: - forall n s1 n1, - eval_static_operation_cases (Oaddimm n) (S s1 n1 :: nil) - | eval_static_operation_case15: - forall n1 n2, - eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil) - | eval_static_operation_case16: - forall s n1 n2, - eval_static_operation_cases (Osubshift s) (I n1 :: I n2 :: nil) - | eval_static_operation_case17: - forall s1 n1 n2, - eval_static_operation_cases (Osub) (S s1 n1 :: I n2 :: nil) - | eval_static_operation_case18: - forall s s1 n1 n2, - eval_static_operation_cases (Osubshift s) (S s1 n1 :: I n2 :: nil) - | eval_static_operation_case19: - forall s n1 n2, - eval_static_operation_cases (Orsubshift s) (I n1 :: I n2 :: nil) - | eval_static_operation_case20: - forall n n1, - eval_static_operation_cases (Orsubimm n) (I n1 :: nil) - | eval_static_operation_case21: - forall n1 n2, - eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil) - | eval_static_operation_case22: - forall n1 n2, - eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil) - | eval_static_operation_case23: - forall n1 n2, - eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil) - | eval_static_operation_case24: - forall n1 n2, - eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil) - | eval_static_operation_case25: - forall s n1 n2, - eval_static_operation_cases (Oandshift s) (I n1 :: I n2 :: nil) - | eval_static_operation_case26: - forall n n1, - eval_static_operation_cases (Oandimm n) (I n1 :: nil) - | eval_static_operation_case27: - forall n1 n2, - eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil) - | eval_static_operation_case28: - forall s n1 n2, - eval_static_operation_cases (Oorshift s) (I n1 :: I n2 :: nil) - | eval_static_operation_case29: - forall n n1, - eval_static_operation_cases (Oorimm n) (I n1 :: nil) - | eval_static_operation_case30: - forall n1 n2, - eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil) - | eval_static_operation_case31: - forall s n1 n2, - eval_static_operation_cases (Oxorshift s) (I n1 :: I n2 :: nil) - | eval_static_operation_case32: - forall n n1, - eval_static_operation_cases (Oxorimm n) (I n1 :: nil) - | eval_static_operation_case33: - forall n1 n2, - eval_static_operation_cases (Obic) (I n1 :: I n2 :: nil) - | eval_static_operation_case34: - forall s n1 n2, - eval_static_operation_cases (Obicshift s) (I n1 :: I n2 :: nil) - | eval_static_operation_case35: - forall n1, - eval_static_operation_cases (Onot) (I n1 :: nil) - | eval_static_operation_case36: - forall s n1, - eval_static_operation_cases (Onotshift s) (I n1 :: nil) - | eval_static_operation_case37: - forall n1 n2, - eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil) - | eval_static_operation_case38: - forall n1 n2, - eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil) - | eval_static_operation_case39: - forall n1 n2, - eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil) - | eval_static_operation_case40: - forall s n1, - eval_static_operation_cases (Oshift s) (I n1 :: nil) - | eval_static_operation_case41: - forall n1, - eval_static_operation_cases (Onegf) (F n1 :: nil) - | eval_static_operation_case42: - forall n1, - eval_static_operation_cases (Oabsf) (F n1 :: nil) - | eval_static_operation_case43: - forall n1 n2, - eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil) - | eval_static_operation_case44: - forall n1 n2, - eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil) - | eval_static_operation_case45: - forall n1 n2, - eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil) - | eval_static_operation_case46: - forall n1 n2, - eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil) - | eval_static_operation_case47: - forall n1, - eval_static_operation_cases (Osingleoffloat) (F n1 :: nil) - | eval_static_operation_case48: - forall n1, - eval_static_operation_cases (Ointoffloat) (F n1 :: nil) - | eval_static_operation_case49: - forall n1, - eval_static_operation_cases (Ofloatofint) (I n1 :: nil) - | eval_static_operation_case50: - forall n1, - eval_static_operation_cases (Ointuoffloat) (F n1 :: nil) - | eval_static_operation_case53: - forall n1, - eval_static_operation_cases (Ofloatofintu) (I n1 :: nil) - | eval_static_operation_case51: - forall c vl, - eval_static_operation_cases (Ocmp c) (vl) - | eval_static_operation_case52: - forall n n1, - eval_static_operation_cases (Oshrximm n) (I n1 :: nil) - | eval_static_operation_default: - forall (op: operation) (vl: list approx), - eval_static_operation_cases op vl. + | eval_static_operation_case1: forall v1, eval_static_operation_cases (Omove) (v1::nil) + | eval_static_operation_case2: forall n, eval_static_operation_cases (Ointconst n) (nil) + | eval_static_operation_case3: forall n, eval_static_operation_cases (Ofloatconst n) (nil) + | eval_static_operation_case4: forall s n, eval_static_operation_cases (Oaddrsymbol s n) (nil) + | eval_static_operation_case5: forall n, eval_static_operation_cases (Oaddrstack n) (nil) + | eval_static_operation_case6: forall n1 n2, eval_static_operation_cases (Oadd) (I n1 :: I n2 :: nil) + | eval_static_operation_case7: forall s n1 n2, eval_static_operation_cases (Oaddshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case8: forall s1 n1 n2, eval_static_operation_cases (Oadd) (G s1 n1 :: I n2 :: nil) + | eval_static_operation_case9: forall s s1 n1 n2, eval_static_operation_cases (Oaddshift s) (G s1 n1 :: I n2 :: nil) + | eval_static_operation_case10: forall n1 n2, eval_static_operation_cases (Oadd) (S n1 :: I n2 :: nil) + | eval_static_operation_case11: forall s n1 n2, eval_static_operation_cases (Oaddshift s) (S n1 :: I n2 :: nil) + | eval_static_operation_case12: forall n1 s2 n2, eval_static_operation_cases (Oadd) (I n1 :: G s2 n2 :: nil) + | eval_static_operation_case13: forall n1 n2, eval_static_operation_cases (Oadd) (I n1 :: S n2 :: nil) + | eval_static_operation_case14: forall n n1, eval_static_operation_cases (Oaddimm n) (I n1 :: nil) + | eval_static_operation_case15: forall n s1 n1, eval_static_operation_cases (Oaddimm n) (G s1 n1 :: nil) + | eval_static_operation_case16: forall n n1, eval_static_operation_cases (Oaddimm n) (S n1 :: nil) + | eval_static_operation_case17: forall n1 n2, eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil) + | eval_static_operation_case18: forall s n1 n2, eval_static_operation_cases (Osubshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case19: forall s1 n1 n2, eval_static_operation_cases (Osub) (G s1 n1 :: I n2 :: nil) + | eval_static_operation_case20: forall n1 n2, eval_static_operation_cases (Osub) (S n1 :: I n2 :: nil) + | eval_static_operation_case21: forall s s1 n1 n2, eval_static_operation_cases (Osubshift s) (G s1 n1 :: I n2 :: nil) + | eval_static_operation_case22: forall s n1 n2, eval_static_operation_cases (Orsubshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case23: forall n n1, eval_static_operation_cases (Orsubimm n) (I n1 :: nil) + | eval_static_operation_case24: forall n1 n2, eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil) + | eval_static_operation_case25: forall n1 n2, eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil) + | eval_static_operation_case26: forall n1 n2, eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil) + | eval_static_operation_case27: forall n1 n2, eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil) + | eval_static_operation_case28: forall s n1 n2, eval_static_operation_cases (Oandshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case29: forall n n1, eval_static_operation_cases (Oandimm n) (I n1 :: nil) + | eval_static_operation_case30: forall n1 n2, eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil) + | eval_static_operation_case31: forall s n1 n2, eval_static_operation_cases (Oorshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case32: forall n n1, eval_static_operation_cases (Oorimm n) (I n1 :: nil) + | eval_static_operation_case33: forall n1 n2, eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil) + | eval_static_operation_case34: forall s n1 n2, eval_static_operation_cases (Oxorshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case35: forall n n1, eval_static_operation_cases (Oxorimm n) (I n1 :: nil) + | eval_static_operation_case36: forall n1 n2, eval_static_operation_cases (Obic) (I n1 :: I n2 :: nil) + | eval_static_operation_case37: forall s n1 n2, eval_static_operation_cases (Obicshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case38: forall n1, eval_static_operation_cases (Onot) (I n1 :: nil) + | eval_static_operation_case39: forall s n1, eval_static_operation_cases (Onotshift s) (I n1 :: nil) + | eval_static_operation_case40: forall n1 n2, eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil) + | eval_static_operation_case41: forall n1 n2, eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil) + | eval_static_operation_case42: forall n1 n2, eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil) + | eval_static_operation_case43: forall s n1, eval_static_operation_cases (Oshift s) (I n1 :: nil) + | eval_static_operation_case44: forall n1, eval_static_operation_cases (Onegf) (F n1 :: nil) + | eval_static_operation_case45: forall n1, eval_static_operation_cases (Oabsf) (F n1 :: nil) + | eval_static_operation_case46: forall n1 n2, eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil) + | eval_static_operation_case47: forall n1 n2, eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil) + | eval_static_operation_case48: forall n1 n2, eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil) + | eval_static_operation_case49: forall n1 n2, eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil) + | eval_static_operation_case50: forall n1, eval_static_operation_cases (Osingleoffloat) (F n1 :: nil) + | eval_static_operation_case51: forall n1, eval_static_operation_cases (Ointoffloat) (F n1 :: nil) + | eval_static_operation_case52: forall n1, eval_static_operation_cases (Ointuoffloat) (F n1 :: nil) + | eval_static_operation_case53: forall n1, eval_static_operation_cases (Ofloatofint) (I n1 :: nil) + | eval_static_operation_case54: forall n1, eval_static_operation_cases (Ofloatofintu) (I n1 :: nil) + | eval_static_operation_case55: forall c vl, eval_static_operation_cases (Ocmp c) (vl) + | eval_static_operation_default: forall (op: operation) (vl: list approx), eval_static_operation_cases op vl. Definition eval_static_operation_match (op: operation) (vl: list approx) := - match op as z1, vl as z2 return eval_static_operation_cases z1 z2 with - | Omove, v1::nil => - eval_static_operation_case1 v1 - | Ointconst n, nil => - eval_static_operation_case2 n - | Ofloatconst n, nil => - eval_static_operation_case3 n - | Oaddrsymbol s n, nil => - eval_static_operation_case4 s n - | Ocast8signed, I n1 :: nil => - eval_static_operation_case5 n1 - | Ocast8unsigned, I n1 :: nil => - eval_static_operation_case6 n1 - | Ocast16signed, I n1 :: nil => - eval_static_operation_case7 n1 - | Ocast16unsigned, I n1 :: nil => - eval_static_operation_case8 n1 - | Oadd, I n1 :: I n2 :: nil => - eval_static_operation_case9 n1 n2 - | Oaddshift s, I n1 :: I n2 :: nil => - eval_static_operation_case10 s n1 n2 - | Oadd, S s1 n1 :: I n2 :: nil => - eval_static_operation_case11 s1 n1 n2 - | Oaddshift s, S s1 n1 :: I n2 :: nil => - eval_static_operation_case12 s s1 n1 n2 - | Oaddimm n, I n1 :: nil => - eval_static_operation_case13 n n1 - | Oaddimm n, S s1 n1 :: nil => - eval_static_operation_case14 n s1 n1 - | Osub, I n1 :: I n2 :: nil => - eval_static_operation_case15 n1 n2 - | Osubshift s, I n1 :: I n2 :: nil => - eval_static_operation_case16 s n1 n2 - | Osub, S s1 n1 :: I n2 :: nil => - eval_static_operation_case17 s1 n1 n2 - | Osubshift s, S s1 n1 :: I n2 :: nil => - eval_static_operation_case18 s s1 n1 n2 - | Orsubshift s, I n1 :: I n2 :: nil => - eval_static_operation_case19 s n1 n2 - | Orsubimm n, I n1 :: nil => - eval_static_operation_case20 n n1 - | Omul, I n1 :: I n2 :: nil => - eval_static_operation_case21 n1 n2 - | Odiv, I n1 :: I n2 :: nil => - eval_static_operation_case22 n1 n2 - | Odivu, I n1 :: I n2 :: nil => - eval_static_operation_case23 n1 n2 - | Oand, I n1 :: I n2 :: nil => - eval_static_operation_case24 n1 n2 - | Oandshift s, I n1 :: I n2 :: nil => - eval_static_operation_case25 s n1 n2 - | Oandimm n, I n1 :: nil => - eval_static_operation_case26 n n1 - | Oor, I n1 :: I n2 :: nil => - eval_static_operation_case27 n1 n2 - | Oorshift s, I n1 :: I n2 :: nil => - eval_static_operation_case28 s n1 n2 - | Oorimm n, I n1 :: nil => - eval_static_operation_case29 n n1 - | Oxor, I n1 :: I n2 :: nil => - eval_static_operation_case30 n1 n2 - | Oxorshift s, I n1 :: I n2 :: nil => - eval_static_operation_case31 s n1 n2 - | Oxorimm n, I n1 :: nil => - eval_static_operation_case32 n n1 - | Obic, I n1 :: I n2 :: nil => - eval_static_operation_case33 n1 n2 - | Obicshift s, I n1 :: I n2 :: nil => - eval_static_operation_case34 s n1 n2 - | Onot, I n1 :: nil => - eval_static_operation_case35 n1 - | Onotshift s, I n1 :: nil => - eval_static_operation_case36 s n1 - | Oshl, I n1 :: I n2 :: nil => - eval_static_operation_case37 n1 n2 - | Oshr, I n1 :: I n2 :: nil => - eval_static_operation_case38 n1 n2 - | Oshru, I n1 :: I n2 :: nil => - eval_static_operation_case39 n1 n2 - | Oshift s, I n1 :: nil => - eval_static_operation_case40 s n1 - | Onegf, F n1 :: nil => - eval_static_operation_case41 n1 - | Oabsf, F n1 :: nil => - eval_static_operation_case42 n1 - | Oaddf, F n1 :: F n2 :: nil => - eval_static_operation_case43 n1 n2 - | Osubf, F n1 :: F n2 :: nil => - eval_static_operation_case44 n1 n2 - | Omulf, F n1 :: F n2 :: nil => - eval_static_operation_case45 n1 n2 - | Odivf, F n1 :: F n2 :: nil => - eval_static_operation_case46 n1 n2 - | Osingleoffloat, F n1 :: nil => - eval_static_operation_case47 n1 - | Ointoffloat, F n1 :: nil => - eval_static_operation_case48 n1 - | Ofloatofint, I n1 :: nil => - eval_static_operation_case49 n1 - | Ointuoffloat, F n1 :: nil => - eval_static_operation_case50 n1 - | Ofloatofintu, I n1 :: nil => - eval_static_operation_case53 n1 - | Ocmp c, vl => - eval_static_operation_case51 c vl - | Oshrximm n, I n1 :: nil => - eval_static_operation_case52 n n1 - | op, vl => - eval_static_operation_default op vl + match op as zz1, vl as zz2 return eval_static_operation_cases zz1 zz2 with + | Omove, v1::nil => eval_static_operation_case1 v1 + | Ointconst n, nil => eval_static_operation_case2 n + | Ofloatconst n, nil => eval_static_operation_case3 n + | Oaddrsymbol s n, nil => eval_static_operation_case4 s n + | Oaddrstack n, nil => eval_static_operation_case5 n + | Oadd, I n1 :: I n2 :: nil => eval_static_operation_case6 n1 n2 + | Oaddshift s, I n1 :: I n2 :: nil => eval_static_operation_case7 s n1 n2 + | Oadd, G s1 n1 :: I n2 :: nil => eval_static_operation_case8 s1 n1 n2 + | Oaddshift s, G s1 n1 :: I n2 :: nil => eval_static_operation_case9 s s1 n1 n2 + | Oadd, S n1 :: I n2 :: nil => eval_static_operation_case10 n1 n2 + | Oaddshift s, S n1 :: I n2 :: nil => eval_static_operation_case11 s n1 n2 + | Oadd, I n1 :: G s2 n2 :: nil => eval_static_operation_case12 n1 s2 n2 + | Oadd, I n1 :: S n2 :: nil => eval_static_operation_case13 n1 n2 + | Oaddimm n, I n1 :: nil => eval_static_operation_case14 n n1 + | Oaddimm n, G s1 n1 :: nil => eval_static_operation_case15 n s1 n1 + | Oaddimm n, S n1 :: nil => eval_static_operation_case16 n n1 + | Osub, I n1 :: I n2 :: nil => eval_static_operation_case17 n1 n2 + | Osubshift s, I n1 :: I n2 :: nil => eval_static_operation_case18 s n1 n2 + | Osub, G s1 n1 :: I n2 :: nil => eval_static_operation_case19 s1 n1 n2 + | Osub, S n1 :: I n2 :: nil => eval_static_operation_case20 n1 n2 + | Osubshift s, G s1 n1 :: I n2 :: nil => eval_static_operation_case21 s s1 n1 n2 + | Orsubshift s, I n1 :: I n2 :: nil => eval_static_operation_case22 s n1 n2 + | Orsubimm n, I n1 :: nil => eval_static_operation_case23 n n1 + | Omul, I n1 :: I n2 :: nil => eval_static_operation_case24 n1 n2 + | Odiv, I n1 :: I n2 :: nil => eval_static_operation_case25 n1 n2 + | Odivu, I n1 :: I n2 :: nil => eval_static_operation_case26 n1 n2 + | Oand, I n1 :: I n2 :: nil => eval_static_operation_case27 n1 n2 + | Oandshift s, I n1 :: I n2 :: nil => eval_static_operation_case28 s n1 n2 + | Oandimm n, I n1 :: nil => eval_static_operation_case29 n n1 + | Oor, I n1 :: I n2 :: nil => eval_static_operation_case30 n1 n2 + | Oorshift s, I n1 :: I n2 :: nil => eval_static_operation_case31 s n1 n2 + | Oorimm n, I n1 :: nil => eval_static_operation_case32 n n1 + | Oxor, I n1 :: I n2 :: nil => eval_static_operation_case33 n1 n2 + | Oxorshift s, I n1 :: I n2 :: nil => eval_static_operation_case34 s n1 n2 + | Oxorimm n, I n1 :: nil => eval_static_operation_case35 n n1 + | Obic, I n1 :: I n2 :: nil => eval_static_operation_case36 n1 n2 + | Obicshift s, I n1 :: I n2 :: nil => eval_static_operation_case37 s n1 n2 + | Onot, I n1 :: nil => eval_static_operation_case38 n1 + | Onotshift s, I n1 :: nil => eval_static_operation_case39 s n1 + | Oshl, I n1 :: I n2 :: nil => eval_static_operation_case40 n1 n2 + | Oshr, I n1 :: I n2 :: nil => eval_static_operation_case41 n1 n2 + | Oshru, I n1 :: I n2 :: nil => eval_static_operation_case42 n1 n2 + | Oshift s, I n1 :: nil => eval_static_operation_case43 s n1 + | Onegf, F n1 :: nil => eval_static_operation_case44 n1 + | Oabsf, F n1 :: nil => eval_static_operation_case45 n1 + | Oaddf, F n1 :: F n2 :: nil => eval_static_operation_case46 n1 n2 + | Osubf, F n1 :: F n2 :: nil => eval_static_operation_case47 n1 n2 + | Omulf, F n1 :: F n2 :: nil => eval_static_operation_case48 n1 n2 + | Odivf, F n1 :: F n2 :: nil => eval_static_operation_case49 n1 n2 + | Osingleoffloat, F n1 :: nil => eval_static_operation_case50 n1 + | Ointoffloat, F n1 :: nil => eval_static_operation_case51 n1 + | Ointuoffloat, F n1 :: nil => eval_static_operation_case52 n1 + | Ofloatofint, I n1 :: nil => eval_static_operation_case53 n1 + | Ofloatofintu, I n1 :: nil => eval_static_operation_case54 n1 + | Ocmp c, vl => eval_static_operation_case55 c vl + | op, vl => eval_static_operation_default op vl end. Definition eval_static_operation (op: operation) (vl: list approx) := match eval_static_operation_match op vl with - | eval_static_operation_case1 v1 => + | eval_static_operation_case1 v1 => (* Omove, v1::nil *) v1 - | eval_static_operation_case2 n => + | eval_static_operation_case2 n => (* Ointconst n, nil *) I n - | eval_static_operation_case3 n => + | eval_static_operation_case3 n => (* Ofloatconst n, nil *) F n - | eval_static_operation_case4 s n => - S s n - | eval_static_operation_case5 n => - I(Int.sign_ext 8 n) - | eval_static_operation_case6 n => - I(Int.zero_ext 8 n) - | eval_static_operation_case7 n => - I(Int.sign_ext 16 n) - | eval_static_operation_case8 n => - I(Int.zero_ext 16 n) - | eval_static_operation_case9 n1 n2 => + | eval_static_operation_case4 s n => (* Oaddrsymbol s n, nil *) + G s n + | eval_static_operation_case5 n => (* Oaddrstack n, nil *) + S n + | eval_static_operation_case6 n1 n2 => (* Oadd, I n1 :: I n2 :: nil *) I(Int.add n1 n2) - | eval_static_operation_case10 s n1 n2 => - I(Int.add n1 (eval_shift s n2)) - | eval_static_operation_case11 s1 n1 n2 => - S s1 (Int.add n1 n2) - | eval_static_operation_case12 s s1 n1 n2 => - S s1 (Int.add n1 (eval_shift s n2)) - | eval_static_operation_case13 n n1 => + | eval_static_operation_case7 s n1 n2 => (* Oaddshift s, I n1 :: I n2 :: nil *) + I(Int.add n1 (eval_static_shift s n2)) + | eval_static_operation_case8 s1 n1 n2 => (* Oadd, G s1 n1 :: I n2 :: nil *) + G s1 (Int.add n1 n2) + | eval_static_operation_case9 s s1 n1 n2 => (* Oaddshift s, G s1 n1 :: I n2 :: nil *) + G s1 (Int.add n1 (eval_static_shift s n2)) + | eval_static_operation_case10 n1 n2 => (* Oadd, S n1 :: I n2 :: nil *) + S (Int.add n1 n2) + | eval_static_operation_case11 s n1 n2 => (* Oaddshift s, S n1 :: I n2 :: nil *) + S (Int.add n1 (eval_static_shift s n2)) + | eval_static_operation_case12 n1 s2 n2 => (* Oadd, I n1 :: G s2 n2 :: nil *) + G s2 (Int.add n1 n2) + | eval_static_operation_case13 n1 n2 => (* Oadd, I n1 :: S n2 :: nil *) + S (Int.add n1 n2) + | eval_static_operation_case14 n n1 => (* Oaddimm n, I n1 :: nil *) I (Int.add n1 n) - | eval_static_operation_case14 n s1 n1 => - S s1 (Int.add n1 n) - | eval_static_operation_case15 n1 n2 => + | eval_static_operation_case15 n s1 n1 => (* Oaddimm n, G s1 n1 :: nil *) + G s1 (Int.add n1 n) + | eval_static_operation_case16 n n1 => (* Oaddimm n, S n1 :: nil *) + S (Int.add n1 n) + | eval_static_operation_case17 n1 n2 => (* Osub, I n1 :: I n2 :: nil *) I(Int.sub n1 n2) - | eval_static_operation_case16 s n1 n2 => - I(Int.sub n1 (eval_shift s n2)) - | eval_static_operation_case17 s1 n1 n2 => - S s1 (Int.sub n1 n2) - | eval_static_operation_case18 s s1 n1 n2 => - S s1 (Int.sub n1 (eval_shift s n2)) - | eval_static_operation_case19 s n1 n2 => - I(Int.sub (eval_shift s n2) n1) - | eval_static_operation_case20 n n1 => + | eval_static_operation_case18 s n1 n2 => (* Osubshift s, I n1 :: I n2 :: nil *) + I(Int.sub n1 (eval_static_shift s n2)) + | eval_static_operation_case19 s1 n1 n2 => (* Osub, G s1 n1 :: I n2 :: nil *) + G s1 (Int.sub n1 n2) + | eval_static_operation_case20 n1 n2 => (* Osub, S n1 :: I n2 :: nil *) + S (Int.sub n1 n2) + | eval_static_operation_case21 s s1 n1 n2 => (* Osubshift s, G s1 n1 :: I n2 :: nil *) + G s1 (Int.sub n1 (eval_static_shift s n2)) + | eval_static_operation_case22 s n1 n2 => (* Orsubshift s, I n1 :: I n2 :: nil *) + I(Int.sub (eval_static_shift s n2) n1) + | eval_static_operation_case23 n n1 => (* Orsubimm n, I n1 :: nil *) I (Int.sub n n1) - | eval_static_operation_case21 n1 n2 => + | eval_static_operation_case24 n1 n2 => (* Omul, I n1 :: I n2 :: nil *) I(Int.mul n1 n2) - | eval_static_operation_case22 n1 n2 => + | eval_static_operation_case25 n1 n2 => (* Odiv, I n1 :: I n2 :: nil *) if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) - | eval_static_operation_case23 n1 n2 => + | eval_static_operation_case26 n1 n2 => (* Odivu, I n1 :: I n2 :: nil *) if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) - | eval_static_operation_case24 n1 n2 => + | eval_static_operation_case27 n1 n2 => (* Oand, I n1 :: I n2 :: nil *) I(Int.and n1 n2) - | eval_static_operation_case25 s n1 n2 => - I(Int.and n1 (eval_shift s n2)) - | eval_static_operation_case26 n n1 => + | eval_static_operation_case28 s n1 n2 => (* Oandshift s, I n1 :: I n2 :: nil *) + I(Int.and n1 (eval_static_shift s n2)) + | eval_static_operation_case29 n n1 => (* Oandimm n, I n1 :: nil *) I(Int.and n1 n) - | eval_static_operation_case27 n1 n2 => + | eval_static_operation_case30 n1 n2 => (* Oor, I n1 :: I n2 :: nil *) I(Int.or n1 n2) - | eval_static_operation_case28 s n1 n2 => - I(Int.or n1 (eval_shift s n2)) - | eval_static_operation_case29 n n1 => + | eval_static_operation_case31 s n1 n2 => (* Oorshift s, I n1 :: I n2 :: nil *) + I(Int.or n1 (eval_static_shift s n2)) + | eval_static_operation_case32 n n1 => (* Oorimm n, I n1 :: nil *) I(Int.or n1 n) - | eval_static_operation_case30 n1 n2 => + | eval_static_operation_case33 n1 n2 => (* Oxor, I n1 :: I n2 :: nil *) I(Int.xor n1 n2) - | eval_static_operation_case31 s n1 n2 => - I(Int.xor n1 (eval_shift s n2)) - | eval_static_operation_case32 n n1 => + | eval_static_operation_case34 s n1 n2 => (* Oxorshift s, I n1 :: I n2 :: nil *) + I(Int.xor n1 (eval_static_shift s n2)) + | eval_static_operation_case35 n n1 => (* Oxorimm n, I n1 :: nil *) I(Int.xor n1 n) - | eval_static_operation_case33 n1 n2 => + | eval_static_operation_case36 n1 n2 => (* Obic, I n1 :: I n2 :: nil *) I(Int.and n1 (Int.not n2)) - | eval_static_operation_case34 s n1 n2 => - I(Int.and n1 (Int.not (eval_shift s n2))) - | eval_static_operation_case35 n1 => + | eval_static_operation_case37 s n1 n2 => (* Obicshift s, I n1 :: I n2 :: nil *) + I(Int.and n1 (Int.not (eval_static_shift s n2))) + | eval_static_operation_case38 n1 => (* Onot, I n1 :: nil *) I(Int.not n1) - | eval_static_operation_case36 s n1 => - I(Int.not (eval_shift s n1)) - | eval_static_operation_case37 n1 n2 => + | eval_static_operation_case39 s n1 => (* Onotshift s, I n1 :: nil *) + I(Int.not (eval_static_shift s n1)) + | eval_static_operation_case40 n1 n2 => (* Oshl, I n1 :: I n2 :: nil *) if Int.ltu n2 Int.iwordsize then I(Int.shl n1 n2) else Unknown - | eval_static_operation_case38 n1 n2 => + | eval_static_operation_case41 n1 n2 => (* Oshr, I n1 :: I n2 :: nil *) if Int.ltu n2 Int.iwordsize then I(Int.shr n1 n2) else Unknown - | eval_static_operation_case39 n1 n2 => + | eval_static_operation_case42 n1 n2 => (* Oshru, I n1 :: I n2 :: nil *) if Int.ltu n2 Int.iwordsize then I(Int.shru n1 n2) else Unknown - | eval_static_operation_case40 s n1 => - I(eval_shift s n1) - | eval_static_operation_case41 n1 => + | eval_static_operation_case43 s n1 => (* Oshift s, I n1 :: nil *) + I(eval_static_shift s n1) + | eval_static_operation_case44 n1 => (* Onegf, F n1 :: nil *) F(Float.neg n1) - | eval_static_operation_case42 n1 => + | eval_static_operation_case45 n1 => (* Oabsf, F n1 :: nil *) F(Float.abs n1) - | eval_static_operation_case43 n1 n2 => + | eval_static_operation_case46 n1 n2 => (* Oaddf, F n1 :: F n2 :: nil *) F(Float.add n1 n2) - | eval_static_operation_case44 n1 n2 => + | eval_static_operation_case47 n1 n2 => (* Osubf, F n1 :: F n2 :: nil *) F(Float.sub n1 n2) - | eval_static_operation_case45 n1 n2 => + | eval_static_operation_case48 n1 n2 => (* Omulf, F n1 :: F n2 :: nil *) F(Float.mul n1 n2) - | eval_static_operation_case46 n1 n2 => + | eval_static_operation_case49 n1 n2 => (* Odivf, F n1 :: F n2 :: nil *) F(Float.div n1 n2) - | eval_static_operation_case47 n1 => + | eval_static_operation_case50 n1 => (* Osingleoffloat, F n1 :: nil *) F(Float.singleoffloat n1) - | eval_static_operation_case48 n1 => - match Float.intoffloat n1 with Some x => I x | None => Unknown end - | eval_static_operation_case49 n1 => + | eval_static_operation_case51 n1 => (* Ointoffloat, F n1 :: nil *) + eval_static_intoffloat n1 + | eval_static_operation_case52 n1 => (* Ointuoffloat, F n1 :: nil *) + eval_static_intuoffloat n1 + | eval_static_operation_case53 n1 => (* Ofloatofint, I n1 :: nil *) F(Float.floatofint n1) - | eval_static_operation_case50 n1 => - match Float.intuoffloat n1 with Some x => I x | None => Unknown end - | eval_static_operation_case53 n1 => + | eval_static_operation_case54 n1 => (* Ofloatofintu, I n1 :: nil *) F(Float.floatofintu n1) - | eval_static_operation_case51 c vl => - match eval_static_condition c vl with - | None => Unknown - | Some b => I(if b then Int.one else Int.zero) - end - | eval_static_operation_case52 n n1 => - if Int.ltu n (Int.repr 31) then I(Int.shrx n1 n) else Unknown + | eval_static_operation_case55 c vl => (* Ocmp c, vl *) + eval_static_condition_val c vl | eval_static_operation_default op vl => Unknown end. + (** * Operator strength reduction *) (** We now define auxiliary functions for strength reduction of @@ -597,134 +441,124 @@ Definition eval_static_operation (op: operation) (vl: list approx) := Section STRENGTH_REDUCTION. -Variable app: reg -> approx. - -Definition intval (r: reg) : option int := - match app r with I n => Some n | _ => None end. - -(* -Definition cond_strength_reduction (cond: condition) (args: list reg) := - match cond, args with - | Ccomp c, r1 :: r2 :: nil => - | Ccompu c, r1 :: r2 :: nil => - | Ccompshift c s, r1 :: r2 :: nil => - | Ccompushift c s, r1 :: r2 :: nil => - | _ => +(** Original definition: +<< +Nondetfunction cond_strength_reduction + (cond: condition) (args: list reg) (vl: list approx) := + match cond, args, vl with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompimm c n2, r1 :: nil) + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompuimm c n2, r1 :: nil) + | Ccompshift c s, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompimm c (eval_static_shift s n2), r1 :: nil) + | Ccompushift c s, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompuimm c (eval_static_shift s n2), r1 :: nil) + | _, _, _ => + (cond, args) end. +>> *) -Inductive cond_strength_reduction_cases: forall (cond: condition) (args: list reg), Type := - | cond_strength_reduction_case1: - forall c r1 r2, - cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) - | cond_strength_reduction_case2: - forall c r1 r2, - cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) - | cond_strength_reduction_case3: - forall c s r1 r2, - cond_strength_reduction_cases (Ccompshift c s) (r1 :: r2 :: nil) - | cond_strength_reduction_case4: - forall c s r1 r2, - cond_strength_reduction_cases (Ccompushift c s) (r1 :: r2 :: nil) - | cond_strength_reduction_default: - forall (cond: condition) (args: list reg), - cond_strength_reduction_cases cond args. - -Definition cond_strength_reduction_match (cond: condition) (args: list reg) := - match cond as z1, args as z2 return cond_strength_reduction_cases z1 z2 with - | Ccomp c, r1 :: r2 :: nil => - cond_strength_reduction_case1 c r1 r2 - | Ccompu c, r1 :: r2 :: nil => - cond_strength_reduction_case2 c r1 r2 - | Ccompshift c s, r1 :: r2 :: nil => - cond_strength_reduction_case3 c s r1 r2 - | Ccompushift c s, r1 :: r2 :: nil => - cond_strength_reduction_case4 c s r1 r2 - | cond, args => - cond_strength_reduction_default cond args +Inductive cond_strength_reduction_cases: forall (cond: condition) (args: list reg) (vl: list approx), Type := + | cond_strength_reduction_case1: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | cond_strength_reduction_case2: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_case3: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | cond_strength_reduction_case4: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_case5: forall c s r1 r2 v1 n2, cond_strength_reduction_cases (Ccompshift c s) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_case6: forall c s r1 r2 v1 n2, cond_strength_reduction_cases (Ccompushift c s) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_default: forall (cond: condition) (args: list reg) (vl: list approx), cond_strength_reduction_cases cond args vl. + +Definition cond_strength_reduction_match (cond: condition) (args: list reg) (vl: list approx) := + match cond as zz1, args as zz2, vl as zz3 return cond_strength_reduction_cases zz1 zz2 zz3 with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case1 c r1 r2 n1 v2 + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case2 c r1 r2 v1 n2 + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case3 c r1 r2 n1 v2 + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case4 c r1 r2 v1 n2 + | Ccompshift c s, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case5 c s r1 r2 v1 n2 + | Ccompushift c s, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case6 c s r1 r2 v1 n2 + | cond, args, vl => cond_strength_reduction_default cond args vl end. -Definition cond_strength_reduction (cond: condition) (args: list reg) := - match cond_strength_reduction_match cond args with - | cond_strength_reduction_case1 c r1 r2 => - match intval r1, intval r2 with - | Some n, _ => - (Ccompimm (swap_comparison c) n, r2 :: nil) - | _, Some n => - (Ccompimm c n, r1 :: nil) - | _, _ => - (cond, args) - end - | cond_strength_reduction_case2 c r1 r2 => - match intval r1, intval r2 with - | Some n, _ => - (Ccompuimm (swap_comparison c) n, r2 :: nil) - | _, Some n => - (Ccompuimm c n, r1 :: nil) - | _, _ => - (cond, args) - end - | cond_strength_reduction_case3 c s r1 r2 => - match intval r2 with - | Some n => - (Ccompimm c (eval_shift s n), r1 :: nil) - | None => - (cond, args) - end - | cond_strength_reduction_case4 c s r1 r2 => - match intval r2 with - | Some n => - (Ccompuimm c (eval_shift s n), r1 :: nil) - | None => - (cond, args) - end - | cond_strength_reduction_default cond args => +Definition cond_strength_reduction (cond: condition) (args: list reg) (vl: list approx) := + match cond_strength_reduction_match cond args vl with + | cond_strength_reduction_case1 c r1 r2 n1 v2 => (* Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case2 c r1 r2 v1 n2 => (* Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompimm c n2, r1 :: nil) + | cond_strength_reduction_case3 c r1 r2 n1 v2 => (* Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case4 c r1 r2 v1 n2 => (* Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompuimm c n2, r1 :: nil) + | cond_strength_reduction_case5 c s r1 r2 v1 n2 => (* Ccompshift c s, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompimm c (eval_static_shift s n2), r1 :: nil) + | cond_strength_reduction_case6 c s r1 r2 v1 n2 => (* Ccompushift c s, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompuimm c (eval_static_shift s n2), r1 :: nil) + | cond_strength_reduction_default cond args vl => (cond, args) end. + Definition make_addimm (n: int) (r: reg) := if Int.eq n Int.zero then (Omove, r :: nil) else (Oaddimm n, r :: nil). -Definition make_shlimm (n: int) (r: reg) := +Definition make_shlimm (n: int) (r1 r2: reg) := if Int.eq n Int.zero then - (Omove, r :: nil) - else match is_shift_amount n with - | Some n' => (Oshift (Slsl n'), r :: nil) - | None => (Ointconst Int.zero, nil) (* never happens *) - end. + (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then + (Oshift (Slsl (mk_shift_amount n)), r1 :: nil) + else + (Oshl, r1 :: r2 :: nil). -Definition make_shrimm (n: int) (r: reg) := +Definition make_shrimm (n: int) (r1 r2: reg) := if Int.eq n Int.zero then - (Omove, r :: nil) - else match is_shift_amount n with - | Some n' => (Oshift (Sasr n'), r :: nil) - | None => (Ointconst Int.zero, nil) (* never happens *) - end. + (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then + (Oshift (Sasr (mk_shift_amount n)), r1 :: nil) + else + (Oshr, r1 :: r2 :: nil). -Definition make_shruimm (n: int) (r: reg) := +Definition make_shruimm (n: int) (r1 r2: reg) := if Int.eq n Int.zero then - (Omove, r :: nil) - else match is_shift_amount n with - | Some n' => (Oshift (Slsr n'), r :: nil) - | None => (Ointconst Int.zero, nil) (* never happens *) - end. + (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then + (Oshift (Slsr (mk_shift_amount n)), r1 :: nil) + else + (Oshru, r1 :: r2 :: nil). -Definition make_mulimm (n: int) (r: reg) (r': reg) := +Definition make_mulimm (n: int) (r1 r2: reg) := if Int.eq n Int.zero then (Ointconst Int.zero, nil) else if Int.eq n Int.one then - (Omove, r :: nil) + (Omove, r1 :: nil) else match Int.is_power2 n with - | Some l => make_shlimm l r - | None => (Omul, r :: r' :: nil) + | Some l => (Oshift (Slsl (mk_shift_amount l)), r1 :: nil) + | None => (Omul, r1 :: r2 :: nil) end. +Definition make_divimm (n: int) (r1 r2: reg) := + match Int.is_power2 n with + | Some l => if Int.ltu l (Int.repr 31) + then (Oshrximm l, r1 :: nil) + else (Odiv, r1 :: r2 :: nil) + | None => (Odiv, r1 :: r2 :: nil) + end. + +Definition make_divuimm (n: int) (r1 r2: reg) := + match Int.is_power2 n with + | Some l => (Oshift (Slsr (mk_shift_amount l)), r1 :: nil) + | None => (Odivu, r1 :: r2 :: nil) + end. + Definition make_andimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Ointconst Int.zero, nil) + if Int.eq n Int.zero then (Ointconst Int.zero, nil) else if Int.eq n Int.mone then (Omove, r :: nil) else (Oandimm n, r :: nil). @@ -738,302 +572,229 @@ Definition make_xorimm (n: int) (r: reg) := else if Int.eq n Int.mone then (Onot, r :: nil) else (Oxorimm n, r :: nil). -(* -Definition op_strength_reduction (op: operation) (args: list reg) := - match op, args with - | Oadd, r1 :: r2 :: nil => - | Oaddshift s, r1 :: r2 :: nil => - | Osub, r1 :: r2 :: nil => - | Osubshift s, r1 :: r2 :: nil => - | Orsubshift s, r1 :: r2 :: nil => - | Omul, r1 :: r2 :: nil => - | Odivu, r1 :: r2 :: nil => - | Oand, r1 :: r2 :: nil => - | Oandshift s, r1 :: r2 :: nil => - | Oor, r1 :: r2 :: nil => - | Oorshift s, r1 :: r2 :: nil => - | Oxor, r1 :: r2 :: nil => - | Oxorshift s, r1 :: r2 :: nil => - | Obic, r1 :: r2 :: nil => - | Obicshift s, r1 :: r2 :: nil => - | Oshl, r1 :: r2 :: nil => - | Oshr, r1 :: r2 :: nil => - | Oshru, r1 :: r2 :: nil => - | Ocmp c, rl => - | _, _ => +(** Original definition: +<< +Nondetfunction op_strength_reduction + (op: operation) (args: list reg) (vl: list approx) := + match op, args, vl with + | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_addimm n1 r2 + | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm n2 r1 + | Oaddshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (eval_static_shift s n2) r1 + | Osub, r1 :: r2 :: nil, I n1 :: v2 :: nil => (Orsubimm n1, r2 :: nil) + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 + | Osubshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg (eval_static_shift s n2)) r1 + | Orsubshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => (Orsubimm (eval_static_shift s n2), r1 :: nil) + | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 r1 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 r2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 + | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 + | Oandshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm (eval_static_shift s n2) r1 + | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 + | Oorshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm (eval_static_shift s n2) r1 + | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 + | Oxorshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm (eval_static_shift s n2) r1 + | Obic, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm (Int.not n2) r1 + | Obicshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm (Int.not (eval_static_shift s n2)) r1 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 + | Ocmp c, args, vl => + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args') + | _, _, _ => (op, args) end. +>> *) -Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg), Type := - | op_strength_reduction_case1: - forall r1 r2, - op_strength_reduction_cases (Oadd) (r1 :: r2 :: nil) - | op_strength_reduction_case2: - forall s r1 r2, - op_strength_reduction_cases (Oaddshift s) (r1 :: r2 :: nil) - | op_strength_reduction_case3: - forall r1 r2, - op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) - | op_strength_reduction_case4: - forall s r1 r2, - op_strength_reduction_cases (Osubshift s) (r1 :: r2 :: nil) - | op_strength_reduction_case5: - forall s r1 r2, - op_strength_reduction_cases (Orsubshift s) (r1 :: r2 :: nil) - | op_strength_reduction_case6: - forall r1 r2, - op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) - | op_strength_reduction_case7: - forall r1 r2, - op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) - | op_strength_reduction_case8: - forall r1 r2, - op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) - | op_strength_reduction_case9: - forall s r1 r2, - op_strength_reduction_cases (Oandshift s) (r1 :: r2 :: nil) - | op_strength_reduction_case10: - forall r1 r2, - op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) - | op_strength_reduction_case11: - forall s r1 r2, - op_strength_reduction_cases (Oorshift s) (r1 :: r2 :: nil) - | op_strength_reduction_case12: - forall r1 r2, - op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) - | op_strength_reduction_case13: - forall s r1 r2, - op_strength_reduction_cases (Oxorshift s) (r1 :: r2 :: nil) - | op_strength_reduction_case14: - forall r1 r2, - op_strength_reduction_cases (Obic) (r1 :: r2 :: nil) - | op_strength_reduction_case15: - forall s r1 r2, - op_strength_reduction_cases (Obicshift s) (r1 :: r2 :: nil) - | op_strength_reduction_case16: - forall r1 r2, - op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) - | op_strength_reduction_case17: - forall r1 r2, - op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) - | op_strength_reduction_case18: - forall r1 r2, - op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) - | op_strength_reduction_case19: - forall c rl, - op_strength_reduction_cases (Ocmp c) rl - | op_strength_reduction_default: - forall (op: operation) (args: list reg), - op_strength_reduction_cases op args. - -Definition op_strength_reduction_match (op: operation) (args: list reg) := - match op as z1, args as z2 return op_strength_reduction_cases z1 z2 with - | Oadd, r1 :: r2 :: nil => - op_strength_reduction_case1 r1 r2 - | Oaddshift s, r1 :: r2 :: nil => - op_strength_reduction_case2 s r1 r2 - | Osub, r1 :: r2 :: nil => - op_strength_reduction_case3 r1 r2 - | Osubshift s, r1 :: r2 :: nil => - op_strength_reduction_case4 s r1 r2 - | Orsubshift s, r1 :: r2 :: nil => - op_strength_reduction_case5 s r1 r2 - | Omul, r1 :: r2 :: nil => - op_strength_reduction_case6 r1 r2 - | Odivu, r1 :: r2 :: nil => - op_strength_reduction_case7 r1 r2 - | Oand, r1 :: r2 :: nil => - op_strength_reduction_case8 r1 r2 - | Oandshift s, r1 :: r2 :: nil => - op_strength_reduction_case9 s r1 r2 - | Oor, r1 :: r2 :: nil => - op_strength_reduction_case10 r1 r2 - | Oorshift s, r1 :: r2 :: nil => - op_strength_reduction_case11 s r1 r2 - | Oxor, r1 :: r2 :: nil => - op_strength_reduction_case12 r1 r2 - | Oxorshift s, r1 :: r2 :: nil => - op_strength_reduction_case13 s r1 r2 - | Obic, r1 :: r2 :: nil => - op_strength_reduction_case14 r1 r2 - | Obicshift s, r1 :: r2 :: nil => - op_strength_reduction_case15 s r1 r2 - | Oshl, r1 :: r2 :: nil => - op_strength_reduction_case16 r1 r2 - | Oshr, r1 :: r2 :: nil => - op_strength_reduction_case17 r1 r2 - | Oshru, r1 :: r2 :: nil => - op_strength_reduction_case18 r1 r2 - | Ocmp c, rl => - op_strength_reduction_case19 c rl - | op, args => - op_strength_reduction_default op args +Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg) (vl: list approx), Type := + | op_strength_reduction_case1: forall r1 r2 n1 v2, op_strength_reduction_cases (Oadd) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case2: forall r1 r2 v1 n2, op_strength_reduction_cases (Oadd) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case3: forall s r1 r2 v1 n2, op_strength_reduction_cases (Oaddshift s) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case4: forall r1 r2 n1 v2, op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case5: forall r1 r2 v1 n2, op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case6: forall s r1 r2 v1 n2, op_strength_reduction_cases (Osubshift s) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case7: forall s r1 r2 v1 n2, op_strength_reduction_cases (Orsubshift s) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case8: forall r1 r2 n1 v2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case9: forall r1 r2 v1 n2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case10: forall r1 r2 v1 n2, op_strength_reduction_cases (Odiv) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case11: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case12: forall r1 r2 n1 v2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case13: forall r1 r2 v1 n2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case14: forall s r1 r2 v1 n2, op_strength_reduction_cases (Oandshift s) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case15: forall r1 r2 n1 v2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case16: forall r1 r2 v1 n2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case17: forall s r1 r2 v1 n2, op_strength_reduction_cases (Oorshift s) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case18: forall r1 r2 n1 v2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case19: forall r1 r2 v1 n2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case20: forall s r1 r2 v1 n2, op_strength_reduction_cases (Oxorshift s) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case21: forall r1 r2 v1 n2, op_strength_reduction_cases (Obic) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case22: forall s r1 r2 v1 n2, op_strength_reduction_cases (Obicshift s) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case23: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case24: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case25: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case26: forall c args vl, op_strength_reduction_cases (Ocmp c) (args) (vl) + | op_strength_reduction_default: forall (op: operation) (args: list reg) (vl: list approx), op_strength_reduction_cases op args vl. + +Definition op_strength_reduction_match (op: operation) (args: list reg) (vl: list approx) := + match op as zz1, args as zz2, vl as zz3 return op_strength_reduction_cases zz1 zz2 zz3 with + | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case1 r1 r2 n1 v2 + | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case2 r1 r2 v1 n2 + | Oaddshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case3 s r1 r2 v1 n2 + | Osub, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case4 r1 r2 n1 v2 + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case5 r1 r2 v1 n2 + | Osubshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case6 s r1 r2 v1 n2 + | Orsubshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case7 s r1 r2 v1 n2 + | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case8 r1 r2 n1 v2 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case9 r1 r2 v1 n2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case10 r1 r2 v1 n2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case11 r1 r2 v1 n2 + | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case12 r1 r2 n1 v2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case13 r1 r2 v1 n2 + | Oandshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case14 s r1 r2 v1 n2 + | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case15 r1 r2 n1 v2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case16 r1 r2 v1 n2 + | Oorshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case17 s r1 r2 v1 n2 + | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case18 r1 r2 n1 v2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case19 r1 r2 v1 n2 + | Oxorshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case20 s r1 r2 v1 n2 + | Obic, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case21 r1 r2 v1 n2 + | Obicshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case22 s r1 r2 v1 n2 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case23 r1 r2 v1 n2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case24 r1 r2 v1 n2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case25 r1 r2 v1 n2 + | Ocmp c, args, vl => op_strength_reduction_case26 c args vl + | op, args, vl => op_strength_reduction_default op args vl end. -Definition op_strength_reduction (op: operation) (args: list reg) := - match op_strength_reduction_match op args with - | op_strength_reduction_case1 r1 r2 => (* Oadd *) - match intval r1, intval r2 with - | Some n, _ => make_addimm n r2 - | _, Some n => make_addimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case2 s r1 r2 => (* Oaddshift *) - match intval r2 with - | Some n => make_addimm (eval_shift s n) r1 - | _ => (op, args) - end - | op_strength_reduction_case3 r1 r2 => (* Osub *) - match intval r1, intval r2 with - | Some n, _ => (Orsubimm n, r2 :: nil) - | _, Some n => make_addimm (Int.neg n) r1 - | _, _ => (op, args) - end - | op_strength_reduction_case4 s r1 r2 => (* Osubshift *) - match intval r2 with - | Some n => make_addimm (Int.neg (eval_shift s n)) r1 - | _ => (op, args) - end - | op_strength_reduction_case5 s r1 r2 => (* Orsubshift *) - match intval r2 with - | Some n => (Orsubimm (eval_shift s n), r1 :: nil) - | _ => (op, args) - end - | op_strength_reduction_case6 r1 r2 => (* Omul *) - match intval r1, intval r2 with - | Some n, _ => make_mulimm n r2 r1 - | _, Some n => make_mulimm n r1 r2 - | _, _ => (op, args) - end - | op_strength_reduction_case7 r1 r2 => (* Odivu *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => make_shruimm l r1 - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case8 r1 r2 => (* Oand *) - match intval r1, intval r2 with - | Some n, _ => make_andimm n r2 - | _, Some n => make_andimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case9 s r1 r2 => (* Oandshift *) - match intval r2 with - | Some n => make_andimm (eval_shift s n) r1 - | _ => (op, args) - end - | op_strength_reduction_case10 r1 r2 => (* Oor *) - match intval r1, intval r2 with - | Some n, _ => make_orimm n r2 - | _, Some n => make_orimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case11 s r1 r2 => (* Oorshift *) - match intval r2 with - | Some n => make_orimm (eval_shift s n) r1 - | _ => (op, args) - end - | op_strength_reduction_case12 r1 r2 => (* Oxor *) - match intval r1, intval r2 with - | Some n, _ => make_xorimm n r2 - | _, Some n => make_xorimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case13 s r1 r2 => (* Oxorshift *) - match intval r2 with - | Some n => make_xorimm (eval_shift s n) r1 - | _ => (op, args) - end - | op_strength_reduction_case14 r1 r2 => (* Obic *) - match intval r2 with - | Some n => make_andimm (Int.not n) r1 - | _ => (op, args) - end - | op_strength_reduction_case15 s r1 r2 => (* Obicshift *) - match intval r2 with - | Some n => make_andimm (Int.not (eval_shift s n)) r1 - | _ => (op, args) - end - | op_strength_reduction_case16 r1 r2 => (* Oshl *) - match intval r2 with - | Some n => - if Int.ltu n Int.iwordsize - then make_shlimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case17 r1 r2 => (* Oshr *) - match intval r2 with - | Some n => - if Int.ltu n Int.iwordsize - then make_shrimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case18 r1 r2 => (* Oshru *) - match intval r2 with - | Some n => - if Int.ltu n Int.iwordsize - then make_shruimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case19 c rl => (* Ocmp *) - let (c', args') := cond_strength_reduction c args in - (Ocmp c', args') - | op_strength_reduction_default op args => (* default *) +Definition op_strength_reduction (op: operation) (args: list reg) (vl: list approx) := + match op_strength_reduction_match op args vl with + | op_strength_reduction_case1 r1 r2 n1 v2 => (* Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_addimm n1 r2 + | op_strength_reduction_case2 r1 r2 v1 n2 => (* Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_addimm n2 r1 + | op_strength_reduction_case3 s r1 r2 v1 n2 => (* Oaddshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_addimm (eval_static_shift s n2) r1 + | op_strength_reduction_case4 r1 r2 n1 v2 => (* Osub, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Orsubimm n1, r2 :: nil) + | op_strength_reduction_case5 r1 r2 v1 n2 => (* Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_addimm (Int.neg n2) r1 + | op_strength_reduction_case6 s r1 r2 v1 n2 => (* Osubshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_addimm (Int.neg (eval_static_shift s n2)) r1 + | op_strength_reduction_case7 s r1 r2 v1 n2 => (* Orsubshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Orsubimm (eval_static_shift s n2), r1 :: nil) + | op_strength_reduction_case8 r1 r2 n1 v2 => (* Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_mulimm n1 r2 r1 + | op_strength_reduction_case9 r1 r2 v1 n2 => (* Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_mulimm n2 r1 r2 + | op_strength_reduction_case10 r1 r2 v1 n2 => (* Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_divimm n2 r1 r2 + | op_strength_reduction_case11 r1 r2 v1 n2 => (* Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_divuimm n2 r1 r2 + | op_strength_reduction_case12 r1 r2 n1 v2 => (* Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_andimm n1 r2 + | op_strength_reduction_case13 r1 r2 v1 n2 => (* Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_andimm n2 r1 + | op_strength_reduction_case14 s r1 r2 v1 n2 => (* Oandshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_andimm (eval_static_shift s n2) r1 + | op_strength_reduction_case15 r1 r2 n1 v2 => (* Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_orimm n1 r2 + | op_strength_reduction_case16 r1 r2 v1 n2 => (* Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_orimm n2 r1 + | op_strength_reduction_case17 s r1 r2 v1 n2 => (* Oorshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_orimm (eval_static_shift s n2) r1 + | op_strength_reduction_case18 r1 r2 n1 v2 => (* Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_xorimm n1 r2 + | op_strength_reduction_case19 r1 r2 v1 n2 => (* Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_xorimm n2 r1 + | op_strength_reduction_case20 s r1 r2 v1 n2 => (* Oxorshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_xorimm (eval_static_shift s n2) r1 + | op_strength_reduction_case21 r1 r2 v1 n2 => (* Obic, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_andimm (Int.not n2) r1 + | op_strength_reduction_case22 s r1 r2 v1 n2 => (* Obicshift s, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_andimm (Int.not (eval_static_shift s n2)) r1 + | op_strength_reduction_case23 r1 r2 v1 n2 => (* Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shlimm n2 r1 r2 + | op_strength_reduction_case24 r1 r2 v1 n2 => (* Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shrimm n2 r1 r2 + | op_strength_reduction_case25 r1 r2 v1 n2 => (* Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shruimm n2 r1 r2 + | op_strength_reduction_case26 c args vl => (* Ocmp c, args, vl *) + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args') + | op_strength_reduction_default op args vl => (op, args) end. -(* -Definition addr_strength_reduction (addr: addressing) (args: list reg) := - match addr, args with - | Aindexed2, r1 :: r2 :: nil => - | Aindexed2shift s, r1 :: r2 :: nil => - | _, _ => + + +(** Original definition: +<< +Nondetfunction addr_strength_reduction + (addr: addressing) (args: list reg) (vl: list approx) := + match addr, args, vl with + | Aindexed2, r1 :: r2 :: nil, S n1 :: I n2 :: nil => + (Ainstack (Int.add n1 n2), nil) + | Aindexed2, r1 :: r2 :: nil, I n1 :: S n2 :: nil => + (Ainstack (Int.add n1 n2), nil) + | Aindexed2, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Aindexed n1, r2 :: nil) + | Aindexed2, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Aindexed n2, r1 :: nil) + | Aindexed2shift s, r1 :: r2 :: nil, S n1 :: I n2 :: nil => + (Ainstack (Int.add n1 (eval_static_shift s n2)), nil) + | Aindexed2shift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Aindexed (eval_static_shift s n2), r1 :: nil) + | Aindexed n, r1 :: nil, S n1 :: nil => + (Ainstack (Int.add n1 n), nil) + | _, _, _ => + (addr, args) end. +>> *) -Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg), Type := - | addr_strength_reduction_case1: - forall r1 r2, - addr_strength_reduction_cases (Aindexed2) (r1 :: r2 :: nil) - | addr_strength_reduction_case2: - forall s r1 r2, - addr_strength_reduction_cases (Aindexed2shift s) (r1 :: r2 :: nil) - | addr_strength_reduction_default: - forall (addr: addressing) (args: list reg), - addr_strength_reduction_cases addr args. - -Definition addr_strength_reduction_match (addr: addressing) (args: list reg) := - match addr as z1, args as z2 return addr_strength_reduction_cases z1 z2 with - | Aindexed2, r1 :: r2 :: nil => - addr_strength_reduction_case1 r1 r2 - | Aindexed2shift s, r1 :: r2 :: nil => - addr_strength_reduction_case2 s r1 r2 - | addr, args => - addr_strength_reduction_default addr args +Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg) (vl: list approx), Type := + | addr_strength_reduction_case1: forall r1 r2 n1 n2, addr_strength_reduction_cases (Aindexed2) (r1 :: r2 :: nil) (S n1 :: I n2 :: nil) + | addr_strength_reduction_case2: forall r1 r2 n1 n2, addr_strength_reduction_cases (Aindexed2) (r1 :: r2 :: nil) (I n1 :: S n2 :: nil) + | addr_strength_reduction_case3: forall r1 r2 n1 v2, addr_strength_reduction_cases (Aindexed2) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | addr_strength_reduction_case4: forall r1 r2 v1 n2, addr_strength_reduction_cases (Aindexed2) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | addr_strength_reduction_case5: forall s r1 r2 n1 n2, addr_strength_reduction_cases (Aindexed2shift s) (r1 :: r2 :: nil) (S n1 :: I n2 :: nil) + | addr_strength_reduction_case6: forall s r1 r2 v1 n2, addr_strength_reduction_cases (Aindexed2shift s) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | addr_strength_reduction_case7: forall n r1 n1, addr_strength_reduction_cases (Aindexed n) (r1 :: nil) (S n1 :: nil) + | addr_strength_reduction_default: forall (addr: addressing) (args: list reg) (vl: list approx), addr_strength_reduction_cases addr args vl. + +Definition addr_strength_reduction_match (addr: addressing) (args: list reg) (vl: list approx) := + match addr as zz1, args as zz2, vl as zz3 return addr_strength_reduction_cases zz1 zz2 zz3 with + | Aindexed2, r1 :: r2 :: nil, S n1 :: I n2 :: nil => addr_strength_reduction_case1 r1 r2 n1 n2 + | Aindexed2, r1 :: r2 :: nil, I n1 :: S n2 :: nil => addr_strength_reduction_case2 r1 r2 n1 n2 + | Aindexed2, r1 :: r2 :: nil, I n1 :: v2 :: nil => addr_strength_reduction_case3 r1 r2 n1 v2 + | Aindexed2, r1 :: r2 :: nil, v1 :: I n2 :: nil => addr_strength_reduction_case4 r1 r2 v1 n2 + | Aindexed2shift s, r1 :: r2 :: nil, S n1 :: I n2 :: nil => addr_strength_reduction_case5 s r1 r2 n1 n2 + | Aindexed2shift s, r1 :: r2 :: nil, v1 :: I n2 :: nil => addr_strength_reduction_case6 s r1 r2 v1 n2 + | Aindexed n, r1 :: nil, S n1 :: nil => addr_strength_reduction_case7 n r1 n1 + | addr, args, vl => addr_strength_reduction_default addr args vl end. -Definition addr_strength_reduction (addr: addressing) (args: list reg) := - match addr_strength_reduction_match addr args with - | addr_strength_reduction_case1 r1 r2 => (* Aindexed2 *) - match intval r1, intval r2 with - | Some n1, _ => (Aindexed n1, r2 :: nil) - | _, Some n2 => (Aindexed n2, r1 :: nil) - | _, _ => (addr, args) - end - | addr_strength_reduction_case2 s r1 r2 => (* Aindexed2shift *) - match intval r2 with - | Some n2 => (Aindexed (eval_shift s n2), r1 :: nil) - | _ => (addr, args) - end - | addr_strength_reduction_default addr args => - (addr, args) +Definition addr_strength_reduction (addr: addressing) (args: list reg) (vl: list approx) := + match addr_strength_reduction_match addr args vl with + | addr_strength_reduction_case1 r1 r2 n1 n2 => (* Aindexed2, r1 :: r2 :: nil, S n1 :: I n2 :: nil *) + (Ainstack (Int.add n1 n2), nil) + | addr_strength_reduction_case2 r1 r2 n1 n2 => (* Aindexed2, r1 :: r2 :: nil, I n1 :: S n2 :: nil *) + (Ainstack (Int.add n1 n2), nil) + | addr_strength_reduction_case3 r1 r2 n1 v2 => (* Aindexed2, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Aindexed n1, r2 :: nil) + | addr_strength_reduction_case4 r1 r2 v1 n2 => (* Aindexed2, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Aindexed n2, r1 :: nil) + | addr_strength_reduction_case5 s r1 r2 n1 n2 => (* Aindexed2shift s, r1 :: r2 :: nil, S n1 :: I n2 :: nil *) + (Ainstack (Int.add n1 (eval_static_shift s n2)), nil) + | addr_strength_reduction_case6 s r1 r2 v1 n2 => (* Aindexed2shift s, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Aindexed (eval_static_shift s n2), r1 :: nil) + | addr_strength_reduction_case7 n r1 n1 => (* Aindexed n, r1 :: nil, S n1 :: nil *) + (Ainstack (Int.add n1 n), nil) + | addr_strength_reduction_default addr args vl => + (addr, args) end. + End STRENGTH_REDUCTION. diff --git a/arm/ConstpropOpproof.v b/arm/ConstpropOpproof.v index 4d43082..0e60796 100644 --- a/arm/ConstpropOpproof.v +++ b/arm/ConstpropOpproof.v @@ -30,6 +30,7 @@ Require Import Constprop. Section ANALYSIS. Variable ge: genv. +Variable sp: val. (** We first show that the dataflow analysis is correct with respect to the dynamic semantics: the approximations (sets of values) @@ -43,7 +44,8 @@ Definition val_match_approx (a: approx) (v: val) : Prop := | Unknown => True | I p => v = Vint p | F p => v = Vfloat p - | S symb ofs => exists b, Genv.find_symbol ge symb = Some b /\ v = Vptr b ofs + | G symb ofs => v = symbol_address ge symb ofs + | S ofs => v = Val.add sp (Vint ofs) | _ => False end. @@ -62,12 +64,10 @@ Ltac SimplVMA := simpl in H; (try subst v); SimplVMA | H: (val_match_approx (F _) ?v) |- _ => simpl in H; (try subst v); SimplVMA - | H: (val_match_approx (S _ _) ?v) |- _ => - simpl in H; - (try (elim H; - let b := fresh "b" in let A := fresh in let B := fresh in - (intros b [A B]; subst v; clear H))); - SimplVMA + | H: (val_match_approx (G _ _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA + | H: (val_match_approx (S _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA | _ => idtac end. @@ -75,9 +75,9 @@ Ltac SimplVMA := Ltac InvVLMA := match goal with | H: (val_list_match_approx nil ?vl) |- _ => - inversion H + inv H | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ => - inversion H; SimplVMA; InvVLMA + inv H; SimplVMA; InvVLMA | _ => idtac end. @@ -87,6 +87,12 @@ Ltac InvVLMA := the given approximations, the concrete results match the approximations returned by [eval_static_operation]. *) +Lemma eval_static_shift_correct: + forall s n, eval_shift s (Vint n) = Vint (eval_static_shift s n). +Proof. + intros. destruct s; simpl; rewrite s_range; auto. +Qed. + Lemma eval_static_condition_correct: forall cond al vl m b, val_list_match_approx al vl -> @@ -96,11 +102,19 @@ Proof. intros until b. unfold eval_static_condition. case (eval_static_condition_match cond al); intros; - InvVLMA; simpl; congruence. + InvVLMA; simpl; try (rewrite eval_static_shift_correct); congruence. Qed. +Remark shift_symbol_address: + forall symb ofs n, + symbol_address ge symb (Int.add ofs n) = Val.add (symbol_address ge symb ofs) (Vint n). +Proof. + unfold symbol_address; intros. destruct (Genv.find_symbol ge symb); auto. +Qed. + + Lemma eval_static_operation_correct: - forall op sp al vl m v, + forall op al vl m v, val_list_match_approx al vl -> eval_operation ge sp op vl m = Some v -> val_match_approx (eval_static_operation op al) v. @@ -108,53 +122,34 @@ Proof. intros until v. unfold eval_static_operation. case (eval_static_operation_match op al); intros; - InvVLMA; simpl in *; FuncInv; try congruence. - - destruct (Genv.find_symbol ge s). exists b. intuition congruence. - congruence. - - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - - exists b. split. auto. congruence. - exists b. split. auto. congruence. - exists b. split. auto. congruence. - exists b. split. auto. congruence. - exists b. split. auto. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence. - - inv H4. destruct (Float.intoffloat f); simpl in H0; inv H0. red; auto. - - inv H4. destruct (Float.intuoffloat f); simpl in H0; inv H0. red; auto. - - caseEq (eval_static_condition c vl0). - intros. generalize (eval_static_condition_correct _ _ _ m _ H H1). - intro. rewrite H2 in H0. - destruct b; injection H0; intro; subst v; simpl; auto. - intros; simpl; auto. - - replace n1 with i. destruct (Int.ltu n (Int.repr 31)). - injection H0; intro; subst v. simpl. auto. congruence. congruence. - - auto. + InvVLMA; simpl in *; FuncInv; try (subst v); try (rewrite eval_static_shift_correct); auto. + + rewrite shift_symbol_address; auto. + rewrite shift_symbol_address; auto. + rewrite Val.add_assoc; auto. + rewrite Val.add_assoc; auto. + fold (Val.add (Vint n1) (symbol_address ge s2 n2)). + rewrite Int.add_commut. rewrite Val.add_commut. rewrite shift_symbol_address; auto. + fold (Val.add (Vint n1) (Val.add sp (Vint n2))). + rewrite Val.add_permut. auto. + rewrite shift_symbol_address. auto. + rewrite Val.add_assoc. auto. + rewrite Int.sub_add_opp. rewrite shift_symbol_address. rewrite Val.sub_add_opp. auto. + rewrite Val.sub_add_opp. rewrite Val.add_assoc. rewrite Int.sub_add_opp. auto. + rewrite Int.sub_add_opp. rewrite shift_symbol_address. rewrite Val.sub_add_opp. auto. + destruct (Int.eq n2 Int.zero); inv H0. simpl; auto. + destruct (Int.eq n2 Int.zero); inv H0. simpl; auto. + destruct (Int.ltu n2 Int.iwordsize); simpl; auto. + destruct (Int.ltu n2 Int.iwordsize); simpl; auto. + destruct (Int.ltu n2 Int.iwordsize); simpl; auto. + unfold eval_static_intoffloat. destruct (Float.intoffloat n1); simpl in H0; inv H0; simpl; auto. + unfold eval_static_intuoffloat. destruct (Float.intuoffloat n1); simpl in H0; inv H0; simpl; auto. + + unfold eval_static_condition_val, Val.of_optbool. + destruct (eval_static_condition c vl0) as []_eqn. + rewrite (eval_static_condition_correct _ _ _ m _ H Heqo). + destruct b; simpl; auto. + simpl; auto. Qed. (** * Correctness of strength reduction *) @@ -167,367 +162,259 @@ Qed. Section STRENGTH_REDUCTION. -Variable app: reg -> approx. -Variable sp: val. +Variable app: D.t. Variable rs: regset. Variable m: mem. -Hypothesis MATCH: forall r, val_match_approx (app r) rs#r. +Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r. -Lemma intval_correct: - forall r n, - intval app r = Some n -> rs#r = Vint n. -Proof. - intros until n. - unfold intval. caseEq (app r); intros; try discriminate. - generalize (MATCH r). unfold val_match_approx. rewrite H. - congruence. -Qed. +Ltac InvApproxRegs := + match goal with + | [ H: _ :: _ = _ :: _ |- _ ] => + injection H; clear H; intros; InvApproxRegs + | [ H: ?v = approx_reg app ?r |- _ ] => + generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs + | _ => idtac + end. Lemma cond_strength_reduction_correct: - forall cond args, - let (cond', args') := cond_strength_reduction app cond args in + forall cond args vl, + vl = approx_regs app args -> + let (cond', args') := cond_strength_reduction cond args vl in eval_condition cond' rs##args' m = eval_condition cond rs##args m. Proof. - intros. unfold cond_strength_reduction. - case (cond_strength_reduction_match cond args); intros. - - caseEq (intval app r1); intros. - simpl. rewrite (intval_correct _ _ H). - destruct (rs#r2); auto. rewrite Int.swap_cmp. auto. - 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. - - caseEq (intval app r2); intros. - simpl. rewrite (intval_correct _ _ H). auto. - auto. - - caseEq (intval app r2); intros. - simpl. rewrite (intval_correct _ _ H). auto. - auto. - + intros until vl. unfold cond_strength_reduction. + case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVMA. + rewrite H0. apply Val.swap_cmp_bool. + rewrite H. auto. + rewrite H0. apply Val.swap_cmpu_bool. + rewrite H. auto. + rewrite H. rewrite eval_static_shift_correct. auto. + rewrite H. rewrite eval_static_shift_correct. auto. auto. Qed. Lemma make_addimm_correct: - forall n r v, + forall n r, let (op, args) := make_addimm n r in - eval_operation ge sp Oadd (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v. Proof. - intros; unfold make_addimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.add_zero in H. congruence. - rewrite Int.add_zero in H. congruence. - exact H0. + intros. unfold make_addimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto. + exists (Val.add rs#r (Vint n)); auto. 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) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1 r2, + rs#r2 = Vint n -> + let (op, args) := make_shlimm n r1 r2 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v. Proof. + Opaque mk_shift_amount. intros; unfold make_shlimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shl_zero in H. congruence. - unfold is_shift_amount. destruct (is_shift_amount_aux n); intros. - simpl in *. FuncInv. rewrite e in H0. auto. - simpl in *. FuncInv. rewrite e in H0. discriminate. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; intros. + econstructor; split. simpl; eauto. rewrite mk_shift_amount_eq; auto. + econstructor; split; eauto. simpl. congruence. 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) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1 r2, + rs#r2 = Vint n -> + let (op, args) := make_shrimm n r1 r2 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v. Proof. intros; unfold make_shrimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shr_zero in H. congruence. - unfold is_shift_amount. destruct (is_shift_amount_aux n); intros. - simpl in *. FuncInv. rewrite e in H0. auto. - simpl in *. FuncInv. rewrite e in H0. discriminate. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; intros. + econstructor; split. simpl; eauto. rewrite mk_shift_amount_eq; auto. + econstructor; split; eauto. simpl. congruence. 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) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1 r2, + rs#r2 = Vint n -> + let (op, args) := make_shruimm n r1 r2 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v. Proof. intros; unfold make_shruimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shru_zero in H. congruence. - unfold is_shift_amount. destruct (is_shift_amount_aux n); intros. - simpl in *. FuncInv. rewrite e in H0. auto. - simpl in *. FuncInv. rewrite e in H0. discriminate. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; intros. + econstructor; split. simpl; eauto. rewrite mk_shift_amount_eq; auto. + econstructor; split; eauto. simpl. congruence. Qed. 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) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1 r2, + rs#r2 = Vint n -> + let (op, args) := make_mulimm n r1 r2 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v. Proof. intros; unfold make_mulimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in H1. FuncInv. rewrite Int.mul_zero in H0. simpl. congruence. - generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros. - subst n. simpl in H2. simpl. FuncInv. rewrite Int.mul_one in H1. congruence. - caseEq (Int.is_power2 n); intros. - replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil) m) - with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil) m). - apply make_shlimm_correct. - simpl. generalize (Int.is_power2_range _ _ H2). - change (Z_of_nat Int.wordsize) with 32. intro. rewrite H3. - destruct rs#r; auto. rewrite (Int.mul_pow2 i0 _ _ H2). auto. - simpl List.map. rewrite H. auto. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto. + destruct (Int.is_power2 n) as []_eqn; intros. + exploit Int.is_power2_range; eauto. intros R. + econstructor; split. simpl; eauto. rewrite mk_shift_amount_eq; auto. + rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). auto. + econstructor; split; eauto. simpl. congruence. +Qed. + +Lemma make_divimm_correct: + forall n r1 r2 v, + Val.divs rs#r1 rs#r2 = Some v -> + rs#r2 = Vint n -> + let (op, args) := make_divimm n r1 r2 in + exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divimm. + destruct (Int.is_power2 n) as []_eqn. + destruct (Int.ltu i (Int.repr 31)) as []_eqn. + exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divuimm_correct: + forall n r1 r2 v, + Val.divu rs#r1 rs#r2 = Some v -> + rs#r2 = Vint n -> + let (op, args) := make_divuimm n r1 r2 in + exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divuimm. + destruct (Int.is_power2 n) as []_eqn. + replace v with (Val.shru rs#r1 (Vint i)). + econstructor; split. simpl. rewrite mk_shift_amount_eq. eauto. + eapply Int.is_power2_range; eauto. auto. + eapply Val.divu_pow2; eauto. congruence. + exists v; auto. Qed. Lemma make_andimm_correct: - forall n r v, + forall n r, let (op, args) := make_andimm n r in - eval_operation ge sp Oand (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v. Proof. intros; unfold make_andimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.and_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. rewrite Int.and_mone in H0. congruence. - exact H1. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto. + econstructor; split; eauto. auto. Qed. Lemma make_orimm_correct: - forall n r v, + forall n r, let (op, args) := make_orimm n r in - eval_operation ge sp Oor (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v. Proof. intros; unfold make_orimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.or_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. rewrite Int.or_mone in H0. congruence. - exact H1. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto. + econstructor; split; eauto. auto. Qed. Lemma make_xorimm_correct: - forall n r v, + forall n r, let (op, args) := make_xorimm n r in - eval_operation ge sp Oxor (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v. Proof. intros; unfold make_xorimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.xor_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. decEq. auto. - exact H1. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Val.notint (rs#r)); split. auto. + destruct (rs#r); simpl; auto. + econstructor; split; eauto. auto. Qed. Lemma op_strength_reduction_correct: - forall op args v, - let (op', args') := op_strength_reduction app op args in + forall op args vl v, + vl = approx_regs app args -> eval_operation ge sp op rs##args m = Some v -> - eval_operation ge sp op' rs##args' m = Some v. + let (op', args') := op_strength_reduction op args vl in + exists w, eval_operation ge sp op' rs##args' m = Some w /\ Val.lessdef v w. 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) 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. - rewrite (intval_correct _ _ H0). apply make_addimm_correct. - assumption. - (* Oaddshift *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp (Oaddshift s) (rs # r1 :: Vint i :: nil) m) - with (eval_operation ge sp Oadd (rs # r1 :: Vint (eval_shift s i) :: nil) m). - apply make_addimm_correct. - simpl. destruct rs#r1; auto. - assumption. - (* Osub *) - caseEq (intval app r1); intros. - rewrite (intval_correct _ _ H) in H0. - 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) 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) m) - with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg (eval_shift s i)) :: nil) m). - apply make_addimm_correct. - simpl. destruct rs#r1; auto; rewrite Int.sub_add_opp; auto. - assumption. - (* Orsubshift *) - caseEq (intval app r2). intros n H. - rewrite (intval_correct _ _ H). - simpl. destruct rs#r1; auto. - auto. - (* Omul *) - caseEq (intval app r1); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Omul (Vint i :: rs # r2 :: nil) m) - with (eval_operation ge sp Omul (rs # r2 :: Vint i :: nil) m). - apply make_mulimm_correct. apply intval_correct; auto. - simpl. destruct rs#r2; auto. rewrite Int.mul_commut; auto. - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H0). apply make_mulimm_correct. - apply intval_correct; auto. - assumption. - (* Odivu *) - 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) 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). - rewrite (Int.is_power2_range _ _ H0). - generalize (Int.eq_spec i Int.zero); case (Int.eq i Int.zero); intros. - subst i. discriminate. - rewrite (Int.divu_pow2 i1 _ _ H0). auto. - assumption. - assumption. - (* Oand *) - caseEq (intval app r1); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oand (Vint i :: rs # r2 :: nil) m) - with (eval_operation ge sp Oand (rs # r2 :: Vint i :: nil) m). - apply make_andimm_correct. - simpl. destruct rs#r2; auto. rewrite Int.and_commut; auto. - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H0). apply make_andimm_correct. - assumption. - (* Oandshift *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp (Oandshift s) (rs # r1 :: Vint i :: nil) m) - with (eval_operation ge sp Oand (rs # r1 :: Vint (eval_shift s i) :: nil) m). - apply make_andimm_correct. reflexivity. - assumption. - (* Oor *) - caseEq (intval app r1); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oor (Vint i :: rs # r2 :: nil) m) - with (eval_operation ge sp Oor (rs # r2 :: Vint i :: nil) m). - apply make_orimm_correct. - simpl. destruct rs#r2; auto. rewrite Int.or_commut; auto. - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H0). apply make_orimm_correct. - assumption. - (* Oorshift *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp (Oorshift s) (rs # r1 :: Vint i :: nil) m) - with (eval_operation ge sp Oor (rs # r1 :: Vint (eval_shift s i) :: nil) m). - apply make_orimm_correct. reflexivity. - assumption. - (* Oxor *) - caseEq (intval app r1); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oxor (Vint i :: rs # r2 :: nil) m) - with (eval_operation ge sp Oxor (rs # r2 :: Vint i :: nil) m). - apply make_xorimm_correct. - simpl. destruct rs#r2; auto. rewrite Int.xor_commut; auto. - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H0). apply make_xorimm_correct. - assumption. - (* Oxorshift *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp (Oxorshift s) (rs # r1 :: Vint i :: nil) m) - with (eval_operation ge sp Oxor (rs # r1 :: Vint (eval_shift s i) :: nil) m). - apply make_xorimm_correct. reflexivity. - assumption. - (* Obic *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Obic (rs # r1 :: Vint i :: nil) m) - with (eval_operation ge sp Oand (rs # r1 :: Vint (Int.not i) :: nil) m). - apply make_andimm_correct. reflexivity. - assumption. - (* Obicshift *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp (Obicshift s) (rs # r1 :: Vint i :: nil) m) - with (eval_operation ge sp Oand (rs # r1 :: Vint (Int.not (eval_shift s i)) :: nil) m). - apply make_andimm_correct. reflexivity. - assumption. - (* Oshl *) - caseEq (intval app r2); intros. - caseEq (Int.ltu i Int.iwordsize); intros. - rewrite (intval_correct _ _ H). apply make_shlimm_correct. - assumption. - assumption. - (* Oshr *) - caseEq (intval app r2); intros. - caseEq (Int.ltu i Int.iwordsize); intros. - rewrite (intval_correct _ _ H). apply make_shrimm_correct. - assumption. - assumption. - (* Oshru *) - caseEq (intval app r2); intros. - caseEq (Int.ltu i Int.iwordsize); intros. - rewrite (intval_correct _ _ H). apply make_shruimm_correct. - assumption. - assumption. - (* Ocmp *) - generalize (cond_strength_reduction_correct c rl). - destruct (cond_strength_reduction app c rl). - simpl. intro. rewrite H. auto. - (* default *) - assumption. + intros until v; unfold op_strength_reduction; + case (op_strength_reduction_match op args vl); simpl; intros. +(* add *) + InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.add_commut. apply make_addimm_correct. + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_addimm_correct. +(* addshift *) + InvApproxRegs. SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. apply make_addimm_correct. +(* sub *) + InvApproxRegs; SimplVMA. inv H0. rewrite H1. econstructor; split; eauto. + InvApproxRegs; SimplVMA. inv H0. rewrite H. rewrite Val.sub_add_opp. apply make_addimm_correct. +(* subshift *) + InvApproxRegs; SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. rewrite Val.sub_add_opp. apply make_addimm_correct. +(* rsubshift *) + InvApproxRegs; SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. econstructor; split; eauto. +(* mul *) + InvApproxRegs; SimplVMA. inv H0. rewrite H1. rewrite Val.mul_commut. apply make_mulimm_correct; auto. + InvApproxRegs; SimplVMA. inv H0. rewrite H. apply make_mulimm_correct; auto. +(* divs *) + assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto. + apply make_divimm_correct; auto. +(* divu *) + assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto. + apply make_divuimm_correct; auto. +(* and *) + InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.and_commut. apply make_andimm_correct. + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_andimm_correct. +(* andshift *) + InvApproxRegs. SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. apply make_andimm_correct. +(* or *) + InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.or_commut. apply make_orimm_correct. + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_orimm_correct. +(* orshift *) + InvApproxRegs. SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. apply make_orimm_correct. +(* xor *) + InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.xor_commut. apply make_xorimm_correct. + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_xorimm_correct. +(* xorshift *) + InvApproxRegs. SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. apply make_xorimm_correct. +(* bic *) + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_andimm_correct. +(* bicshift *) + InvApproxRegs. SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. apply make_andimm_correct. +(* shl *) + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shlimm_correct; auto. +(* shr *) + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shrimm_correct; auto. +(* shru *) + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shruimm_correct; auto. +(* cmp *) + generalize (cond_strength_reduction_correct c args0 vl0). + destruct (cond_strength_reduction c args0 vl0) as [c' args']; intros. + rewrite <- H1 in H0; auto. econstructor; split; eauto. +(* default *) + exists v; auto. Qed. Lemma addr_strength_reduction_correct: - forall addr args, - let (addr', args') := addr_strength_reduction app addr args in + forall addr args vl, + vl = approx_regs app args -> + let (addr', args') := addr_strength_reduction addr args vl in eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args. Proof. - intros. - - unfold addr_strength_reduction; - case (addr_strength_reduction_match addr args); intros. - - (* Aindexed2 *) - caseEq (intval app r1); intros. - simpl; rewrite (intval_correct _ _ H). - destruct rs#r2; auto. rewrite Int.add_commut; auto. - caseEq (intval app r2); intros. - simpl; rewrite (intval_correct _ _ H0). auto. + intros until vl. unfold addr_strength_reduction. + destruct (addr_strength_reduction_match addr args vl); simpl; intros; InvApproxRegs; SimplVMA. + rewrite H; rewrite H0. rewrite Val.add_assoc; auto. + rewrite H; rewrite H0. rewrite Val.add_permut; auto. + rewrite H0. rewrite Val.add_commut. auto. + rewrite H. auto. + rewrite H; rewrite H0. rewrite Val.add_assoc. rewrite eval_static_shift_correct. auto. + rewrite H. rewrite eval_static_shift_correct. auto. + rewrite H. rewrite Val.add_assoc. auto. auto. - - (* Aindexed2shift *) - caseEq (intval app r2); intros. - simpl; rewrite (intval_correct _ _ H). auto. - auto. - - (* default *) - reflexivity. Qed. End STRENGTH_REDUCTION. @@ -36,11 +36,11 @@ Require Import Events. Set Implicit Arguments. -Record shift_amount : Type := - mk_shift_amount { - s_amount: int; - s_amount_ltu: Int.ltu s_amount Int.iwordsize = true - }. +Record shift_amount: Type := + { s_amount: int; + s_range: Int.ltu s_amount Int.iwordsize = true }. + +Coercion s_amount: shift_amount >-> int. Inductive shift : Type := | Slsl: shift_amount -> shift @@ -70,10 +70,6 @@ Inductive operation : Type := | Oaddrsymbol: ident -> int -> operation (**r [rd] is set to the the address of the symbol plus the offset *) | Oaddrstack: int -> operation (**r [rd] is set to the stack pointer plus the given offset *) (*c Integer arithmetic: *) - | Ocast8signed: operation (**r [rd] is 8-bit sign extension of [r1] *) - | Ocast8unsigned: operation (**r [rd] is 8-bit zero extension of [r1] *) - | Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *) - | Ocast16unsigned: operation (**r [rd] is 16-bit zero extension of [r1] *) | Oadd: operation (**r [rd = r1 + r2] *) | Oaddshift: shift -> operation (**r [rd = r1 + shifted r2] *) | Oaddimm: int -> operation (**r [rd = r1 + n] *) @@ -158,68 +154,39 @@ Proof. decide equality. Qed. -(** Evaluation of conditions, operators and addressing modes applied - to lists of values. Return [None] when the computation is undefined: - wrong number of arguments, arguments of the wrong types, undefined - operations such as division by zero. [eval_condition] returns a boolean, - [eval_operation] and [eval_addressing] return a value. *) +(** * Evaluation functions *) -Definition eval_compare_mismatch (c: comparison) : option bool := - match c with Ceq => Some false | Cne => Some true | _ => None end. +Definition symbol_address (F V: Type) (genv: Genv.t F V) (id: ident) (ofs: int) : val := + match Genv.find_symbol genv id with + | Some b => Vptr b ofs + | None => Vundef + end. -Definition eval_compare_null (c: comparison) (n: int) : option bool := - if Int.eq n Int.zero then eval_compare_mismatch c else None. +(** Evaluation of conditions, operators and addressing modes applied + to lists of values. Return [None] when the computation can trigger an + error, e.g. integer division by zero. [eval_condition] returns a boolean, + [eval_operation] and [eval_addressing] return a value. *) -Definition eval_shift (s: shift) (n: int) : int := +Definition eval_shift (s: shift) (v: val) : val := match s with - | Slsl x => Int.shl n (s_amount x) - | Slsr x => Int.shru n (s_amount x) - | Sasr x => Int.shr n (s_amount x) - | Sror x => Int.ror n (s_amount x) + | Slsl x => Val.shl v (Vint x) + | Slsr x => Val.shru v (Vint x) + | Sasr x => Val.shr v (Vint x) + | Sror x => Val.ror v (Vint x) end. Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := match cond, vl with - | Ccomp c, Vint n1 :: Vint n2 :: nil => - Some (Int.cmp c n1 n2) - | 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)) - | 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) - | 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 => - Some (negb (Float.cmp c f1 f2)) - | _, _ => - None - end. - -Definition offset_sp (sp: val) (delta: int) : option val := - match sp with - | Vptr b n => Some (Vptr b (Int.add n delta)) - | _ => None + | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 + | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 + | Ccompshift c s, v1 :: v2 :: nil => Val.cmp_bool c v1 (eval_shift s v2) + | Ccompushift c s, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (eval_shift s v2) + | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n) + | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n) + | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2 + | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2) + | _, _ => None end. Definition eval_operation @@ -229,75 +196,48 @@ Definition eval_operation | Omove, v1::nil => Some v1 | Ointconst n, nil => Some (Vint n) | Ofloatconst n, nil => Some (Vfloat n) - | Oaddrsymbol s ofs, nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b ofs) - end - | Oaddrstack ofs, nil => offset_sp sp ofs - | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1) - | Ocast8unsigned, v1 :: nil => Some (Val.zero_ext 8 v1) - | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) - | Ocast16unsigned, v1 :: nil => Some (Val.zero_ext 16 v1) - | Oadd, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.add n1 n2)) - | Oadd, Vint n1 :: Vptr b2 n2 :: nil => Some (Vptr b2 (Int.add n2 n1)) - | Oadd, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.add n1 n2)) - | Oaddshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.add n1 (eval_shift s n2))) - | Oaddshift s, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.add n1 (eval_shift s n2))) - | Oaddimm n, Vint n1 :: nil => Some (Vint (Int.add n1 n)) - | Oaddimm n, Vptr b1 n1 :: nil => Some (Vptr b1 (Int.add n1 n)) - | Osub, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub n1 n2)) - | Osub, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.sub n1 n2)) - | Osub, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if eq_block b1 b2 then Some (Vint (Int.sub n1 n2)) else None - | Osubshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub n1 (eval_shift s n2))) - | Osubshift s, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.sub n1 (eval_shift s n2))) - | Orsubshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub (eval_shift s n2) n1)) - | Orsubimm n, Vint n1 :: nil => Some (Vint (Int.sub n n1)) - | Omul, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.mul n1 n2)) - | Odiv, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divs n1 n2)) - | Odivu, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2)) - | Oand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 n2)) - | Oandshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 (eval_shift s n2))) - | Oandimm n, Vint n1 :: nil => Some (Vint (Int.and n1 n)) - | Oor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 n2)) - | Oorshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 (eval_shift s n2))) - | Oorimm n, Vint n1 :: nil => Some (Vint (Int.or n1 n)) - | Oxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 n2)) - | Oxorshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 (eval_shift s n2))) - | Oxorimm n, Vint n1 :: nil => Some (Vint (Int.xor n1 n)) - | Obic, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 (Int.not n2))) - | Obicshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 (Int.not (eval_shift s n2)))) - | Onot, Vint n1 :: nil => Some (Vint (Int.not n1)) - | Onotshift s, Vint n1 :: nil => Some (Vint (Int.not (eval_shift s n1))) - | Oshl, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shl n1 n2)) else None - | Oshr, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shr n1 n2)) else None - | Oshru, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shru n1 n2)) else None - | Oshift s, Vint n :: nil => Some (Vint (eval_shift s n)) - | Oshrximm n, Vint n1 :: nil => - if Int.ltu n (Int.repr 31) then Some (Vint (Int.shrx n1 n)) else None - | Onegf, Vfloat f1 :: nil => Some (Vfloat (Float.neg f1)) - | Oabsf, Vfloat f1 :: nil => Some (Vfloat (Float.abs f1)) - | Oaddf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.add f1 f2)) - | Osubf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.sub f1 f2)) - | Omulf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.mul f1 f2)) - | Odivf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.div f1 f2)) - | Osingleoffloat, v1 :: nil => Some (Val.singleoffloat v1) - | Ointoffloat, Vfloat f1 :: nil => option_map Vint (Float.intoffloat f1) - | Ointuoffloat, Vfloat f1 :: nil => option_map Vint (Float.intuoffloat f1) - | Ofloatofint, Vint n1 :: nil => Some (Vfloat (Float.floatofint n1)) - | Ofloatofintu, Vint n1 :: nil => Some (Vfloat (Float.floatofintu n1)) - | Ocmp c, _ => - match eval_condition c vl m with - | None => None - | Some false => Some Vfalse - | Some true => Some Vtrue - end + | Oaddrsymbol s ofs, nil => Some (symbol_address genv s ofs) + | Oaddrstack ofs, nil => Some (Val.add sp (Vint ofs)) + | Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2) + | Oaddshift s, v1 :: v2 :: nil => Some (Val.add v1 (eval_shift s v2)) + | Oaddimm n, v1 :: nil => Some (Val.add v1 (Vint n)) + | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2) + | Osubshift s, v1 :: v2 :: nil => Some (Val.sub v1 (eval_shift s v2)) + | Orsubshift s, v1 :: v2 :: nil => Some (Val.sub (eval_shift s v2) v1) + | Orsubimm n, v1 :: nil => Some (Val.sub (Vint n) v1) + | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2) + | Odiv, v1 :: v2 :: nil => Val.divs v1 v2 + | Odivu, v1 :: v2 :: nil => Val.divu v1 v2 + | Oand, v1 :: v2 :: nil => Some (Val.and v1 v2) + | Oandshift s, v1 :: v2 :: nil => Some (Val.and v1 (eval_shift s v2)) + | Oandimm n, v1 :: nil => Some (Val.and v1 (Vint n)) + | Oor, v1 :: v2 :: nil => Some (Val.or v1 v2) + | Oorshift s, v1 :: v2 :: nil => Some (Val.or v1 (eval_shift s v2)) + | Oorimm n, v1 :: nil => Some (Val.or v1 (Vint n)) + | Oxor, v1 :: v2 :: nil => Some (Val.xor v1 v2) + | Oxorshift s, v1 :: v2 :: nil => Some (Val.xor v1 (eval_shift s v2)) + | Oxorimm n, v1 :: nil => Some (Val.xor v1 (Vint n)) + | Obic, v1 :: v2 :: nil => Some (Val.and v1 (Val.notint v2)) + | Obicshift s, v1 :: v2 :: nil => Some (Val.and v1 (Val.notint (eval_shift s v2))) + | Onot, v1 :: nil => Some (Val.notint v1) + | Onotshift s, v1 :: nil => Some (Val.notint (eval_shift s v1)) + | Oshl, v1 :: v2 :: nil => Some (Val.shl v1 v2) + | Oshr, v1 :: v2 :: nil => Some (Val.shr v1 v2) + | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2) + | Oshift s, v1 :: nil => Some (eval_shift s v1) + | Oshrximm n, v1 :: nil => Val.shrx v1 (Vint n) + | Onegf, v1::nil => Some(Val.negf v1) + | Oabsf, v1::nil => Some(Val.absf v1) + | Oaddf, v1::v2::nil => Some(Val.addf v1 v2) + | Osubf, v1::v2::nil => Some(Val.subf v1 v2) + | Omulf, v1::v2::nil => Some(Val.mulf v1 v2) + | Odivf, v1::v2::nil => Some(Val.divf v1 v2) + | Osingleoffloat, v1::nil => Some(Val.singleoffloat v1) + | Ointoffloat, v1::nil => Val.intoffloat v1 + | Ointuoffloat, v1::nil => Val.intuoffloat v1 + | Ofloatofint, v1::nil => Val.floatofint v1 + | Ofloatofintu, v1::nil => Val.floatofintu v1 + | Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m)) | _, _ => None end. @@ -305,31 +245,13 @@ Definition eval_addressing (F V: Type) (genv: Genv.t F V) (sp: val) (addr: addressing) (vl: list val) : option val := match addr, vl with - | Aindexed n, Vptr b1 n1 :: nil => - Some (Vptr b1 (Int.add n1 n)) - | Aindexed2, Vptr b1 n1 :: Vint n2 :: nil => - Some (Vptr b1 (Int.add n1 n2)) - | Aindexed2, Vint n1 :: Vptr b2 n2 :: nil => - Some (Vptr b2 (Int.add n1 n2)) - | Aindexed2shift s, Vptr b1 n1 :: Vint n2 :: nil => - Some (Vptr b1 (Int.add n1 (eval_shift s n2))) - | Ainstack ofs, nil => - offset_sp sp ofs + | Aindexed n, v1 :: nil => Some (Val.add v1 (Vint n)) + | Aindexed2, v1 :: v2 :: nil => Some (Val.add v1 v2) + | Aindexed2shift s, v1 :: v2 :: nil => Some (Val.add v1 (eval_shift s v2)) + | Ainstack ofs, nil => Some (Val.add sp (Vint ofs)) | _, _ => None end. -Definition negate_condition (cond: condition): condition := - match cond with - | Ccomp c => Ccomp(negate_comparison c) - | Ccompu c => Ccompu(negate_comparison c) - | Ccompshift c s => Ccompshift (negate_comparison c) s - | Ccompushift c s => Ccompushift (negate_comparison c) s - | Ccompimm c n => Ccompimm (negate_comparison c) n - | Ccompuimm c n => Ccompuimm (negate_comparison c) n - | Ccompf c => Cnotcompf c - | Cnotcompf c => Ccompf c - end. - Ltac FuncInv := match goal with | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => @@ -342,99 +264,7 @@ Ltac FuncInv := idtac end. -Remark eval_negate_compare_null: - forall c n b, - eval_compare_null c n = Some b -> - eval_compare_null (negate_comparison c) n = Some (negb b). -Proof. - intros until b. unfold eval_compare_null. - case (Int.eq n Int.zero). - destruct c; intro EQ; simplify_eq EQ; intros; subst b; reflexivity. - intro; discriminate. -Qed. - -Lemma eval_negate_condition: - forall (cond: condition) (vl: list val) (b: bool) (m: mem), - eval_condition cond vl m = Some b -> - eval_condition (negate_condition cond) vl m = Some (negb b). -Proof. - intros. - destruct cond; simpl in H; FuncInv; try subst b; simpl. - rewrite Int.negate_cmp. auto. - rewrite Int.negate_cmpu. auto. - apply eval_negate_compare_null; auto. - apply eval_negate_compare_null; auto. - 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_cmp. auto. - rewrite Int.negate_cmpu. 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. - -(** [eval_operation] and [eval_addressing] depend on a global environment - for resolving references to global symbols. We show that they give - the same results if a global environment is replaced by another that - assigns the same addresses to the same symbols. *) - -Section GENV_TRANSF. - -Variable F1 F2 V1 V2: Type. -Variable ge1: Genv.t F1 V1. -Variable ge2: Genv.t F2 V2. -Hypothesis agree_on_symbols: - forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. - -Lemma eval_operation_preserved: - forall sp op vl m, - eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. -Proof. - intros. - unfold eval_operation; destruct op; try rewrite agree_on_symbols; - reflexivity. -Qed. - -Lemma eval_addressing_preserved: - forall sp addr vl, - eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. -Proof. - intros. - assert (UNUSED: forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s). - exact agree_on_symbols. - unfold eval_addressing; destruct addr; try rewrite agree_on_symbols; - reflexivity. -Qed. - -End GENV_TRANSF. - -(** Recognition of move operations. *) - -Definition is_move_operation - (A: Type) (op: operation) (args: list A) : option A := - match op, args with - | Omove, arg :: nil => Some arg - | _, _ => None - end. - -Lemma is_move_operation_correct: - forall (A: Type) (op: operation) (args: list A) (a: A), - is_move_operation op args = Some a -> - op = Omove /\ args = a :: nil. -Proof. - intros until a. unfold is_move_operation; destruct op; - try (intros; discriminate). - destruct args. intros; discriminate. - destruct args. intros. intuition congruence. - intros; discriminate. -Qed. - -(** Static typing of conditions, operators and addressing modes. *) +(** * Static typing of conditions, operators and addressing modes. *) Definition type_of_condition (c: condition) : list typ := match c with @@ -455,10 +285,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ofloatconst _ => (nil, Tfloat) | Oaddrsymbol _ _ => (nil, Tint) | Oaddrstack _ => (nil, Tint) - | Ocast8signed => (Tint :: nil, Tint) - | Ocast8unsigned => (Tint :: nil, Tint) - | Ocast16signed => (Tint :: nil, Tint) - | Ocast16unsigned => (Tint :: nil, Tint) | Oadd => (Tint :: Tint :: nil, Tint) | Oaddshift _ => (Tint :: Tint :: nil, Tint) | Oaddimm _ => (Tint :: nil, Tint) @@ -534,37 +360,54 @@ Lemma type_of_operation_sound: op <> Omove -> eval_operation genv sp op vl m = Some v -> Val.has_type v (snd (type_of_operation op)). -Proof. +Proof with (try exact I). + assert (S: forall s v, Val.has_type (eval_shift s v) Tint). + intros. unfold eval_shift. destruct s; destruct v; simpl; auto; rewrite s_range; exact I. intros. - destruct op; simpl in H0; FuncInv; try subst v; try exact I. + destruct op; simpl; simpl in H0; FuncInv; try subst v... congruence. - destruct (Genv.find_symbol genv i); simplify_eq H0; intro; subst v; exact I. - simpl. unfold offset_sp in H0. destruct sp; try discriminate. - inversion H0. exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct (eq_block b b0). injection H0; intro; subst v; exact I. - discriminate. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i (Int.repr 31)). - injection H0; intro; subst v; exact I. discriminate. - destruct v0; exact I. - destruct (Float.intoffloat f); simpl in H0; inv H0. exact I. - destruct (Float.intuoffloat f); simpl in H0; inv H0. exact I. - destruct (eval_condition c vl). - destruct b; injection H0; intro; subst v; exact I. - discriminate. + unfold symbol_address. destruct (Genv.find_symbol genv i)... + destruct sp... + destruct v0; destruct v1... + generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; tauto. + destruct v0... + destruct v0; destruct v1... simpl. destruct (zeq b b0)... + generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; intuition. destruct (zeq b b0)... + generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; intuition. destruct (zeq b0 b)... + destruct v0... + destruct v0; destruct v1... + destruct v0; destruct v1; simpl in H0; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1; simpl in H0; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1... + generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; tauto. + destruct v0... + destruct v0; destruct v1... + generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; tauto. + destruct v0... + destruct v0; destruct v1... + generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; tauto. + destruct v0... + destruct v0; destruct v1... + generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; tauto. + destruct v0... + generalize (S s v0). destruct (eval_shift s v0); simpl; tauto. + destruct v0; destruct v1... simpl. destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; destruct v1... simpl. destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; destruct v1... simpl. destruct (Int.ltu i0 Int.iwordsize)... + apply S. + destruct v0; simpl in H0; inv H0. destruct (Int.ltu i (Int.repr 31)); inv H2... + destruct v0... + destruct v0... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0... + destruct v0; simpl in H0; inv H0. destruct (Float.intoffloat f); simpl in H2; inv H2... + destruct v0; simpl in H0; inv H0. destruct (Float.intuoffloat f); simpl in H2; inv H2... + destruct v0; simpl in H0; inv H0... + destruct v0; simpl in H0; inv H0... + destruct (eval_condition c vl m)... destruct b... Qed. Lemma type_of_chunk_correct: @@ -582,332 +425,263 @@ Qed. End SOUNDNESS. -(** Alternate definition of [eval_condition], [eval_op], [eval_addressing] - as total functions that return [Vundef] when not applicable - (instead of [None]). Used in the proof of [PPCgen]. *) +(** * Manipulating and transforming operations *) -Section EVAL_OP_TOTAL. +(** Constructing shift amounts. *) -Variable F V: Type. -Variable genv: Genv.t F V. +Program Definition mk_shift_amount (n: int) : shift_amount := + {| s_amount := Int.modu n Int.iwordsize; s_range := _ |}. +Next Obligation. + assert (0 <= Zmod (Int.unsigned n) 32 < 32). apply Z_mod_lt. omega. + unfold Int.ltu, Int.modu. change (Int.unsigned Int.iwordsize) with 32. + rewrite Int.unsigned_repr. apply zlt_true. omega. + assert (32 < Int.max_unsigned). compute; auto. omega. +Qed. -Definition find_symbol_offset (id: ident) (ofs: int) : val := - match Genv.find_symbol genv id with - | Some b => Vptr b ofs - | None => Vundef - end. +Lemma mk_shift_amount_eq: + forall n, Int.ltu n Int.iwordsize = true -> s_amount (mk_shift_amount n) = n. +Proof. + intros; simpl. unfold Int.modu. transitivity (Int.repr (Int.unsigned n)). + decEq. apply Zmod_small. apply Int.ltu_inv; auto. + apply Int.repr_unsigned. +Qed. -Definition eval_shift_total (s: shift) (v: val) : val := - match v with - | Vint n => Vint(eval_shift s n) - | _ => Vundef +(** Recognition of move operations. *) + +Definition is_move_operation + (A: Type) (op: operation) (args: list A) : option A := + match op, args with + | Omove, arg :: nil => Some arg + | _, _ => None end. -Definition eval_condition_total (cond: condition) (vl: list val) : val := - match cond, vl with - | Ccomp c, v1::v2::nil => Val.cmp c v1 v2 - | Ccompu c, v1::v2::nil => Val.cmpu c v1 v2 - | Ccompshift c s, v1::v2::nil => Val.cmp c v1 (eval_shift_total s v2) - | Ccompushift c s, v1::v2::nil => Val.cmpu c v1 (eval_shift_total s v2) - | Ccompimm c n, v1::nil => Val.cmp c v1 (Vint n) - | Ccompuimm c n, v1::nil => Val.cmpu c v1 (Vint n) - | Ccompf c, v1::v2::nil => Val.cmpf c v1 v2 - | Cnotcompf c, v1::v2::nil => Val.notbool(Val.cmpf c v1 v2) - | _, _ => Vundef +Lemma is_move_operation_correct: + forall (A: Type) (op: operation) (args: list A) (a: A), + is_move_operation op args = Some a -> + op = Omove /\ args = a :: nil. +Proof. + intros until a. unfold is_move_operation; destruct op; + try (intros; discriminate). + destruct args. intros; discriminate. + destruct args. intros. intuition congruence. + intros; discriminate. +Qed. + +(** [negate_condition cond] returns a condition that is logically + equivalent to the negation of [cond]. *) + +Definition negate_condition (cond: condition): condition := + match cond with + | Ccomp c => Ccomp(negate_comparison c) + | Ccompu c => Ccompu(negate_comparison c) + | Ccompshift c s => Ccompshift (negate_comparison c) s + | Ccompushift c s => Ccompushift (negate_comparison c) s + | Ccompimm c n => Ccompimm (negate_comparison c) n + | Ccompuimm c n => Ccompuimm (negate_comparison c) n + | Ccompf c => Cnotcompf c + | Cnotcompf c => Ccompf c end. -Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val := - match op, vl with - | Omove, v1::nil => v1 - | Ointconst n, nil => Vint n - | Ofloatconst n, nil => Vfloat n - | Oaddrsymbol s ofs, nil => find_symbol_offset s ofs - | Oaddrstack ofs, nil => Val.add sp (Vint ofs) - | Ocast8signed, v1::nil => Val.sign_ext 8 v1 - | Ocast8unsigned, v1::nil => Val.zero_ext 8 v1 - | Ocast16signed, v1::nil => Val.sign_ext 16 v1 - | Ocast16unsigned, v1::nil => Val.zero_ext 16 v1 - | Oadd, v1::v2::nil => Val.add v1 v2 - | Oaddshift s, v1::v2::nil => Val.add v1 (eval_shift_total s v2) - | Oaddimm n, v1::nil => Val.add v1 (Vint n) - | Osub, v1::v2::nil => Val.sub v1 v2 - | Osubshift s, v1::v2::nil => Val.sub v1 (eval_shift_total s v2) - | Orsubshift s, v1::v2::nil => Val.sub (eval_shift_total s v2) v1 - | Orsubimm n, v1::nil => Val.sub (Vint n) v1 - | Omul, v1::v2::nil => Val.mul v1 v2 - | Odiv, v1::v2::nil => Val.divs v1 v2 - | Odivu, v1::v2::nil => Val.divu v1 v2 - | Oand, v1::v2::nil => Val.and v1 v2 - | Oandshift s, v1::v2::nil => Val.and v1 (eval_shift_total s v2) - | Oandimm n, v1::nil => Val.and v1 (Vint n) - | Oor, v1::v2::nil => Val.or v1 v2 - | Oorshift s, v1::v2::nil => Val.or v1 (eval_shift_total s v2) - | Oorimm n, v1::nil => Val.or v1 (Vint n) - | Oxor, v1::v2::nil => Val.xor v1 v2 - | Oxorshift s, v1::v2::nil => Val.xor v1 (eval_shift_total s v2) - | Oxorimm n, v1::nil => Val.xor v1 (Vint n) - | Obic, v1::v2::nil => Val.and v1 (Val.notint v2) - | Obicshift s, v1::v2::nil => Val.and v1 (Val.notint (eval_shift_total s v2)) - | Onot, v1::nil => Val.notint v1 - | Onotshift s, v1::nil => Val.notint (eval_shift_total s v1) - | Oshl, v1::v2::nil => Val.shl v1 v2 - | Oshr, v1::v2::nil => Val.shr v1 v2 - | Oshru, v1::v2::nil => Val.shru v1 v2 - | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) - | Oshift s, v1::nil => eval_shift_total s v1 - | Onegf, v1::nil => Val.negf v1 - | Oabsf, v1::nil => Val.absf v1 - | Oaddf, v1::v2::nil => Val.addf v1 v2 - | Osubf, v1::v2::nil => Val.subf v1 v2 - | Omulf, v1::v2::nil => Val.mulf v1 v2 - | Odivf, v1::v2::nil => Val.divf v1 v2 - | Osingleoffloat, v1::nil => Val.singleoffloat v1 - | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ointuoffloat, v1::nil => Val.intuoffloat v1 - | Ofloatofint, v1::nil => Val.floatofint v1 - | Ofloatofintu, v1::nil => Val.floatofintu v1 - | Ocmp c, _ => eval_condition_total c vl - | _, _ => Vundef +Lemma eval_negate_condition: + forall (cond: condition) (vl: list val) (b: bool) (m: mem), + eval_condition cond vl m = Some b -> + eval_condition (negate_condition cond) vl m = Some (negb b). +Proof. + intros. + destruct cond; simpl in H; FuncInv; simpl. + rewrite Val.negate_cmp_bool; rewrite H; auto. + rewrite Val.negate_cmpu_bool; rewrite H; auto. + rewrite Val.negate_cmp_bool; rewrite H; auto. + rewrite Val.negate_cmpu_bool; rewrite H; auto. + rewrite Val.negate_cmp_bool; rewrite H; auto. + rewrite Val.negate_cmpu_bool; rewrite H; auto. + rewrite H; auto. + destruct (Val.cmpf_bool c v v0); simpl in H; inv H. rewrite negb_elim; auto. +Qed. + +(** Shifting stack-relative references. This is used in [Stacking]. *) + +Definition shift_stack_addressing (delta: int) (addr: addressing) := + match addr with + | Ainstack ofs => Ainstack (Int.add delta ofs) + | _ => addr end. -Definition eval_addressing_total - (sp: val) (addr: addressing) (vl: list val) : val := - match addr, vl with - | Aindexed n, v1::nil => Val.add v1 (Vint n) - | Aindexed2, v1::v2::nil => Val.add v1 v2 - | Aindexed2shift s, v1::v2::nil => Val.add v1 (eval_shift_total s v2) - | Ainstack ofs, nil => Val.add sp (Vint ofs) - | _, _ => Vundef +Definition shift_stack_operation (delta: int) (op: operation) := + match op with + | Oaddrstack ofs => Oaddrstack (Int.add delta ofs) + | _ => op end. -Lemma eval_compare_mismatch_weaken: - forall c b, - eval_compare_mismatch c = Some b -> - Val.cmp_mismatch c = Val.of_bool b. +Lemma type_shift_stack_addressing: + forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. Proof. - unfold eval_compare_mismatch. intros. destruct c; inv H; auto. + intros. destruct addr; auto. Qed. -Lemma eval_compare_null_weaken: - forall c i b, - eval_compare_null c i = Some b -> - (if Int.eq i Int.zero then Val.cmp_mismatch c else Vundef) = Val.of_bool b. +Lemma type_shift_stack_operation: + forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. Proof. - unfold eval_compare_null. intros. - destruct (Int.eq i Int.zero); try discriminate. - apply eval_compare_mismatch_weaken; auto. + intros. destruct op; auto. Qed. -Lemma eval_condition_weaken: - forall c vl b m, - eval_condition c vl m = Some b -> - eval_condition_total c vl = Val.of_bool b. +Lemma eval_shift_stack_addressing: + forall F V (ge: Genv.t F V) sp addr vl delta, + eval_addressing ge sp (shift_stack_addressing delta addr) vl = + eval_addressing ge (Val.add sp (Vint delta)) addr vl. Proof. - intros. - 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. + intros. destruct addr; simpl; auto. + rewrite Val.add_assoc. simpl. auto. Qed. -Lemma eval_operation_weaken: - forall sp op vl v m, - eval_operation genv sp op vl m = Some v -> - eval_operation_total sp op vl = v. +Lemma eval_shift_stack_operation: + forall F V (ge: Genv.t F V) sp op vl m delta, + eval_operation ge sp (shift_stack_operation delta op) vl m = + eval_operation ge (Val.add sp (Vint delta)) op vl m. Proof. - intros. - unfold eval_operation in H; destruct op; FuncInv; - try subst v; try reflexivity; simpl. - unfold find_symbol_offset. - destruct (Genv.find_symbol genv i); try discriminate. - congruence. - unfold offset_sp in H. - destruct sp; try discriminate. simpl. congruence. - unfold eq_block in H. destruct (zeq b b0); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.ltu i0 Int.iwordsize); congruence. - destruct (Int.ltu i0 Int.iwordsize); congruence. - destruct (Int.ltu i0 Int.iwordsize); congruence. - unfold Int.ltu in H. destruct (zlt (Int.unsigned i) (Int.unsigned (Int.repr 31))). - unfold Int.ltu. rewrite zlt_true. congruence. - assert (Int.unsigned (Int.repr 31) < Int.unsigned Int.iwordsize). vm_compute; auto. - omega. discriminate. - destruct (Float.intoffloat f); simpl in H; inv H. auto. - destruct (Float.intuoffloat f); simpl in H; inv H. auto. - caseEq (eval_condition c vl m); intros; rewrite H0 in H. - replace v with (Val.of_bool b). - eapply eval_condition_weaken; eauto. - destruct b; simpl; congruence. - discriminate. + intros. destruct op; simpl; auto. + rewrite Val.add_assoc. simpl. auto. Qed. -Lemma eval_addressing_weaken: - forall sp addr vl v, - eval_addressing genv sp addr vl = Some v -> - eval_addressing_total sp addr vl = v. +(** Transformation of addressing modes with two operands or more + into an equivalent arithmetic operation. This is used in the [Reload] + pass when a store instruction cannot be reloaded directly because + it runs out of temporary registers. *) + +(** For the ARM, there are only two binary addressing mode: [Aindexed2] + and [Aindexed2shift]. The corresponding operations are [Oadd] + and [Oaddshift]. *) + +Definition op_for_binary_addressing (addr: addressing) : operation := + match addr with + | Aindexed2 => Oadd + | Aindexed2shift s => Oaddshift s + | _ => Ointconst Int.zero (* never happens *) + end. + +Lemma eval_op_for_binary_addressing: + forall (F V: Type) (ge: Genv.t F V) sp addr args v m, + (length args >= 2)%nat -> + eval_addressing ge sp addr args = Some v -> + eval_operation ge sp (op_for_binary_addressing addr) args m = Some v. Proof. intros. - unfold eval_addressing in H; destruct addr; FuncInv; - try subst v; simpl; try reflexivity. - decEq. apply Int.add_commut. - unfold offset_sp in H. destruct sp; simpl; congruence. + unfold eval_addressing in H0; destruct addr; FuncInv; simpl in H; try omegaContradiction; simpl. + congruence. + congruence. Qed. -Lemma eval_condition_total_is_bool: - forall cond vl, Val.is_bool (eval_condition_total cond vl). +Lemma type_op_for_binary_addressing: + forall addr, + (length (type_of_addressing addr) >= 2)%nat -> + type_of_operation (op_for_binary_addressing addr) = (type_of_addressing addr, Tint). Proof. - intros; destruct cond; - destruct vl; try apply Val.undef_is_bool; - destruct vl; try apply Val.undef_is_bool; - try (destruct vl; try apply Val.undef_is_bool); simpl. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmpf_is_bool. - apply Val.notbool_is_bool. + intros. destruct addr; simpl in H; reflexivity || omegaContradiction. Qed. -End EVAL_OP_TOTAL. - -(** Compatibility of the evaluation functions with the - ``is less defined'' relation over values and memory states. *) +(** Two-address operations. There are none in the ARM architecture. *) -Section EVAL_LESSDEF. +Definition two_address_op (op: operation) : bool := false. -Variable F V: Type. -Variable genv: Genv.t F V. +(** Operations that are so cheap to recompute that CSE should not factor them out. *) -Ltac InvLessdef := - match goal with - | [ H: Val.lessdef (Vint _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef (Vfloat _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef (Vptr _ _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef_list nil _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef_list (_ :: _) _ |- _ ] => - inv H; InvLessdef - | _ => idtac +Definition is_trivial_op (op: operation) : bool := + match op with + | Omove => true + | Ointconst _ => true + | Oaddrstack _ => true + | _ => false end. -Lemma eval_condition_lessdef: - forall cond vl1 vl2 b m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. 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. +(** Operations that depend on the memory state. *) -Ltac TrivialExists := - match goal with - | [ |- exists v2, Some ?v1 = Some v2 /\ Val.lessdef ?v1 v2 ] => - exists v1; split; [auto | constructor] - | _ => idtac +Definition op_depends_on_memory (op: operation) : bool := + match op with + | Ocmp (Ccompu _ | Ccompushift _ _) => true + | _ => false end. -Lemma eval_operation_lessdef: - forall sp op vl1 vl2 v1 m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> - eval_operation genv sp op vl1 m1 = Some v1 -> - exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. -Proof. - intros. destruct op; simpl in *; FuncInv; InvLessdef; TrivialExists. - exists v2; auto. - 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 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 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 H1. TrivialExists. - destruct (Float.intuoffloat 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: - forall sp addr vl1 vl2 v1, - Val.lessdef_list vl1 vl2 -> - eval_addressing genv sp addr vl1 = Some v1 -> - exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. +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 in *; FuncInv; InvLessdef; TrivialExists. - exists v1; auto. + intros until m2. destruct op; simpl; try congruence. + intros. destruct c; simpl; auto; congruence. Qed. -End EVAL_LESSDEF. +(** * Invariance and compatibility properties. *) -(** Shifting stack-relative references. This is used in [Stacking]. *) +(** [eval_operation] and [eval_addressing] depend on a global environment + for resolving references to global symbols. We show that they give + the same results if a global environment is replaced by another that + assigns the same addresses to the same symbols. *) -Definition shift_stack_addressing (delta: int) (addr: addressing) := - match addr with - | Ainstack ofs => Ainstack (Int.add delta ofs) - | _ => addr - end. +Section GENV_TRANSF. -Definition shift_stack_operation (delta: int) (op: operation) := - match op with - | Oaddrstack ofs => Oaddrstack (Int.add delta ofs) - | _ => op - end. +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. +Hypothesis agree_on_symbols: + forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. -Lemma type_shift_stack_addressing: - forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. +Lemma eval_operation_preserved: + forall sp op vl m, + eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. Proof. - intros. destruct addr; auto. + intros. + unfold eval_operation; destruct op; auto. + unfold symbol_address. rewrite agree_on_symbols; auto. Qed. -Lemma type_shift_stack_operation: - forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. +Lemma eval_addressing_preserved: + forall sp addr vl, + eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. Proof. - intros. destruct op; auto. + intros. + assert (UNUSED: forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s). + exact agree_on_symbols. + unfold eval_addressing; destruct addr; auto. Qed. -(** Compatibility of the evaluation functions with memory injections. *) +End GENV_TRANSF. -Section EVAL_INJECT. +(** Compatibility of the evaluation functions with value injections. *) + +Section EVAL_COMPAT. 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). + +Hypothesis symbol_address_inj: + forall id ofs, + val_inject f (symbol_address genv id ofs) (symbol_address genv id ofs). + +Variable m1: mem. +Variable m2: mem. + +Hypothesis valid_pointer_inj: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + +Hypothesis valid_pointer_no_overflow: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + +Hypothesis valid_different_pointers_inj: + forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)). Ltac InvInject := match goal with @@ -924,202 +698,330 @@ Ltac InvInject := | _ => idtac end. -Lemma eval_condition_inject: - forall cond vl1 vl2 b m1 m2, +Remark val_add_inj: + forall v1 v1' v2 v2', + val_inject f v1 v1' -> val_inject f v2 v2' -> val_inject f (Val.add v1 v2) (Val.add v1' v2'). +Proof. + intros. inv H; inv H0; simpl; econstructor; eauto. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. +Qed. + +Remark val_sub_inj: + forall v1 v1' v2 v2', + val_inject f v1 v1' -> val_inject f v2 v2' -> val_inject f (Val.sub v1 v2) (Val.sub v1' v2'). +Proof. + intros. inv H; inv H0; simpl; auto. + econstructor; eauto. rewrite Int.sub_add_l. auto. + destruct (zeq b1 b0); auto. subst. rewrite H1 in H. inv H. rewrite zeq_true. + rewrite Int.sub_shifted. auto. +Qed. + +Remark eval_shift_inj: + forall s v v', val_inject f v v' -> val_inject f (eval_shift s v) (eval_shift s v'). +Proof. + intros. inv H; destruct s; simpl; auto; rewrite s_range; auto. +Qed. + +Lemma eval_condition_inj: + forall cond vl1 vl2 b, 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. +Opaque Int.add. + assert (CMP: + forall c v1 v2 v1' v2' b, + val_inject f v1 v1' -> + val_inject f v2 v2' -> + Val.cmp_bool c v1 v2 = Some b -> + Val.cmp_bool c v1' v2' = Some b). + intros. inv H; simpl in H1; try discriminate; inv H0; simpl in H1; try discriminate; simpl; auto. + + assert (CMPU: + forall c v1 v2 v1' v2' b, + val_inject f v1 v1' -> + val_inject f v2 v2' -> + Val.cmpu_bool (Mem.valid_pointer m1) c v1 v2 = Some b -> + Val.cmpu_bool (Mem.valid_pointer m2) c v1' v2' = Some b). + intros. inv H; simpl in H1; try discriminate; inv H0; simpl in H1; try discriminate; simpl; auto. + destruct (Mem.valid_pointer m1 b1 (Int.unsigned ofs1)) as []_eqn; try discriminate. + destruct (Mem.valid_pointer m1 b0 (Int.unsigned ofs0)) as []_eqn; try discriminate. + rewrite (valid_pointer_inj _ H2 Heqb4). + rewrite (valid_pointer_inj _ H Heqb0). simpl. + destruct (zeq b1 b0); simpl in H1. + inv H1. rewrite H in H2; inv H2. rewrite zeq_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. + eapply valid_pointer_no_overflow; eauto. + eapply valid_pointer_no_overflow; eauto. + exploit valid_different_pointers_inj; eauto. intros P. + destruct (zeq b2 b3); auto. + destruct P. congruence. + destruct c; simpl in H1; inv H1. + simpl; decEq. rewrite Int.eq_false; auto. congruence. + simpl; decEq. rewrite Int.eq_false; auto. congruence. + + intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl. + eapply CMP; eauto. + eapply CMPU; eauto. + eapply CMP. eauto. eapply eval_shift_inj. eauto. auto. + eapply CMPU. eauto. eapply eval_shift_inj. eauto. auto. + eapply CMP; eauto. + eapply CMPU; eauto. + inv H3; inv H2; simpl in H0; inv H0; auto. + inv H3; inv H2; simpl in H0; inv H0; auto. Qed. -Ltac TrivialExists2 := +Ltac TrivialExists := match goal with | [ |- exists v2, Some ?v1 = Some v2 /\ val_inject _ _ v2 ] => - exists v1; split; [auto | econstructor; eauto] + exists v1; split; auto | _ => idtac end. -Lemma eval_addressing_inject: - forall addr vl1 vl2 v1, +Lemma eval_operation_inj: + forall op sp1 vl1 sp2 vl2 v1, + val_inject f sp1 sp2 -> 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. + eval_operation genv sp1 op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp2 op vl2 m2 = 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. + intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + apply val_add_inj; auto. + apply val_add_inj; auto. + apply val_add_inj; auto. apply eval_shift_inj; auto. + apply val_add_inj; auto. + + apply val_sub_inj; auto. + apply val_sub_inj; auto. apply eval_shift_inj; auto. + apply val_sub_inj; auto. apply eval_shift_inj; auto. + apply (@val_sub_inj (Vint i) (Vint i) v v'); auto. + + inv H4; inv H2; simpl; auto. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + + inv H4; inv H2; simpl; auto. + exploit (eval_shift_inj s). eexact H2. intros IS. inv H4; inv IS; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + exploit (eval_shift_inj s). eexact H2. intros IS. inv H4; inv IS; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + exploit (eval_shift_inj s). eexact H2. intros IS. inv H4; inv IS; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + exploit (eval_shift_inj s). eexact H2. intros IS. inv H4; inv IS; simpl; auto. + + inv H4; simpl; auto. + exploit (eval_shift_inj s). eexact H4. intros IS. inv IS; simpl; auto. + + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + apply eval_shift_inj; auto. + inv H4; simpl in H1; inv H1. simpl. destruct (Int.ltu i (Int.repr 31)); inv H2. TrivialExists. + + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + + inv H4; simpl in H1; inv H1. simpl. destruct (Float.intoffloat f0); simpl in H2; inv H2. + exists (Vint i); auto. + inv H4; simpl in H1; inv H1. simpl. destruct (Float.intuoffloat f0); simpl in H2; inv H2. + exists (Vint i); auto. + inv H4; simpl in *; inv H1. TrivialExists. + inv H4; simpl in *; inv H1. TrivialExists. + + subst v1. destruct (eval_condition c vl1 m1) as []_eqn. + exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. + destruct b; simpl; constructor. + simpl; constructor. Qed. -Lemma eval_operation_inject: - forall op vl1 vl2 v1 m1 m2, +Lemma eval_addressing_inj: + forall addr sp1 vl1 sp2 vl2 v1, + val_inject f sp1 sp2 -> 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. + eval_addressing genv sp1 addr vl1 = Some v1 -> + exists v2, eval_addressing genv sp2 addr vl2 = 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 (Float.intuoffloat 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. + assert (UNUSED: forall id ofs, + val_inject f (symbol_address genv id ofs) (symbol_address genv id ofs)). + exact symbol_address_inj. + intros. destruct addr; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + apply val_add_inj; auto. + apply val_add_inj; auto. + apply val_add_inj; auto. apply eval_shift_inj; auto. + apply val_add_inj; auto. Qed. -End EVAL_INJECT. +End EVAL_COMPAT. -(** Recognition of integers that are valid shift amounts. *) +(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) -Definition is_shift_amount_aux (n: int) : - { Int.ltu n Int.iwordsize = true } + - { Int.ltu n Int.iwordsize = false }. -Proof. - case (Int.ltu n Int.iwordsize). left; auto. right; auto. -Defined. +Section EVAL_LESSDEF. -Definition is_shift_amount (n: int) : option shift_amount := - match is_shift_amount_aux n with - | left H => Some(mk_shift_amount n H) - | right _ => None - end. +Variable F V: Type. +Variable genv: Genv.t F V. -Lemma is_shift_amount_Some: - forall n s, is_shift_amount n = Some s -> s_amount s = n. +Remark valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. Proof. - intros until s. unfold is_shift_amount. - destruct (is_shift_amount_aux n). - simpl. intros. inv H. reflexivity. - congruence. + intros. inv H0. rewrite Int.add_zero. eapply Mem.valid_pointer_extends; eauto. Qed. -Lemma is_shift_amount_None: - forall n, is_shift_amount n = None -> Int.ltu n Int.iwordsize = true -> False. +Remark valid_pointer_no_overflow_extends: + forall m1 b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. Proof. - intro n. unfold is_shift_amount. - destruct (is_shift_amount_aux n). - congruence. - congruence. + intros. inv H. rewrite Zplus_0_r. apply Int.unsigned_range_2. Qed. -(** Transformation of addressing modes with two operands or more - into an equivalent arithmetic operation. This is used in the [Reload] - pass when a store instruction cannot be reloaded directly because - it runs out of temporary registers. *) - -(** For the ARM, there are only two binary addressing mode: [Aindexed2] - and [Aindexed2shift]. The corresponding operations are [Oadd] - and [Oaddshift]. *) +Remark valid_different_pointers_extends: + forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + Some(b1, 0) = Some (b1', delta1) -> + Some(b2, 0) = Some (b2', delta2) -> + b1' <> b2' \/ + Int.unsigned(Int.add ofs1 (Int.repr delta1)) <> Int.unsigned(Int.add ofs2 (Int.repr delta2)). +Proof. + intros. inv H2; inv H3. auto. +Qed. -Definition op_for_binary_addressing (addr: addressing) : operation := - match addr with - | Aindexed2 => Oadd - | Aindexed2shift s => Oaddshift s - | _ => Ointconst Int.zero (* never happens *) - end. +Lemma eval_condition_lessdef: + forall cond vl1 vl2 b m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1). + apply valid_pointer_extends; auto. + apply valid_pointer_no_overflow_extends; auto. + apply valid_different_pointers_extends; auto. + rewrite <- val_list_inject_lessdef. eauto. auto. +Qed. -Lemma eval_op_for_binary_addressing: - forall (F V: Type) (ge: Genv.t F V) sp addr args v m, - (length args >= 2)%nat -> - eval_addressing ge sp addr args = Some v -> - eval_operation ge sp (op_for_binary_addressing addr) args m = Some v. +Lemma eval_operation_lessdef: + forall sp op vl1 vl2 v1 m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_operation genv sp op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. Proof. - intros. - unfold eval_addressing in H0; destruct addr; FuncInv; simpl in H; try omegaContradiction; simpl. - rewrite Int.add_commut. congruence. - congruence. - congruence. + intros. rewrite val_list_inject_lessdef in H. + assert (exists v2 : val, + eval_operation genv sp op vl2 m2 = Some v2 + /\ val_inject (fun b => Some(b, 0)) v1 v2). + eapply eval_operation_inj with (m1 := m1) (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + apply valid_pointer_extends; auto. + apply valid_pointer_no_overflow_extends; auto. + apply valid_different_pointers_extends; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. Qed. -Lemma type_op_for_binary_addressing: - forall addr, - (length (type_of_addressing addr) >= 2)%nat -> - type_of_operation (op_for_binary_addressing addr) = (type_of_addressing addr, Tint). +Lemma eval_addressing_lessdef: + forall sp addr vl1 vl2 v1, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = Some v1 -> + exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. Proof. - intros. destruct addr; simpl in H; reflexivity || omegaContradiction. + intros. rewrite val_list_inject_lessdef in H. + assert (exists v2 : val, + eval_addressing genv sp addr vl2 = Some v2 + /\ val_inject (fun b => Some(b, 0)) v1 v2). + eapply eval_addressing_inj with (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. Qed. -(** Two-address operations. There are none in the ARM architecture. *) +End EVAL_LESSDEF. -Definition two_address_op (op: operation) : bool := false. +(** Compatibility of the evaluation functions with memory injections. *) -(** Operations that are so cheap to recompute that CSE should not factor them out. *) +Section EVAL_INJECT. -Definition is_trivial_op (op: operation) : bool := - match op with - | Omove => true - | Ointconst _ => true - | Oaddrsymbol _ _ => true - | Oaddrstack _ => true - | _ => false - end. +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. +Hypothesis globals: meminj_preserves_globals genv f. +Variable sp1: block. +Variable sp2: block. +Variable delta: Z. +Hypothesis sp_inj: f sp1 = Some(sp2, delta). +Remark symbol_address_inject: + forall id ofs, val_inject f (symbol_address genv id ofs) (symbol_address genv id ofs). +Proof. + intros. unfold symbol_address. destruct (Genv.find_symbol genv id) as []_eqn; auto. + exploit (proj1 globals); eauto. intros. + econstructor; eauto. rewrite Int.add_zero; auto. +Qed. -(** Operations that depend on the memory state. *) +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. eapply eval_condition_inj with (f := f) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. +Qed. -Definition op_depends_on_memory (op: operation) : bool := - match op with - | Ocmp (Ccompu _) => true - | _ => false - 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. + rewrite eval_shift_stack_addressing. simpl. + eapply eval_addressing_inj with (sp1 := Vptr sp1 Int.zero); eauto. + exact symbol_address_inject. +Qed. -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. +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 until m2. destruct op; simpl; try congruence. - destruct c; simpl; congruence. + intros. + rewrite eval_shift_stack_operation. simpl. + eapply eval_operation_inj with (sp1 := Vptr sp1 Int.zero) (m1 := m1); eauto. + exact symbol_address_inject. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. Qed. +End EVAL_INJECT. diff --git a/arm/SelectOp.v b/arm/SelectOp.v index 6580901..64d15cb 100644 --- a/arm/SelectOp.v +++ b/arm/SelectOp.v @@ -60,14 +60,9 @@ Definition addrstack (ofs: int) := (** ** Integer logical negation *) -(** The natural way to write smart constructors is by pattern-matching - on their arguments, recognizing cases where cheaper operators - or combined operators are applicable. For instance, integer logical - negation has three special cases (not-and, not-or and not-xor), - along with a default case that uses not-or over its arguments and itself. - This is written naively as follows: +(** Original definition: << -Definition notint (e: expr) := +Nondetfunction notint (e: expr) := match e with | Eop (Oshift s) (t1:::Enil) => Eop (Onotshift s) (t1:::Enil) | Eop Onot (t1:::Enil) => t1 @@ -75,80 +70,39 @@ Definition notint (e: expr) := | _ => Eop Onot (e:::Enil) end. >> - However, Coq expands complex pattern-matchings like the above into - elementary matchings over all constructors of an inductive type, - resulting in much duplication of the final catch-all case. - Such duplications generate huge executable code and duplicate - cases in the correctness proofs. - - To limit this duplication, we use the following trick due to - Yves Bertot. We first define a dependent inductive type that - characterizes the expressions that match each of the 4 cases of interest. *) Inductive notint_cases: forall (e: expr), Type := - | notint_case1: - forall s t1, - notint_cases (Eop (Oshift s) (t1:::Enil)) - | notint_case2: - forall t1, - notint_cases (Eop Onot (t1:::Enil)) - | notint_case3: - forall s t1, - notint_cases (Eop (Onotshift s) (t1:::Enil)) - | notint_default: - forall (e: expr), - notint_cases e. - -(** We then define a classification function that takes an expression - and return the case in which it falls. Note that the catch-all case - [notint_default] does not state that it is mutually exclusive with - the first three, more specific cases. The classification function - nonetheless chooses the specific cases in preference to the catch-all - case. *) + | notint_case1: forall s t1, notint_cases (Eop (Oshift s) (t1:::Enil)) + | notint_case2: forall t1, notint_cases (Eop Onot (t1:::Enil)) + | notint_case3: forall s t1, notint_cases (Eop (Onotshift s) (t1:::Enil)) + | notint_default: forall (e: expr), notint_cases e. Definition notint_match (e: expr) := - match e as z1 return notint_cases z1 with - | Eop (Oshift s) (t1:::Enil) => - notint_case1 s t1 - | Eop Onot (t1:::Enil) => - notint_case2 t1 - | Eop (Onotshift s) (t1:::Enil) => - notint_case3 s t1 - | e => - notint_default e - end. - -(** Finally, the [notint] function we need is defined by a 4-case match - over the result of the classification function. Thus, no duplication - of the right-hand sides of this match occur, and the proof has only - 4 cases to consider (it proceeds by case over [notint_match e]). - Since the default case is not obviously exclusive with the three - specific cases, it is important that its right-hand side is - semantically correct for all possible values of [e], which is the - case here and for all other smart constructors. *) + match e as zz1 return notint_cases zz1 with + | Eop (Oshift s) (t1:::Enil) => notint_case1 s t1 + | Eop Onot (t1:::Enil) => notint_case2 t1 + | Eop (Onotshift s) (t1:::Enil) => notint_case3 s t1 + | e => notint_default e + end. Definition notint (e: expr) := match notint_match e with - | notint_case1 s t1 => + | notint_case1 s t1 => (* Eop (Oshift s) (t1:::Enil) *) Eop (Onotshift s) (t1:::Enil) - | notint_case2 t1 => + | notint_case2 t1 => (* Eop Onot (t1:::Enil) *) t1 - | notint_case3 s t1 => + | notint_case3 s t1 => (* Eop (Onotshift s) (t1:::Enil) *) Eop (Oshift s) (t1:::Enil) | notint_default e => Eop Onot (e:::Enil) end. -(** This programming pattern will be applied systematically for the - other smart constructors in this file. *) (** ** Boolean negation *) -Definition notbool_base (e: expr) := - Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil). - Fixpoint notbool (e: expr) {struct e} : expr := + let default := Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil) in match e with | Eop (Ointconst n) Enil => Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil @@ -157,15 +111,14 @@ Fixpoint notbool (e: expr) {struct e} : expr := | Econdition e1 e2 e3 => Econdition e1 (notbool e2) (notbool e3) | _ => - notbool_base e + default end. (** ** Integer addition and pointer addition *) -(** Addition of an integer constant. *) - -(* -Definition addimm (n: int) (e: expr) := +(** Original definition: +<< +Nondetfunction addimm (n: int) (e: expr) := if Int.eq n Int.zero then e else match e with | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil @@ -174,372 +127,292 @@ Definition addimm (n: int) (e: expr) := | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) | _ => Eop (Oaddimm n) (e ::: Enil) end. +>> *) Inductive addimm_cases: forall (e: expr), Type := - | addimm_case1: - forall m, - addimm_cases (Eop (Ointconst m) Enil) - | addimm_case2: - forall s m, - addimm_cases (Eop (Oaddrsymbol s m) Enil) - | addimm_case3: - forall m, - addimm_cases (Eop (Oaddrstack m) Enil) - | addimm_case4: - forall m t, - addimm_cases (Eop (Oaddimm m) (t ::: Enil)) - | addimm_default: - forall (e: expr), - addimm_cases e. + | addimm_case1: forall m, addimm_cases (Eop (Ointconst m) Enil) + | addimm_case2: forall s m, addimm_cases (Eop (Oaddrsymbol s m) Enil) + | addimm_case3: forall m, addimm_cases (Eop (Oaddrstack m) Enil) + | addimm_case4: forall m t, addimm_cases (Eop (Oaddimm m) (t ::: Enil)) + | addimm_default: forall (e: expr), addimm_cases e. Definition addimm_match (e: expr) := - match e as z1 return addimm_cases z1 with - | Eop (Ointconst m) Enil => - addimm_case1 m - | Eop (Oaddrsymbol s m) Enil => - addimm_case2 s m - | Eop (Oaddrstack m) Enil => - addimm_case3 m - | Eop (Oaddimm m) (t ::: Enil) => - addimm_case4 m t - | e => - addimm_default e + match e as zz1 return addimm_cases zz1 with + | Eop (Ointconst m) Enil => addimm_case1 m + | Eop (Oaddrsymbol s m) Enil => addimm_case2 s m + | Eop (Oaddrstack m) Enil => addimm_case3 m + | Eop (Oaddimm m) (t ::: Enil) => addimm_case4 m t + | e => addimm_default e end. Definition addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match addimm_match e with - | addimm_case1 m => + if Int.eq n Int.zero then e else match addimm_match e with + | addimm_case1 m => (* Eop (Ointconst m) Enil *) Eop (Ointconst(Int.add n m)) Enil - | addimm_case2 s m => + | addimm_case2 s m => (* Eop (Oaddrsymbol s m) Enil *) Eop (Oaddrsymbol s (Int.add n m)) Enil - | addimm_case3 m => + | addimm_case3 m => (* Eop (Oaddrstack m) Enil *) Eop (Oaddrstack (Int.add n m)) Enil - | addimm_case4 m t => + | addimm_case4 m t => (* Eop (Oaddimm m) (t ::: Enil) *) Eop (Oaddimm(Int.add n m)) (t ::: Enil) | addimm_default e => Eop (Oaddimm n) (e ::: Enil) end. -(** Addition of two integer or pointer expressions. *) -(* -Definition add (e1: expr) (e2: expr) := +(** Original definition: +<< +Nondetfunction add (e1: expr) (e2: expr) := match e1, e2 with | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) - | Eop(Oaddimm n1) (t1:::Enil)), t2 => addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | Eop(Oaddimm n1) (t1:::Enil), t2 => addimm n1 (Eop Oadd (t1:::t2:::Enil)) | t1, Eop (Ointconst n2) Enil => addimm n2 t1 | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm n2 (Eop Oadd (t1:::t2:::Enil)) | Eop (Oshift s) (t1:::Enil), t2 => Eop (Oaddshift s) (t2:::t1:::Enil) | t1, Eop (Oshift s) (t2:::Enil) => Eop (Oaddshift s) (t1:::t2:::Enil) | _, _ => Eop Oadd (e1:::e2:::Enil) end. +>> *) Inductive add_cases: forall (e1: expr) (e2: expr), Type := - | add_case1: - forall n1 t2, - add_cases (Eop (Ointconst n1) Enil) (t2) - | add_case2: - forall n1 t1 n2 t2, - add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) - | add_case3: - forall n1 t1 t2, - add_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) - | add_case4: - forall t1 n2, - add_cases (t1) (Eop (Ointconst n2) Enil) - | add_case5: - forall t1 n2 t2, - add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) - | add_case6: - forall s t1 t2, - add_cases (Eop (Oshift s) (t1:::Enil)) (t2) - | add_case7: - forall t1 s t2, - add_cases (t1) (Eop (Oshift s) (t2:::Enil)) - | add_default: - forall (e1: expr) (e2: expr), - add_cases e1 e2. + | add_case1: forall n1 t2, add_cases (Eop (Ointconst n1) Enil) (t2) + | add_case2: forall n1 t1 n2 t2, add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) + | add_case3: forall n1 t1 t2, add_cases (Eop(Oaddimm n1) (t1:::Enil)) (t2) + | add_case4: forall t1 n2, add_cases (t1) (Eop (Ointconst n2) Enil) + | add_case5: forall t1 n2 t2, add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) + | add_case6: forall s t1 t2, add_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | add_case7: forall t1 s t2, add_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | add_default: forall (e1: expr) (e2: expr), add_cases e1 e2. Definition add_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return add_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - add_case1 n1 t2 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => - add_case2 n1 t1 n2 t2 - | Eop(Oaddimm n1) (t1:::Enil), t2 => - add_case3 n1 t1 t2 - | t1, Eop (Ointconst n2) Enil => - add_case4 t1 n2 - | t1, Eop (Oaddimm n2) (t2:::Enil) => - add_case5 t1 n2 t2 - | Eop (Oshift s) (t1:::Enil), t2 => - add_case6 s t1 t2 - | t1, Eop (Oshift s) (t2:::Enil) => - add_case7 t1 s t2 - | e1, e2 => - add_default e1 e2 + match e1 as zz1, e2 as zz2 return add_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => add_case1 n1 t2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => add_case2 n1 t1 n2 t2 + | Eop(Oaddimm n1) (t1:::Enil), t2 => add_case3 n1 t1 t2 + | t1, Eop (Ointconst n2) Enil => add_case4 t1 n2 + | t1, Eop (Oaddimm n2) (t2:::Enil) => add_case5 t1 n2 t2 + | Eop (Oshift s) (t1:::Enil), t2 => add_case6 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => add_case7 t1 s t2 + | e1, e2 => add_default e1 e2 end. Definition add (e1: expr) (e2: expr) := match add_match e1 e2 with - | add_case1 n1 t2 => + | add_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) addimm n1 t2 - | add_case2 n1 t1 n2 t2 => + | add_case2 n1 t1 n2 t2 => (* Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) *) addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) - | add_case3 n1 t1 t2 => + | add_case3 n1 t1 t2 => (* Eop(Oaddimm n1) (t1:::Enil), t2 *) addimm n1 (Eop Oadd (t1:::t2:::Enil)) - | add_case4 t1 n2 => + | add_case4 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) addimm n2 t1 - | add_case5 t1 n2 t2 => + | add_case5 t1 n2 t2 => (* t1, Eop (Oaddimm n2) (t2:::Enil) *) addimm n2 (Eop Oadd (t1:::t2:::Enil)) - | add_case6 s t1 t2 => + | add_case6 s t1 t2 => (* Eop (Oshift s) (t1:::Enil), t2 *) Eop (Oaddshift s) (t2:::t1:::Enil) - | add_case7 t1 s t2 => + | add_case7 t1 s t2 => (* t1, Eop (Oshift s) (t2:::Enil) *) Eop (Oaddshift s) (t1:::t2:::Enil) | add_default e1 e2 => Eop Oadd (e1:::e2:::Enil) end. + (** ** Integer and pointer subtraction *) -(* -Definition sub (e1: expr) (e2: expr) := +(** Original definition: +<< +Nondetfunction sub (e1: expr) (e2: expr) := match e1, e2 with | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => addimm (intsub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | Eop (Oaddimm n1) (t1:::Enil), t2 => addimm n1 (Eop Osub (t1:::t2:::Rnil)) - | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1::::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) | Eop (Ointconst n1) Enil, t2 => Eop (Orsubimm n1) (t2:::Enil) | Eop (Oshift s) (t1:::Enil), t2 => Eop (Orsubshift s) (t2:::t1:::Enil) | t1, Eop (Oshift s) (t2:::Enil) => Eop (Osubshift s) (t1:::t2:::Enil) | _, _ => Eop Osub (e1:::e2:::Enil) end. +>> *) Inductive sub_cases: forall (e1: expr) (e2: expr), Type := - | sub_case1: - forall t1 n2, - sub_cases (t1) (Eop (Ointconst n2) Enil) - | sub_case2: - forall n1 t1 n2 t2, - sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) - | sub_case3: - forall n1 t1 t2, - sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) - | sub_case4: - forall t1 n2 t2, - sub_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) - | sub_case5: - forall n1 t2, - sub_cases (Eop (Ointconst n1) Enil) (t2) - | sub_case6: - forall s t1 t2, - sub_cases (Eop (Oshift s) (t1:::Enil)) (t2) - | sub_case7: - forall t1 s t2, - sub_cases (t1) (Eop (Oshift s) (t2:::Enil)) - | sub_default: - forall (e1: expr) (e2: expr), - sub_cases e1 e2. + | sub_case1: forall t1 n2, sub_cases (t1) (Eop (Ointconst n2) Enil) + | sub_case2: forall n1 t1 n2 t2, sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) + | sub_case3: forall n1 t1 t2, sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) + | sub_case4: forall t1 n2 t2, sub_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) + | sub_case5: forall n1 t2, sub_cases (Eop (Ointconst n1) Enil) (t2) + | sub_case6: forall s t1 t2, sub_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | sub_case7: forall t1 s t2, sub_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | sub_default: forall (e1: expr) (e2: expr), sub_cases e1 e2. Definition sub_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return sub_cases z1 z2 with - | t1, Eop (Ointconst n2) Enil => - sub_case1 t1 n2 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => - sub_case2 n1 t1 n2 t2 - | Eop (Oaddimm n1) (t1:::Enil), t2 => - sub_case3 n1 t1 t2 - | t1, Eop (Oaddimm n2) (t2:::Enil) => - sub_case4 t1 n2 t2 - | Eop (Ointconst n1) Enil, t2 => - sub_case5 n1 t2 - | Eop (Oshift s) (t1:::Enil), t2 => - sub_case6 s t1 t2 - | t1, Eop (Oshift s) (t2:::Enil) => - sub_case7 t1 s t2 - | e1, e2 => - sub_default e1 e2 + match e1 as zz1, e2 as zz2 return sub_cases zz1 zz2 with + | t1, Eop (Ointconst n2) Enil => sub_case1 t1 n2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => sub_case2 n1 t1 n2 t2 + | Eop (Oaddimm n1) (t1:::Enil), t2 => sub_case3 n1 t1 t2 + | t1, Eop (Oaddimm n2) (t2:::Enil) => sub_case4 t1 n2 t2 + | Eop (Ointconst n1) Enil, t2 => sub_case5 n1 t2 + | Eop (Oshift s) (t1:::Enil), t2 => sub_case6 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => sub_case7 t1 s t2 + | e1, e2 => sub_default e1 e2 end. Definition sub (e1: expr) (e2: expr) := match sub_match e1 e2 with - | sub_case1 t1 n2 => + | sub_case1 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) addimm (Int.neg n2) t1 - | sub_case2 n1 t1 n2 t2 => + | sub_case2 n1 t1 n2 t2 => (* Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) *) addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | sub_case3 n1 t1 t2 => + | sub_case3 n1 t1 t2 => (* Eop (Oaddimm n1) (t1:::Enil), t2 *) addimm n1 (Eop Osub (t1:::t2:::Enil)) - | sub_case4 t1 n2 t2 => + | sub_case4 t1 n2 t2 => (* t1, Eop (Oaddimm n2) (t2:::Enil) *) addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) - | sub_case5 n1 t2 => + | sub_case5 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) Eop (Orsubimm n1) (t2:::Enil) - | sub_case6 s t1 t2 => + | sub_case6 s t1 t2 => (* Eop (Oshift s) (t1:::Enil), t2 *) Eop (Orsubshift s) (t2:::t1:::Enil) - | sub_case7 t1 s t2 => + | sub_case7 t1 s t2 => (* t1, Eop (Oshift s) (t2:::Enil) *) Eop (Osubshift s) (t1:::t2:::Enil) | sub_default e1 e2 => Eop Osub (e1:::e2:::Enil) end. + +Definition negint (e: expr) := Eop (Orsubimm Int.zero) (e ::: Enil). + (** ** Immediate shifts *) -(* -Definition shlimm (e1: expr) := - if Int.eq n Int.zero then e1 else - match e1 with - | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shl n1 n)) - | Eop (Oshift (Olsl n1)) (t1:::Enil) => if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshift (Olsl (Int.add n n1))) (t1:::Enil) else Eop (Oshift (Olsl n)) (e1:::Enil) - | _ => Eop (Oshift (Olsl n)) (e1:::Enil) - end. +(** Original definition: +<< +Nondetfunction shlimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shl n1 n)) Enil + | Eop (Oshift (Slsl n1)) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshift (Slsl (mk_shift_amount(Int.add n n1)))) (t1:::Enil) + else Eop (Oshift (Slsl (mk_shift_amount n))) (e1:::Enil) + | _ => Eop (Oshift (Slsl (mk_shift_amount n))) (e1:::Enil) + end. +>> *) -Inductive shlimm_cases: forall (e1: expr), Type := - | shlimm_case1: - forall n1, - shlimm_cases (Eop (Ointconst n1) Enil) - | shlimm_case2: - forall n1 t1, - shlimm_cases (Eop (Oshift (Slsl n1)) (t1:::Enil)) - | shlimm_default: - forall (e1: expr), - shlimm_cases e1. - -Definition shlimm_match (e1: expr) := - match e1 as z1 return shlimm_cases z1 with - | Eop (Ointconst n1) Enil => - shlimm_case1 n1 - | Eop (Oshift (Slsl n1)) (t1:::Enil) => - shlimm_case2 n1 t1 - | e1 => - shlimm_default e1 +Inductive shlimm_cases: forall (e1: expr) , Type := + | shlimm_case1: forall n1, shlimm_cases (Eop (Ointconst n1) Enil) + | shlimm_case2: forall n1 t1, shlimm_cases (Eop (Oshift (Slsl n1)) (t1:::Enil)) + | shlimm_default: forall (e1: expr) , shlimm_cases e1. + +Definition shlimm_match (e1: expr) := + match e1 as zz1 return shlimm_cases zz1 with + | Eop (Ointconst n1) Enil => shlimm_case1 n1 + | Eop (Oshift (Slsl n1)) (t1:::Enil) => shlimm_case2 n1 t1 + | e1 => shlimm_default e1 end. Definition shlimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else - match is_shift_amount n with - | None => Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) - | Some n' => - match shlimm_match e1 with - | shlimm_case1 n1 => - Eop (Ointconst(Int.shl n1 n)) Enil - | shlimm_case2 n1 t1 => - match is_shift_amount (Int.add n (s_amount n1)) with - | None => - Eop (Oshift (Slsl n')) (e1:::Enil) - | Some n'' => - Eop (Oshift (Slsl n'')) (t1:::Enil) - end - | shlimm_default e1 => - Eop (Oshift (Slsl n')) (e1:::Enil) - end - end. - -(* -Definition shruimm (e1: expr) := - if Int.eq n Int.zero then e1 else - match e1 with - | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shru n1 n)) - | Eop (Oshift (Olsr n1)) (t1:::Enil) => if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshift (Olsr (Int.add n n1))) (t1:::Enil) else Eop (Oshift (Olsr n)) (e1:::Enil) - | _ => Eop (Oshift (Olsr n)) (e1:::Enil) + if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int.iwordsize) then Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shlimm_match e1 with + | shlimm_case1 n1 => (* Eop (Ointconst n1) Enil *) + Eop (Ointconst(Int.shl n1 n)) Enil + | shlimm_case2 n1 t1 => (* Eop (Oshift (Slsl n1)) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshift (Slsl (mk_shift_amount(Int.add n n1)))) (t1:::Enil) else Eop (Oshift (Slsl (mk_shift_amount n))) (e1:::Enil) + | shlimm_default e1 => + Eop (Oshift (Slsl (mk_shift_amount n))) (e1:::Enil) end. + + +(** Original definition: +<< +Nondetfunction shruimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shru n1 n)) Enil + | Eop (Oshift (Slsr n1)) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshift (Slsr (mk_shift_amount (Int.add n n1)))) (t1:::Enil) + else Eop (Oshift (Slsr (mk_shift_amount n))) (e1:::Enil) + | _ => Eop (Oshift (Slsr (mk_shift_amount n))) (e1:::Enil) + end. +>> *) -Inductive shruimm_cases: forall (e1: expr), Type := - | shruimm_case1: - forall n1, - shruimm_cases (Eop (Ointconst n1) Enil) - | shruimm_case2: - forall n1 t1, - shruimm_cases (Eop (Oshift (Slsr n1)) (t1:::Enil)) - | shruimm_default: - forall (e1: expr), - shruimm_cases e1. - -Definition shruimm_match (e1: expr) := - match e1 as z1 return shruimm_cases z1 with - | Eop (Ointconst n1) Enil => - shruimm_case1 n1 - | Eop (Oshift (Slsr n1)) (t1:::Enil) => - shruimm_case2 n1 t1 - | e1 => - shruimm_default e1 +Inductive shruimm_cases: forall (e1: expr) , Type := + | shruimm_case1: forall n1, shruimm_cases (Eop (Ointconst n1) Enil) + | shruimm_case2: forall n1 t1, shruimm_cases (Eop (Oshift (Slsr n1)) (t1:::Enil)) + | shruimm_default: forall (e1: expr) , shruimm_cases e1. + +Definition shruimm_match (e1: expr) := + match e1 as zz1 return shruimm_cases zz1 with + | Eop (Ointconst n1) Enil => shruimm_case1 n1 + | Eop (Oshift (Slsr n1)) (t1:::Enil) => shruimm_case2 n1 t1 + | e1 => shruimm_default e1 end. Definition shruimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else - match is_shift_amount n with - | None => Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) - | Some n' => - match shruimm_match e1 with - | shruimm_case1 n1 => - Eop (Ointconst(Int.shru n1 n)) Enil - | shruimm_case2 n1 t1 => - match is_shift_amount (Int.add n (s_amount n1)) with - | None => - Eop (Oshift (Slsr n')) (e1:::Enil) - | Some n'' => - Eop (Oshift (Slsr n'')) (t1:::Enil) - end - | shruimm_default e1 => - Eop (Oshift (Slsr n')) (e1:::Enil) - end - end. - -(* -Definition shrimm (e1: expr) := - match e1 with - | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shr n1 n)) - | Eop (Oshift (Oasr n1)) (t1:::Enil) => if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshift (Oasr (Int.add n n1))) (t1:::Enil) else Eop (Oshift (Oasr n)) (e1:::Enil) - | _ => Eop (Oshift (Oasr n)) (e1:::Enil) + if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int.iwordsize) then Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shruimm_match e1 with + | shruimm_case1 n1 => (* Eop (Ointconst n1) Enil *) + Eop (Ointconst(Int.shru n1 n)) Enil + | shruimm_case2 n1 t1 => (* Eop (Oshift (Slsr n1)) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshift (Slsr (mk_shift_amount (Int.add n n1)))) (t1:::Enil) else Eop (Oshift (Slsr (mk_shift_amount n))) (e1:::Enil) + | shruimm_default e1 => + Eop (Oshift (Slsr (mk_shift_amount n))) (e1:::Enil) end. + + +(** Original definition: +<< +Nondetfunction shrimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else + match e1 with + | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shr n1 n)) Enil + | Eop (Oshift (Sasr n1)) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshift (Sasr (mk_shift_amount (Int.add n n1)))) (t1:::Enil) + else Eop (Oshift (Sasr (mk_shift_amount n))) (e1:::Enil) + | _ => Eop (Oshift (Sasr (mk_shift_amount n))) (e1:::Enil) + end. +>> *) -Inductive shrimm_cases: forall (e1: expr), Type := - | shrimm_case1: - forall n1, - shrimm_cases (Eop (Ointconst n1) Enil) - | shrimm_case2: - forall n1 t1, - shrimm_cases (Eop (Oshift (Sasr n1)) (t1:::Enil)) - | shrimm_default: - forall (e1: expr), - shrimm_cases e1. - -Definition shrimm_match (e1: expr) := - match e1 as z1 return shrimm_cases z1 with - | Eop (Ointconst n1) Enil => - shrimm_case1 n1 - | Eop (Oshift (Sasr n1)) (t1:::Enil) => - shrimm_case2 n1 t1 - | e1 => - shrimm_default e1 +Inductive shrimm_cases: forall (e1: expr) , Type := + | shrimm_case1: forall n1, shrimm_cases (Eop (Ointconst n1) Enil) + | shrimm_case2: forall n1 t1, shrimm_cases (Eop (Oshift (Sasr n1)) (t1:::Enil)) + | shrimm_default: forall (e1: expr) , shrimm_cases e1. + +Definition shrimm_match (e1: expr) := + match e1 as zz1 return shrimm_cases zz1 with + | Eop (Ointconst n1) Enil => shrimm_case1 n1 + | Eop (Oshift (Sasr n1)) (t1:::Enil) => shrimm_case2 n1 t1 + | e1 => shrimm_default e1 end. Definition shrimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else - match is_shift_amount n with - | None => Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) - | Some n' => - match shrimm_match e1 with - | shrimm_case1 n1 => - Eop (Ointconst(Int.shr n1 n)) Enil - | shrimm_case2 n1 t1 => - match is_shift_amount (Int.add n (s_amount n1)) with - | None => - Eop (Oshift (Sasr n')) (e1:::Enil) - | Some n'' => - Eop (Oshift (Sasr n'')) (t1:::Enil) - end - | shrimm_default e1 => - Eop (Oshift (Sasr n')) (e1:::Enil) - end + if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int.iwordsize) then Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shrimm_match e1 with + | shrimm_case1 n1 => (* Eop (Ointconst n1) Enil *) + Eop (Ointconst(Int.shr n1 n)) Enil + | shrimm_case2 n1 t1 => (* Eop (Oshift (Sasr n1)) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshift (Sasr (mk_shift_amount (Int.add n n1)))) (t1:::Enil) else Eop (Oshift (Sasr (mk_shift_amount n))) (e1:::Enil) + | shrimm_default e1 => + Eop (Oshift (Sasr (mk_shift_amount n))) (e1:::Enil) end. + (** ** Integer multiply *) Definition mulimm_base (n1: int) (e2: expr) := @@ -553,170 +426,122 @@ Definition mulimm_base (n1: int) (e2: expr) := Eop Omul (Eop (Ointconst n1) Enil ::: e2 ::: Enil) end. -(* -Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then - Eop (Ointconst Int.zero) Enil - else if Int.eq n1 Int.one then - e2 +(** Original definition: +<< +Nondetfunction mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.one then e2 else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil - | Eop (Oaddimm n2) (t2:::Enil) => addimm (intmul n1 n2) (mulimm_base n1 t2) + | Eop (Ointconst n2) Enil => Eop (Ointconst(Int.mul n1 n2)) Enil + | Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) | _ => mulimm_base n1 e2 end. +>> *) Inductive mulimm_cases: forall (e2: expr), Type := - | mulimm_case1: - forall (n2: int), - mulimm_cases (Eop (Ointconst n2) Enil) - | mulimm_case2: - forall (n2: int) (t2: expr), - mulimm_cases (Eop (Oaddimm n2) (t2:::Enil)) - | mulimm_default: - forall (e2: expr), - mulimm_cases e2. + | mulimm_case1: forall n2, mulimm_cases (Eop (Ointconst n2) Enil) + | mulimm_case2: forall n2 t2, mulimm_cases (Eop (Oaddimm n2) (t2:::Enil)) + | mulimm_default: forall (e2: expr), mulimm_cases e2. Definition mulimm_match (e2: expr) := - match e2 as z1 return mulimm_cases z1 with - | Eop (Ointconst n2) Enil => - mulimm_case1 n2 - | Eop (Oaddimm n2) (t2:::Enil) => - mulimm_case2 n2 t2 - | e2 => - mulimm_default e2 + match e2 as zz1 return mulimm_cases zz1 with + | Eop (Ointconst n2) Enil => mulimm_case1 n2 + | Eop (Oaddimm n2) (t2:::Enil) => mulimm_case2 n2 t2 + | e2 => mulimm_default e2 end. Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then - Eop (Ointconst Int.zero) Enil - else if Int.eq n1 Int.one then - e2 - else match mulimm_match e2 with - | mulimm_case1 n2 => + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil else if Int.eq n1 Int.one then e2 else match mulimm_match e2 with + | mulimm_case1 n2 => (* Eop (Ointconst n2) Enil *) Eop (Ointconst(Int.mul n1 n2)) Enil - | mulimm_case2 n2 t2 => + | mulimm_case2 n2 t2 => (* Eop (Oaddimm n2) (t2:::Enil) *) addimm (Int.mul n1 n2) (mulimm_base n1 t2) | mulimm_default e2 => mulimm_base n1 e2 end. -(* -Definition mul (e1: expr) (e2: expr) := + +(** Original definition: +<< +Nondetfunction mul (e1: expr) (e2: expr) := match e1, e2 with | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 | _, _ => Eop Omul (e1:::e2:::Enil) end. +>> *) Inductive mul_cases: forall (e1: expr) (e2: expr), Type := - | mul_case1: - forall (n1: int) (t2: expr), - mul_cases (Eop (Ointconst n1) Enil) (t2) - | mul_case2: - forall (t1: expr) (n2: int), - mul_cases (t1) (Eop (Ointconst n2) Enil) - | mul_default: - forall (e1: expr) (e2: expr), - mul_cases e1 e2. - -Definition mul_match_aux (e1: expr) (e2: expr) := - match e2 as z2 return mul_cases e1 z2 with - | Eop (Ointconst n2) Enil => - mul_case2 e1 n2 - | e2 => - mul_default e1 e2 - end. + | mul_case1: forall n1 t2, mul_cases (Eop (Ointconst n1) Enil) (t2) + | mul_case2: forall t1 n2, mul_cases (t1) (Eop (Ointconst n2) Enil) + | mul_default: forall (e1: expr) (e2: expr), mul_cases e1 e2. Definition mul_match (e1: expr) (e2: expr) := - match e1 as z1 return mul_cases z1 e2 with - | Eop (Ointconst n1) Enil => - mul_case1 n1 e2 - | e1 => - mul_match_aux e1 e2 + match e1 as zz1, e2 as zz2 return mul_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => mul_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => mul_case2 t1 n2 + | e1, e2 => mul_default e1 e2 end. Definition mul (e1: expr) (e2: expr) := match mul_match e1 e2 with - | mul_case1 n1 t2 => + | mul_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) mulimm n1 t2 - | mul_case2 t1 n2 => + | mul_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) mulimm n2 t1 | mul_default e1 e2 => Eop Omul (e1:::e2:::Enil) end. -(** ** Integer division and modulus *) - -Definition mod_aux (divop: operation) (e1 e2: expr) := - Elet e1 - (Elet (lift e2) - (Eop Osub (Eletvar 1 ::: - Eop Omul (Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) ::: - Eletvar 0 ::: - Enil) ::: - Enil))). -Inductive divu_cases: forall (e2: expr), Type := - | divu_case1: - forall (n2: int), - divu_cases (Eop (Ointconst n2) Enil) - | divu_default: - forall (e2: expr), - divu_cases e2. +(** ** Bitwise and, or, xor *) -Definition divu_match (e2: expr) := - match e2 as z1 return divu_cases z1 with +(** Original definition: +<< +Nondetfunction andimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil else + match e2 with | Eop (Ointconst n2) Enil => - divu_case1 n2 - | e2 => - divu_default e2 + Eop (Ointconst (Int.and n1 n2)) Enil + | Eop (Oandimm n2) (t2:::Enil) => + Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | _ => + Eop (Oandimm n1) (e2:::Enil) end. +>> +*) -Definition divu (e1: expr) (e2: expr) := - match divu_match e2 with - | divu_case1 n2 => - match Int.is_power2 n2 with - | Some l2 => shruimm e1 l2 - | None => Eop Odivu (e1:::e2:::Enil) - end - | divu_default e2 => - Eop Odivu (e1:::e2:::Enil) - end. +Inductive andimm_cases: forall (e2: expr), Type := + | andimm_case1: forall n2, andimm_cases (Eop (Ointconst n2) Enil) + | andimm_case2: forall n2 t2, andimm_cases (Eop (Oandimm n2) (t2:::Enil)) + | andimm_default: forall (e2: expr), andimm_cases e2. -Definition modu (e1: expr) (e2: expr) := - match divu_match e2 with - | divu_case1 n2 => - match Int.is_power2 n2 with - | Some l2 => Eop (Oandimm (Int.sub n2 Int.one)) (e1:::Enil) - | None => mod_aux Odivu e1 e2 - end - | divu_default e2 => - mod_aux Odivu e1 e2 +Definition andimm_match (e2: expr) := + match e2 as zz1 return andimm_cases zz1 with + | Eop (Ointconst n2) Enil => andimm_case1 n2 + | Eop (Oandimm n2) (t2:::Enil) => andimm_case2 n2 t2 + | e2 => andimm_default e2 end. -Definition divs (e1: expr) (e2: expr) := - match divu_match e2 with - | divu_case1 n2 => - match Int.is_power2 n2 with - | Some l2 => if Int.ltu l2 (Int.repr 31) - then Eop (Oshrximm l2) (e1:::Enil) - else Eop Odiv (e1:::e2:::Enil) - | None => Eop Odiv (e1:::e2:::Enil) - end - | divu_default e2 => - Eop Odiv (e1:::e2:::Enil) +Definition andimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil else match andimm_match e2 with + | andimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.and n1 n2)) Enil + | andimm_case2 n2 t2 => (* Eop (Oandimm n2) (t2:::Enil) *) + Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | andimm_default e2 => + Eop (Oandimm n1) (e2:::Enil) end. -Definition mods := mod_aux Odiv. (* could be improved *) - -(** ** Bitwise and, or, xor *) - -(* -Definition and (e1: expr) (e2: expr) := +(** Original definition: +<< +Nondetfunction and (e1: expr) (e2: expr) := match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 + | t1, Eop (Ointconst n2) Enil => andimm n2 t1 | Eop (Oshift s) (t1:::Enil), t2 => Eop (Oandshift s) (t2:::t1:::Enil) | t1, Eop (Oshift s) (t2:::Enil) => Eop (Oandshift s) (t1:::t2:::Enil) | Eop (Onotshift s) (t1:::Enil), t2 => Eop (Obicshift s) (t2:::t1:::Enil) @@ -725,362 +550,551 @@ Definition and (e1: expr) (e2: expr) := | t1, Eop Onot (t2:::Enil) => Eop Obic (t1:::t2:::Enil) | _, _ => Eop Oand (e1:::e2:::Enil) end. +>> *) Inductive and_cases: forall (e1: expr) (e2: expr), Type := - | and_case1: - forall s t1 t2, - and_cases (Eop (Oshift s) (t1:::Enil)) (t2) - | and_case2: - forall t1 s t2, - and_cases (t1) (Eop (Oshift s) (t2:::Enil)) - | and_case3: - forall s t1 t2, - and_cases (Eop (Onotshift s) (t1:::Enil)) (t2) - | and_case4: - forall t1 s t2, - and_cases (t1) (Eop (Onotshift s) (t2:::Enil)) - | and_case5: - forall t1 t2, - and_cases (Eop Onot (t1:::Enil)) (t2) - | and_case6: - forall t1 t2, - and_cases (t1) (Eop Onot (t2:::Enil)) - | and_default: - forall (e1: expr) (e2: expr), - and_cases e1 e2. + | and_case1: forall n1 t2, and_cases (Eop (Ointconst n1) Enil) (t2) + | and_case2: forall t1 n2, and_cases (t1) (Eop (Ointconst n2) Enil) + | and_case3: forall s t1 t2, and_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | and_case4: forall t1 s t2, and_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | and_case5: forall s t1 t2, and_cases (Eop (Onotshift s) (t1:::Enil)) (t2) + | and_case6: forall t1 s t2, and_cases (t1) (Eop (Onotshift s) (t2:::Enil)) + | and_case7: forall t1 t2, and_cases (Eop Onot (t1:::Enil)) (t2) + | and_case8: forall t1 t2, and_cases (t1) (Eop Onot (t2:::Enil)) + | and_default: forall (e1: expr) (e2: expr), and_cases e1 e2. Definition and_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return and_cases z1 z2 with - | Eop (Oshift s) (t1:::Enil), t2 => - and_case1 s t1 t2 - | t1, Eop (Oshift s) (t2:::Enil) => - and_case2 t1 s t2 - | Eop (Onotshift s) (t1:::Enil), t2 => - and_case3 s t1 t2 - | t1, Eop (Onotshift s) (t2:::Enil) => - and_case4 t1 s t2 - | Eop Onot (t1:::Enil), t2 => - and_case5 t1 t2 - | t1, Eop Onot (t2:::Enil) => - and_case6 t1 t2 - | e1, e2 => - and_default e1 e2 + match e1 as zz1, e2 as zz2 return and_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => and_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => and_case2 t1 n2 + | Eop (Oshift s) (t1:::Enil), t2 => and_case3 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => and_case4 t1 s t2 + | Eop (Onotshift s) (t1:::Enil), t2 => and_case5 s t1 t2 + | t1, Eop (Onotshift s) (t2:::Enil) => and_case6 t1 s t2 + | Eop Onot (t1:::Enil), t2 => and_case7 t1 t2 + | t1, Eop Onot (t2:::Enil) => and_case8 t1 t2 + | e1, e2 => and_default e1 e2 end. Definition and (e1: expr) (e2: expr) := match and_match e1 e2 with - | and_case1 s t1 t2 => + | and_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + andimm n1 t2 + | and_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + andimm n2 t1 + | and_case3 s t1 t2 => (* Eop (Oshift s) (t1:::Enil), t2 *) Eop (Oandshift s) (t2:::t1:::Enil) - | and_case2 t1 s t2 => + | and_case4 t1 s t2 => (* t1, Eop (Oshift s) (t2:::Enil) *) Eop (Oandshift s) (t1:::t2:::Enil) - | and_case3 s t1 t2 => + | and_case5 s t1 t2 => (* Eop (Onotshift s) (t1:::Enil), t2 *) Eop (Obicshift s) (t2:::t1:::Enil) - | and_case4 t1 s t2 => + | and_case6 t1 s t2 => (* t1, Eop (Onotshift s) (t2:::Enil) *) Eop (Obicshift s) (t1:::t2:::Enil) - | and_case5 t1 t2 => + | and_case7 t1 t2 => (* Eop Onot (t1:::Enil), t2 *) Eop Obic (t2:::t1:::Enil) - | and_case6 t1 t2 => + | and_case8 t1 t2 => (* t1, Eop Onot (t2:::Enil) *) Eop Obic (t1:::t2:::Enil) | and_default e1 e2 => Eop Oand (e1:::e2:::Enil) end. + Definition same_expr_pure (e1 e2: expr) := match e1, e2 with | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false | _, _ => false end. -(* -Definition or (e1: expr) (e2: expr) := +(** Original definition: +<< +Nondetfunction orimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else + match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil + | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorimm n1) (e2:::Enil) + end. +>> +*) + +Inductive orimm_cases: forall (e2: expr), Type := + | orimm_case1: forall n2, orimm_cases (Eop (Ointconst n2) Enil) + | orimm_case2: forall n2 t2, orimm_cases (Eop (Oorimm n2) (t2:::Enil)) + | orimm_default: forall (e2: expr), orimm_cases e2. + +Definition orimm_match (e2: expr) := + match e2 as zz1 return orimm_cases zz1 with + | Eop (Ointconst n2) Enil => orimm_case1 n2 + | Eop (Oorimm n2) (t2:::Enil) => orimm_case2 n2 t2 + | e2 => orimm_default e2 + end. + +Definition orimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else match orimm_match e2 with + | orimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.or n1 n2)) Enil + | orimm_case2 n2 t2 => (* Eop (Oorimm n2) (t2:::Enil) *) + Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | orimm_default e2 => + Eop (Oorimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction or (e1: expr) (e2: expr) := match e1, e2 with - | Eop (Oshift (Olsl n1) (t1:::Enil), Eop (Oshift (Olsr n2) (t2:::Enil)) => ... - | Eop (Oshift (Olsr n1) (t1:::Enil), Eop (Oshift (Olsl n2) (t2:::Enil)) => ... + | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 + | t1, Eop (Ointconst n2) Enil => orimm n2 t1 + | Eop (Oshift (Slsl n1)) (t1:::Enil), Eop (Oshift (Slsr n2)) (t2:::Enil) => + if Int.eq (Int.add n1 n2) Int.iwordsize + && same_expr_pure t1 t2 + then Eop (Oshift (Sror n2)) (t1:::Enil) + else Eop (Oorshift (Slsr n2)) (e1:::t2:::Enil) + | Eop (Oshift (Slsr n1)) (t1:::Enil), Eop (Oshift (Slsl n2)) (t2:::Enil) => + if Int.eq (Int.add n2 n1) Int.iwordsize + && same_expr_pure t1 t2 + then Eop (Oshift (Sror n1)) (t1:::Enil) + else Eop (Oorshift (Slsl n2)) (e1:::t2:::Enil) | Eop (Oshift s) (t1:::Enil), t2 => Eop (Oorshift s) (t2:::t1:::Enil) | t1, Eop (Oshift s) (t2:::Enil) => Eop (Oorshift s) (t1:::t2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. +>> *) Inductive or_cases: forall (e1: expr) (e2: expr), Type := - | or_case1: - forall n1 t1 n2 t2, - or_cases (Eop (Oshift (Slsl n1)) (t1:::Enil)) (Eop (Oshift (Slsr n2)) (t2:::Enil)) - | or_case2: - forall n1 t1 n2 t2, - or_cases (Eop (Oshift (Slsr n1)) (t1:::Enil)) (Eop (Oshift (Slsl n2)) (t2:::Enil)) - | or_case3: - forall s t1 t2, - or_cases (Eop (Oshift s) (t1:::Enil)) (t2) - | or_case4: - forall t1 s t2, - or_cases (t1) (Eop (Oshift s) (t2:::Enil)) - | or_default: - forall (e1: expr) (e2: expr), - or_cases e1 e2. + | or_case1: forall n1 t2, or_cases (Eop (Ointconst n1) Enil) (t2) + | or_case2: forall t1 n2, or_cases (t1) (Eop (Ointconst n2) Enil) + | or_case3: forall n1 t1 n2 t2, or_cases (Eop (Oshift (Slsl n1)) (t1:::Enil)) (Eop (Oshift (Slsr n2)) (t2:::Enil)) + | or_case4: forall n1 t1 n2 t2, or_cases (Eop (Oshift (Slsr n1)) (t1:::Enil)) (Eop (Oshift (Slsl n2)) (t2:::Enil)) + | or_case5: forall s t1 t2, or_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | or_case6: forall t1 s t2, or_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | or_default: forall (e1: expr) (e2: expr), or_cases e1 e2. Definition or_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return or_cases z1 z2 with - | Eop (Oshift (Slsl n1)) (t1:::Enil), Eop (Oshift (Slsr n2)) (t2:::Enil) => - or_case1 n1 t1 n2 t2 - | Eop (Oshift (Slsr n1)) (t1:::Enil), Eop (Oshift (Slsl n2)) (t2:::Enil) => - or_case2 n1 t1 n2 t2 - | Eop (Oshift s) (t1:::Enil), t2 => - or_case3 s t1 t2 - | t1, Eop (Oshift s) (t2:::Enil) => - or_case4 t1 s t2 - | e1, e2 => - or_default e1 e2 + match e1 as zz1, e2 as zz2 return or_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => or_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => or_case2 t1 n2 + | Eop (Oshift (Slsl n1)) (t1:::Enil), Eop (Oshift (Slsr n2)) (t2:::Enil) => or_case3 n1 t1 n2 t2 + | Eop (Oshift (Slsr n1)) (t1:::Enil), Eop (Oshift (Slsl n2)) (t2:::Enil) => or_case4 n1 t1 n2 t2 + | Eop (Oshift s) (t1:::Enil), t2 => or_case5 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => or_case6 t1 s t2 + | e1, e2 => or_default e1 e2 end. Definition or (e1: expr) (e2: expr) := match or_match e1 e2 with - | or_case1 n1 t1 n2 t2 => - if Int.eq (Int.add (s_amount n1) (s_amount n2)) Int.iwordsize - && same_expr_pure t1 t2 - then Eop (Oshift (Sror n2)) (t1:::Enil) - else Eop (Oorshift (Slsr n2)) (e1:::t2:::Enil) - | or_case2 n1 t1 n2 t2 => - if Int.eq (Int.add (s_amount n2) (s_amount n1)) Int.iwordsize - && same_expr_pure t1 t2 - then Eop (Oshift (Sror n1)) (t1:::Enil) - else Eop (Oorshift (Slsl n2)) (e1:::t2:::Enil) - | or_case3 s t1 t2 => + | or_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + orimm n1 t2 + | or_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + orimm n2 t1 + | or_case3 n1 t1 n2 t2 => (* Eop (Oshift (Slsl n1)) (t1:::Enil), Eop (Oshift (Slsr n2)) (t2:::Enil) *) + if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 then Eop (Oshift (Sror n2)) (t1:::Enil) else Eop (Oorshift (Slsr n2)) (e1:::t2:::Enil) + | or_case4 n1 t1 n2 t2 => (* Eop (Oshift (Slsr n1)) (t1:::Enil), Eop (Oshift (Slsl n2)) (t2:::Enil) *) + if Int.eq (Int.add n2 n1) Int.iwordsize && same_expr_pure t1 t2 then Eop (Oshift (Sror n1)) (t1:::Enil) else Eop (Oorshift (Slsl n2)) (e1:::t2:::Enil) + | or_case5 s t1 t2 => (* Eop (Oshift s) (t1:::Enil), t2 *) Eop (Oorshift s) (t2:::t1:::Enil) - | or_case4 t1 s t2 => + | or_case6 t1 s t2 => (* t1, Eop (Oshift s) (t2:::Enil) *) Eop (Oorshift s) (t1:::t2:::Enil) | or_default e1 e2 => Eop Oor (e1:::e2:::Enil) end. -(* -Definition xor (e1: expr) (e2: expr) := + +(** Original definition: +<< +Nondetfunction xorimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else + match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.xor n1 n2)) Enil + | Eop (Oxorimm n2) (t2:::Enil) => Eop (Oxorimm (Int.xor n1 n2)) (t2:::Enil) + | _ => Eop (Oxorimm n1) (e2:::Enil) + end. +>> +*) + +Inductive xorimm_cases: forall (e2: expr), Type := + | xorimm_case1: forall n2, xorimm_cases (Eop (Ointconst n2) Enil) + | xorimm_case2: forall n2 t2, xorimm_cases (Eop (Oxorimm n2) (t2:::Enil)) + | xorimm_default: forall (e2: expr), xorimm_cases e2. + +Definition xorimm_match (e2: expr) := + match e2 as zz1 return xorimm_cases zz1 with + | Eop (Ointconst n2) Enil => xorimm_case1 n2 + | Eop (Oxorimm n2) (t2:::Enil) => xorimm_case2 n2 t2 + | e2 => xorimm_default e2 + end. + +Definition xorimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else match xorimm_match e2 with + | xorimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.xor n1 n2)) Enil + | xorimm_case2 n2 t2 => (* Eop (Oxorimm n2) (t2:::Enil) *) + Eop (Oxorimm (Int.xor n1 n2)) (t2:::Enil) + | xorimm_default e2 => + Eop (Oxorimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction xor (e1: expr) (e2: expr) := match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2 + | t1, Eop (Ointconst n2) Enil => xorimm n2 t1 | Eop (Oshift s) (t1:::Enil), t2 => Eop (Oxorshift s) (t2:::t1:::Enil) | t1, Eop (Oshift s) (t2:::Enil) => Eop (Oxorshift s) (t1:::t2:::Enil) | _, _ => Eop Oxor (e1:::e2:::Enil) end. +>> *) Inductive xor_cases: forall (e1: expr) (e2: expr), Type := - | xor_case1: - forall s t1 t2, - xor_cases (Eop (Oshift s) (t1:::Enil)) (t2) - | xor_case2: - forall t1 s t2, - xor_cases (t1) (Eop (Oshift s) (t2:::Enil)) - | xor_default: - forall (e1: expr) (e2: expr), - xor_cases e1 e2. + | xor_case1: forall n1 t2, xor_cases (Eop (Ointconst n1) Enil) (t2) + | xor_case2: forall t1 n2, xor_cases (t1) (Eop (Ointconst n2) Enil) + | xor_case3: forall s t1 t2, xor_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | xor_case4: forall t1 s t2, xor_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | xor_default: forall (e1: expr) (e2: expr), xor_cases e1 e2. Definition xor_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return xor_cases z1 z2 with - | Eop (Oshift s) (t1:::Enil), t2 => - xor_case1 s t1 t2 - | t1, Eop (Oshift s) (t2:::Enil) => - xor_case2 t1 s t2 - | e1, e2 => - xor_default e1 e2 + match e1 as zz1, e2 as zz2 return xor_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => xor_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => xor_case2 t1 n2 + | Eop (Oshift s) (t1:::Enil), t2 => xor_case3 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => xor_case4 t1 s t2 + | e1, e2 => xor_default e1 e2 end. Definition xor (e1: expr) (e2: expr) := match xor_match e1 e2 with - | xor_case1 s t1 t2 => + | xor_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + xorimm n1 t2 + | xor_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + xorimm n2 t1 + | xor_case3 s t1 t2 => (* Eop (Oshift s) (t1:::Enil), t2 *) Eop (Oxorshift s) (t2:::t1:::Enil) - | xor_case2 t1 s t2 => + | xor_case4 t1 s t2 => (* t1, Eop (Oshift s) (t2:::Enil) *) Eop (Oxorshift s) (t1:::t2:::Enil) | xor_default e1 e2 => Eop Oxor (e1:::e2:::Enil) end. + +(** ** Integer division and modulus *) + +Definition mod_aux (divop: operation) (e1 e2: expr) := + Elet e1 + (Elet (lift e2) + (Eop Osub (Eletvar 1 ::: + Eop Omul (Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) ::: + Eletvar 0 ::: + Enil) ::: + Enil))). + +Definition divs (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). + +Definition mods := mod_aux Odiv. + +Definition divuimm (e: expr) (n: int) := + match Int.is_power2 n with + | Some l => shruimm e l + | None => Eop Odivu (e ::: Eop (Ointconst n) Enil ::: Enil) + end. + +(** Original definition: +<< +Nondetfunction divu (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => divuimm e1 n2 + | _ => Eop Odivu (e1:::e2:::Enil) + end. +>> +*) + +Inductive divu_cases: forall (e2: expr), Type := + | divu_case1: forall n2, divu_cases (Eop (Ointconst n2) Enil) + | divu_default: forall (e2: expr), divu_cases e2. + +Definition divu_match (e2: expr) := + match e2 as zz1 return divu_cases zz1 with + | Eop (Ointconst n2) Enil => divu_case1 n2 + | e2 => divu_default e2 + end. + +Definition divu (e1: expr) (e2: expr) := + match divu_match e2 with + | divu_case1 n2 => (* Eop (Ointconst n2) Enil *) + divuimm e1 n2 + | divu_default e2 => + Eop Odivu (e1:::e2:::Enil) + end. + + +Definition moduimm (e: expr) (n: int) := + match Int.is_power2 n with + | Some l => Eop (Oandimm (Int.sub n Int.one)) (e ::: Enil) + | None => mod_aux Odivu e (Eop (Ointconst n) Enil) + end. + +(** Original definition: +<< +Nondetfunction modu (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => moduimm e1 n2 + | _ => mod_aux Odivu e1 e2 + end. +>> +*) + +Inductive modu_cases: forall (e2: expr), Type := + | modu_case1: forall n2, modu_cases (Eop (Ointconst n2) Enil) + | modu_default: forall (e2: expr), modu_cases e2. + +Definition modu_match (e2: expr) := + match e2 as zz1 return modu_cases zz1 with + | Eop (Ointconst n2) Enil => modu_case1 n2 + | e2 => modu_default e2 + end. + +Definition modu (e1: expr) (e2: expr) := + match modu_match e2 with + | modu_case1 n2 => (* Eop (Ointconst n2) Enil *) + moduimm e1 n2 + | modu_default e2 => + mod_aux Odivu e1 e2 + end. + + (** ** General shifts *) -Inductive shift_cases: forall (e1: expr), Type := - | shift_case1: - forall (n2: int), - shift_cases (Eop (Ointconst n2) Enil) - | shift_default: - forall (e1: expr), - shift_cases e1. +(** Original definition: +<< +Nondetfunction shl (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shlimm e1 n2 + | _ => Eop Oshl (e1:::e2:::Enil) + end. +>> +*) + +Inductive shl_cases: forall (e2: expr), Type := + | shl_case1: forall n2, shl_cases (Eop (Ointconst n2) Enil) + | shl_default: forall (e2: expr), shl_cases e2. -Definition shift_match (e1: expr) := - match e1 as z1 return shift_cases z1 with - | Eop (Ointconst n2) Enil => - shift_case1 n2 - | e1 => - shift_default e1 +Definition shl_match (e2: expr) := + match e2 as zz1 return shl_cases zz1 with + | Eop (Ointconst n2) Enil => shl_case1 n2 + | e2 => shl_default e2 end. Definition shl (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => + match shl_match e2 with + | shl_case1 n2 => (* Eop (Ointconst n2) Enil *) shlimm e1 n2 - | shift_default e2 => + | shl_default e2 => Eop Oshl (e1:::e2:::Enil) end. -Definition shru (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shruimm e1 n2 - | shift_default e2 => - Eop Oshru (e1:::e2:::Enil) + +(** Original definition: +<< +Nondetfunction shr (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shrimm e1 n2 + | _ => Eop Oshr (e1:::e2:::Enil) + end. +>> +*) + +Inductive shr_cases: forall (e2: expr), Type := + | shr_case1: forall n2, shr_cases (Eop (Ointconst n2) Enil) + | shr_default: forall (e2: expr), shr_cases e2. + +Definition shr_match (e2: expr) := + match e2 as zz1 return shr_cases zz1 with + | Eop (Ointconst n2) Enil => shr_case1 n2 + | e2 => shr_default e2 end. Definition shr (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => + match shr_match e2 with + | shr_case1 n2 => (* Eop (Ointconst n2) Enil *) shrimm e1 n2 - | shift_default e2 => + | shr_default e2 => Eop Oshr (e1:::e2:::Enil) end. -(** ** Comparisons *) -(* -Definition comp (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2:::Enil) - | t1, Eop (Ointconst n2) Enil => Eop (Ocmp (Ccompimm c n1)) (t1:::Enil) - | Eop (Oshift s) (t1:::Enil), t2 => Eop (Ocmp (Ccompshift (swap_comparison c) s)) (t2:::t1:::Enil) - | t1, Eop (Oshift s) (t2:::Enil) => Eop (Ocmp (Ccompshift c s)) (t1:::t2:::Enil) - | _, _ => Eop (Ocmp (Ccomp c)) (e1:::e2:::Enil) +(** Original definition: +<< +Nondetfunction shru (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shruimm e1 n2 + | _ => Eop Oshru (e1:::e2:::Enil) end. +>> *) - -Inductive comp_cases: forall (e1: expr) (e2: expr), Type := - | comp_case1: - forall n1 t2, - comp_cases (Eop (Ointconst n1) Enil) (t2) - | comp_case2: - forall t1 n2, - comp_cases (t1) (Eop (Ointconst n2) Enil) - | comp_case3: - forall s t1 t2, - comp_cases (Eop (Oshift s) (t1:::Enil)) (t2) - | comp_case4: - forall t1 s t2, - comp_cases (t1) (Eop (Oshift s) (t2:::Enil)) - | comp_default: - forall (e1: expr) (e2: expr), - comp_cases e1 e2. -Definition comp_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return comp_cases z1 z2 with +Inductive shru_cases: forall (e2: expr), Type := + | shru_case1: forall n2, shru_cases (Eop (Ointconst n2) Enil) + | shru_default: forall (e2: expr), shru_cases e2. + +Definition shru_match (e2: expr) := + match e2 as zz1 return shru_cases zz1 with + | Eop (Ointconst n2) Enil => shru_case1 n2 + | e2 => shru_default e2 + end. + +Definition shru (e1: expr) (e2: expr) := + match shru_match e2 with + | shru_case1 n2 => (* Eop (Ointconst n2) Enil *) + shruimm e1 n2 + | shru_default e2 => + Eop Oshru (e1:::e2:::Enil) + end. + + +(** ** Floating-point arithmetic *) + +Definition negf (e: expr) := Eop Onegf (e ::: Enil). +Definition absf (e: expr) := Eop Oabsf (e ::: Enil). +Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). +Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). +Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). +Definition divf (e1 e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil). + +(** ** Comparisons *) + +(** Original definition: +<< +Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with | Eop (Ointconst n1) Enil, t2 => - comp_case1 n1 t2 + Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2:::Enil) | t1, Eop (Ointconst n2) Enil => - comp_case2 t1 n2 + Eop (Ocmp (Ccompimm c n2)) (t1:::Enil) | Eop (Oshift s) (t1:::Enil), t2 => - comp_case3 s t1 t2 + Eop (Ocmp (Ccompshift (swap_comparison c) s)) (t2:::t1:::Enil) | t1, Eop (Oshift s) (t2:::Enil) => - comp_case4 t1 s t2 - | e1, e2 => - comp_default e1 e2 + Eop (Ocmp (Ccompshift c s)) (t1:::t2:::Enil) + | _, _ => + Eop (Ocmp (Ccomp c)) (e1:::e2:::Enil) + end. +>> +*) + +Inductive comp_cases: forall (e1: expr) (e2: expr), Type := + | comp_case1: forall n1 t2, comp_cases (Eop (Ointconst n1) Enil) (t2) + | comp_case2: forall t1 n2, comp_cases (t1) (Eop (Ointconst n2) Enil) + | comp_case3: forall s t1 t2, comp_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | comp_case4: forall t1 s t2, comp_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | comp_default: forall (e1: expr) (e2: expr), comp_cases e1 e2. + +Definition comp_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return comp_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => comp_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => comp_case2 t1 n2 + | Eop (Oshift s) (t1:::Enil), t2 => comp_case3 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => comp_case4 t1 s t2 + | e1, e2 => comp_default e1 e2 end. Definition comp (c: comparison) (e1: expr) (e2: expr) := match comp_match e1 e2 with - | comp_case1 n1 t2 => + | comp_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2:::Enil) - | comp_case2 t1 n2 => + | comp_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) Eop (Ocmp (Ccompimm c n2)) (t1:::Enil) - | comp_case3 s t1 t2 => + | comp_case3 s t1 t2 => (* Eop (Oshift s) (t1:::Enil), t2 *) Eop (Ocmp (Ccompshift (swap_comparison c) s)) (t2:::t1:::Enil) - | comp_case4 t1 s t2 => + | comp_case4 t1 s t2 => (* t1, Eop (Oshift s) (t2:::Enil) *) Eop (Ocmp (Ccompshift c s)) (t1:::t2:::Enil) | comp_default e1 e2 => Eop (Ocmp (Ccomp c)) (e1:::e2:::Enil) end. + +(** Original definition: +<< +Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2:::Enil) + | t1, Eop (Ointconst n2) Enil => + Eop (Ocmp (Ccompuimm c n2)) (t1:::Enil) + | Eop (Oshift s) (t1:::Enil), t2 => + Eop (Ocmp (Ccompushift (swap_comparison c) s)) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => + Eop (Ocmp (Ccompushift c s)) (t1:::t2:::Enil) + | _, _ => + Eop (Ocmp (Ccompu c)) (e1:::e2:::Enil) + end. +>> +*) + +Inductive compu_cases: forall (e1: expr) (e2: expr), Type := + | compu_case1: forall n1 t2, compu_cases (Eop (Ointconst n1) Enil) (t2) + | compu_case2: forall t1 n2, compu_cases (t1) (Eop (Ointconst n2) Enil) + | compu_case3: forall s t1 t2, compu_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | compu_case4: forall t1 s t2, compu_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | compu_default: forall (e1: expr) (e2: expr), compu_cases e1 e2. + +Definition compu_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return compu_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => compu_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => compu_case2 t1 n2 + | Eop (Oshift s) (t1:::Enil), t2 => compu_case3 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => compu_case4 t1 s t2 + | e1, e2 => compu_default e1 e2 + end. + Definition compu (c: comparison) (e1: expr) (e2: expr) := - match comp_match e1 e2 with - | comp_case1 n1 t2 => + match compu_match e1 e2 with + | compu_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2:::Enil) - | comp_case2 t1 n2 => + | compu_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) Eop (Ocmp (Ccompuimm c n2)) (t1:::Enil) - | comp_case3 s t1 t2 => + | compu_case3 s t1 t2 => (* Eop (Oshift s) (t1:::Enil), t2 *) Eop (Ocmp (Ccompushift (swap_comparison c) s)) (t2:::t1:::Enil) - | comp_case4 t1 s t2 => + | compu_case4 t1 s t2 => (* t1, Eop (Oshift s) (t2:::Enil) *) Eop (Ocmp (Ccompushift c s)) (t1:::t2:::Enil) - | comp_default e1 e2 => + | compu_default e1 e2 => Eop (Ocmp (Ccompu c)) (e1:::e2:::Enil) end. + Definition compf (c: comparison) (e1: expr) (e2: expr) := Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). -(** ** Non-optimized operators. *) +(** ** Integer conversions *) + +Definition cast8unsigned (e: expr) := andimm (Int.repr 255) e. + +Definition cast8signed (e: expr) := shrimm (shlimm e (Int.repr 24)) (Int.repr 24). + +Definition cast16unsigned (e: expr) := andimm (Int.repr 65535) e. + +Definition cast16signed (e: expr) := shrimm (shlimm e (Int.repr 16)) (Int.repr 16). + +(** ** Floating-point conversions *) -Definition cast8unsigned (e: expr) := Eop Ocast8unsigned (e ::: Enil). -Definition cast8signed (e: expr) := Eop Ocast8signed (e ::: Enil). -Definition cast16unsigned (e: expr) := Eop Ocast16unsigned (e ::: Enil). -Definition cast16signed (e: expr) := Eop Ocast16signed (e ::: Enil). Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). -Definition negint (e: expr) := Eop (Orsubimm Int.zero) (e ::: Enil). -Definition negf (e: expr) := Eop Onegf (e ::: Enil). -Definition absf (e: expr) := Eop Oabsf (e ::: Enil). Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil). Definition floatofint (e: expr) := Eop Ofloatofint (e ::: Enil). Definition floatofintu (e: expr) := Eop Ofloatofintu (e ::: Enil). -Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). -Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). -Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). -Definition divf (e1 e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil). (** ** Recognition of addressing modes for load and store operations *) -(* -Definition addressing (e: expr) := - match e with - | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) - | Eop (Oaddimm n) (e1:::Enil) => (Aindexed n, e1:::Enil) - | Eop (Oaddshift s) (e1:::e2:::Enil) => (Aindexed2shift s, e1:::e2:::Enil) - | Eop Oadd (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) - | _ => (Aindexed Int.zero, e:::Enil) - end. -*) - -Inductive addressing_cases: forall (e: expr), Type := - | addressing_case2: - forall n, - addressing_cases (Eop (Oaddrstack n) Enil) - | addressing_case3: - forall n e1, - addressing_cases (Eop (Oaddimm n) (e1:::Enil)) - | addressing_case4: - forall s e1 e2, - addressing_cases (Eop (Oaddshift s) (e1:::e2:::Enil)) - | addressing_case5: - forall e1 e2, - addressing_cases (Eop Oadd (e1:::e2:::Enil)) - | addressing_default: - forall (e: expr), - addressing_cases e. - -Definition addressing_match (e: expr) := - match e as z1 return addressing_cases z1 with - | Eop (Oaddrstack n) Enil => - addressing_case2 n - | Eop (Oaddimm n) (e1:::Enil) => - addressing_case3 n e1 - | Eop (Oaddshift s) (e1:::e2:::Enil) => - addressing_case4 s e1 e2 - | Eop Oadd (e1:::e2:::Enil) => - addressing_case5 e1 e2 - | e => - addressing_default e - end. - (** We do not recognize the [Aindexed2] and [Aindexed2shift] modes for floating-point accesses, since these are not supported by the hardware and emulated inefficiently in [Asmgen]. Likewise, [Aindexed2shift] are not supported for halfword and signed byte accesses. *) -Definition can_use_Aindexed (chunk: memory_chunk): bool := +Definition can_use_Aindexed2 (chunk: memory_chunk): bool := match chunk with | Mint8signed => true | Mint8unsigned => true @@ -1091,7 +1105,7 @@ Definition can_use_Aindexed (chunk: memory_chunk): bool := | Mfloat64 => false end. -Definition can_use_Aindexed2 (chunk: memory_chunk): bool := +Definition can_use_Aindexed2shift (chunk: memory_chunk): bool := match chunk with | Mint8signed => false | Mint8unsigned => true @@ -1102,22 +1116,54 @@ Definition can_use_Aindexed2 (chunk: memory_chunk): bool := | Mfloat64 => false end. -Definition addressing (chunk: memory_chunk) (e: expr) := - match addressing_match e with - | addressing_case2 n => - (Ainstack n, Enil) - | addressing_case3 n e1 => - (Aindexed n, e1:::Enil) - | addressing_case4 s e1 e2 => - if can_use_Aindexed2 chunk +(** Original definition: +<< +Nondetfunction addressing (chunk: memory_chunk) (e: expr) := + match e with + | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) + | Eop (Oaddimm n) (e1:::Enil) => (Aindexed n, e1:::Enil) + | Eop (Oaddshift s) (e1:::e2:::Enil) => + if can_use_Aindexed2shift chunk then (Aindexed2shift s, e1:::e2:::Enil) else (Aindexed Int.zero, Eop (Oaddshift s) (e1:::e2:::Enil) ::: Enil) - | addressing_case5 e1 e2 => - if can_use_Aindexed chunk + | Eop Oadd (e1:::e2:::Enil) => + if can_use_Aindexed2 chunk then (Aindexed2, e1:::e2:::Enil) else (Aindexed Int.zero, Eop Oadd (e1:::e2:::Enil) ::: Enil) + | _ => (Aindexed Int.zero, e:::Enil) + end. +>> +*) + +Inductive addressing_cases: forall (e: expr), Type := + | addressing_case1: forall n, addressing_cases (Eop (Oaddrstack n) Enil) + | addressing_case2: forall n e1, addressing_cases (Eop (Oaddimm n) (e1:::Enil)) + | addressing_case3: forall s e1 e2, addressing_cases (Eop (Oaddshift s) (e1:::e2:::Enil)) + | addressing_case4: forall e1 e2, addressing_cases (Eop Oadd (e1:::e2:::Enil)) + | addressing_default: forall (e: expr), addressing_cases e. + +Definition addressing_match (e: expr) := + match e as zz1 return addressing_cases zz1 with + | Eop (Oaddrstack n) Enil => addressing_case1 n + | Eop (Oaddimm n) (e1:::Enil) => addressing_case2 n e1 + | Eop (Oaddshift s) (e1:::e2:::Enil) => addressing_case3 s e1 e2 + | Eop Oadd (e1:::e2:::Enil) => addressing_case4 e1 e2 + | e => addressing_default e + end. + +Definition addressing (chunk: memory_chunk) (e: expr) := + match addressing_match e with + | addressing_case1 n => (* Eop (Oaddrstack n) Enil *) + (Ainstack n, Enil) + | addressing_case2 n e1 => (* Eop (Oaddimm n) (e1:::Enil) *) + (Aindexed n, e1:::Enil) + | addressing_case3 s e1 e2 => (* Eop (Oaddshift s) (e1:::e2:::Enil) *) + if can_use_Aindexed2shift chunk then (Aindexed2shift s, e1:::e2:::Enil) else (Aindexed Int.zero, Eop (Oaddshift s) (e1:::e2:::Enil) ::: Enil) + | addressing_case4 e1 e2 => (* Eop Oadd (e1:::e2:::Enil) *) + if can_use_Aindexed2 chunk then (Aindexed2, e1:::e2:::Enil) else (Aindexed Int.zero, Eop Oadd (e1:::e2:::Enil) ::: Enil) | addressing_default e => (Aindexed Int.zero, e:::Enil) end. + diff --git a/arm/SelectOpproof.v b/arm/SelectOpproof.v index 9ecf1de..fa41682 100644 --- a/arm/SelectOpproof.v +++ b/arm/SelectOpproof.v @@ -44,8 +44,6 @@ Variable m: mem. Ltac EvalOp := eapply eval_Eop; eauto with evalexpr. -Ltac TrivialOp cstr := unfold cstr; intros; EvalOp. - Ltac InvEval1 := match goal with | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => @@ -78,6 +76,11 @@ Ltac InvEval2 := Ltac InvEval := InvEval1; InvEval2; InvEval2. +Ltac TrivialExists := + match goal with + | [ |- exists v, _ /\ Val.lessdef ?a v ] => exists a; split; [EvalOp | auto] + end. + (** * Correctness of the smart constructors *) (** We now show that the code generated by "smart constructor" functions @@ -100,440 +103,373 @@ Ltac InvEval := InvEval1; InvEval2; InvEval2. by the smart constructor. *) +Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. + +Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := + forall le a x b y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. + Theorem eval_addrsymbol: - forall le id ofs b, - Genv.find_symbol ge id = Some b -> - eval_expr ge sp e m le (addrsymbol id ofs) (Vptr b ofs). + forall le id ofs, + exists v, eval_expr ge sp e m le (addrsymbol id ofs) v /\ Val.lessdef (symbol_address ge id ofs) v. Proof. - intros. unfold addrsymbol. econstructor. constructor. - simpl. rewrite H. auto. + intros. unfold addrsymbol. econstructor; split. + EvalOp. simpl; eauto. + auto. Qed. Theorem eval_addrstack: - forall le ofs b n, - sp = Vptr b n -> - eval_expr ge sp e m le (addrstack ofs) (Vptr b (Int.add n ofs)). + forall le ofs, + exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.add sp (Vint ofs)) v. Proof. - intros. unfold addrstack. econstructor. constructor. - simpl. unfold offset_sp. rewrite H. auto. + intros. unfold addrstack. econstructor; split. + EvalOp. simpl; eauto. + auto. Qed. -Theorem eval_notint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (notint a) (Vint (Int.not x)). +Theorem eval_notint: unary_constructor_sound notint Val.notint. Proof. - unfold notint; intros until x; case (notint_match a); intros; InvEval. - EvalOp. simpl. congruence. - subst x. rewrite Int.not_involutive. auto. - EvalOp. simpl. subst x. rewrite Int.not_involutive. auto. - EvalOp. + unfold notint; red; intros until x; case (notint_match a); intros; InvEval. + subst x. TrivialExists. + exists v1; split; auto. subst. destruct v1; simpl; auto. rewrite Int.not_involutive; auto. + exists (eval_shift s v1); split. EvalOp. subst x. destruct (eval_shift s v1); simpl; auto. rewrite Int.not_involutive; auto. + TrivialExists. Qed. -Lemma eval_notbool_base: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_expr ge sp e m le (notbool_base a) (Val.of_bool (negb b)). -Proof. - TrivialOp notbool_base. simpl. - inv H0. - rewrite Int.eq_false; auto. - rewrite Int.eq_true; auto. - reflexivity. -Qed. - -Hint Resolve Val.bool_of_true_val Val.bool_of_false_val - Val.bool_of_true_val_inv Val.bool_of_false_val_inv: valboolof. - -Theorem eval_notbool: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_expr ge sp e m le (notbool a) (Val.of_bool (negb b)). +Theorem eval_notbool: unary_constructor_sound notbool Val.notbool. Proof. - induction a; simpl; intros; try (eapply eval_notbool_base; eauto). - destruct o; try (eapply eval_notbool_base; eauto). + assert (DFL: + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (Eop (Ocmp (Ccompuimm Ceq Int.zero)) (a ::: Enil)) v + /\ Val.lessdef (Val.notbool x) v). + intros. TrivialExists. simpl. destruct x; simpl; auto. - destruct e0. InvEval. - inv H0. rewrite Int.eq_false; auto. - simpl; eauto with evalexpr. - rewrite Int.eq_true; simpl; eauto with evalexpr. - eapply eval_notbool_base; eauto. - - inv H. eapply eval_Eop; eauto. - simpl. assert (eval_condition c vl m = Some b). - generalize H6. simpl. - case (eval_condition c vl); intros. - destruct b0; inv H1; inversion H0; auto; congruence. - congruence. - rewrite (Op.eval_negate_condition _ _ _ H). - destruct b; reflexivity. - - inv H. eapply eval_Econdition; eauto. - destruct v1; eauto. + red. induction a; simpl; intros; eauto. destruct o; eauto. +(* intconst *) + destruct e0; eauto. InvEval. TrivialExists. simpl. destruct (Int.eq i Int.zero); auto. +(* cmp *) + inv H. simpl in H5. + destruct (eval_condition c vl m) as []_eqn. + TrivialExists. simpl. rewrite (eval_negate_condition _ _ _ Heqo). destruct b; inv H5; auto. + inv H5. simpl. + destruct (eval_condition (negate_condition c) vl m) as []_eqn. + destruct b; [exists Vtrue | exists Vfalse]; split; auto; EvalOp; simpl. rewrite Heqo0; auto. rewrite Heqo0; auto. + exists Vundef; split; auto; EvalOp; simpl. rewrite Heqo0; auto. +(* condition *) + inv H. destruct v1. + exploit IHa1; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. + exploit IHa2; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. Qed. Theorem eval_addimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (addimm n a) (Vint (Int.add x n)). -Proof. - unfold addimm; intros until x. - generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. - subst n. rewrite Int.add_zero. auto. - case (addimm_match a); intros; InvEval; EvalOp; simpl. + forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)). +Proof. + red; unfold addimm; intros until x. + predSpec Int.eq Int.eq_spec n Int.zero. + subst n. intros. exists x; split; auto. + destruct x; simpl; auto. rewrite Int.add_zero. auto. rewrite Int.add_zero. auto. + case (addimm_match a); intros; InvEval; simpl; TrivialExists; simpl. rewrite Int.add_commut. auto. - destruct (Genv.find_symbol ge s); discriminate. - destruct sp; simpl in H1; discriminate. - subst x. rewrite Int.add_assoc. decEq; decEq; decEq. apply Int.add_commut. + unfold symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. rewrite Int.add_commut; auto. + rewrite Val.add_assoc. rewrite Int.add_commut. auto. + subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. Qed. -Theorem eval_addimm_ptr: - forall le n a b ofs, - eval_expr ge sp e m le a (Vptr b ofs) -> - eval_expr ge sp e m le (addimm n a) (Vptr b (Int.add ofs n)). -Proof. - unfold addimm; intros until ofs. - generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. - subst n. rewrite Int.add_zero. auto. - case (addimm_match a); intros; InvEval; EvalOp; simpl. - destruct (Genv.find_symbol ge s). - rewrite Int.add_commut. congruence. - discriminate. - destruct sp; simpl in H1; try discriminate. - inv H1. simpl. decEq. decEq. - rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. rewrite (Int.add_commut n m0). rewrite Int.add_assoc. auto. -Qed. - -Theorem eval_add: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (add a b) (Vint (Int.add x y)). +Theorem eval_add: binary_constructor_sound add Val.add. Proof. - intros until y. + red; intros until y. unfold add; case (add_match a b); intros; InvEval. - rewrite Int.add_commut. apply eval_addimm. auto. - replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)). - apply eval_addimm. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - replace (Int.add x y) with (Int.add (Int.add i y) n1). - apply eval_addimm. EvalOp. - subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - apply eval_addimm. auto. - replace (Int.add x y) with (Int.add (Int.add x i) n2). - apply eval_addimm. EvalOp. - subst y. rewrite Int.add_assoc. auto. - EvalOp. simpl. subst x. rewrite Int.add_commut. auto. - EvalOp. simpl. congruence. - EvalOp. -Qed. - -Theorem eval_add_ptr: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (add a b) (Vptr p (Int.add x y)). -Proof. - intros until y. unfold add; case (add_match a b); intros; InvEval. - replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)). - apply eval_addimm_ptr. subst b0. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - replace (Int.add x y) with (Int.add (Int.add i y) n1). - apply eval_addimm_ptr. subst b0. EvalOp. - subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - apply eval_addimm_ptr. auto. - replace (Int.add x y) with (Int.add (Int.add x i) n2). - apply eval_addimm_ptr. EvalOp. - subst y. rewrite Int.add_assoc. auto. - EvalOp. simpl. congruence. - EvalOp. -Qed. - -Theorem eval_add_ptr_2: - forall le a b x p y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vptr p y) -> - eval_expr ge sp e m le (add a b) (Vptr p (Int.add y x)). -Proof. - intros until y. unfold add; case (add_match a b); intros; InvEval. - apply eval_addimm_ptr. auto. - replace (Int.add y x) with (Int.add (Int.add i i0) (Int.add n1 n2)). - apply eval_addimm_ptr. subst b0. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. - rewrite (Int.add_commut n1 n2). apply Int.add_permut. - replace (Int.add y x) with (Int.add (Int.add y i) n1). - apply eval_addimm_ptr. EvalOp. - subst x. repeat rewrite Int.add_assoc. auto. - replace (Int.add y x) with (Int.add (Int.add i x) n2). - apply eval_addimm_ptr. EvalOp. subst b0; reflexivity. - subst y. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - EvalOp. simpl. congruence. - EvalOp. -Qed. - -Theorem eval_sub: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - rewrite Int.sub_add_opp. - apply eval_addimm. assumption. - replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm. EvalOp. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm. EvalOp. - subst x. rewrite Int.sub_add_l. auto. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm. EvalOp. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. - EvalOp. simpl. congruence. - EvalOp. simpl. congruence. - EvalOp. -Qed. - -Theorem eval_sub_ptr_int: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (sub a b) (Vptr p (Int.sub x y)). -Proof. - intros until y. + rewrite Val.add_commut. apply eval_addimm; auto. + subst. + replace (Val.add (Val.add v1 (Vint n1)) (Val.add v0 (Vint n2))) + with (Val.add (Val.add v1 v0) (Val.add (Vint n1) (Vint n2))). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. decEq. apply Val.add_permut. + subst. + replace (Val.add (Val.add v1 (Vint n1)) y) + with (Val.add (Val.add v1 y) (Vint n1)). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. decEq. apply Val.add_commut. + apply eval_addimm; auto. + subst. rewrite <- Val.add_assoc. apply eval_addimm. EvalOp. + subst. rewrite Val.add_commut. TrivialExists. + subst. TrivialExists. + TrivialExists. +Qed. + +Theorem eval_sub: binary_constructor_sound sub Val.sub. +Proof. + red; intros until y. unfold sub; case (sub_match a b); intros; InvEval. - rewrite Int.sub_add_opp. - apply eval_addimm_ptr. assumption. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm_ptr. EvalOp. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm_ptr. EvalOp. - subst x. rewrite Int.sub_add_l. auto. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm_ptr. EvalOp. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. simpl. congruence. - EvalOp. + rewrite Val.sub_add_opp. apply eval_addimm; auto. + subst. rewrite Val.sub_add_l. rewrite Val.sub_add_r. + rewrite Val.add_assoc. simpl. rewrite Int.add_commut. rewrite <- Int.sub_add_opp. + apply eval_addimm; EvalOp. + subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp. + subst. rewrite Val.sub_add_r. apply eval_addimm; EvalOp. + TrivialExists. + subst. TrivialExists. + subst. TrivialExists. + TrivialExists. Qed. -Theorem eval_sub_ptr_ptr: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vptr p y) -> - eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). +Theorem eval_negint: unary_constructor_sound negint (fun v => Val.sub Vzero v). Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm. EvalOp. - simpl; unfold eq_block. subst b0; subst b1; rewrite zeq_true. auto. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm. EvalOp. - simpl. unfold eq_block. rewrite zeq_true. auto. - subst x. rewrite Int.sub_add_l. auto. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm. EvalOp. - simpl. unfold eq_block. rewrite zeq_true. auto. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. simpl. unfold eq_block. rewrite zeq_true. auto. + red; intros. unfold negint. TrivialExists. Qed. Theorem eval_shlimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n Int.iwordsize = true -> - eval_expr ge sp e m le (shlimm a n) (Vint (Int.shl x n)). -Proof. - intros until x. unfold shlimm, is_shift_amount. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - intros. subst n. rewrite Int.shl_zero. auto. - destruct (is_shift_amount_aux n). simpl. - case (shlimm_match a); intros; InvEval. - EvalOp. - destruct (is_shift_amount_aux (Int.add n (s_amount n1))). - EvalOp. simpl. subst x. - decEq. decEq. symmetry. rewrite Int.add_commut. apply Int.shl_shl. - apply s_amount_ltu. auto. - rewrite Int.add_commut. auto. - EvalOp. econstructor. EvalOp. simpl. reflexivity. constructor. - simpl. congruence. - EvalOp. - congruence. + forall n, unary_constructor_sound (fun a => shlimm a n) + (fun x => Val.shl x (Vint n)). +Proof. +Opaque mk_shift_amount. + red; intros until x. unfold shlimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shl_zero; auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; simpl. + destruct (shlimm_match a); intros. + InvEval. simpl; rewrite Heqb. TrivialExists. + destruct (Int.ltu (Int.add n n1) Int.iwordsize) as []_eqn. + InvEval. subst x. exists (Val.shl v1 (Vint (Int.add n n1))); split. EvalOp. + simpl. rewrite mk_shift_amount_eq; auto. + destruct v1; simpl; auto. rewrite s_range. simpl. rewrite Heqb. rewrite Heqb0. + rewrite Int.add_commut. rewrite Int.shl_shl; auto. apply s_range. rewrite Int.add_commut; auto. + TrivialExists. simpl. rewrite mk_shift_amount_eq; auto. + TrivialExists. simpl. rewrite mk_shift_amount_eq; auto. + intros; TrivialExists. simpl. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + + Theorem eval_shrimm: + forall n, unary_constructor_sound (fun a => shrimm a n) + (fun x => Val.shr x (Vint n)). +Proof. + red; intros until x. unfold shrimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; simpl. + destruct (shrimm_match a); intros. + InvEval. simpl; rewrite Heqb. TrivialExists. + destruct (Int.ltu (Int.add n n1) Int.iwordsize) as []_eqn. + InvEval. subst x. exists (Val.shr v1 (Vint (Int.add n n1))); split. EvalOp. + simpl. rewrite mk_shift_amount_eq; auto. + destruct v1; simpl; auto. rewrite s_range. simpl. rewrite Heqb. rewrite Heqb0. + rewrite Int.add_commut. rewrite Int.shr_shr; auto. apply s_range. rewrite Int.add_commut; auto. + TrivialExists. simpl. rewrite mk_shift_amount_eq; auto. + TrivialExists. simpl. rewrite mk_shift_amount_eq; auto. + intros; TrivialExists. simpl. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. auto. Qed. Theorem eval_shruimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n Int.iwordsize = true -> - eval_expr ge sp e m le (shruimm a n) (Vint (Int.shru x n)). -Proof. - intros until x. unfold shruimm, is_shift_amount. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - intros. subst n. rewrite Int.shru_zero. auto. - destruct (is_shift_amount_aux n). simpl. - case (shruimm_match a); intros; InvEval. - EvalOp. - destruct (is_shift_amount_aux (Int.add n (s_amount n1))). - EvalOp. simpl. subst x. - decEq. decEq. symmetry. rewrite Int.add_commut. apply Int.shru_shru. - apply s_amount_ltu. auto. - rewrite Int.add_commut. auto. - EvalOp. econstructor. EvalOp. simpl. reflexivity. constructor. - simpl. congruence. - EvalOp. - congruence. -Qed. - -Theorem eval_shrimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n Int.iwordsize = true -> - eval_expr ge sp e m le (shrimm a n) (Vint (Int.shr x n)). -Proof. - intros until x. unfold shrimm, is_shift_amount. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - intros. subst n. rewrite Int.shr_zero. auto. - destruct (is_shift_amount_aux n). simpl. - case (shrimm_match a); intros; InvEval. - EvalOp. - destruct (is_shift_amount_aux (Int.add n (s_amount n1))). - EvalOp. simpl. subst x. - decEq. decEq. symmetry. rewrite Int.add_commut. apply Int.shr_shr. - apply s_amount_ltu. auto. - rewrite Int.add_commut. auto. - EvalOp. econstructor. EvalOp. simpl. reflexivity. constructor. - simpl. congruence. - EvalOp. - congruence. + forall n, unary_constructor_sound (fun a => shruimm a n) + (fun x => Val.shru x (Vint n)). +Proof. + red; intros until x. unfold shruimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; simpl. + destruct (shruimm_match a); intros. + InvEval. simpl; rewrite Heqb. TrivialExists. + destruct (Int.ltu (Int.add n n1) Int.iwordsize) as []_eqn. + InvEval. subst x. exists (Val.shru v1 (Vint (Int.add n n1))); split. EvalOp. + simpl. rewrite mk_shift_amount_eq; auto. + destruct v1; simpl; auto. destruct (Int.ltu n1 Int.iwordsize) as []_eqn; simpl; auto. + rewrite Heqb; rewrite Heqb0. rewrite Int.add_commut. rewrite Int.shru_shru; auto. rewrite Int.add_commut; auto. + TrivialExists. simpl. rewrite mk_shift_amount_eq; auto. + TrivialExists. simpl. rewrite mk_shift_amount_eq; auto. + intros; TrivialExists. simpl. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. auto. Qed. Lemma eval_mulimm_base: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (mulimm_base n a) (Vint (Int.mul x n)). + forall n, unary_constructor_sound (mulimm_base n) (fun x => Val.mul x (Vint n)). Proof. - intros; unfold mulimm_base. + intros; red; intros; unfold mulimm_base. + assert (DFL: exists v, eval_expr ge sp e m le (Eop Omul (Eop (Ointconst n) Enil ::: a ::: Enil)) v /\ Val.lessdef (Val.mul x (Vint n)) v). + TrivialExists. econstructor. EvalOp. simpl; eauto. econstructor. eauto. constructor. + rewrite Val.mul_commut. auto. generalize (Int.one_bits_decomp n). generalize (Int.one_bits_range n). - change (Z_of_nat Int.wordsize) with 32. destruct (Int.one_bits n). - intros. EvalOp. constructor. EvalOp. simpl; reflexivity. - constructor. eauto. constructor. simpl. rewrite Int.mul_commut. auto. + intros. auto. destruct l. intros. rewrite H1. simpl. - rewrite Int.add_zero. rewrite <- Int.shl_mul. - apply eval_shlimm. auto. auto with coqlib. + rewrite Int.add_zero. + replace (Vint (Int.shl Int.one i)) with (Val.shl Vone (Vint i)). rewrite Val.shl_mul. + apply eval_shlimm. auto. simpl. rewrite H0; auto with coqlib. destruct l. - intros. apply eval_Elet with (Vint x). auto. - rewrite H1. simpl. rewrite Int.add_zero. - rewrite Int.mul_add_distr_r. - rewrite <- Int.shl_mul. - rewrite <- Int.shl_mul. - apply eval_add. - apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. - auto with coqlib. - apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. - auto with coqlib. - intros. EvalOp. constructor. EvalOp. simpl; reflexivity. - constructor. eauto. constructor. simpl. rewrite Int.mul_commut. auto. + intros. rewrite H1. simpl. + exploit (eval_shlimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]]. + exploit (eval_shlimm i0 (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]]. + exploit (eval_add (x :: le)). eexact A1. eexact A2. intros [v [A B]]. + exists v; split. econstructor; eauto. + rewrite Int.add_zero. + replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one i0))) + with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint i0))). + rewrite Val.mul_add_distr_r. + repeat rewrite Val.shl_mul. eapply Val.lessdef_trans. 2: eauto. apply Val.add_lessdef; auto. + simpl. repeat rewrite H0; auto with coqlib. + intros. auto. Qed. + Theorem eval_mulimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (mulimm n a) (Vint (Int.mul x n)). -Proof. - intros until x; unfold mulimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.mul_zero. - intro. EvalOp. - generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intro. - subst n. rewrite Int.mul_one. auto. + forall n, unary_constructor_sound (mulimm n) (fun x => Val.mul x (Vint n)). +Proof. + intros; red; intros until x; unfold mulimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.mul_zero. auto. + predSpec Int.eq Int.eq_spec n Int.one. + intros. exists x; split; auto. + destruct x; simpl; auto. subst n. rewrite Int.mul_one. auto. case (mulimm_match a); intros; InvEval. - EvalOp. rewrite Int.mul_commut. reflexivity. - replace (Int.mul x n) with (Int.add (Int.mul i n) (Int.mul n n2)). - apply eval_addimm. apply eval_mulimm_base. auto. - subst x. rewrite Int.mul_add_distr_l. decEq. apply Int.mul_commut. - apply eval_mulimm_base. assumption. + TrivialExists. simpl. rewrite Int.mul_commut; auto. + subst. rewrite Val.mul_add_distr_l. + exploit eval_mulimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]]. + exploit (eval_addimm (Int.mul n n2) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]]. + exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.add_lessdef; eauto. + rewrite Val.mul_commut; auto. + apply eval_mulimm_base; auto. Qed. -Theorem eval_mul: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (mul a b) (Vint (Int.mul x y)). +Theorem eval_mul: binary_constructor_sound mul Val.mul. Proof. - intros until y. + red; intros until y. unfold mul; case (mul_match a b); intros; InvEval. - rewrite Int.mul_commut. apply eval_mulimm. auto. + rewrite Val.mul_commut. apply eval_mulimm. auto. apply eval_mulimm. auto. - EvalOp. + TrivialExists. Qed. -Theorem eval_divs_base: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (Eop Odiv (a ::: b ::: Enil)) (Vint (Int.divs x y)). +Theorem eval_andimm: + forall n, unary_constructor_sound (andimm n) (fun x => Val.and x (Vint n)). Proof. - intros. EvalOp; simpl. - predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. + intros; red; intros until x. unfold andimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.and_zero. auto. + case (andimm_match a); intros. + InvEval. TrivialExists. simpl. rewrite Int.and_commut; auto. + InvEval. subst. rewrite Val.and_assoc. simpl. rewrite Int.and_commut. TrivialExists. + TrivialExists. Qed. -Theorem eval_divs: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (divs a b) (Vint (Int.divs x y)). -Proof. - intros until y. - unfold divs; case (divu_match b); intros; InvEval. - caseEq (Int.is_power2 y); intros. - caseEq (Int.ltu i (Int.repr 31)); intros. - EvalOp. simpl. unfold Int.ltu. rewrite zlt_true. - rewrite (Int.divs_pow2 x y i H0). auto. - exploit Int.ltu_inv; eauto. - change (Int.unsigned (Int.repr 31)) with 31. - change (Int.unsigned Int.iwordsize) with 32. - omega. - apply eval_divs_base. auto. EvalOp. auto. - apply eval_divs_base. auto. EvalOp. auto. - apply eval_divs_base; auto. +Theorem eval_and: binary_constructor_sound and Val.and. +Proof. + red; intros until y; unfold and; case (and_match a b); intros; InvEval. + rewrite Val.and_commut. apply eval_andimm; auto. + apply eval_andimm; auto. + subst. rewrite Val.and_commut. TrivialExists. + subst. TrivialExists. + subst. rewrite Val.and_commut. TrivialExists. + subst. TrivialExists. + subst. rewrite Val.and_commut. TrivialExists. + subst. TrivialExists. + TrivialExists. +Qed. + +Theorem eval_orimm: + forall n, unary_constructor_sound (orimm n) (fun x => Val.or x (Vint n)). +Proof. + intros; red; intros until x. unfold orimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. subst. exists x; split; auto. + destruct x; simpl; auto. rewrite Int.or_zero; auto. + destruct (orimm_match a); intros; InvEval. + TrivialExists. simpl. rewrite Int.or_commut; auto. + subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists. + TrivialExists. +Qed. + +Remark eval_same_expr: + forall a1 a2 le v1 v2, + same_expr_pure a1 a2 = true -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + a1 = a2 /\ v1 = v2. +Proof. + intros until v2. + destruct a1; simpl; try (intros; discriminate). + destruct a2; simpl; try (intros; discriminate). + case (ident_eq i i0); intros. + subst i0. inversion H0. inversion H1. split. auto. congruence. + discriminate. +Qed. + +Theorem eval_or: binary_constructor_sound or Val.or. +Proof. + red; intros until y; unfold or; case (or_match a b); intros; InvEval. + rewrite Val.or_commut. apply eval_orimm; auto. + apply eval_orimm; auto. +(* shl - shru *) + destruct (Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2) as []_eqn. + destruct (andb_prop _ _ Heqb0). + generalize (Int.eq_spec (Int.add n1 n2) Int.iwordsize); rewrite H1; intros. + exploit eval_same_expr; eauto. intros [EQ1 EQ2]. subst. + exists (Val.ror v0 (Vint n2)); split. EvalOp. + destruct v0; simpl; auto. + destruct (Int.ltu n1 Int.iwordsize) as []_eqn; auto. + destruct (Int.ltu n2 Int.iwordsize) as []_eqn; auto. + simpl. rewrite <- Int.or_ror; auto. + subst. TrivialExists. + econstructor. EvalOp. simpl; eauto. econstructor; eauto. constructor. + simpl. auto. +(* shru - shr *) + destruct (Int.eq (Int.add n2 n1) Int.iwordsize && same_expr_pure t1 t2) as []_eqn. + destruct (andb_prop _ _ Heqb0). + generalize (Int.eq_spec (Int.add n2 n1) Int.iwordsize); rewrite H1; intros. + exploit eval_same_expr; eauto. intros [EQ1 EQ2]. subst. + exists (Val.ror v0 (Vint n1)); split. EvalOp. + destruct v0; simpl; auto. + destruct (Int.ltu n1 Int.iwordsize) as []_eqn; auto. + destruct (Int.ltu n2 Int.iwordsize) as []_eqn; auto. + simpl. rewrite Int.or_commut. rewrite <- Int.or_ror; auto. + subst. TrivialExists. + econstructor. EvalOp. simpl; eauto. econstructor; eauto. constructor. + simpl. auto. +(* orshift *) + subst. rewrite Val.or_commut. TrivialExists. + subst. TrivialExists. +(* default *) + TrivialExists. +Qed. + +Theorem eval_xorimm: + forall n, unary_constructor_sound (xorimm n) (fun x => Val.xor x (Vint n)). +Proof. + intros; red; intros until x. unfold xorimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists x; split. auto. + destruct x; simpl; auto. subst n. rewrite Int.xor_zero. auto. + destruct (xorimm_match a); intros; InvEval. + TrivialExists. simpl. rewrite Int.xor_commut; auto. + subst. rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. TrivialExists. + TrivialExists. +Qed. + +Theorem eval_xor: binary_constructor_sound xor Val.xor. +Proof. + red; intros until y; unfold xor; case (xor_match a b); intros; InvEval. + rewrite Val.xor_commut. apply eval_xorimm; auto. + apply eval_xorimm; auto. + subst. rewrite Val.xor_commut. TrivialExists. + subst. TrivialExists. + TrivialExists. Qed. Lemma eval_mod_aux: forall divop semdivop, - (forall sp x y m, - y <> Int.zero -> - eval_operation ge sp divop (Vint x :: Vint y :: nil) m = - Some (Vint (semdivop x y))) -> - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (mod_aux divop a b) - (Vint (Int.sub x (Int.mul (semdivop x y) y))). + (forall sp x y m, eval_operation ge sp divop (x :: y :: nil) m = semdivop x y) -> + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + semdivop x y = Some z -> + eval_expr ge sp e m le (mod_aux divop a b) (Val.sub x (Val.mul z y)). Proof. intros; unfold mod_aux. eapply eval_Elet. eexact H0. eapply eval_Elet. @@ -545,424 +481,246 @@ Proof. eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. apply eval_Enil. - apply H. assumption. + rewrite H. eauto. eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. apply eval_Enil. simpl; reflexivity. apply eval_Enil. reflexivity. Qed. -Theorem eval_mods: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (mods a b) (Vint (Int.mods x y)). +Theorem eval_divs: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divs x y = Some z -> + exists v, eval_expr ge sp e m le (divs a b) v /\ Val.lessdef z v. Proof. - intros; unfold mods. - rewrite Int.mods_divs. - eapply eval_mod_aux; eauto. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. + intros. unfold divs. exists z; split. EvalOp. auto. Qed. -Lemma eval_divu_base: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (Eop Odivu (a ::: b ::: Enil)) (Vint (Int.divu x y)). +Theorem eval_mods: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.mods x y = Some z -> + exists v, eval_expr ge sp e m le (mods a b) v /\ Val.lessdef z v. Proof. - intros. EvalOp. simpl. - predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. + intros; unfold mods. + exploit Val.mods_divs; eauto. intros [v [A B]]. + subst. econstructor; split; eauto. + apply eval_mod_aux with (semdivop := Val.divs); auto. Qed. -Theorem eval_divu: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (divu a b) (Vint (Int.divu x y)). +Theorem eval_divuimm: + forall le n a x z, + eval_expr ge sp e m le a x -> + Val.divu x (Vint n) = Some z -> + exists v, eval_expr ge sp e m le (divuimm a n) v /\ Val.lessdef z v. Proof. - intros until y. - unfold divu; case (divu_match b); intros; InvEval. - caseEq (Int.is_power2 y). - intros. rewrite (Int.divu_pow2 x y i H0). - apply eval_shruimm. auto. - apply Int.is_power2_range with y. auto. - intros. apply eval_divu_base. auto. EvalOp. auto. - eapply eval_divu_base; eauto. + intros; unfold divuimm. + destruct (Int.is_power2 n) as []_eqn. + replace z with (Val.shru x (Vint i)). apply eval_shruimm; auto. + eapply Val.divu_pow2; eauto. + TrivialExists. + econstructor. eauto. econstructor. EvalOp. simpl; eauto. constructor. auto. Qed. -Theorem eval_modu: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (modu a b) (Vint (Int.modu x y)). -Proof. - intros until y; unfold modu; case (divu_match b); intros; InvEval. - caseEq (Int.is_power2 y). - intros. rewrite (Int.modu_and x y i H0). - EvalOp. - intro. rewrite Int.modu_divu. eapply eval_mod_aux. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. - auto. EvalOp. auto. auto. - rewrite Int.modu_divu. eapply eval_mod_aux. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. auto. auto. auto. auto. -Qed. - -Theorem eval_and: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (and a b) (Vint (Int.and x y)). -Proof. - intros until y; unfold and; case (and_match a b); intros; InvEval. - rewrite Int.and_commut. EvalOp. simpl. congruence. - EvalOp. simpl. congruence. - rewrite Int.and_commut. EvalOp. simpl. congruence. - EvalOp. simpl. congruence. - rewrite Int.and_commut. EvalOp. simpl. congruence. - EvalOp. simpl. congruence. +Theorem eval_divu: + forall le a x b y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divu x y = Some z -> + exists v, eval_expr ge sp e m le (divu a b) v /\ Val.lessdef z v. +Proof. + intros until z. unfold divu; destruct (divu_match b); intros; InvEval. + eapply eval_divuimm; eauto. + TrivialExists. +Qed. + +Theorem eval_moduimm: + forall le n a x z, + eval_expr ge sp e m le a x -> + Val.modu x (Vint n) = Some z -> + exists v, eval_expr ge sp e m le (moduimm a n) v /\ Val.lessdef z v. +Proof. + intros; unfold moduimm. + destruct (Int.is_power2 n) as []_eqn. + replace z with (Val.and x (Vint (Int.sub n Int.one))). TrivialExists. + eapply Val.modu_pow2; eauto. + exploit Val.modu_divu; eauto. intros [v [A B]]. + subst. econstructor; split; eauto. + apply eval_mod_aux with (semdivop := Val.divu); auto. EvalOp. Qed. -Remark eval_same_expr: - forall a1 a2 le v1 v2, - same_expr_pure a1 a2 = true -> - eval_expr ge sp e m le a1 v1 -> - eval_expr ge sp e m le a2 v2 -> - a1 = a2 /\ v1 = v2. +Theorem eval_modu: + forall le a x b y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.modu x y = Some z -> + exists v, eval_expr ge sp e m le (modu a b) v /\ Val.lessdef z v. Proof. - intros until v2. - destruct a1; simpl; try (intros; discriminate). - destruct a2; simpl; try (intros; discriminate). - case (ident_eq i i0); intros. - subst i0. inversion H0. inversion H1. split. auto. congruence. - discriminate. + intros until y; unfold modu; case (modu_match b); intros; InvEval. + eapply eval_moduimm; eauto. + exploit Val.modu_divu; eauto. intros [v [A B]]. + subst. econstructor; split; eauto. + apply eval_mod_aux with (semdivop := Val.divu); auto. Qed. -Lemma eval_or: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (or a b) (Vint (Int.or x y)). -Proof. - intros until y; unfold or; case (or_match a b); intros; InvEval. - caseEq (Int.eq (Int.add (s_amount n1) (s_amount n2)) Int.iwordsize - && same_expr_pure t1 t2); intro. - destruct (andb_prop _ _ H1). - generalize (Int.eq_spec (Int.add (s_amount n1) (s_amount n2)) Int.iwordsize). - rewrite H4. intro. - exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. - simpl. EvalOp. simpl. decEq. decEq. apply Int.or_ror. - destruct n1; auto. destruct n2; auto. auto. - EvalOp. econstructor. EvalOp. simpl. reflexivity. - econstructor; eauto with evalexpr. - simpl. congruence. - caseEq (Int.eq (Int.add (s_amount n2) (s_amount n1)) Int.iwordsize - && same_expr_pure t1 t2); intro. - destruct (andb_prop _ _ H1). - generalize (Int.eq_spec (Int.add (s_amount n2) (s_amount n1)) Int.iwordsize). - rewrite H4. intro. - exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. - simpl. EvalOp. simpl. decEq. decEq. rewrite Int.or_commut. apply Int.or_ror. - destruct n2; auto. destruct n1; auto. auto. - EvalOp. econstructor. EvalOp. simpl. reflexivity. - econstructor; eauto with evalexpr. - simpl. congruence. - EvalOp. simpl. rewrite Int.or_commut. congruence. - EvalOp. simpl. congruence. - EvalOp. -Qed. - -Theorem eval_xor: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (xor a b) (Vint (Int.xor x y)). +Theorem eval_shl: binary_constructor_sound shl Val.shl. Proof. - intros until y; unfold xor; case (xor_match a b); intros; InvEval. - rewrite Int.xor_commut. EvalOp. simpl. congruence. - EvalOp. simpl. congruence. - EvalOp. + red; intros until y; unfold shl; case (shl_match b); intros. + InvEval. apply eval_shlimm; auto. + TrivialExists. Qed. -Theorem eval_shl: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y Int.iwordsize = true -> - eval_expr ge sp e m le (shl a b) (Vint (Int.shl x y)). +Theorem eval_shr: binary_constructor_sound shr Val.shr. Proof. - intros until y; unfold shl; case (shift_match b); intros. - InvEval. apply eval_shlimm; auto. - EvalOp. simpl. rewrite H1. auto. + red; intros until y; unfold shr; case (shr_match b); intros. + InvEval. apply eval_shrimm; auto. + TrivialExists. Qed. -Theorem eval_shru: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y Int.iwordsize = true -> - eval_expr ge sp e m le (shru a b) (Vint (Int.shru x y)). +Theorem eval_shru: binary_constructor_sound shru Val.shru. Proof. - intros until y; unfold shru; case (shift_match b); intros. + red; intros until y; unfold shru; case (shru_match b); intros. InvEval. apply eval_shruimm; auto. - EvalOp. simpl. rewrite H1. auto. + TrivialExists. Qed. -Theorem eval_shr: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y Int.iwordsize = true -> - eval_expr ge sp e m le (shr a b) (Vint (Int.shr x y)). + +Theorem eval_negf: unary_constructor_sound negf Val.negf. Proof. - intros until y; unfold shr; case (shift_match b); intros. - InvEval. apply eval_shrimm; auto. - EvalOp. simpl. rewrite H1. auto. + red; intros. TrivialExists. Qed. -Theorem eval_cast8signed: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v). -Proof. TrivialOp cast8signed. Qed. - -Theorem eval_cast8unsigned: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v). -Proof. TrivialOp cast8unsigned. Qed. +Theorem eval_absf: unary_constructor_sound absf Val.absf. +Proof. + red; intros. TrivialExists. +Qed. -Theorem eval_cast16signed: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v). -Proof. TrivialOp cast16signed. Qed. +Theorem eval_addf: binary_constructor_sound addf Val.addf. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_subf: binary_constructor_sound subf Val.subf. +Proof. + red; intros; TrivialExists. +Qed. -Theorem eval_cast16unsigned: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v). -Proof. TrivialOp cast16unsigned. Qed. +Theorem eval_mulf: binary_constructor_sound mulf Val.mulf. +Proof. + red; intros; TrivialExists. +Qed. -Theorem eval_singleoffloat: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v). -Proof. TrivialOp singleoffloat. Qed. +Theorem eval_divf: binary_constructor_sound divf Val.divf. +Proof. + red; intros; TrivialExists. +Qed. 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) -> - eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x y)). -Proof. - intros until y. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. rewrite 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 -> - match eval_compare_null c x with - | Some true => Some Vtrue - | Some false => Some Vfalse - | None => None (A:=val) - end = Some v. -Proof. - unfold Cminor.eval_compare_mismatch, eval_compare_null; intros. - destruct (Int.eq x Int.zero); try discriminate. - destruct c; try discriminate; auto. -Qed. - -Theorem eval_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 (compu c a b) v. -Proof. - intros until v. - 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. -Qed. - -Remark eval_swap_compare_null_trans: - forall c x v, - (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> - match eval_compare_null (swap_comparison c) x with - | Some true => Some Vtrue - | Some false => Some Vfalse - | None => None (A:=val) - end = Some v. -Proof. - unfold Cminor.eval_compare_mismatch, eval_compare_null; intros. - destruct (Int.eq x Int.zero); try discriminate. - destruct c; simpl; try discriminate; auto. -Qed. - -Theorem eval_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 (compu c a b) v. -Proof. - intros until v. - 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_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 (compu c a b) (Val.of_bool(Int.cmpu c x2 y2)). -Proof. - intros until y2. - 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_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 (compu c a b) v. -Proof. - intros until y2. - unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto. - destruct c; simpl in H3; inv H3; auto. + forall c, binary_constructor_sound (comp c) (Val.cmp c). +Proof. + intros; red; intros until y. unfold comp; case (comp_match a b); intros; InvEval. + TrivialExists. simpl. rewrite Val.swap_cmp_bool. auto. + TrivialExists. + subst. TrivialExists. simpl. rewrite Val.swap_cmp_bool. auto. + subst. TrivialExists. + TrivialExists. Qed. -Theorem eval_compf: - forall le c a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (compf c a b) (Val.of_bool(Float.cmp c x y)). +Theorem eval_compu: + forall c, binary_constructor_sound (compu c) (Val.cmpu (Mem.valid_pointer m) c). Proof. - intros. unfold compf. EvalOp. simpl. - destruct (Float.cmp c x y); reflexivity. + intros; red; intros until y. unfold compu; case (compu_match a b); intros; InvEval. + TrivialExists. simpl. rewrite Val.swap_cmpu_bool. auto. + TrivialExists. + subst. TrivialExists. simpl. rewrite Val.swap_cmpu_bool. auto. + subst. TrivialExists. + TrivialExists. Qed. -Theorem eval_negint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (negint a) (Vint (Int.neg x)). -Proof. intros; unfold negint; EvalOp. Qed. - -Theorem eval_negf: - forall le a x, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le (negf a) (Vfloat (Float.neg x)). -Proof. intros; unfold negf; EvalOp. Qed. +Theorem eval_compf: + forall c, binary_constructor_sound (compf c) (Val.cmpf c). +Proof. + intros; red; intros. unfold compf. TrivialExists. +Qed. -Theorem eval_absf: - forall le a x, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le (absf a) (Vfloat (Float.abs x)). -Proof. intros; unfold absf; EvalOp. Qed. +Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8). +Proof. + red; intros. unfold cast8signed. + exploit (eval_shlimm (Int.repr 24)); eauto. intros [v1 [A1 B1]]. + exploit (eval_shrimm (Int.repr 24)). eexact A1. intros [v2 [A2 B2]]. + exists v2; split; auto. + destruct x; simpl; auto. simpl in *. inv B1. simpl in *. inv B2. + rewrite Int.sign_ext_shr_shl. auto. compute; auto. +Qed. -Theorem eval_addf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (addf a b) (Vfloat (Float.add x y)). -Proof. intros; unfold addf; EvalOp. Qed. +Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). +Proof. + red; intros until x. unfold cast8unsigned. + rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. +Qed. -Theorem eval_subf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (subf a b) (Vfloat (Float.sub x y)). -Proof. intros; unfold subf; EvalOp. Qed. +Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). +Proof. + red; intros. unfold cast16signed. + exploit (eval_shlimm (Int.repr 16)); eauto. intros [v1 [A1 B1]]. + exploit (eval_shrimm (Int.repr 16)). eexact A1. intros [v2 [A2 B2]]. + exists v2; split; auto. + destruct x; simpl; auto. simpl in *. inv B1. simpl in *. inv B2. + rewrite Int.sign_ext_shr_shl. auto. compute; auto. +Qed. -Theorem eval_mulf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (mulf a b) (Vfloat (Float.mul x y)). -Proof. intros; unfold mulf; EvalOp. Qed. +Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). +Proof. + red; intros until x. unfold cast8unsigned. + rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. +Qed. -Theorem eval_divf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (divf a b) (Vfloat (Float.div x y)). -Proof. intros; unfold divf; EvalOp. Qed. +Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. +Proof. + red; intros. unfold singleoffloat. TrivialExists. +Qed. Theorem eval_intoffloat: - forall le a x n, - eval_expr ge sp e m le a (Vfloat x) -> - Float.intoffloat x = Some n -> - eval_expr ge sp e m le (intoffloat a) (Vint n). + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v. Proof. - intros; unfold intoffloat; EvalOp. - simpl. rewrite H0. auto. + intros; unfold intoffloat. TrivialExists. Qed. -Theorem eval_intuoffloat: - forall le a x n, - eval_expr ge sp e m le a (Vfloat x) -> - Float.intuoffloat x = Some n -> - eval_expr ge sp e m le (intuoffloat a) (Vint n). +Theorem eval_floatofint: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofint x = Some y -> + exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v. Proof. - intros; unfold intuoffloat; EvalOp. - simpl. rewrite H0. auto. + intros; unfold floatofint. TrivialExists. Qed. -Theorem eval_floatofint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (floatofint a) (Vfloat (Float.floatofint x)). -Proof. intros; unfold floatofint; EvalOp. Qed. +Theorem eval_intuoffloat: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intuoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. +Proof. + intros; unfold intuoffloat. TrivialExists. +Qed. Theorem eval_floatofintu: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (floatofintu a) (Vfloat (Float.floatofintu x)). -Proof. intros; unfold floatofintu; EvalOp. Qed. + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofintu x = Some y -> + exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v. +Proof. + intros; unfold floatofintu. TrivialExists. +Qed. -Lemma eval_addressing: +Theorem eval_addressing: forall le chunk a v b ofs, eval_expr ge sp e m le a v -> v = Vptr b ofs -> @@ -974,29 +732,16 @@ Lemma eval_addressing: Proof. intros until v. unfold addressing; case (addressing_match a); intros; InvEval. exists (@nil val). split. eauto with evalexpr. simpl. auto. - exists (Vptr b0 i :: nil). split. eauto with evalexpr. - simpl. congruence. - destruct (can_use_Aindexed2 chunk). - exists (Vptr b0 i :: Vint i0 :: nil). - split. eauto with evalexpr. simpl. congruence. - exists (Vptr b0 ofs :: nil). - split. constructor. econstructor. eauto with evalexpr. simpl. congruence. constructor. - simpl. rewrite Int.add_zero. congruence. - destruct (can_use_Aindexed chunk). - exists (Vint i :: Vptr b0 i0 :: nil). - split. eauto with evalexpr. simpl. - rewrite Int.add_commut. congruence. - exists (Vptr b0 ofs :: nil). - split. constructor. econstructor. eauto with evalexpr. simpl. congruence. constructor. - simpl. rewrite Int.add_zero. congruence. - destruct (can_use_Aindexed chunk). - exists (Vptr b0 i :: Vint i0 :: nil). - split. eauto with evalexpr. simpl. congruence. - exists (Vptr b0 ofs :: nil). - split. constructor. econstructor. eauto with evalexpr. simpl. congruence. constructor. - simpl. rewrite Int.add_zero. congruence. - exists (v :: nil). split. eauto with evalexpr. - subst v. simpl. rewrite Int.add_zero. auto. + exists (v1 :: nil); split. eauto with evalexpr. simpl. congruence. + destruct (can_use_Aindexed2shift chunk); simpl. + exists (v1 :: v0 :: nil); split. eauto with evalexpr. congruence. + exists (Vptr b ofs :: nil); split. constructor. EvalOp. simpl. congruence. constructor. + simpl. rewrite Int.add_zero; auto. + destruct (can_use_Aindexed2 chunk); simpl. + exists (v1 :: v0 :: nil); split. eauto with evalexpr. congruence. + exists (Vptr b ofs :: nil); split. constructor. EvalOp. simpl. congruence. constructor. + simpl. rewrite Int.add_zero; auto. + exists (v :: nil); split. eauto with evalexpr. subst. simpl. rewrite Int.add_zero; auto. Qed. End CMCONSTR. diff --git a/backend/Allocproof.v b/backend/Allocproof.v index ae86ee8..a9477e0 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -705,22 +705,13 @@ Proof. eapply agree_assign_live; eauto. eapply agree_reg_list_live; eauto. - (* Icond, true *) - assert (COND: eval_condition cond (map ls (map assign args)) m = Some true). + (* Icond *) + assert (COND: eval_condition cond (map ls (map assign args)) m = Some b). replace (map ls (map assign args)) with (rs##args). auto. eapply agree_eval_regs; eauto. econstructor; split. - eapply exec_Lcond_true; eauto. TranslInstr. - MatchStates. - eapply agree_undef_temps; eauto. - eapply agree_reg_list_live. eauto. - (* Icond, 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. - eapply exec_Lcond_false; eauto. TranslInstr. - MatchStates. + eapply exec_Lcond; eauto. TranslInstr. + MatchStates. destruct b; simpl; auto. eapply agree_undef_temps; eauto. eapply agree_reg_list_live. eauto. diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 77da538..c685ef6 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -899,21 +899,14 @@ Proof. apply add_unknown_satisfiable. apply wf_kill_loads. apply wf_analyze. eapply kill_load_satisfiable; eauto. - (* Icond true *) + (* Icond *) econstructor; split. - eapply exec_Icond_true; eauto. + eapply exec_Icond; eauto. econstructor; eauto. - eapply analysis_correct_1; eauto. simpl; auto. - unfold transfer; rewrite H; auto. - - (* Icond false *) - econstructor; split. - eapply exec_Icond_false; eauto. - econstructor; eauto. - eapply analysis_correct_1; eauto. simpl; auto. + destruct b; eapply analysis_correct_1; eauto; simpl; auto; unfold transfer; rewrite H; auto. - (* Icond false *) + (* Ijumptable *) econstructor; split. eapply exec_Ijumptable; eauto. econstructor; eauto. diff --git a/backend/CastOptim.v b/backend/CastOptim.v deleted file mode 100644 index 19d0065..0000000 --- a/backend/CastOptim.v +++ /dev/null @@ -1,276 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Elimination of redundant conversions to small numerical types. *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Globalenvs. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import Lattice. -Require Import Kildall. - -(** * Static analysis *) - -(** Compile-time approximations *) - -Inductive approx : Type := - | Unknown (**r any value *) - | Int7 (**r [[0,127]] *) - | Int8s (**r [[-128,127]] *) - | Int8u (**r [[0,255]] *) - | Int15 (**r [[0,32767]] *) - | Int16s (**r [[-32768,32767]] *) - | Int16u (**r [[0,65535]] *) - | Single (**r single-precision float *) - | Novalue. (**r empty *) - -(** We equip this type of approximations with a semi-lattice structure. - The ordering is inclusion between the sets of values denoted by - the approximations. *) - -Module Approx <: SEMILATTICE_WITH_TOP. - Definition t := approx. - Definition eq (x y: t) := (x = y). - Definition eq_refl: forall x, eq x x := (@refl_equal t). - Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t). - Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t). - Lemma eq_dec: forall (x y: t), {x=y} + {x<>y}. - Proof. - decide equality. - Qed. - Definition beq (x y: t) := if eq_dec x y then true else false. - Lemma beq_correct: forall x y, beq x y = true -> x = y. - Proof. - unfold beq; intros. destruct (eq_dec x y). auto. congruence. - Qed. - Definition ge (x y: t) : Prop := - match x, y with - | Unknown, _ => True - | _, Novalue => True - | Int7, Int7 => True - | Int8s, (Int7 | Int8s) => True - | Int8u, (Int7 | Int8u) => True - | Int15, (Int7 | Int8u | Int15) => True - | Int16s, (Int7 | Int8s | Int8u | Int15 | Int16s) => True - | Int16u, (Int7 | Int8u | Int15 | Int16u) => True - | Single, Single => True - | _, _ => False - end. - Lemma ge_refl: forall x y, eq x y -> ge x y. - Proof. - unfold eq, ge; intros. subst y. destruct x; auto. - Qed. - Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. - Proof. - unfold ge; intros. - destruct x; auto; (destruct y; auto; try contradiction; destruct z; auto). - Qed. - Lemma ge_compat: forall x x' y y', eq x x' -> eq y y' -> ge x y -> ge x' y'. - Proof. - unfold eq; intros. congruence. - Qed. - Definition bge (x y: t) : bool := - match x, y with - | Unknown, _ => true - | _, Novalue => true - | Int7, Int7 => true - | Int8s, (Int7 | Int8s) => true - | Int8u, (Int7 | Int8u) => true - | Int15, (Int7 | Int8u | Int15) => true - | Int16s, (Int7 | Int8s | Int8u | Int15 | Int16s) => true - | Int16u, (Int7 | Int8u | Int15 | Int16u) => true - | Single, Single => true - | _, _ => false - end. - Lemma bge_correct: forall x y, bge x y = true -> ge x y. - Proof. - destruct x; destruct y; simpl; auto || congruence. - Qed. - Definition bot := Novalue. - Definition top := Unknown. - Lemma ge_bot: forall x, ge x bot. - Proof. - unfold ge, bot. destruct x; auto. - Qed. - Lemma ge_top: forall x, ge top x. - Proof. - unfold ge, top. auto. - Qed. - Definition lub (x y: t) : t := - match x, y with - | Novalue, _ => y - | _, Novalue => x - | Int7, Int7 => Int7 - | Int7, Int8u => Int8u - | Int7, Int8s => Int8s - | Int7, Int15 => Int15 - | Int7, Int16u => Int16u - | Int7, Int16s => Int16s - | Int8u, (Int7|Int8u) => Int8u - | Int8u, Int15 => Int15 - | Int8u, Int16u => Int16u - | Int8u, Int16s => Int16s - | Int8s, (Int7|Int8s) => Int8s - | Int8s, (Int15|Int16s) => Int16s - | Int15, (Int7|Int8u|Int15) => Int15 - | Int15, Int16u => Int16u - | Int15, (Int8s|Int16s) => Int16s - | Int16u, (Int7|Int8u|Int15|Int16u) => Int16u - | Int16s, (Int7|Int8u|Int8s|Int15|Int16s) => Int16s - | Single, Single => Single - | _, _ => Unknown - end. - Lemma ge_lub_left: forall x y, ge (lub x y) x. - Proof. - unfold lub, ge; intros. - destruct x; destruct y; auto. - Qed. - Lemma ge_lub_right: forall x y, ge (lub x y) y. - Proof. - unfold lub, ge; intros. - destruct x; destruct y; auto. - Qed. -End Approx. - -Module D := LPMap Approx. - -(** Abstract interpretation of operators *) - -Definition approx_bitwise_op (v1 v2: approx) : approx := - if Approx.bge Int8u v1 && Approx.bge Int8u v2 then Int8u - else if Approx.bge Int16u v1 && Approx.bge Int16u v2 then Int16u - else Unknown. - -Function approx_operation (op: operation) (vl: list approx) : approx := - match op, vl with - | Omove, v1 :: nil => v1 - | Ointconst n, _ => - if Int.eq_dec n (Int.zero_ext 7 n) then Int7 - else if Int.eq_dec n (Int.zero_ext 8 n) then Int8u - else if Int.eq_dec n (Int.sign_ext 8 n) then Int8s - else if Int.eq_dec n (Int.zero_ext 15 n) then Int15 - else if Int.eq_dec n (Int.zero_ext 16 n) then Int16u - else if Int.eq_dec n (Int.sign_ext 16 n) then Int16s - else Unknown - | Ofloatconst n, _ => - if Float.eq_dec n (Float.singleoffloat n) then Single else Unknown - | Ocast8signed, _ => Int8s - | Ocast8unsigned, _ => Int8u - | Ocast16signed, _ => Int16s - | Ocast16unsigned, _ => Int16u - | Osingleoffloat, _ => Single - | Oand, v1 :: v2 :: nil => approx_bitwise_op v1 v2 - | Oor, v1 :: v2 :: nil => approx_bitwise_op v1 v2 - | Oxor, v1 :: v2 :: nil => approx_bitwise_op v1 v2 - (* Problem: what about and/or/xor immediate? and other - machine-specific operators? *) - | Ocmp c, _ => Int7 - | _, _ => Unknown - end. - -Definition approx_of_chunk (chunk: memory_chunk) := - match chunk with - | Mint8signed => Int8s - | Mint8unsigned => Int8u - | Mint16signed => Int16s - | Mint16unsigned => Int16u - | Mint32 => Unknown - | Mfloat32 => Single - | Mfloat64 => Unknown - end. - -(** Transfer function for the analysis *) - -Definition approx_reg (app: D.t) (r: reg) := - D.get r app. - -Definition approx_regs (app: D.t) (rl: list reg):= - List.map (approx_reg app) rl. - -Definition transfer (f: function) (pc: node) (before: D.t) := - match f.(fn_code)!pc with - | None => before - | Some i => - match i with - | Iop op args res s => - let a := approx_operation op (approx_regs before args) in - D.set res a before - | Iload chunk addr args dst s => - D.set dst (approx_of_chunk chunk) before - | Icall sig ros args res s => - D.set res Unknown before - | Ibuiltin ef args res s => - D.set res Unknown before - | _ => - before - end - end. - -(** The static analysis is a forward dataflow analysis. *) - -Module DS := Dataflow_Solver(D)(NodeSetForward). - -Definition analyze (f: RTL.function): PMap.t D.t := - match DS.fixpoint (successors f) (transfer f) - ((f.(fn_entrypoint), D.top) :: nil) with - | None => PMap.init D.top - | Some res => res - end. - -(** * Code transformation *) - -(** Cast operations that have no effect (because the argument is already - in the right range) are turned into moves. *) - -Function transf_operation (op: operation) (vl: list approx) : operation := - match op, vl with - | Ocast8signed, v :: nil => if Approx.bge Int8s v then Omove else op - | Ocast8unsigned, v :: nil => if Approx.bge Int8u v then Omove else op - | Ocast16signed, v :: nil => if Approx.bge Int16s v then Omove else op - | Ocast16unsigned, v :: nil => if Approx.bge Int16u v then Omove else op - | Osingleoffloat, v :: nil => if Approx.bge Single v then Omove else op - | _, _ => op - end. - -Definition transf_instr (app: D.t) (instr: instruction) := - match instr with - | Iop op args res s => - let op' := transf_operation op (approx_regs app args) in - Iop op' args res s - | _ => - instr - end. - -Definition transf_code (approxs: PMap.t D.t) (instrs: code) : code := - PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs. - -Definition transf_function (f: function) : function := - let approxs := analyze f in - mkfunction - f.(fn_sig) - f.(fn_params) - f.(fn_stacksize) - (transf_code approxs f.(fn_code)) - f.(fn_entrypoint). - -Definition transf_fundef (fd: fundef) : fundef := - AST.transf_fundef transf_function fd. - -Definition transf_program (p: program) : program := - transform_program transf_fundef p. diff --git a/backend/CastOptimproof.v b/backend/CastOptimproof.v deleted file mode 100644 index 0afc208..0000000 --- a/backend/CastOptimproof.v +++ /dev/null @@ -1,577 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for cast optimization. *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Events. -Require Import Memory. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import Lattice. -Require Import Kildall. -Require Import CastOptim. - -(** * Correctness of the static analysis *) - -Section ANALYSIS. - -Definition val_match_approx (a: approx) (v: val) : Prop := - match a with - | Novalue => False - | Int7 => v = Val.zero_ext 8 v /\ v = Val.sign_ext 8 v - | Int8u => v = Val.zero_ext 8 v - | Int8s => v = Val.sign_ext 8 v - | Int15 => v = Val.zero_ext 16 v /\ v = Val.sign_ext 16 v - | Int16u => v = Val.zero_ext 16 v - | Int16s => v = Val.sign_ext 16 v - | Single => v = Val.singleoffloat v - | Unknown => True - end. - -Definition regs_match_approx (a: D.t) (rs: regset) : Prop := - forall r, val_match_approx (D.get r a) rs#r. - -Lemma regs_match_approx_top: - forall rs, regs_match_approx D.top rs. -Proof. - intros. red; intros. simpl. rewrite PTree.gempty. - unfold Approx.top, val_match_approx. auto. -Qed. - -Lemma val_match_approx_increasing: - forall a1 a2 v, - Approx.ge a1 a2 -> val_match_approx a2 v -> val_match_approx a1 v. -Proof. - assert (A: forall v, v = Val.zero_ext 8 v -> v = Val.zero_ext 16 v). - intros. rewrite H. - destruct v; simpl; auto. decEq. symmetry. - apply Int.zero_ext_widen. compute; auto. split. omega. compute; auto. - assert (B: forall v, v = Val.sign_ext 8 v -> v = Val.sign_ext 16 v). - intros. rewrite H. - destruct v; simpl; auto. decEq. symmetry. - apply Int.sign_ext_widen. compute; auto. split. omega. compute; auto. - assert (C: forall v, v = Val.zero_ext 8 v -> v = Val.sign_ext 16 v). - intros. rewrite H. - destruct v; simpl; auto. decEq. symmetry. - apply Int.sign_zero_ext_widen. compute; auto. split. omega. compute; auto. - intros. destruct a1; destruct a2; simpl in *; intuition; auto. -Qed. - -Lemma regs_match_approx_increasing: - forall a1 a2 rs, - D.ge a1 a2 -> regs_match_approx a2 rs -> regs_match_approx a1 rs. -Proof. - unfold D.ge, regs_match_approx. intros. - apply val_match_approx_increasing with (D.get r a2); auto. -Qed. - -Lemma regs_match_approx_update: - forall ra rs a v r, - val_match_approx a v -> - regs_match_approx ra rs -> - regs_match_approx (D.set r a ra) (rs#r <- v). -Proof. - intros; red; intros. rewrite Regmap.gsspec. - case (peq r0 r); intro. - subst r0. rewrite D.gss. auto. - rewrite D.gso; auto. -Qed. - -Lemma approx_regs_val_list: - forall ra rs rl, - regs_match_approx ra rs -> - list_forall2 val_match_approx (approx_regs ra rl) rs##rl. -Proof. - induction rl; simpl; intros. - constructor. - constructor. apply H. auto. -Qed. - -Lemma analyze_correct: - forall f pc rs pc' i, - f.(fn_code)!pc = Some i -> - In pc' (successors_instr i) -> - regs_match_approx (transfer f pc (analyze f)!!pc) rs -> - regs_match_approx (analyze f)!!pc' rs. -Proof. - intros until i. unfold analyze. - caseEq (DS.fixpoint (successors f) (transfer f) - ((fn_entrypoint f, D.top) :: nil)). - intros approxs; intros. - apply regs_match_approx_increasing with (transfer f pc approxs!!pc). - eapply DS.fixpoint_solution; eauto. - unfold successors_list, successors. rewrite PTree.gmap1. rewrite H0. auto. - auto. - intros. rewrite PMap.gi. apply regs_match_approx_top. -Qed. - -Lemma analyze_correct_start: - forall f rs, - regs_match_approx (analyze f)!!(f.(fn_entrypoint)) rs. -Proof. - intros. unfold analyze. - caseEq (DS.fixpoint (successors f) (transfer f) - ((fn_entrypoint f, D.top) :: nil)). - intros approxs; intros. - apply regs_match_approx_increasing with D.top. - eapply DS.fixpoint_entry; eauto. auto with coqlib. - apply regs_match_approx_top. - intros. rewrite PMap.gi. apply regs_match_approx_top. -Qed. - -Lemma approx_bitwise_correct: - forall (sem_op: int -> int -> int) a1 n1 a2 n2, - (forall a b c, sem_op (Int.and a c) (Int.and b c) = Int.and (sem_op a b) c) -> - val_match_approx a1 (Vint n1) -> val_match_approx a2 (Vint n2) -> - val_match_approx (approx_bitwise_op a1 a2) (Vint (sem_op n1 n2)). -Proof. - intros. - assert (forall N, 0 < N < Z_of_nat Int.wordsize -> - sem_op (Int.zero_ext N n1) (Int.zero_ext N n2) = - Int.zero_ext N (sem_op (Int.zero_ext N n1) (Int.zero_ext N n2))). - intros. repeat rewrite Int.zero_ext_and; auto. rewrite H. - rewrite Int.and_assoc. rewrite Int.and_idem. auto. - unfold approx_bitwise_op. - caseEq (Approx.bge Int8u a1 && Approx.bge Int8u a2); intro EQ1. - destruct (andb_prop _ _ EQ1). - assert (V1: val_match_approx Int8u (Vint n1)). - eapply val_match_approx_increasing; eauto. apply Approx.bge_correct; eauto. - assert (V2: val_match_approx Int8u (Vint n2)). - eapply val_match_approx_increasing; eauto. apply Approx.bge_correct; eauto. - simpl in *. inversion V1; inversion V2; decEq. apply H2. compute; auto. - caseEq (Approx.bge Int16u a1 && Approx.bge Int16u a2); intro EQ2. - destruct (andb_prop _ _ EQ2). - assert (V1: val_match_approx Int16u (Vint n1)). - eapply val_match_approx_increasing; eauto. apply Approx.bge_correct; eauto. - assert (V2: val_match_approx Int16u (Vint n2)). - eapply val_match_approx_increasing; eauto. apply Approx.bge_correct; eauto. - simpl in *. inversion V1; inversion V2; decEq. apply H2. compute; auto. - exact I. -Qed. - -Lemma approx_operation_correct: - forall app rs (ge: genv) sp op args m v, - regs_match_approx app rs -> - 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). -(* move *) - destruct args; try (exact I). destruct args; try (exact I). - simpl. simpl in H0. inv H0. apply H. -(* const int *) - destruct args; simpl in H0; inv H0. - destruct (Int.eq_dec i (Int.zero_ext 7 i)). red; simpl. - split. - decEq. rewrite e. symmetry. apply Int.zero_ext_widen. compute; auto. split. omega. compute; auto. - decEq. rewrite e. symmetry. apply Int.sign_zero_ext_widen. compute; auto. compute; auto. - destruct (Int.eq_dec i (Int.zero_ext 8 i)). red; simpl; congruence. - destruct (Int.eq_dec i (Int.sign_ext 8 i)). red; simpl; congruence. - destruct (Int.eq_dec i (Int.zero_ext 15 i)). red; simpl. - split. - decEq. rewrite e. symmetry. apply Int.zero_ext_widen. compute; auto. split. omega. compute; auto. - decEq. rewrite e. symmetry. apply Int.sign_zero_ext_widen. compute; auto. compute; auto. - destruct (Int.eq_dec i (Int.zero_ext 16 i)). red; simpl; congruence. - destruct (Int.eq_dec i (Int.sign_ext 16 i)). red; simpl; congruence. - exact I. -(* const float *) - destruct args; simpl in H0; inv H0. - destruct (Float.eq_dec f (Float.singleoffloat f)). red; simpl; congruence. - exact I. -(* cast8signed *) - destruct args; simpl in H0; try congruence. - destruct args; simpl in H0; try congruence. - inv H0. destruct (rs#p); simpl; auto. - decEq. symmetry. apply Int.sign_ext_idem. compute; auto. -(* cast8unsigned *) - destruct args; simpl in H0; try congruence. - destruct args; simpl in H0; try congruence. - inv H0. destruct (rs#p); simpl; auto. - decEq. symmetry. apply Int.zero_ext_idem. compute; auto. -(* cast16signed *) - destruct args; simpl in H0; try congruence. - destruct args; simpl in H0; try congruence. - inv H0. destruct (rs#p); simpl; auto. - decEq. symmetry. apply Int.sign_ext_idem. compute; auto. -(* cast16unsigned *) - destruct args; simpl in H0; try congruence. - destruct args; simpl in H0; try congruence. - inv H0. destruct (rs#p); simpl; auto. - decEq. symmetry. apply Int.zero_ext_idem. compute; auto. -(* and *) - destruct args; try (exact I). - destruct args; try (exact I). - destruct args; try (exact I). - generalize (H p) (H p0). simpl in *. FuncInv. subst. - apply approx_bitwise_correct; auto. - intros. repeat rewrite Int.and_assoc. decEq. - rewrite (Int.and_commut b c). rewrite <- Int.and_assoc. rewrite Int.and_idem. auto. -(* or *) - destruct args; try (exact I). - destruct args; try (exact I). - destruct args; try (exact I). - generalize (H p) (H p0). simpl in *. FuncInv. subst. - apply approx_bitwise_correct; auto. - intros. rewrite (Int.and_commut a c); rewrite (Int.and_commut b c). - rewrite <- Int.and_or_distrib. apply Int.and_commut. -(* xor *) - destruct args; try (exact I). - destruct args; try (exact I). - destruct args; try (exact I). - generalize (H p) (H p0). simpl in *. FuncInv. subst. - apply approx_bitwise_correct; auto. - intros. rewrite (Int.and_commut a c); rewrite (Int.and_commut b c). - rewrite <- Int.and_xor_distrib. apply Int.and_commut. -(* singleoffloat *) - destruct args; simpl in H0; try congruence. - destruct args; simpl in H0; try congruence. - inv H0. destruct (rs#p); simpl; auto. - decEq. rewrite Float.singleoffloat_idem; auto. -(* comparison *) - simpl in H0. destruct (eval_condition c rs##args); try discriminate. - destruct b; inv H0; compute; auto. -Qed. - -Lemma approx_of_chunk_correct: - forall chunk m a v, - Mem.loadv chunk m a = Some v -> - val_match_approx (approx_of_chunk chunk) v. -Proof. - intros. destruct a; simpl in H; try discriminate. - exploit Mem.load_cast; eauto. - destruct chunk; intros; simpl; auto. -Qed. - -End ANALYSIS. - -(** * Correctness of the code transformation *) - -Section PRESERVATION. - -Variable prog: program. -Let tprog := transf_program prog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - intros; unfold ge, tge, tprog, transf_program. - apply Genv.find_symbol_transf. -Qed. - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof. - intros; unfold ge, tge, tprog, transf_program. - apply Genv.find_var_info_transf. -Qed. - -Lemma functions_translated: - forall (v: val) (f: fundef), - Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (transf_fundef f). -Proof. - intros. - exact (Genv.find_funct_transf transf_fundef _ _ H). -Qed. - -Lemma function_ptr_translated: - forall (b: block) (f: fundef), - Genv.find_funct_ptr ge b = Some f -> - Genv.find_funct_ptr tge b = Some (transf_fundef f). -Proof. - intros. - exact (Genv.find_funct_ptr_transf transf_fundef _ _ H). -Qed. - -Lemma sig_function_translated: - forall f, - funsig (transf_fundef f) = funsig f. -Proof. - intros. destruct f; reflexivity. -Qed. - -Lemma find_function_translated: - forall ros rs fd, - find_function ge ros rs = Some fd -> - find_function tge ros rs = Some (transf_fundef fd). -Proof. - intros. destruct ros; simpl in *. - apply functions_translated; auto. - rewrite symbols_preserved. destruct (Genv.find_symbol ge i); try congruence. - apply function_ptr_translated; auto. -Qed. - -(** Correctness of [transf_operation]. *) - -Lemma transf_operation_correct: - forall (ge: genv) app rs sp op args m v, - regs_match_approx app rs -> - 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). - intros. eapply val_match_approx_increasing. apply Approx.bge_correct; eauto. apply RMA. -Opaque Approx.bge. - destruct op; simpl; auto. -(* cast8signed *) - destruct args; simpl; try congruence. destruct args; simpl; try congruence. - intros EQ; inv EQ. - caseEq (Approx.bge Int8s (approx_reg app p)); intros. - exploit A; eauto. unfold val_match_approx. simpl. congruence. - auto. -(* cast8unsigned *) - destruct args; simpl; try congruence. destruct args; simpl; try congruence. - intros EQ; inv EQ. - caseEq (Approx.bge Int8u (approx_reg app p)); intros. - exploit A; eauto. unfold val_match_approx. simpl. congruence. - auto. -(* cast8signed *) - destruct args; simpl; try congruence. destruct args; simpl; try congruence. - intros EQ; inv EQ. - caseEq (Approx.bge Int16s (approx_reg app p)); intros. - exploit A; eauto. unfold val_match_approx. simpl. congruence. - auto. -(* cast8unsigned *) - destruct args; simpl; try congruence. destruct args; simpl; try congruence. - intros EQ; inv EQ. - caseEq (Approx.bge Int16u (approx_reg app p)); intros. - exploit A; eauto. unfold val_match_approx. simpl. congruence. - auto. -(* singleoffloat *) - destruct args; simpl; try congruence. destruct args; simpl; try congruence. - intros EQ; inv EQ. - caseEq (Approx.bge Single (approx_reg app p)); intros. - exploit A; eauto. unfold val_match_approx. simpl. congruence. - auto. -Qed. - -(** Matching between states. *) - -Inductive match_stackframes: stackframe -> stackframe -> Prop := - match_stackframe_intro: - forall res sp pc rs f, - (forall v, regs_match_approx (analyze f)!!pc (rs#res <- v)) -> - match_stackframes - (Stackframe res f sp pc rs) - (Stackframe res (transf_function f) sp pc rs). - -Inductive match_states: state -> state -> Prop := - | match_states_intro: - forall s sp pc rs m f s' - (MATCH: regs_match_approx (analyze f)!!pc rs) - (STACKS: list_forall2 match_stackframes s s'), - match_states (State s f sp pc rs m) - (State s' (transf_function f) sp pc rs m) - | match_states_call: - forall s f args m s', - list_forall2 match_stackframes s s' -> - match_states (Callstate s f args m) - (Callstate s' (transf_fundef f) args m) - | match_states_return: - forall s s' v m, - list_forall2 match_stackframes s s' -> - match_states (Returnstate s v m) - (Returnstate s' v m). - -Ltac TransfInstr := - match goal with - | H1: (PTree.get ?pc ?c = Some ?instr), f: function |- _ => - cut ((transf_function f).(fn_code)!pc = Some(transf_instr (analyze f)!!pc instr)); - [ simpl transf_instr - | unfold transf_function, transf_code; simpl; rewrite PTree.gmap; - unfold option_map; rewrite H1; reflexivity ] - end. - -(** The proof of semantic preservation follows from the lock-step simulation lemma below. *) - -Lemma transf_step_correct: - forall s1 t s2, - step ge s1 t s2 -> - forall s1' (MS: match_states s1 s1'), - exists s2', step tge s1' t s2' /\ match_states s2 s2'. -Proof. - induction 1; intros; inv MS. - - (* Inop *) - econstructor; split. - TransfInstr; intro. eapply exec_Inop; eauto. - econstructor; eauto. - eapply analyze_correct with (pc := pc); eauto. - simpl; auto. - unfold transfer; rewrite H. auto. - - (* Iop *) - exists (State s' (transf_function f) sp pc' (rs#res <- v) m); split. - TransfInstr; intro. eapply exec_Iop; eauto. - apply transf_operation_correct; auto. - rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved. - econstructor; eauto. - eapply analyze_correct with (pc := pc); eauto. - simpl; auto. - unfold transfer; rewrite H. apply regs_match_approx_update; auto. - eapply approx_operation_correct; eauto. - - (* Iload *) - econstructor; split. - TransfInstr; intro. eapply exec_Iload with (a := a). eauto. - rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. - eauto. - econstructor; eauto. - eapply analyze_correct with (pc := pc); eauto. - simpl; auto. - unfold transfer; rewrite H. apply regs_match_approx_update; auto. - eapply approx_of_chunk_correct; eauto. - - (* Istore *) - econstructor; split. - TransfInstr; intro. eapply exec_Istore with (a := a). eauto. - rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. - eauto. - econstructor; eauto. - eapply analyze_correct with (pc := pc); eauto. - simpl; auto. - unfold transfer; rewrite H. auto. - - (* Icall *) - TransfInstr; intro. - econstructor; split. - eapply exec_Icall. eauto. apply find_function_translated; eauto. - apply sig_function_translated; auto. - constructor; auto. constructor; auto. - econstructor; eauto. - intros. eapply analyze_correct; eauto. simpl; auto. - unfold transfer; rewrite H. - apply regs_match_approx_update; auto. exact I. - - (* Itailcall *) - TransfInstr; intro. - econstructor; split. - eapply exec_Itailcall. eauto. apply find_function_translated; eauto. - apply sig_function_translated; auto. - simpl; eauto. - constructor; auto. - - (* Ibuiltin *) - TransfInstr. intro. - exists (State s' (transf_function f) sp pc' (rs#res <- v) m'); split. - eapply exec_Ibuiltin; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact varinfo_preserved. - econstructor; eauto. - eapply analyze_correct; eauto. simpl; auto. - unfold transfer; rewrite H. - apply regs_match_approx_update; auto. exact I. - - (* Icond, true *) - exists (State s' (transf_function f) sp ifso rs m); split. - TransfInstr. intro. - eapply exec_Icond_true; eauto. - econstructor; eauto. - eapply analyze_correct; eauto. - simpl; auto. - unfold transfer; rewrite H; auto. - - (* Icond, false *) - exists (State s' (transf_function f) sp ifnot rs m); split. - TransfInstr. intro. - eapply exec_Icond_false; eauto. - econstructor; eauto. - eapply analyze_correct; eauto. - simpl; auto. - unfold transfer; rewrite H; auto. - - (* Ijumptable *) - exists (State s' (transf_function f) sp pc' rs m); split. - TransfInstr. intro. - eapply exec_Ijumptable; eauto. - constructor; auto. - eapply analyze_correct; eauto. - simpl. eapply list_nth_z_in; eauto. - unfold transfer; rewrite H; auto. - - (* Ireturn *) - exists (Returnstate s' (regmap_optget or Vundef rs) m'); split. - eapply exec_Ireturn; eauto. TransfInstr; auto. - constructor; auto. - - (* internal function *) - simpl. unfold transf_function. - econstructor; split. - eapply exec_function_internal; simpl; eauto. - simpl. econstructor; eauto. - apply analyze_correct_start; auto. - - (* external function *) - simpl. econstructor; split. - eapply exec_function_external; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact varinfo_preserved. - constructor; auto. - - (* return *) - inv H3. inv H1. - econstructor; split. - eapply exec_return; eauto. - econstructor; eauto. -Qed. - -Lemma transf_initial_states: - forall st1, initial_state prog st1 -> - exists st2, initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inversion H. - exploit function_ptr_translated; eauto. intro FIND. - exists (Callstate nil (transf_fundef f) nil m0); split. - econstructor; eauto. - apply Genv.init_mem_transf; auto. - replace (prog_main tprog) with (prog_main prog). - rewrite symbols_preserved. eauto. - reflexivity. - rewrite <- H3. apply sig_function_translated. - constructor. constructor. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> final_state st1 r -> final_state st2 r. -Proof. - intros. inv H0. inv H. inv H4. constructor. -Qed. - -(** The preservation of the observable behavior of the program then - follows. *) - -Theorem transf_program_correct: - forward_simulation (RTL.semantics prog) (RTL.semantics tprog). -Proof. - eapply forward_simulation_step. - eexact symbols_preserved. - eexact transf_initial_states. - eexact transf_final_states. - exact transf_step_correct. -Qed. - -End PRESERVATION. - - diff --git a/backend/Cminor.v b/backend/Cminor.v index 45efdf9..c9ee5b5 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -216,93 +216,53 @@ Definition eval_constant (sp: val) (cst: constant) : option val := | Ointconst n => Some (Vint n) | Ofloatconst n => Some (Vfloat n) | Oaddrsymbol s ofs => - match Genv.find_symbol ge s with - | None => None - | Some b => Some (Vptr b ofs) - end - | Oaddrstack ofs => - match sp with - | Vptr b n => Some (Vptr b (Int.add n ofs)) - | _ => None - end + Some(match Genv.find_symbol ge s with + | None => Vundef + | Some b => Vptr b ofs end) + | Oaddrstack ofs => Some (Val.add sp (Vint ofs)) end. Definition eval_unop (op: unary_operation) (arg: val) : option val := - match op, arg with - | Ocast8unsigned, _ => Some (Val.zero_ext 8 arg) - | Ocast8signed, _ => Some (Val.sign_ext 8 arg) - | Ocast16unsigned, _ => Some (Val.zero_ext 16 arg) - | Ocast16signed, _ => Some (Val.sign_ext 16 arg) - | Onegint, Vint n1 => Some (Vint (Int.neg n1)) - | Onotbool, Vint n1 => Some (Val.of_bool (Int.eq n1 Int.zero)) - | Onotbool, Vptr b1 n1 => Some Vfalse - | Onotint, Vint n1 => Some (Vint (Int.not n1)) - | Onegf, Vfloat f1 => Some (Vfloat (Float.neg f1)) - | Oabsf, Vfloat f1 => Some (Vfloat (Float.abs f1)) - | Osingleoffloat, _ => Some (Val.singleoffloat arg) - | Ointoffloat, Vfloat f1 => option_map Vint (Float.intoffloat f1) - | Ointuoffloat, Vfloat f1 => option_map Vint (Float.intuoffloat f1) - | Ofloatofint, Vint n1 => Some (Vfloat (Float.floatofint n1)) - | Ofloatofintu, Vint n1 => Some (Vfloat (Float.floatofintu n1)) - | _, _ => None + match op with + | Ocast8unsigned => Some (Val.zero_ext 8 arg) + | Ocast8signed => Some (Val.sign_ext 8 arg) + | Ocast16unsigned => Some (Val.zero_ext 16 arg) + | Ocast16signed => Some (Val.sign_ext 16 arg) + | Onegint => Some (Val.negint arg) + | Onotbool => Some (Val.notbool arg) + | Onotint => Some (Val.notint arg) + | Onegf => Some (Val.negf arg) + | Oabsf => Some (Val.absf arg) + | Osingleoffloat => Some (Val.singleoffloat arg) + | Ointoffloat => Val.intoffloat arg + | Ointuoffloat => Val.intuoffloat arg + | Ofloatofint => Val.floatofint arg + | Ofloatofintu => Val.floatofintu arg end. -Definition eval_compare_mismatch (c: comparison) : option val := - match c with Ceq => Some Vfalse | Cne => Some Vtrue | _ => None end. - -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) (m: mem): option val := - match op, arg1, arg2 with - | Oadd, Vint n1, Vint n2 => Some (Vint (Int.add n1 n2)) - | Oadd, Vint n1, Vptr b2 n2 => Some (Vptr b2 (Int.add n2 n1)) - | Oadd, Vptr b1 n1, Vint n2 => Some (Vptr b1 (Int.add n1 n2)) - | Osub, Vint n1, Vint n2 => Some (Vint (Int.sub n1 n2)) - | Osub, Vptr b1 n1, Vint n2 => Some (Vptr b1 (Int.sub n1 n2)) - | Osub, Vptr b1 n1, Vptr b2 n2 => - if eq_block b1 b2 then Some (Vint (Int.sub n1 n2)) else None - | Omul, Vint n1, Vint n2 => Some (Vint (Int.mul n1 n2)) - | Odiv, Vint n1, Vint n2 => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divs n1 n2)) - | Odivu, Vint n1, Vint n2 => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2)) - | Omod, Vint n1, Vint n2 => - if Int.eq n2 Int.zero then None else Some (Vint (Int.mods n1 n2)) - | Omodu, Vint n1, Vint n2 => - if Int.eq n2 Int.zero then None else Some (Vint (Int.modu n1 n2)) - | Oand, Vint n1, Vint n2 => Some (Vint (Int.and n1 n2)) - | Oor, Vint n1, Vint n2 => Some (Vint (Int.or n1 n2)) - | Oxor, Vint n1, Vint n2 => Some (Vint (Int.xor n1 n2)) - | Oshl, Vint n1, Vint n2 => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shl n1 n2)) else None - | Oshr, Vint n1, Vint n2 => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shr n1 n2)) else None - | Oshru, Vint n1, Vint n2 => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shru n1 n2)) else None - | Oaddf, Vfloat f1, Vfloat f2 => Some (Vfloat (Float.add f1 f2)) - | Osubf, Vfloat f1, Vfloat f2 => Some (Vfloat (Float.sub f1 f2)) - | Omulf, Vfloat f1, Vfloat f2 => Some (Vfloat (Float.mul f1 f2)) - | Odivf, Vfloat f1, Vfloat f2 => Some (Vfloat (Float.div f1 f2)) - | Ocmp c, Vint n1, Vint n2 => - Some (Val.of_bool(Int.cmp c n1 n2)) - | 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 + match op with + | Oadd => Some (Val.add arg1 arg2) + | Osub => Some (Val.sub arg1 arg2) + | Omul => Some (Val.mul arg1 arg2) + | Odiv => Val.divs arg1 arg2 + | Odivu => Val.divu arg1 arg2 + | Omod => Val.mods arg1 arg2 + | Omodu => Val.modu arg1 arg2 + | Oand => Some (Val.and arg1 arg2) + | Oor => Some (Val.or arg1 arg2) + | Oxor => Some (Val.xor arg1 arg2) + | Oshl => Some (Val.shl arg1 arg2) + | Oshr => Some (Val.shr arg1 arg2) + | Oshru => Some (Val.shru arg1 arg2) + | Oaddf => Some (Val.addf arg1 arg2) + | Osubf => Some (Val.subf arg1 arg2) + | Omulf => Some (Val.mulf arg1 arg2) + | Odivf => Some (Val.divf arg1 arg2) + | Ocmp c => Some (Val.cmp c arg1 arg2) + | Ocmpu c => Some (Val.cmpu (Mem.valid_pointer m) c arg1 arg2) + | Ocmpf c => Some (Val.cmpf c arg1 arg2) end. (** Evaluation of an expression: [eval_expr ge sp e m a v] diff --git a/backend/Constprop.v b/backend/Constprop.v index 39568a3..4c303ac 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -50,14 +50,16 @@ Module Approx <: SEMILATTICE_WITH_TOP. apply Float.eq_dec. apply Int.eq_dec. apply ident_eq. + apply Int.eq_dec. Qed. Definition beq (x y: t) := if eq_dec x y then true else false. Lemma beq_correct: forall x y, beq x y = true -> x = y. Proof. unfold beq; intros. destruct (eq_dec x y). auto. congruence. Qed. - Definition ge (x y: t) : Prop := - x = Unknown \/ y = Novalue \/ x = y. + + Definition ge (x y: t) : Prop := x = Unknown \/ y = Novalue \/ x = y. + Lemma ge_refl: forall x y, eq x y -> ge x y. Proof. unfold eq, ge; tauto. @@ -165,7 +167,7 @@ Definition transf_ros (app: D.t) (ros: reg + ident) : reg + ident := match ros with | inl r => match D.get r app with - | S symb ofs => if Int.eq ofs Int.zero then inr _ symb else ros + | G symb ofs => if Int.eq ofs Int.zero then inr _ symb else ros | _ => ros end | inr s => ros @@ -179,17 +181,19 @@ Definition transf_instr (app: D.t) (instr: instruction) := Iop (Ointconst n) nil res s | F n => Iop (Ofloatconst n) nil res s - | S symb ofs => + | G symb ofs => Iop (Oaddrsymbol symb ofs) nil res s + | S ofs => + Iop (Oaddrstack ofs) nil res s | _ => - let (op', args') := op_strength_reduction (approx_reg app) op args in + let (op', args') := op_strength_reduction op args (approx_regs app args) in Iop op' args' res s end | Iload chunk addr args dst s => - let (addr', args') := addr_strength_reduction (approx_reg app) addr args in + let (addr', args') := addr_strength_reduction addr args (approx_regs app args) in Iload chunk addr' args' dst s | Istore chunk addr args src s => - let (addr', args') := addr_strength_reduction (approx_reg app) addr args in + let (addr', args') := addr_strength_reduction addr args (approx_regs app args) in Istore chunk addr' args' src s | Icall sig ros args res s => Icall sig (transf_ros app ros) args res s @@ -200,17 +204,17 @@ Definition transf_instr (app: D.t) (instr: instruction) := | Some b => if b then Inop s1 else Inop s2 | None => - let (cond', args') := cond_strength_reduction (approx_reg app) cond args in + let (cond', args') := cond_strength_reduction cond args (approx_regs app args) in Icond cond' args' s1 s2 end | Ijumptable arg tbl => - match intval (approx_reg app) arg with - | Some n => + match approx_reg app arg with + | I n => match list_nth_z tbl (Int.unsigned n) with | Some s => Inop s | None => instr end - | None => instr + | _ => instr end | _ => instr diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index 058d68e..7ac4339 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -36,9 +36,10 @@ Require Import ConstpropOpproof. Section ANALYSIS. Variable ge: genv. +Variable sp: val. Definition regs_match_approx (a: D.t) (rs: regset) : Prop := - forall r, val_match_approx ge (D.get r a) rs#r. + forall r, val_match_approx ge sp (D.get r a) rs#r. Lemma regs_match_approx_top: forall rs, regs_match_approx D.top rs. @@ -49,7 +50,7 @@ Qed. Lemma val_match_approx_increasing: forall a1 a2 v, - Approx.ge a1 a2 -> val_match_approx ge a2 v -> val_match_approx ge a1 v. + Approx.ge a1 a2 -> val_match_approx ge sp a2 v -> val_match_approx ge sp a1 v. Proof. intros until v. intros [A|[B|C]]. @@ -68,7 +69,7 @@ Qed. Lemma regs_match_approx_update: forall ra rs a v r, - val_match_approx ge a v -> + val_match_approx ge sp a v -> regs_match_approx ra rs -> regs_match_approx (D.set r a ra) (rs#r <- v). Proof. @@ -81,14 +82,13 @@ Qed. Lemma approx_regs_val_list: forall ra rs rl, regs_match_approx ra rs -> - val_list_match_approx ge (approx_regs ra rl) rs##rl. + val_list_match_approx ge sp (approx_regs ra rl) rs##rl. Proof. induction rl; simpl; intros. constructor. constructor. apply H. auto. Qed. - (** The correctness of the static analysis follows from the results of module [ConstpropOpproof] and the fact that the result of the static analysis is a solution of the forward dataflow inequations. *) @@ -178,26 +178,56 @@ Proof. intros. destruct f; reflexivity. Qed. +Definition regs_lessdef (rs1 rs2: regset) : Prop := + forall r, Val.lessdef (rs1#r) (rs2#r). + +Lemma regs_lessdef_regs: + forall rs1 rs2, regs_lessdef rs1 rs2 -> + forall rl, Val.lessdef_list rs1##rl rs2##rl. +Proof. + induction rl; constructor; auto. +Qed. + +Lemma set_reg_lessdef: + forall r v1 v2 rs1 rs2, + Val.lessdef v1 v2 -> regs_lessdef rs1 rs2 -> regs_lessdef (rs1#r <- v1) (rs2#r <- v2). +Proof. + intros; red; intros. repeat rewrite Regmap.gsspec. + destruct (peq r0 r); auto. +Qed. + +Lemma init_regs_lessdef: + forall rl vl1 vl2, + Val.lessdef_list vl1 vl2 -> + regs_lessdef (init_regs vl1 rl) (init_regs vl2 rl). +Proof. + induction rl; simpl; intros. + red; intros. rewrite Regmap.gi. auto. + inv H. red; intros. rewrite Regmap.gi. auto. + apply set_reg_lessdef; auto. +Qed. + Lemma transf_ros_correct: - forall ros rs f approx, - regs_match_approx ge approx rs -> + forall sp ros rs rs' f approx, + regs_match_approx ge sp approx rs -> find_function ge ros rs = Some f -> - find_function tge (transf_ros approx ros) rs = Some (transf_fundef f). + regs_lessdef rs rs' -> + find_function tge (transf_ros approx ros) rs' = Some (transf_fundef f). Proof. - intros until approx; intro MATCH. - destruct ros; simpl. - intro. - exploit functions_translated; eauto. intro FIND. - caseEq (D.get r approx); intros; auto. - generalize (Int.eq_spec i0 Int.zero); case (Int.eq i0 Int.zero); intros; auto. - generalize (MATCH r). rewrite H0. intros [b [A B]]. - rewrite <- symbols_preserved in A. - rewrite B in FIND. rewrite H1 in FIND. - rewrite Genv.find_funct_find_funct_ptr in FIND. - simpl. rewrite A. auto. - rewrite symbols_preserved. destruct (Genv.find_symbol ge i). - intro. apply function_ptr_translated. auto. - congruence. + intros. destruct ros; simpl in *. + generalize (H r); intro MATCH. generalize (H1 r); intro LD. + destruct (rs#r); simpl in H0; try discriminate. + destruct (Int.eq_dec i Int.zero); try discriminate. + inv LD. + assert (find_function tge (inl _ r) rs' = Some (transf_fundef f)). + simpl. rewrite <- H4. simpl. rewrite dec_eq_true. apply function_ptr_translated. auto. + destruct (D.get r approx); auto. + predSpec Int.eq Int.eq_spec i0 Int.zero; intros; auto. + simpl in *. unfold symbol_address in MATCH. rewrite symbols_preserved. + destruct (Genv.find_symbol ge i); try discriminate. + inv MATCH. apply function_ptr_translated; auto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge i); try discriminate. + apply function_ptr_translated; auto. Qed. (** The proof of semantic preservation is a simulation argument @@ -227,29 +257,37 @@ Qed. Inductive match_stackframes: stackframe -> stackframe -> Prop := match_stackframe_intro: - forall res sp pc rs f, - (forall v, regs_match_approx ge (analyze f)!!pc (rs#res <- v)) -> + forall res sp pc rs f rs', + regs_lessdef rs rs' -> + (forall v, regs_match_approx ge sp (analyze f)!!pc (rs#res <- v)) -> match_stackframes (Stackframe res f sp pc rs) - (Stackframe res (transf_function f) sp pc rs). + (Stackframe res (transf_function f) sp pc rs'). Inductive match_states: state -> state -> Prop := | match_states_intro: - forall s sp pc rs m f s' - (MATCH: regs_match_approx ge (analyze f)!!pc rs) - (STACKS: list_forall2 match_stackframes s s'), + forall s sp pc rs m f s' rs' m' + (MATCH: regs_match_approx ge sp (analyze f)!!pc rs) + (STACKS: list_forall2 match_stackframes s s') + (REGS: regs_lessdef rs rs') + (MEM: Mem.extends m m'), match_states (State s f sp pc rs m) - (State s' (transf_function f) sp pc rs m) + (State s' (transf_function f) sp pc rs' m') | match_states_call: - forall s f args m s', - list_forall2 match_stackframes s s' -> + forall s f args m s' args' m' + (STACKS: list_forall2 match_stackframes s s') + (ARGS: Val.lessdef_list args args') + (MEM: Mem.extends m m'), match_states (Callstate s f args m) - (Callstate s' (transf_fundef f) args m) + (Callstate s' (transf_fundef f) args' m') | match_states_return: - forall s s' v m, + forall s v m s' v' m' + (STACKS: list_forall2 match_stackframes s s') + (RES: Val.lessdef v v') + (MEM: Mem.extends m m'), list_forall2 match_stackframes s s' -> match_states (Returnstate s v m) - (Returnstate s' v m). + (Returnstate s' v' m'). Ltac TransfInstr := match goal with @@ -272,7 +310,7 @@ Proof. induction 1; intros; inv MS. (* Inop *) - exists (State s' (transf_function f) sp pc' rs m); split. + exists (State s' (transf_function f) sp pc' rs' m'); split. TransfInstr; intro. eapply exec_Inop; eauto. econstructor; eauto. eapply analyze_correct_1 with (pc := pc); eauto. @@ -280,58 +318,78 @@ Proof. unfold transfer; rewrite H. auto. (* Iop *) - 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' m = Some v). - rewrite (eval_operation_preserved _ _ symbols_preserved). - 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 m v - (approx_regs_val_list _ _ _ args MATCH) H0). - case (eval_static_operation op (approx_regs (analyze f)!!pc args)); intros; - simpl in H2; - eapply exec_Iop; eauto; simpl. - congruence. - congruence. - elim H2; intros b [A B]. rewrite symbols_preserved. - rewrite A; rewrite B; auto. - econstructor; eauto. - eapply analyze_correct_1 with (pc := pc); eauto. - simpl; auto. - unfold transfer; rewrite H. - apply regs_match_approx_update; auto. - eapply eval_static_operation_correct; eauto. - apply approx_regs_val_list; auto. + assert (MATCH': regs_match_approx ge sp (analyze f) # pc' rs # res <- v). + eapply analyze_correct_1 with (pc := pc); eauto. simpl; auto. + unfold transfer; rewrite H. + apply regs_match_approx_update; auto. + eapply eval_static_operation_correct; eauto. + apply approx_regs_val_list; auto. + TransfInstr. + exploit eval_static_operation_correct; eauto. eapply approx_regs_val_list; eauto. intros VM. + destruct (eval_static_operation op (approx_regs (analyze f) # pc args)); intros; simpl in VM. + (* Novalue *) + contradiction. + (* Unknown *) + exploit op_strength_reduction_correct. eexact MATCH. reflexivity. eauto. + destruct (op_strength_reduction op args (approx_regs (analyze f) # pc args)) as [op' args']. + intros [v' [EV' LD']]. + assert (EV'': exists v'', eval_operation ge sp op' rs'##args' m' = Some v'' /\ Val.lessdef v' v''). + eapply eval_operation_lessdef; eauto. eapply regs_lessdef_regs; eauto. + destruct EV'' as [v'' [EV'' LD'']]. + exists (State s' (transf_function f) sp pc' (rs'#res <- v'') m'); split. + econstructor. eauto. rewrite <- EV''. apply eval_operation_preserved. exact symbols_preserved. + econstructor; eauto. apply set_reg_lessdef; auto. eapply Val.lessdef_trans; eauto. + (* I i *) + subst v. exists (State s' (transf_function f) sp pc' (rs'#res <- (Vint i)) m'); split. + econstructor; eauto. + econstructor; eauto. apply set_reg_lessdef; auto. + (* F *) + subst v. exists (State s' (transf_function f) sp pc' (rs'#res <- (Vfloat f0)) m'); split. + econstructor; eauto. + econstructor; eauto. apply set_reg_lessdef; auto. + (* G *) + subst v. exists (State s' (transf_function f) sp pc' (rs'#res <- (symbol_address tge i i0)) m'); split. + econstructor; eauto. + econstructor; eauto. apply set_reg_lessdef; auto. + unfold symbol_address. rewrite symbols_preserved; auto. + (* S *) + subst v. exists (State s' (transf_function f) sp pc' (rs'#res <- (Val.add sp (Vint i))) m'); split. + econstructor; eauto. + econstructor; eauto. apply set_reg_lessdef; auto. (* Iload *) - caseEq (addr_strength_reduction (approx_reg (analyze f)!!pc) addr args); - intros addr' args' ASR. - assert (eval_addressing tge sp addr' rs##args' = Some a). - rewrite (eval_addressing_preserved _ _ symbols_preserved). - generalize (addr_strength_reduction_correct ge (approx_reg (analyze f)!!pc) sp rs - MATCH addr args). - rewrite ASR; simpl. congruence. - TransfInstr. rewrite ASR. intro. - exists (State s' (transf_function f) sp pc' (rs#dst <- v) m); split. + TransfInstr. + generalize (addr_strength_reduction_correct ge sp (analyze f)!!pc rs + MATCH addr args (approx_regs (analyze f) # pc args) (refl_equal _)). + destruct (addr_strength_reduction addr args (approx_regs (analyze f) # pc args)) as [addr' args']. + intros P Q. rewrite H0 in P. + assert (ADDR': exists a', eval_addressing ge sp addr' rs'##args' = Some a' /\ Val.lessdef a a'). + eapply eval_addressing_lessdef; eauto. eapply regs_lessdef_regs; eauto. + destruct ADDR' as [a' [A B]]. + assert (C: eval_addressing tge sp addr' rs'##args' = Some a'). + rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. + exploit Mem.loadv_extends; eauto. intros [v' [D E]]. + exists (State s' (transf_function f) sp pc' (rs'#dst <- v') m'); split. eapply exec_Iload; eauto. econstructor; eauto. eapply analyze_correct_1; eauto. simpl; auto. unfold transfer; rewrite H. apply regs_match_approx_update; auto. simpl; auto. + apply set_reg_lessdef; auto. (* Istore *) - caseEq (addr_strength_reduction (approx_reg (analyze f)!!pc) addr args); - intros addr' args' ASR. - assert (eval_addressing tge sp addr' rs##args' = Some a). - rewrite (eval_addressing_preserved _ _ symbols_preserved). - generalize (addr_strength_reduction_correct ge (approx_reg (analyze f)!!pc) sp rs - MATCH addr args). - rewrite ASR; simpl. congruence. - TransfInstr. rewrite ASR. intro. - exists (State s' (transf_function f) sp pc' rs m'); split. + TransfInstr. + generalize (addr_strength_reduction_correct ge sp (analyze f)!!pc rs + MATCH addr args (approx_regs (analyze f) # pc args) (refl_equal _)). + destruct (addr_strength_reduction addr args (approx_regs (analyze f) # pc args)) as [addr' args']. + intros P Q. rewrite H0 in P. + assert (ADDR': exists a', eval_addressing ge sp addr' rs'##args' = Some a' /\ Val.lessdef a a'). + eapply eval_addressing_lessdef; eauto. eapply regs_lessdef_regs; eauto. + destruct ADDR' as [a' [A B]]. + assert (C: eval_addressing tge sp addr' rs'##args' = Some a'). + rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. + exploit Mem.storev_extends; eauto. intros [m2' [D E]]. + exists (State s' (transf_function f) sp pc' rs' m2'); split. eapply exec_Istore; eauto. econstructor; eauto. eapply analyze_correct_1; eauto. simpl; auto. @@ -347,17 +405,22 @@ Proof. intros. eapply analyze_correct_1; eauto. simpl; auto. unfold transfer; rewrite H. apply regs_match_approx_update; auto. simpl. auto. + apply regs_lessdef_regs; auto. (* Itailcall *) + exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]]. exploit transf_ros_correct; eauto. intros FIND'. TransfInstr; intro. econstructor; split. eapply exec_Itailcall; eauto. apply sig_function_translated; auto. - constructor; auto. + constructor; auto. apply regs_lessdef_regs; auto. (* Ibuiltin *) + exploit external_call_mem_extends; eauto. + instantiate (1 := rs'##args). apply regs_lessdef_regs; auto. + intros [v' [m2' [A [B [C D]]]]]. TransfInstr. intro. - exists (State s' (transf_function f) sp pc' (rs#res <- v) m'); split. + exists (State s' (transf_function f) sp pc' (rs'#res <- v') m2'); split. eapply exec_Ibuiltin; eauto. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact varinfo_preserved. @@ -365,72 +428,61 @@ Proof. eapply analyze_correct_1; eauto. simpl; auto. unfold transfer; rewrite H. apply regs_match_approx_update; auto. simpl; auto. - - (* Icond, true *) - 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' m = Some true). - generalize (cond_strength_reduction_correct - 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 _ _ m _ - (approx_regs_val_list _ _ _ args MATCH) ESC); intro. - replace b with true. intro; eapply exec_Inop; eauto. congruence. - intros. eapply exec_Icond_true; eauto. - econstructor; eauto. - eapply analyze_correct_1; eauto. - simpl; auto. - unfold transfer; rewrite H; auto. - - (* Icond, false *) - 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' m = Some false). - generalize (cond_strength_reduction_correct - 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 _ _ m _ - (approx_regs_val_list _ _ _ args MATCH) ESC); intro. - replace b with false. intro; eapply exec_Inop; eauto. congruence. - intros. eapply exec_Icond_false; eauto. - econstructor; eauto. - eapply analyze_correct_1; eauto. - simpl; auto. - unfold transfer; rewrite H; auto. + apply set_reg_lessdef; auto. + + (* Icond *) + TransfInstr. + generalize (cond_strength_reduction_correct ge sp (analyze f)#pc rs m + MATCH cond args (approx_regs (analyze f) # pc args) (refl_equal _)). + destruct (cond_strength_reduction cond args (approx_regs (analyze f) # pc args)) as [cond' args']. + intros EV1. + exists (State s' (transf_function f) sp (if b then ifso else ifnot) rs' m'); split. + destruct (eval_static_condition cond (approx_regs (analyze f) # pc args)) as []_eqn. + assert (eval_condition cond rs ## args m = Some b0). + eapply eval_static_condition_correct; eauto. eapply approx_regs_val_list; eauto. + assert (b = b0) by congruence. subst b0. + destruct b; eapply exec_Inop; eauto. + eapply exec_Icond; eauto. + eapply eval_condition_lessdef with (vl1 := rs##args'); eauto. eapply regs_lessdef_regs; eauto. congruence. + econstructor; eauto. + eapply analyze_correct_1; eauto. destruct b; simpl; auto. + unfold transfer; rewrite H. auto. (* Ijumptable *) - exists (State s' (transf_function f) sp pc' rs m); split. - caseEq (intval (approx_reg (analyze f)!!pc) arg); intros. - exploit intval_correct; eauto. eexact MATCH. intro VRS. - eapply exec_Inop; eauto. TransfInstr. rewrite H2. - replace i with n by congruence. rewrite H1. auto. - eapply exec_Ijumptable; eauto. TransfInstr. rewrite H2. auto. - constructor; auto. + assert (A: (fn_code (transf_function f))!pc = Some(Ijumptable arg tbl) + \/ (fn_code (transf_function f))!pc = Some(Inop pc')). + TransfInstr. destruct (approx_reg (analyze f) # pc arg) as []_eqn; auto. + generalize (MATCH arg). unfold approx_reg in Heqt. rewrite Heqt. rewrite H0. + simpl. intro EQ; inv EQ. rewrite H1. auto. + assert (B: rs'#arg = Vint n). + generalize (REGS arg); intro LD; inv LD; congruence. + exists (State s' (transf_function f) sp pc' rs' m'); split. + destruct A. eapply exec_Ijumptable; eauto. eapply exec_Inop; eauto. + econstructor; eauto. eapply analyze_correct_1; eauto. simpl. eapply list_nth_z_in; eauto. unfold transfer; rewrite H; auto. (* Ireturn *) - exists (Returnstate s' (regmap_optget or Vundef rs) m'); split. + exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]]. + exists (Returnstate s' (regmap_optget or Vundef rs') m2'); split. eapply exec_Ireturn; eauto. TransfInstr; auto. constructor; auto. + destruct or; simpl; auto. (* internal function *) + exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl. + intros [m2' [A B]]. simpl. unfold transf_function. econstructor; split. eapply exec_function_internal; simpl; eauto. simpl. econstructor; eauto. apply analyze_correct_3; auto. + apply init_regs_lessdef; auto. (* external function *) + exploit external_call_mem_extends; eauto. + intros [v' [m2' [A [B [C D]]]]]. simpl. econstructor; split. eapply exec_function_external; eauto. eapply external_call_symbols_preserved; eauto. @@ -441,7 +493,7 @@ Proof. inv H3. inv H1. econstructor; split. eapply exec_return; eauto. - econstructor; eauto. + econstructor; eauto. apply set_reg_lessdef; auto. Qed. Lemma transf_initial_states: @@ -457,14 +509,14 @@ Proof. rewrite symbols_preserved. eauto. reflexivity. rewrite <- H3. apply sig_function_translated. - constructor. constructor. + constructor. constructor. constructor. apply Mem.extends_refl. Qed. Lemma transf_final_states: forall st1 st2 r, match_states st1 st2 -> final_state st1 r -> final_state st2 r. Proof. - intros. inv H0. inv H. inv H4. constructor. + intros. inv H0. inv H. inv STACKS. inv RES. constructor. Qed. (** The preservation of the observable behavior of the program then diff --git a/backend/LTL.v b/backend/LTL.v index 5ed0a8f..422b0e0 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -207,18 +207,13 @@ Inductive step: state -> trace -> state -> Prop := external_call ef ge (map rs args) m t v m' -> step (State s f sp pc rs m) t (State s f sp pc' (Locmap.set res v rs) m') - | exec_Lcond_true: - forall s f sp pc rs m cond args ifso ifnot, + | exec_Lcond: + forall s f sp pc rs m cond args ifso ifnot b pc', (fn_code f)!pc = Some(Lcond cond args ifso ifnot) -> - eval_condition cond (map rs args) m = Some true -> + eval_condition cond (map rs args) m = Some b -> + pc' = (if b then ifso else ifnot) -> 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) m = Some false -> - step (State s f sp pc rs m) - E0 (State s f sp ifnot (undef_temps rs) m) + E0 (State s f sp pc' (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) -> diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index 2f96a09..50db0c6 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -629,12 +629,14 @@ Proof. traceEq. econstructor; eauto. - (* Lcond true *) + (* Lcond *) destruct (find_label_lin_inv _ _ _ _ _ TRF H REACH AT) as [c' EQ]. simpl in EQ. subst c. + destruct b. + (* true *) assert (REACH': (reachable f)!!ifso = true). eapply reachable_successors; eauto. simpl; auto. - exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. + exploit find_label_lin_succ; eauto. inv WTI; eauto. intros [c'' AT']. destruct (starts_with ifso c'). econstructor; split. eapply plus_left'. @@ -648,10 +650,7 @@ Proof. econstructor; split. apply plus_one. eapply exec_Lcond_true; eauto. econstructor; eauto. - - (* Lcond false *) - destruct (find_label_lin_inv _ _ _ _ _ TRF H REACH AT) as [c' EQ]. - simpl in EQ. subst c. + (* false *) assert (REACH': (reachable f)!!ifnot = true). eapply reachable_successors; eauto. simpl; auto. exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. diff --git a/backend/RTL.v b/backend/RTL.v index 10d4a3f..6a20941 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -255,18 +255,13 @@ Inductive step: state -> trace -> state -> Prop := external_call ef ge rs##args m t v m' -> step (State s f sp pc rs m) t (State s f sp pc' (rs#res <- v) m') - | exec_Icond_true: - forall s f sp pc rs m cond args ifso ifnot, + | exec_Icond: + forall s f sp pc rs m cond args ifso ifnot b pc', (fn_code f)!pc = Some(Icond cond args ifso ifnot) -> - eval_condition cond rs##args m = Some true -> + eval_condition cond rs##args m = Some b -> + pc' = (if b then ifso else ifnot) -> 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 m = Some false -> - step (State s f sp pc rs m) - E0 (State s f sp ifnot rs m) + E0 (State s f sp pc' rs m) | exec_Ijumptable: forall s f sp pc rs m arg tbl n pc', (fn_code f)!pc = Some(Ijumptable arg tbl) -> diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index 55cdd6b..c5182db 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -427,22 +427,22 @@ Proof. (* ifeq *) caseEq (Int.eq i key); intro EQ; rewrite EQ in H5. inv H5. exists nfound; exists rs; intuition. - apply star_one. eapply exec_Icond_true; eauto. - simpl. rewrite H2. congruence. + apply star_one. eapply exec_Icond with (b := true); eauto. + simpl. rewrite H2. simpl. congruence. exploit IHtr_switch; eauto. intros [nd1 [rs1 [EX [NTH ME]]]]. exists nd1; exists rs1; intuition. - eapply star_step. eapply exec_Icond_false; eauto. - simpl. rewrite H2. congruence. eexact EX. traceEq. + eapply star_step. eapply exec_Icond with (b := false); eauto. + simpl. rewrite H2. simpl. congruence. eexact EX. traceEq. (* iflt *) caseEq (Int.ltu i key); intro EQ; rewrite EQ in H5. exploit IHtr_switch1; eauto. intros [nd1 [rs1 [EX [NTH ME]]]]. exists nd1; exists rs1; intuition. - eapply star_step. eapply exec_Icond_true; eauto. - simpl. rewrite H2. congruence. eexact EX. traceEq. + eapply star_step. eapply exec_Icond with (b := true); eauto. + simpl. rewrite H2. simpl. congruence. eexact EX. traceEq. exploit IHtr_switch2; eauto. intros [nd1 [rs1 [EX [NTH ME]]]]. exists nd1; exists rs1; intuition. - eapply star_step. eapply exec_Icond_false; eauto. - simpl. rewrite H2. congruence. eexact EX. traceEq. + eapply star_step. eapply exec_Icond with (b := false); eauto. + simpl. rewrite H2. simpl. congruence. eexact EX. traceEq. (* jumptable *) set (rs1 := rs#rt <- (Vint(Int.sub i ofs))). assert (ME1: match_env map e nil rs1). @@ -451,21 +451,21 @@ Proof. eapply exec_Iop; eauto. predSpec Int.eq Int.eq_spec ofs Int.zero; simpl. rewrite H10. rewrite Int.sub_zero_l. congruence. - rewrite H6. rewrite <- Int.sub_add_opp. auto. + rewrite H6. simpl. rewrite <- Int.sub_add_opp. auto. caseEq (Int.ltu (Int.sub i ofs) sz); intro EQ; rewrite EQ in H9. exploit H5; eauto. intros [nd [A B]]. exists nd; exists rs1; intuition. eapply star_step. eexact EX1. - eapply star_step. eapply exec_Icond_true; eauto. - simpl. unfold rs1. rewrite Regmap.gss. congruence. + eapply star_step. eapply exec_Icond with (b := true); eauto. + simpl. unfold rs1. rewrite Regmap.gss. simpl. congruence. apply star_one. eapply exec_Ijumptable; eauto. unfold rs1. apply Regmap.gss. reflexivity. traceEq. exploit (IHtr_switch rs1); eauto. unfold rs1. rewrite Regmap.gso; auto. intros [nd [rs' [EX [NTH ME]]]]. exists nd; exists rs'; intuition. eapply star_step. eexact EX1. - eapply star_step. eapply exec_Icond_false; eauto. - simpl. unfold rs1. rewrite Regmap.gss. congruence. + eapply star_step. eapply exec_Icond with (b := false); eauto. + simpl. unfold rs1. rewrite Regmap.gss. simpl. congruence. eexact EX. reflexivity. traceEq. Qed. @@ -739,11 +739,8 @@ Proof. exists rs1. (* Exec *) split. eapply star_right. eexact EX1. - destruct b. - eapply exec_Icond_true; eauto. - rewrite RES1. assumption. - eapply exec_Icond_false; eauto. - rewrite RES1. assumption. + eapply exec_Icond with (b := b); eauto. + rewrite RES1. auto. traceEq. (* Match-env *) split. assumption. diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index 02359b9..65506c8 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -565,7 +565,6 @@ Proof. rewrite H6. eapply external_call_well_typed; eauto. (* Icond *) econstructor; eauto. - econstructor; eauto. (* Ijumptable *) econstructor; eauto. (* Ireturn *) diff --git a/backend/Reloadproof.v b/backend/Reloadproof.v index 6ee9263..75c7dad 100644 --- a/backend/Reloadproof.v +++ b/backend/Reloadproof.v @@ -1154,7 +1154,7 @@ Proof. eapply star_right. eauto. eapply exec_Lstore with (a := ta); eauto. simpl reglist. rewrite G. unfold ls3. rewrite Locmap.gss. simpl. - destruct ta; simpl in Y; try discriminate. rewrite Int.add_zero. auto. + destruct ta; simpl in Y; try discriminate. simpl; rewrite Int.add_zero; auto. reflexivity. reflexivity. traceEq. econstructor; eauto with coqlib. apply agree_undef_temps2. apply agree_exten with ls; auto. diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index d6c850a..54d59b1 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -147,8 +147,9 @@ Proof. inv H0. simpl in H7. assert (eval_condition c vl m = Some b). - destruct (eval_condition c vl m); try discriminate. + destruct (eval_condition c vl m). destruct b0; inv H7; inversion H1; congruence. + inv H7. inv H1. assert (eval_condexpr ge sp e m le (CEcond c e0) b). eapply eval_CEcond; eauto. destruct e0; auto. destruct e1; auto. @@ -204,7 +205,7 @@ Lemma eval_sel_unop: forall le op a1 v1 v, eval_expr ge sp e m le a1 v1 -> eval_unop op v1 = Some v -> - eval_expr ge sp e m le (sel_unop op a1) v. + exists v', eval_expr ge sp e m le (sel_unop op a1) v' /\ Val.lessdef v v'. Proof. destruct op; simpl; intros; FuncInv; try subst v. apply eval_cast8unsigned; auto. @@ -212,19 +213,15 @@ Proof. apply eval_cast16unsigned; auto. apply eval_cast16signed; auto. apply eval_negint; auto. - generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intro. - change true with (negb false). eapply eval_notbool; eauto. subst i; constructor. - change false with (negb true). eapply eval_notbool; eauto. constructor; auto. - change Vfalse with (Val.of_bool (negb true)). - eapply eval_notbool; eauto. constructor. + apply eval_notbool; auto. apply eval_notint; auto. apply eval_negf; auto. apply eval_absf; auto. apply eval_singleoffloat; auto. - remember (Float.intoffloat f) as oi; destruct oi; inv H0. eapply eval_intoffloat; eauto. - remember (Float.intuoffloat f) as oi; destruct oi; inv H0. eapply eval_intuoffloat; eauto. - apply eval_floatofint; auto. - apply eval_floatofintu; auto. + eapply eval_intoffloat; eauto. + eapply eval_intuoffloat; eauto. + eapply eval_floatofint; eauto. + eapply eval_floatofintu; eauto. Qed. Lemma eval_sel_binop: @@ -232,48 +229,29 @@ Lemma eval_sel_binop: eval_expr ge sp e m le a1 v1 -> eval_expr ge sp e m le a2 v2 -> eval_binop op v1 v2 m = Some v -> - eval_expr ge sp e m le (sel_binop op a1 a2) v. + exists v', eval_expr ge sp e m le (sel_binop op a1 a2) v' /\ Val.lessdef v v'. Proof. destruct op; simpl; intros; FuncInv; try subst v. apply eval_add; auto. - apply eval_add_ptr_2; auto. - apply eval_add_ptr; auto. apply eval_sub; auto. - apply eval_sub_ptr_int; auto. - destruct (eq_block b b0); inv H1. - eapply eval_sub_ptr_ptr; eauto. - apply eval_mul; eauto. - generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. - apply eval_divs; eauto. - generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. - apply eval_divu; eauto. - generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. - apply eval_mods; eauto. - generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. - apply eval_modu; eauto. + apply eval_mul; auto. + eapply eval_divs; eauto. + eapply eval_divu; eauto. + eapply eval_mods; eauto. + eapply eval_modu; eauto. apply eval_and; auto. apply eval_or; auto. apply eval_xor; auto. - caseEq (Int.ltu i0 Int.iwordsize); intro; rewrite H2 in H1; inv H1. apply eval_shl; auto. - caseEq (Int.ltu i0 Int.iwordsize); intro; rewrite H2 in H1; inv H1. apply eval_shr; auto. - caseEq (Int.ltu i0 Int.iwordsize); intro; rewrite H2 in H1; inv H1. apply eval_shru; auto. apply eval_addf; auto. apply eval_subf; auto. apply eval_mulf; auto. apply eval_divf; auto. 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_compu_ptr_ptr; eauto. - eapply eval_compu_ptr_ptr_2; eauto. - eapply eval_compf; eauto. + apply eval_compu; auto. + apply eval_compf; auto. Qed. End CMCONSTR. @@ -303,11 +281,46 @@ Proof. exploit expr_is_addrof_ident_correct; eauto. intro EQ; subst a. inv H1. inv H4. destruct (Genv.find_symbol ge i); try congruence. - inv H3. rewrite Genv.find_funct_find_funct_ptr in H2. rewrite H2 in H0. + rewrite Genv.find_funct_find_funct_ptr in H2. rewrite H2 in H0. destruct fd; try congruence. destruct (ef_inline e0); congruence. Qed. +(** Compatibility of evaluation functions with the "less defined than" relation. *) + +Ltac TrivialExists := + match goal with + | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto + | _ => idtac + end. + +Lemma eval_unop_lessdef: + forall op v1 v1' v, + eval_unop op v1 = Some v -> Val.lessdef v1 v1' -> + exists v', eval_unop op v1' = Some v' /\ Val.lessdef v v'. +Proof. + intros until v; intros EV LD. inv LD. + exists v; auto. + destruct op; simpl in *; inv EV; TrivialExists. +Qed. + +Lemma eval_binop_lessdef: + forall op v1 v1' v2 v2' v m m', + eval_binop op v1 v2 m = Some v -> + Val.lessdef v1 v1' -> Val.lessdef v2 v2' -> Mem.extends m m' -> + exists v', eval_binop op v1' v2' m' = Some v' /\ Val.lessdef v v'. +Proof. + intros until m'; intros EV LD1 LD2 ME. + assert (exists v', eval_binop op v1' v2' m = Some v' /\ Val.lessdef v v'). + inv LD1. inv LD2. exists v; auto. + destruct op; destruct v1'; simpl in *; inv EV; TrivialExists. + destruct op; simpl in *; inv EV; TrivialExists. + destruct op; try (exact H). + simpl in *. TrivialExists. inv EV. apply Val.of_optbool_lessdef. + intros. apply Val.cmpu_bool_lessdef with (Mem.valid_pointer m) v1 v2; auto. + intros; eapply Mem.valid_pointer_extends; eauto. +Qed. + (** * Semantic preservation for instruction selection. *) Section PRESERVATION. @@ -318,7 +331,7 @@ Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. (** Relationship between the global environments for the original - CminorSel program and the generated RTL program. *) + Cminor program and the generated CminorSel program. *) Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. @@ -327,15 +340,6 @@ Proof. apply Genv.find_symbol_transf. Qed. -Lemma functions_translated: - forall (v: val) (f: Cminor.fundef), - Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (sel_fundef ge f). -Proof. - intros. - exact (Genv.find_funct_transf (sel_fundef ge) _ _ H). -Qed. - Lemma function_ptr_translated: forall (b: block) (f: Cminor.fundef), Genv.find_funct_ptr ge b = Some f -> @@ -345,6 +349,17 @@ Proof. exact (Genv.find_funct_ptr_transf (sel_fundef ge) _ _ H). Qed. +Lemma functions_translated: + forall (v v': val) (f: Cminor.fundef), + Genv.find_funct ge v = Some f -> + Val.lessdef v v' -> + Genv.find_funct tge v' = Some (sel_fundef ge f). +Proof. + intros. inv H0. + exact (Genv.find_funct_transf (sel_fundef ge) _ _ H). + simpl in H. discriminate. +Qed. + Lemma sig_function_translated: forall f, funsig (sel_fundef ge f) = Cminor.funsig f. @@ -359,113 +374,189 @@ Proof. apply Genv.find_var_info_transf. Qed. +(** Relationship between the local environments. *) + +Definition env_lessdef (e1 e2: env) : Prop := + forall id v1, e1!id = Some v1 -> exists v2, e2!id = Some v2 /\ Val.lessdef v1 v2. + +Lemma set_var_lessdef: + forall e1 e2 id v1 v2, + env_lessdef e1 e2 -> Val.lessdef v1 v2 -> + env_lessdef (PTree.set id v1 e1) (PTree.set id v2 e2). +Proof. + intros; red; intros. rewrite PTree.gsspec in *. destruct (peq id0 id). + exists v2; split; congruence. + auto. +Qed. + +Lemma set_params_lessdef: + forall il vl1 vl2, + Val.lessdef_list vl1 vl2 -> + env_lessdef (set_params vl1 il) (set_params vl2 il). +Proof. + induction il; simpl; intros. + red; intros. rewrite PTree.gempty in H0; congruence. + inv H; apply set_var_lessdef; auto. +Qed. + +Lemma set_locals_lessdef: + forall e1 e2, env_lessdef e1 e2 -> + forall il, env_lessdef (set_locals il e1) (set_locals il e2). +Proof. + induction il; simpl. auto. apply set_var_lessdef; auto. +Qed. + (** Semantic preservation for expressions. *) Lemma sel_expr_correct: forall sp e m a v, Cminor.eval_expr ge sp e m a v -> - forall le, - eval_expr tge sp e m le (sel_expr a) v. + forall e' le m', + env_lessdef e e' -> Mem.extends m m' -> + exists v', eval_expr tge sp e' m' le (sel_expr a) v' /\ Val.lessdef v v'. Proof. induction 1; intros; simpl. (* Evar *) - constructor; auto. + exploit H0; eauto. intros [v' [A B]]. exists v'; split; auto. constructor; auto. (* Econst *) - destruct cst; simpl; simpl in H; (econstructor; [constructor|simpl;auto]). - rewrite symbols_preserved. auto. + destruct cst; simpl in *; inv H. + exists (Vint i); split; auto. econstructor. constructor. auto. + exists (Vfloat f); split; auto. econstructor. constructor. auto. + rewrite <- symbols_preserved. fold (symbol_address tge i i0). apply eval_addrsymbol. + apply eval_addrstack. (* Eunop *) - eapply eval_sel_unop; eauto. + exploit IHeval_expr; eauto. intros [v1' [A B]]. + exploit eval_unop_lessdef; eauto. intros [v' [C D]]. + exploit eval_sel_unop; eauto. intros [v'' [E F]]. + exists v''; split; eauto. eapply Val.lessdef_trans; eauto. (* Ebinop *) - eapply eval_sel_binop; eauto. + exploit IHeval_expr1; eauto. intros [v1' [A B]]. + exploit IHeval_expr2; eauto. intros [v2' [C D]]. + exploit eval_binop_lessdef; eauto. intros [v' [E F]]. + exploit eval_sel_binop. eexact A. eexact C. eauto. intros [v'' [P Q]]. + exists v''; split; eauto. eapply Val.lessdef_trans; eauto. (* Eload *) - eapply eval_load; eauto. + exploit IHeval_expr; eauto. intros [vaddr' [A B]]. + exploit Mem.loadv_extends; eauto. intros [v' [C D]]. + exists v'; split; auto. eapply eval_load; eauto. (* Econdition *) + exploit IHeval_expr1; eauto. intros [v1' [A B]]. + exploit IHeval_expr2; eauto. intros [v2' [C D]]. + replace (sel_expr (if b1 then a2 else a3)) with (if b1 then sel_expr a2 else sel_expr a3) in C. + assert (Val.bool_of_val v1' b1). inv B. auto. inv H0. + exists v2'; split; auto. econstructor; eauto. eapply eval_condition_of_expr; eauto. destruct b1; auto. Qed. -Hint Resolve sel_expr_correct: evalexpr. - Lemma sel_exprlist_correct: forall sp e m a v, Cminor.eval_exprlist ge sp e m a v -> - forall le, - eval_exprlist tge sp e m le (sel_exprlist a) v. + forall e' le m', + env_lessdef e e' -> Mem.extends m m' -> + exists v', eval_exprlist tge sp e' m' le (sel_exprlist a) v' /\ Val.lessdef_list v v'. Proof. - induction 1; intros; simpl; constructor; auto with evalexpr. + induction 1; intros; simpl. + exists (@nil val); split; auto. constructor. + exploit sel_expr_correct; eauto. intros [v1' [A B]]. + exploit IHeval_exprlist; eauto. intros [vl' [C D]]. + exists (v1' :: vl'); split; auto. constructor; eauto. Qed. -Hint Resolve sel_exprlist_correct: evalexpr. - -(** Semantic preservation for terminating function calls and statements. *) - -Fixpoint sel_cont (k: Cminor.cont) : CminorSel.cont := - match k with - | Cminor.Kstop => Kstop - | Cminor.Kseq s1 k1 => Kseq (sel_stmt ge s1) (sel_cont k1) - | Cminor.Kblock k1 => Kblock (sel_cont k1) - | Cminor.Kcall id f sp e k1 => - Kcall id (sel_function ge f) sp e (sel_cont k1) - end. +(** Semantic preservation for functions and statements. *) + +Inductive match_cont: Cminor.cont -> CminorSel.cont -> Prop := + | match_cont_stop: + match_cont Cminor.Kstop Kstop + | match_cont_seq: forall s k k', + match_cont k k' -> + match_cont (Cminor.Kseq s k) (Kseq (sel_stmt ge s) k') + | match_cont_block: forall k k', + match_cont k k' -> + match_cont (Cminor.Kblock k) (Kblock k') + | match_cont_call: forall id f sp e k e' k', + match_cont k k' -> env_lessdef e e' -> + match_cont (Cminor.Kcall id f sp e k) (Kcall id (sel_function ge f) sp e' k'). Inductive match_states: Cminor.state -> CminorSel.state -> Prop := - | match_state: forall f s k s' k' sp e m, + | match_state: forall f s k s' k' sp e m e' m', s' = sel_stmt ge s -> - k' = sel_cont k -> + match_cont k k' -> + env_lessdef e e' -> + Mem.extends m m' -> match_states (Cminor.State f s k sp e m) - (State (sel_function ge f) s' k' sp e m) - | match_callstate: forall f args k k' m, - k' = sel_cont k -> + (State (sel_function ge f) s' k' sp e' m') + | match_callstate: forall f args args' k k' m m', + match_cont k k' -> + Val.lessdef_list args args' -> + Mem.extends m m' -> match_states (Cminor.Callstate f args k m) - (Callstate (sel_fundef ge f) args k' m) - | match_returnstate: forall v k k' m, - k' = sel_cont k -> + (Callstate (sel_fundef ge f) args' k' m') + | match_returnstate: forall v v' k k' m m', + match_cont k k' -> + Val.lessdef v v' -> + Mem.extends m m' -> match_states (Cminor.Returnstate v k m) - (Returnstate v k' m) - | match_builtin_1: forall ef args optid f sp e k m al k', - k' = sel_cont k -> - eval_exprlist tge sp e m nil al args -> + (Returnstate v' k' m') + | match_builtin_1: forall ef args args' optid f sp e k m al e' k' m', + match_cont k k' -> + Val.lessdef_list args args' -> + env_lessdef e e' -> + Mem.extends m m' -> + eval_exprlist tge sp e' m' nil al args' -> match_states (Cminor.Callstate (External ef) args (Cminor.Kcall optid f sp e k) m) - (State (sel_function ge f) (Sbuiltin optid ef al) k' sp e m) - | match_builtin_2: forall v optid f sp e k m k', - k' = sel_cont k -> + (State (sel_function ge f) (Sbuiltin optid ef al) k' sp e' m') + | match_builtin_2: forall v v' optid f sp e k m e' m' k', + match_cont k k' -> + Val.lessdef v v' -> + env_lessdef e e' -> + Mem.extends m m' -> match_states (Cminor.Returnstate v (Cminor.Kcall optid f sp e k) m) - (State (sel_function ge f) Sskip k' sp (set_optvar optid v e) m). + (State (sel_function ge f) Sskip k' sp (set_optvar optid v' e') m'). Remark call_cont_commut: - forall k, call_cont (sel_cont k) = sel_cont (Cminor.call_cont k). + forall k k', match_cont k k' -> match_cont (Cminor.call_cont k) (call_cont k'). Proof. - induction k; simpl; auto. + induction 1; simpl; auto. constructor. constructor; auto. Qed. Remark find_label_commut: - forall lbl s k, - find_label lbl (sel_stmt ge s) (sel_cont k) = - option_map (fun sk => (sel_stmt ge (fst sk), sel_cont (snd sk))) - (Cminor.find_label lbl s k). + forall lbl s k k', + match_cont k k' -> + match Cminor.find_label lbl s k, find_label lbl (sel_stmt ge s) k' with + | None, None => True + | Some(s1, k1), Some(s1', k1') => s1' = sel_stmt ge s1 /\ match_cont k1 k1' + | _, _ => False + end. Proof. induction s; intros; simpl; auto. - unfold store. destruct (addressing m (sel_expr e)); auto. - destruct (expr_is_addrof_builtin ge e); auto. - change (Kseq (sel_stmt ge s2) (sel_cont k)) - with (sel_cont (Cminor.Kseq s2 k)). - rewrite IHs1. rewrite IHs2. - destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)); auto. - rewrite IHs1. rewrite IHs2. - destruct (Cminor.find_label lbl s1 k); auto. - change (Kseq (Sloop (sel_stmt ge s)) (sel_cont k)) - with (sel_cont (Cminor.Kseq (Cminor.Sloop s) k)). - auto. - change (Kblock (sel_cont k)) - with (sel_cont (Cminor.Kblock k)). - auto. - destruct o; auto. - destruct (ident_eq lbl l); auto. +(* store *) + unfold store. destruct (addressing m (sel_expr e)); simpl; auto. +(* call *) + destruct (expr_is_addrof_builtin ge e); simpl; auto. +(* seq *) + exploit (IHs1 (Cminor.Kseq s2 k)). constructor; eauto. + destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)) as [[sx kx] | ]; + destruct (find_label lbl (sel_stmt ge s1) (Kseq (sel_stmt ge s2) k')) as [[sy ky] | ]; + intuition. apply IHs2; auto. +(* ifthenelse *) + exploit (IHs1 k); eauto. + destruct (Cminor.find_label lbl s1 k) as [[sx kx] | ]; + destruct (find_label lbl (sel_stmt ge s1) k') as [[sy ky] | ]; + intuition. apply IHs2; auto. +(* loop *) + apply IHs. constructor; auto. +(* block *) + apply IHs. constructor; auto. +(* return *) + destruct o; simpl; auto. +(* label *) + destruct (ident_eq lbl l). auto. apply IHs; auto. Qed. Definition measure (s: Cminor.state) : nat := @@ -481,66 +572,125 @@ Lemma sel_step_correct: (exists T2, step tge T1 t T2 /\ match_states S2 T2) \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 T1)%nat. Proof. - induction 1; intros T1 ME; inv ME; simpl; - try (left; econstructor; split; [econstructor; eauto with evalexpr | econstructor; eauto]; fail). - + induction 1; intros T1 ME; inv ME; simpl. + (* skip seq *) + inv H7. left; econstructor; split. econstructor. constructor; auto. + (* skip block *) + inv H7. left; econstructor; split. econstructor. constructor; auto. (* skip call *) + exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]]. left; econstructor; split. - econstructor. destruct k; simpl in H; simpl; auto. + econstructor. inv H10; simpl in H; simpl; auto. rewrite <- H0; reflexivity. - simpl. eauto. + eauto. constructor; auto. + (* assign *) + exploit sel_expr_correct; eauto. intros [v' [A B]]. + left; econstructor; split. + econstructor; eauto. + constructor; auto. apply set_var_lessdef; auto. (* store *) + exploit sel_expr_correct. eexact H. eauto. eauto. intros [vaddr' [A B]]. + exploit sel_expr_correct. eexact H0. eauto. eauto. intros [v' [C D]]. + exploit Mem.storev_extends; eauto. intros [m2' [P Q]]. left; econstructor; split. - eapply eval_store; eauto with evalexpr. + eapply eval_store; eauto. constructor; auto. (* Scall *) - case_eq (expr_is_addrof_builtin ge a). + exploit sel_expr_correct; eauto. intros [vf' [A B]]. + exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. + destruct (expr_is_addrof_builtin ge a) as [ef|]_eqn. (* Scall turned into Sbuiltin *) - intros ef EQ. exploit expr_is_addrof_builtin_correct; eauto. intro EQ1. subst fd. + exploit expr_is_addrof_builtin_correct; eauto. intro EQ1. subst fd. right; split. omega. split. auto. - econstructor; eauto with evalexpr. + econstructor; eauto. (* Scall preserved *) - intro EQ. left; econstructor; split. - econstructor; eauto with evalexpr. - apply functions_translated; eauto. + left; econstructor; split. + econstructor; eauto. + eapply functions_translated; eauto. apply sig_function_translated. - constructor; auto. + constructor; auto. constructor; auto. (* Stailcall *) + exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. + exploit sel_expr_correct; eauto. intros [vf' [A B]]. + exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. left; econstructor; split. - econstructor; eauto with evalexpr. - apply functions_translated; eauto. + econstructor; eauto. + eapply functions_translated; eauto. apply sig_function_translated. - constructor; auto. apply call_cont_commut. + constructor; auto. apply call_cont_commut; auto. + (* Seq *) + left; econstructor; split. constructor. constructor; auto. constructor; auto. (* Sifthenelse *) - left; exists (State (sel_function ge f) (if b then sel_stmt ge s1 else sel_stmt ge s2) (sel_cont k) sp e m); split. - constructor. eapply eval_condition_of_expr; eauto with evalexpr. + exploit sel_expr_correct; eauto. intros [v' [A B]]. + assert (Val.bool_of_val v' b). inv B. auto. inv H0. + left; exists (State (sel_function ge f) (if b then sel_stmt ge s1 else sel_stmt ge s2) k' sp e' m'); split. + constructor. eapply eval_condition_of_expr; eauto. constructor; auto. destruct b; auto. + (* Sloop *) + left; econstructor; split. constructor. constructor; auto. constructor; auto. + (* Sblock *) + left; econstructor; split. constructor. constructor; auto. constructor; auto. + (* Sexit seq *) + inv H7. left; econstructor; split. constructor. constructor; auto. + (* Sexit0 block *) + inv H7. left; econstructor; split. constructor. constructor; auto. + (* SexitS block *) + inv H7. left; econstructor; split. constructor. constructor; auto. + (* Sswitch *) + exploit sel_expr_correct; eauto. intros [v' [A B]]. inv B. + left; econstructor; split. econstructor; eauto. constructor; auto. (* Sreturn None *) + exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. left; econstructor; split. econstructor. simpl; eauto. - constructor; auto. apply call_cont_commut. + constructor; auto. apply call_cont_commut; auto. (* Sreturn Some *) + exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. + exploit sel_expr_correct; eauto. intros [v' [A B]]. left; econstructor; split. - econstructor. simpl. eauto with evalexpr. simpl; eauto. - constructor; auto. apply call_cont_commut. + econstructor; eauto. + constructor; auto. apply call_cont_commut; auto. + (* Slabel *) + left; econstructor; split. constructor. constructor; auto. (* Sgoto *) + exploit (find_label_commut lbl (Cminor.fn_body f) (Cminor.call_cont k)). + apply call_cont_commut; eauto. + rewrite H. + destruct (find_label lbl (sel_stmt ge (Cminor.fn_body f)) (call_cont k'0)) + as [[s'' k'']|]_eqn; intros; try contradiction. + destruct H0. left; econstructor; split. - econstructor. simpl. rewrite call_cont_commut. rewrite find_label_commut. - rewrite H. simpl. reflexivity. + econstructor; eauto. constructor; auto. + (* internal function *) + exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl. + intros [m2' [A B]]. + left; econstructor; split. + econstructor; eauto. + constructor; auto. apply set_locals_lessdef. apply set_params_lessdef; auto. (* external call *) + exploit external_call_mem_extends; eauto. + intros [vres' [m2 [A [B [C D]]]]]. left; econstructor; split. econstructor. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact varinfo_preserved. constructor; auto. (* external call turned into a Sbuiltin *) + exploit external_call_mem_extends; eauto. + intros [vres' [m2 [A [B [C D]]]]]. left; econstructor; split. econstructor. eauto. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact varinfo_preserved. constructor; auto. + (* return *) + inv H2. + left; econstructor; split. + econstructor. + constructor; auto. destruct optid; simpl; auto. apply set_var_lessdef; auto. (* return of an external call turned into a Sbuiltin *) - right; split. omega. split. auto. constructor; auto. + right; split. omega. split. auto. constructor; auto. + destruct optid; simpl; auto. apply set_var_lessdef; auto. Qed. Lemma sel_initial_states: @@ -554,14 +704,14 @@ Proof. simpl. fold tge. rewrite symbols_preserved. eexact H0. apply function_ptr_translated. eauto. rewrite <- H2. apply sig_function_translated; auto. - constructor; auto. + constructor; auto. constructor. apply Mem.extends_refl. Qed. Lemma sel_final_states: forall S R r, match_states S R -> Cminor.final_state S r -> final_state R r. Proof. - intros. inv H0. inv H. simpl. constructor. + intros. inv H0. inv H. inv H3. inv H5. constructor. Qed. Theorem transf_program_correct: diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index f3dd9ed..02a6ca9 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -508,17 +508,10 @@ Proof. exact symbols_preserved. exact varinfo_preserved. econstructor; eauto. apply regset_set; auto. -(* cond true *) +(* cond *) 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) 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. + left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) (if b then ifso else ifnot) rs' m'); split. + eapply exec_Icond; eauto. apply eval_condition_lessdef with (rs##args) m; auto. apply regset_get_list; auto. constructor; auto. diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index 8ff7347..d589260 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -319,14 +319,9 @@ Proof. (* cond *) generalize (record_gotos_correct f pc); rewrite H; intro A; rewrite A. left; econstructor; split. - eapply exec_Lcond_true; eauto. + eapply exec_Lcond; eauto. rewrite (tunnel_function_lookup _ _ _ H); simpl; eauto. - econstructor; eauto. - generalize (record_gotos_correct f pc); rewrite H; intro A; rewrite A. - left; econstructor; split. - eapply exec_Lcond_false; eauto. - rewrite (tunnel_function_lookup _ _ _ H); simpl; eauto. - econstructor; eauto. + destruct b; econstructor; eauto. (* jumptable *) generalize (record_gotos_correct f pc); rewrite H; intro A; rewrite A. left; econstructor; split. diff --git a/cfrontend/Cminorgen.v b/cfrontend/Cminorgen.v index c293efb..3a8b857 100644 --- a/cfrontend/Cminorgen.v +++ b/cfrontend/Cminorgen.v @@ -20,12 +20,13 @@ Require Import Maps. Require Import Ordered. Require Import AST. Require Import Integers. +Require Import Floats. Require Import Memdata. Require Import Csharpminor. Require Import Cminor. -Open Local Scope string_scope. -Open Local Scope error_monad_scope. +Local Open Scope string_scope. +Local Open Scope error_monad_scope. (** The main task in translating Csharpminor to Cminor is to explicitly stack-allocate local variables whose address is taken: these local @@ -37,17 +38,17 @@ Open Local Scope error_monad_scope. taken in the Csharpminor code can be mapped to Cminor local variable, since the latter do not reside in memory. - Another task performed during the translation to Cminor is the - insertion of truncation, zero- and sign-extension operations when - assigning to a Csharpminor local variable of ``small'' type - (e.g. [Mfloat32] or [Mint8signed]). This is necessary to preserve - the ``normalize at assignment-time'' semantics of Clight and Csharpminor. + Another task performed during the translation to Cminor is to eliminate + redundant casts to small numerical types (8- and 16-bit integers, + single-precision floats). Finally, the Clight-like [switch] construct of Csharpminor is transformed into the simpler, lower-level [switch] construct of Cminor. *) +(** * Handling of variables *) + Definition for_var (id: ident) : ident := xO id. Definition for_temp (id: ident) : ident := xI id. @@ -69,41 +70,46 @@ Inductive var_info: Type := Definition compilenv := PMap.t var_info. -(***** -(** [make_cast chunk e] returns a Cminor expression that normalizes - the value of Cminor expression [e] as prescribed by the memory chunk - [chunk]. For instance, 8-bit sign extension is performed if - [chunk] is [Mint8signed]. *) - -Definition make_cast (chunk: memory_chunk) (e: expr): expr := - match chunk with - | Mint8signed => Eunop Ocast8signed e - | Mint8unsigned => Eunop Ocast8unsigned e - | Mint16signed => Eunop Ocast16signed e - | Mint16unsigned => Eunop Ocast16unsigned e - | Mint32 => e - | Mfloat32 => Eunop Osingleoffloat e - | Mfloat64 => e - end. -**********) +(** * Helper functions for code generation *) (** When the translation of an expression is stored in memory, - a cast at the toplevel of the expression can be redundant + one or several casts at the toplevel of the expression can be redundant with that implicitly performed by the memory store. [store_arg] detects this case and strips away the redundant cast. *) -Definition store_arg (chunk: memory_chunk) (e: expr) : expr := +Function uncast_int8 (e: expr) : expr := + match e with + | Eunop (Ocast8unsigned|Ocast8signed|Ocast16unsigned|Ocast16signed) e1 => + uncast_int8 e1 + | Ebinop Oand e1 (Econst (Ointconst n)) => + if Int.eq (Int.and n (Int.repr 255)) (Int.repr 255) + then uncast_int8 e1 + else e + | _ => e + end. + +Function uncast_int16 (e: expr) : expr := match e with - | Eunop Ocast8signed e1 => - match chunk with Mint8signed => e1 | _ => e end - | Eunop Ocast8unsigned e1 => - match chunk with Mint8unsigned => e1 | _ => e end - | Eunop Ocast16signed e1 => - match chunk with Mint16signed => e1 | _ => e end - | Eunop Ocast16unsigned e1 => - match chunk with Mint16unsigned => e1 | _ => e end - | Eunop Osingleoffloat e1 => - match chunk with Mfloat32 => e1 | _ => e end + | Eunop (Ocast16unsigned|Ocast16signed) e1 => + uncast_int16 e1 + | Ebinop Oand e1 (Econst (Ointconst n)) => + if Int.eq (Int.and n (Int.repr 65535)) (Int.repr 65535) + then uncast_int16 e1 + else e + | _ => e + end. + +Function uncast_float32 (e: expr) : expr := + match e with + | Eunop Osingleoffloat e1 => uncast_float32 e1 + | _ => e + end. + +Function store_arg (chunk: memory_chunk) (e: expr) : expr := + match chunk with + | Mint8signed | Mint8unsigned => uncast_int8 e + | Mint16signed | Mint16unsigned => uncast_int16 e + | Mfloat32 => uncast_float32 e | _ => e end. @@ -116,16 +122,148 @@ Definition make_stackaddr (ofs: Z): expr := Definition make_globaladdr (id: ident): expr := Econst (Oaddrsymbol id Int.zero). +Definition make_unop (op: unary_operation) (e: expr): expr := + match op with + | Ocast8unsigned => Eunop Ocast8unsigned (uncast_int8 e) + | Ocast8signed => Eunop Ocast8signed (uncast_int8 e) + | Ocast16unsigned => Eunop Ocast16unsigned (uncast_int16 e) + | Ocast16signed => Eunop Ocast16signed (uncast_int16 e) + | Osingleoffloat => Eunop Osingleoffloat (uncast_float32 e) + | _ => Eunop op e + end. + +(** * Optimization of casts *) + +(** To remove redundant casts, we perform a modest static analysis + on the values of expressions, classifying them into the following + ranges. *) + +Inductive approx : Type := + | Any (**r any value *) + | Int7 (**r [[0,127]] *) + | Int8s (**r [[-128,127]] *) + | Int8u (**r [[0,255]] *) + | Int15 (**r [[0,32767]] *) + | Int16s (**r [[-32768,32767]] *) + | Int16u (**r [[0,65535]] *) + | Float32. (**r single-precision float *) + +Module Approx. + +Definition bge (x y: approx) : bool := + match x, y with + | Any, _ => true + | Int7, Int7 => true + | Int8s, (Int7 | Int8s) => true + | Int8u, (Int7 | Int8u) => true + | Int15, (Int7 | Int8u | Int15) => true + | Int16s, (Int7 | Int8s | Int8u | Int15 | Int16s) => true + | Int16u, (Int7 | Int8u | Int15 | Int16u) => true + | Float32, Float32 => true + | _, _ => false + end. + +Definition lub (x y: approx) : approx := + match x, y with + | Int7, Int7 => Int7 + | Int7, Int8u => Int8u + | Int7, Int8s => Int8s + | Int7, Int15 => Int15 + | Int7, Int16u => Int16u + | Int7, Int16s => Int16s + | Int8u, (Int7|Int8u) => Int8u + | Int8u, Int15 => Int15 + | Int8u, Int16u => Int16u + | Int8u, Int16s => Int16s + | Int8s, (Int7|Int8s) => Int8s + | Int8s, (Int15|Int16s) => Int16s + | Int15, (Int7|Int8u|Int15) => Int15 + | Int15, Int16u => Int16u + | Int15, (Int8s|Int16s) => Int16s + | Int16u, (Int7|Int8u|Int15|Int16u) => Int16u + | Int16s, (Int7|Int8u|Int8s|Int15|Int16s) => Int16s + | Float32, Float32 => Float32 + | _, _ => Any + end. + +Definition of_int (n: int) := + if Int.eq_dec n (Int.zero_ext 7 n) then Int7 + else if Int.eq_dec n (Int.zero_ext 8 n) then Int8u + else if Int.eq_dec n (Int.sign_ext 8 n) then Int8s + else if Int.eq_dec n (Int.zero_ext 15 n) then Int15 + else if Int.eq_dec n (Int.zero_ext 16 n) then Int16u + else if Int.eq_dec n (Int.sign_ext 16 n) then Int16s + else Any. + +Definition of_float (n: float) := + if Float.eq_dec n (Float.singleoffloat n) then Float32 else Any. + +Definition of_chunk (chunk: memory_chunk) := + match chunk with + | Mint8signed => Int8s + | Mint8unsigned => Int8u + | Mint16signed => Int16s + | Mint16unsigned => Int16u + | Mint32 => Any + | Mfloat32 => Float32 + | Mfloat64 => Any + end. + +Definition unop (op: unary_operation) (a: approx) := + match op with + | Ocast8unsigned => Int8u + | Ocast8signed => Int8s + | Ocast16unsigned => Int16u + | Ocast16signed => Int16s + | Osingleoffloat => Float32 + | Onotbool => Int7 + | _ => Any + end. + +Definition unop_is_redundant (op: unary_operation) (a: approx) := + match op with + | Ocast8unsigned => bge Int8u a + | Ocast8signed => bge Int8s a + | Ocast16unsigned => bge Int16u a + | Ocast16signed => bge Int16s a + | Osingleoffloat => bge Float32 a + | _ => false + end. + +Definition bitwise_and (a1 a2: approx) := + if bge Int8u a1 || bge Int8u a2 then Int8u + else if bge Int16u a1 || bge Int16u a2 then Int16u + else Any. + +Definition bitwise_or (a1 a2: approx) := + if bge Int8u a1 && bge Int8u a2 then Int8u + else if bge Int16u a1 && bge Int16u a2 then Int16u + else Any. + +Definition binop (op: binary_operation) (a1 a2: approx) := + match op with + | Oand => bitwise_and a1 a2 + | Oor | Oxor => bitwise_or a1 a2 + | Ocmp _ => Int7 + | Ocmpu _ => Int7 + | Ocmpf _ => Int7 + | _ => Any + end. + +End Approx. + +(** * Translation of expressions and statements. *) + (** Generation of a Cminor expression for reading a Csharpminor variable. *) -Definition var_get (cenv: compilenv) (id: ident): res expr := +Definition var_get (cenv: compilenv) (id: ident): res (expr * approx) := match PMap.get id cenv with | Var_local chunk => - OK(Evar (for_var id)) + OK(Evar (for_var id), Approx.of_chunk chunk) | Var_stack_scalar chunk ofs => - OK(Eload chunk (make_stackaddr ofs)) + OK(Eload chunk (make_stackaddr ofs), Approx.of_chunk chunk) | Var_global_scalar chunk => - OK(Eload chunk (make_globaladdr id)) + OK(Eload chunk (make_globaladdr id), Approx.of_chunk chunk) | _ => Error(msg "Cminorgen.var_get") end. @@ -133,12 +271,12 @@ Definition var_get (cenv: compilenv) (id: ident): res expr := (** Generation of a Cminor expression for taking the address of a Csharpminor variable. *) -Definition var_addr (cenv: compilenv) (id: ident): res expr := +Definition var_addr (cenv: compilenv) (id: ident): res (expr * approx) := match PMap.get id cenv with | Var_local chunk => Error(msg "Cminorgen.var_addr") - | Var_stack_scalar chunk ofs => OK (make_stackaddr ofs) - | Var_stack_array ofs => OK (make_stackaddr ofs) - | _ => OK (make_globaladdr id) + | Var_stack_scalar chunk ofs => OK (make_stackaddr ofs, Any) + | Var_stack_array ofs => OK (make_stackaddr ofs, Any) + | _ => OK (make_globaladdr id, Any) end. (** Generation of a Cminor statement performing an assignment to @@ -175,38 +313,46 @@ Definition var_set_self (cenv: compilenv) (id: ident) (ty: typ) (k: stmt): res s (** Translation of constants. *) -Definition transl_constant (cst: Csharpminor.constant): constant := +Definition transl_constant (cst: Csharpminor.constant): (constant * approx) := match cst with - | Csharpminor.Ointconst n => Ointconst n - | Csharpminor.Ofloatconst n => Ofloatconst n + | Csharpminor.Ointconst n => + (Ointconst n, Approx.of_int n) + | Csharpminor.Ofloatconst n => + (Ofloatconst n, Approx.of_float n) end. -(** Translation of expressions. All the hard work is done by the - [make_*] and [var_*] functions defined above. *) +(** Translation of expressions. Return both a Cminor expression and + a compile-time approximation of the value of the original + C#minor expression, which is used to remove redundant casts. *) Fixpoint transl_expr (cenv: compilenv) (e: Csharpminor.expr) - {struct e}: res expr := + {struct e}: res (expr * approx) := match e with - | Csharpminor.Evar id => var_get cenv id - | Csharpminor.Etempvar id => OK (Evar (for_temp id)) - | Csharpminor.Eaddrof id => var_addr cenv id + | Csharpminor.Evar id => + var_get cenv id + | Csharpminor.Etempvar id => + OK (Evar (for_temp id), Any) + | Csharpminor.Eaddrof id => + var_addr cenv id | Csharpminor.Econst cst => - OK (Econst (transl_constant cst)) + let (tcst, a) := transl_constant cst in OK (Econst tcst, a) | Csharpminor.Eunop op e1 => - do te1 <- transl_expr cenv e1; - OK (Eunop op te1) + do (te1, a1) <- transl_expr cenv e1; + if Approx.unop_is_redundant op a1 + then OK (te1, a1) + else OK (make_unop op te1, Approx.unop op a1) | Csharpminor.Ebinop op e1 e2 => - do te1 <- transl_expr cenv e1; - do te2 <- transl_expr cenv e2; - OK (Ebinop op te1 te2) + do (te1, a1) <- transl_expr cenv e1; + do (te2, a2) <- transl_expr cenv e2; + OK (Ebinop op te1 te2, Approx.binop op a1 a2) | Csharpminor.Eload chunk e => - do te <- transl_expr cenv e; - OK (Eload chunk te) + do (te, a) <- transl_expr cenv e; + OK (Eload chunk te, Approx.of_chunk chunk) | Csharpminor.Econdition e1 e2 e3 => - do te1 <- transl_expr cenv e1; - do te2 <- transl_expr cenv e2; - do te3 <- transl_expr cenv e3; - OK (Econdition te1 te2 te3) + do (te1, a1) <- transl_expr cenv e1; + do (te2, a2) <- transl_expr cenv e2; + do (te3, a3) <- transl_expr cenv e3; + OK (Econdition te1 te2 te3, Approx.lub a2 a3) end. Fixpoint transl_exprlist (cenv: compilenv) (el: list Csharpminor.expr) @@ -215,7 +361,7 @@ Fixpoint transl_exprlist (cenv: compilenv) (el: list Csharpminor.expr) | nil => OK nil | e1 :: e2 => - do te1 <- transl_expr cenv e1; + do (te1, a1) <- transl_expr cenv e1; do te2 <- transl_exprlist cenv e2; OK (te1 :: te2) end. @@ -261,12 +407,7 @@ Fixpoint switch_env (ls: lbl_stmt) (e: exit_env) {struct ls}: exit_env := end. (** Translation of statements. The nonobvious part is - the translation of [switch] statements, outlined above. - Also note the additional type checks on arguments to calls and returns. - These checks should always succeed for C#minor code generated from - well-typed Clight code, but are necessary for the correctness proof - to go through. -*) + the translation of [switch] statements, outlined above. *) Definition typ_of_opttyp (ot: option typ) := match ot with None => Tint | Some t => t end. @@ -278,17 +419,17 @@ Fixpoint transl_stmt (ret: option typ) (cenv: compilenv) | Csharpminor.Sskip => OK Sskip | Csharpminor.Sassign id e => - do te <- transl_expr cenv e; + do (te, a) <- transl_expr cenv e; var_set cenv id te | Csharpminor.Sset id e => - do te <- transl_expr cenv e; + do (te, a) <- transl_expr cenv e; OK (Sassign (for_temp id) te) | Csharpminor.Sstore chunk e1 e2 => - do te1 <- transl_expr cenv e1; - do te2 <- transl_expr cenv e2; + do (te1, a1) <- transl_expr cenv e1; + do (te2, a2) <- transl_expr cenv e2; OK (make_store chunk te1 te2) | Csharpminor.Scall optid sig e el => - do te <- transl_expr cenv e; + do (te, a) <- transl_expr cenv e; do tel <- transl_exprlist cenv el; OK (Scall (option_map for_temp optid) sig te tel) | Csharpminor.Sseq s1 s2 => @@ -296,7 +437,7 @@ Fixpoint transl_stmt (ret: option typ) (cenv: compilenv) do ts2 <- transl_stmt ret cenv xenv s2; OK (Sseq ts1 ts2) | Csharpminor.Sifthenelse e s1 s2 => - do te <- transl_expr cenv e; + do (te, a) <- transl_expr cenv e; do ts1 <- transl_stmt ret cenv xenv s1; do ts2 <- transl_stmt ret cenv xenv s2; OK (Sifthenelse te ts1 ts2) @@ -311,12 +452,12 @@ Fixpoint transl_stmt (ret: option typ) (cenv: compilenv) | Csharpminor.Sswitch e ls => let cases := switch_table ls O in let default := length cases in - do te <- transl_expr cenv e; + do (te, a) <- transl_expr cenv e; transl_lblstmt ret cenv (switch_env ls xenv) ls (Sswitch te cases default) | Csharpminor.Sreturn None => OK (Sreturn None) | Csharpminor.Sreturn (Some e) => - do te <- transl_expr cenv e; + do (te, a) <- transl_expr cenv e; OK (Sreturn (Some te)) | Csharpminor.Slabel lbl s => do ts <- transl_stmt ret cenv xenv s; OK (Slabel lbl ts) @@ -336,6 +477,8 @@ with transl_lblstmt (ret: option typ) (cenv: compilenv) transl_lblstmt ret cenv (List.tail xenv) ls' (Sseq (Sblock body) ts) end. +(** * Stack layout *) + (** Computation of the set of variables whose address is taken in a piece of Csharpminor code. *) @@ -455,6 +598,8 @@ Definition build_global_compilenv (p: Csharpminor.program) : compilenv := List.fold_left assign_global_variable p.(prog_vars) (PMap.init Var_global_array). +(** * Translation of functions *) + (** Function parameters whose address is taken must be stored in their stack slots at function entry. (Cminor passes these parameters in local variables.) *) diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index 10ffbe4..a6656e0 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -1152,63 +1152,240 @@ Proof. intros. symmetry. eapply IMAGE; eauto. Qed. -(** * Correctness of Cminor construction functions *) +(** * Properties of compile-time approximations of values *) + +Definition val_match_approx (a: approx) (v: val) : Prop := + match a with + | Int7 => v = Val.zero_ext 8 v /\ v = Val.sign_ext 8 v + | Int8u => v = Val.zero_ext 8 v + | Int8s => v = Val.sign_ext 8 v + | Int15 => v = Val.zero_ext 16 v /\ v = Val.sign_ext 16 v + | Int16u => v = Val.zero_ext 16 v + | Int16s => v = Val.sign_ext 16 v + | Float32 => v = Val.singleoffloat v + | Any => True + end. -Remark val_inject_val_of_bool: - forall f b, val_inject f (Val.of_bool b) (Val.of_bool b). +Remark undef_match_approx: forall a, val_match_approx a Vundef. +Proof. + destruct a; simpl; auto. +Qed. + +Lemma val_match_approx_increasing: + forall a1 a2 v, + Approx.bge a1 a2 = true -> val_match_approx a2 v -> val_match_approx a1 v. +Proof. + assert (A: forall v, v = Val.zero_ext 8 v -> v = Val.zero_ext 16 v). + intros. rewrite H. + destruct v; simpl; auto. decEq. symmetry. + apply Int.zero_ext_widen. compute; auto. split. omega. compute; auto. + assert (B: forall v, v = Val.sign_ext 8 v -> v = Val.sign_ext 16 v). + intros. rewrite H. + destruct v; simpl; auto. decEq. symmetry. + apply Int.sign_ext_widen. compute; auto. split. omega. compute; auto. + assert (C: forall v, v = Val.zero_ext 8 v -> v = Val.sign_ext 16 v). + intros. rewrite H. + destruct v; simpl; auto. decEq. symmetry. + apply Int.sign_zero_ext_widen. compute; auto. split. omega. compute; auto. + intros. + unfold Approx.bge in H; destruct a1; try discriminate; destruct a2; simpl in *; try discriminate; intuition; auto. +Qed. + +Lemma approx_lub_ge_left: + forall x y, Approx.bge (Approx.lub x y) x = true. +Proof. + destruct x; destruct y; auto. +Qed. + +Lemma approx_lub_ge_right: + forall x y, Approx.bge (Approx.lub x y) y = true. +Proof. + destruct x; destruct y; auto. +Qed. + +Lemma approx_of_int_sound: + forall n, val_match_approx (Approx.of_int n) (Vint n). +Proof. + unfold Approx.of_int; intros. + destruct (Int.eq_dec n (Int.zero_ext 7 n)). simpl. + split. + decEq. rewrite e. symmetry. apply Int.zero_ext_widen. compute; auto. split. omega. compute; auto. + decEq. rewrite e. symmetry. apply Int.sign_zero_ext_widen. compute; auto. compute; auto. + destruct (Int.eq_dec n (Int.zero_ext 8 n)). simpl; congruence. + destruct (Int.eq_dec n (Int.sign_ext 8 n)). simpl; congruence. + destruct (Int.eq_dec n (Int.zero_ext 15 n)). simpl. + split. + decEq. rewrite e. symmetry. apply Int.zero_ext_widen. compute; auto. split. omega. compute; auto. + decEq. rewrite e. symmetry. apply Int.sign_zero_ext_widen. compute; auto. compute; auto. + destruct (Int.eq_dec n (Int.zero_ext 16 n)). simpl; congruence. + destruct (Int.eq_dec n (Int.sign_ext 16 n)). simpl; congruence. + exact I. +Qed. + +Lemma approx_of_float_sound: + forall f, val_match_approx (Approx.of_float f) (Vfloat f). Proof. - intros; destruct b; unfold Val.of_bool, Vtrue, Vfalse; constructor. + unfold Approx.of_float; intros. + destruct (Float.eq_dec f (Float.singleoffloat f)); simpl; auto. congruence. Qed. -Remark val_inject_eval_compare_mismatch: - forall f c v, - eval_compare_mismatch c = Some v -> - val_inject f v v. +Lemma approx_of_chunk_sound: + forall chunk m b ofs v, + Mem.load chunk m b ofs = Some v -> + val_match_approx (Approx.of_chunk chunk) v. Proof. - unfold eval_compare_mismatch; intros. - destruct c; inv H; unfold Vfalse, Vtrue; constructor. + intros. exploit Mem.load_cast; eauto. + destruct chunk; intros; simpl; auto. Qed. -Remark val_inject_eval_compare_null: - forall f i c v, - eval_compare_null c i = Some v -> - val_inject f v v. +Lemma approx_of_unop_sound: + forall op v1 v a1, + eval_unop op v1 = Some v -> + val_match_approx a1 v1 -> + val_match_approx (Approx.unop op a1) v. +Proof. + destruct op; simpl; intros; auto; inv H. + destruct v1; simpl; auto. rewrite Int.zero_ext_idem; auto. compute; auto. + destruct v1; simpl; auto. rewrite Int.sign_ext_idem; auto. compute; auto. + destruct v1; simpl; auto. rewrite Int.zero_ext_idem; auto. compute; auto. + destruct v1; simpl; auto. rewrite Int.sign_ext_idem; auto. compute; auto. + destruct v1; simpl; auto. destruct (Int.eq i Int.zero); auto. + destruct v1; simpl; auto. rewrite Float.singleoffloat_idem; auto. +Qed. + +Lemma approx_bitwise_and_sound: + forall a1 v1 a2 v2, + val_match_approx a1 v1 -> val_match_approx a2 v2 -> + val_match_approx (Approx.bitwise_and a1 a2) (Val.and v1 v2). +Proof. + assert (X: forall v1 v2 N, 0 < N < Z_of_nat Int.wordsize -> + v2 = Val.zero_ext N v2 -> + Val.and v1 v2 = Val.zero_ext N (Val.and v1 v2)). + intros. rewrite Val.zero_ext_and in *; auto. + rewrite Val.and_assoc. congruence. + assert (Y: forall v1 v2 N, 0 < N < Z_of_nat Int.wordsize -> + v1 = Val.zero_ext N v1 -> + Val.and v1 v2 = Val.zero_ext N (Val.and v1 v2)). + intros. rewrite (Val.and_commut v1 v2). apply X; auto. + assert (P: forall a v, val_match_approx a v -> Approx.bge Int8u a = true -> + v = Val.zero_ext 8 v). + intros. apply (val_match_approx_increasing Int8u a v); auto. + assert (Q: forall a v, val_match_approx a v -> Approx.bge Int16u a = true -> + v = Val.zero_ext 16 v). + intros. apply (val_match_approx_increasing Int16u a v); auto. + intros; unfold Approx.bitwise_and. + destruct (Approx.bge Int8u a1) as []_eqn. simpl. apply Y; eauto. compute; auto. + destruct (Approx.bge Int8u a2) as []_eqn. simpl. apply X; eauto. compute; auto. + destruct (Approx.bge Int16u a1) as []_eqn. simpl. apply Y; eauto. compute; auto. + destruct (Approx.bge Int16u a2) as []_eqn. simpl. apply X; eauto. compute; auto. + simpl; auto. +Qed. + +Lemma approx_bitwise_or_sound: + forall (sem_op: val -> val -> val) a1 v1 a2 v2, + (forall a b c, sem_op (Val.and a (Vint c)) (Val.and b (Vint c)) = + Val.and (sem_op a b) (Vint c)) -> + val_match_approx a1 v1 -> val_match_approx a2 v2 -> + val_match_approx (Approx.bitwise_or a1 a2) (sem_op v1 v2). +Proof. + intros. + assert (X: forall v v' N, 0 < N < Z_of_nat Int.wordsize -> + v = Val.zero_ext N v -> + v' = Val.zero_ext N v' -> + sem_op v v' = Val.zero_ext N (sem_op v v')). + intros. rewrite Val.zero_ext_and in *; auto. + rewrite H3; rewrite H4. rewrite H. rewrite Val.and_assoc. + simpl. rewrite Int.and_idem. auto. + + unfold Approx.bitwise_or. + destruct (Approx.bge Int8u a1 && Approx.bge Int8u a2) as []_eqn. + destruct (andb_prop _ _ Heqb). + simpl. apply X. compute; auto. + apply (val_match_approx_increasing Int8u a1 v1); auto. + apply (val_match_approx_increasing Int8u a2 v2); auto. + + destruct (Approx.bge Int16u a1 && Approx.bge Int16u a2) as []_eqn. + destruct (andb_prop _ _ Heqb0). + simpl. apply X. compute; auto. + apply (val_match_approx_increasing Int16u a1 v1); auto. + apply (val_match_approx_increasing Int16u a2 v2); auto. + + exact I. +Qed. + +Lemma approx_of_binop_sound: + forall op v1 a1 v2 a2 m v, + eval_binop op v1 v2 m = Some v -> + val_match_approx a1 v1 -> val_match_approx a2 v2 -> + val_match_approx (Approx.binop op a1 a2) v. +Proof. + assert (OB: forall ob, val_match_approx Int7 (Val.of_optbool ob)). + destruct ob; simpl. destruct b; auto. auto. + + destruct op; intros; simpl Approx.binop; simpl in H; try (exact I); inv H. + apply approx_bitwise_and_sound; auto. + apply approx_bitwise_or_sound; auto. + intros. destruct a; destruct b; simpl; auto. + rewrite (Int.and_commut i c); rewrite (Int.and_commut i0 c). + rewrite <- Int.and_or_distrib. rewrite Int.and_commut. auto. + apply approx_bitwise_or_sound; auto. + intros. destruct a; destruct b; simpl; auto. + rewrite (Int.and_commut i c); rewrite (Int.and_commut i0 c). + rewrite <- Int.and_xor_distrib. rewrite Int.and_commut. auto. + apply OB. + apply OB. + apply OB. +Qed. + +Lemma approx_unop_is_redundant_sound: + forall op a v, + Approx.unop_is_redundant op a = true -> + val_match_approx a v -> + eval_unop op v = Some v. +Proof. + unfold Approx.unop_is_redundant; intros; destruct op; try discriminate. +(* cast8unsigned *) + assert (V: val_match_approx Int8u v) by (eapply val_match_approx_increasing; eauto). + simpl in *. congruence. +(* cast8signed *) + assert (V: val_match_approx Int8s v) by (eapply val_match_approx_increasing; eauto). + simpl in *. congruence. +(* cast16unsigned *) + assert (V: val_match_approx Int16u v) by (eapply val_match_approx_increasing; eauto). + simpl in *. congruence. +(* cast16signed *) + assert (V: val_match_approx Int16s v) by (eapply val_match_approx_increasing; eauto). + simpl in *. congruence. +(* singleoffloat *) + assert (V: val_match_approx Float32 v) by (eapply val_match_approx_increasing; eauto). + simpl in *. congruence. +Qed. + +(** * Compatibility of evaluation functions with respect to memory injections. *) + +Remark val_inject_val_of_bool: + forall f b, val_inject f (Val.of_bool b) (Val.of_bool b). Proof. - unfold eval_compare_null. intros. destruct (Int.eq i Int.zero). - eapply val_inject_eval_compare_mismatch; eauto. - discriminate. + intros; destruct b; constructor. Qed. -Hint Resolve eval_Econst eval_Eunop eval_Ebinop eval_Eload: evalexpr. +Remark val_inject_val_of_optbool: + forall f ob, val_inject f (Val.of_optbool ob) (Val.of_optbool ob). +Proof. + intros; destruct ob; simpl. destruct b; constructor. constructor. +Qed. -Ltac TrivialOp := +Ltac TrivialExists := match goal with + | [ |- exists y, Some ?x = Some y /\ val_inject _ _ _ ] => + exists x; split; [auto | try(econstructor; eauto)] | [ |- exists y, _ /\ val_inject _ (Vint ?x) _ ] => - exists (Vint x); split; - [eauto with evalexpr | constructor] + exists (Vint x); split; [eauto with evalexpr | constructor] | [ |- exists y, _ /\ val_inject _ (Vfloat ?x) _ ] => - exists (Vfloat x); split; - [eauto with evalexpr | constructor] - | [ |- exists y, _ /\ val_inject _ (Val.of_bool ?x) _ ] => - exists (Val.of_bool x); split; - [eauto with evalexpr | apply val_inject_val_of_bool] - | [ |- exists y, Some ?x = Some y /\ val_inject _ _ _ ] => - exists x; split; [auto | econstructor; eauto] + exists (Vfloat x); split; [eauto with evalexpr | constructor] | _ => idtac end. -(** Correctness of [transl_constant]. *) - -Lemma transl_constant_correct: - forall f sp cst v, - Csharpminor.eval_constant cst = Some v -> - exists tv, - eval_constant tge sp (transl_constant cst) = Some tv - /\ val_inject f v tv. -Proof. - destruct cst; simpl; intros; inv H; TrivialOp. -Qed. - (** Compatibility of [eval_unop] with respect to [val_inject]. *) Lemma eval_unop_compat: @@ -1220,104 +1397,96 @@ Lemma eval_unop_compat: /\ val_inject f v tv. Proof. destruct op; simpl; intros. - inv H; inv H0; simpl; TrivialOp. - inv H; inv H0; simpl; TrivialOp. - inv H; inv H0; simpl; TrivialOp. - inv H; inv H0; simpl; TrivialOp. - inv H0; inv H. TrivialOp. unfold Vfalse; TrivialOp. - inv H0; inv H. TrivialOp. unfold Vfalse; TrivialOp. - inv H0; inv H; TrivialOp. - inv H0; inv H; TrivialOp. - inv H0; inv H; TrivialOp. - inv H0; inv H; TrivialOp. - inv H0; inv H. destruct (Float.intoffloat f0); simpl in H1; inv H1. TrivialOp. - inv H0; inv H. destruct (Float.intuoffloat f0); simpl in H1; inv H1. TrivialOp. - inv H0; inv H; TrivialOp. - inv H0; inv H; TrivialOp. + inv H; inv H0; simpl; TrivialExists. + inv H; inv H0; simpl; TrivialExists. + inv H; inv H0; simpl; TrivialExists. + inv H; inv H0; simpl; TrivialExists. + inv H; inv H0; simpl; TrivialExists. + inv H; inv H0; simpl; TrivialExists. apply val_inject_val_of_bool. + inv H; inv H0; simpl; TrivialExists. + inv H; inv H0; simpl; TrivialExists. + inv H; inv H0; simpl; TrivialExists. + inv H; inv H0; simpl; TrivialExists. + inv H0; simpl in H; inv H. simpl. destruct (Float.intoffloat f0); simpl in *; inv H1. TrivialExists. + inv H0; simpl in H; inv H. simpl. destruct (Float.intuoffloat f0); simpl in *; inv H1. TrivialExists. + inv H0; simpl in H; inv H. simpl. TrivialExists. + inv H0; simpl in H; inv H. simpl. TrivialExists. Qed. (** Compatibility of [eval_binop] with respect to [val_inject]. *) Lemma eval_binop_compat: forall f op v1 tv1 v2 tv2 v m tm, - Csharpminor.eval_binop op v1 v2 m = Some v -> + eval_binop op v1 v2 m = Some v -> val_inject f v1 tv1 -> val_inject f v2 tv2 -> Mem.inject f m tm -> exists tv, - Cminor.eval_binop op tv1 tv2 tm = Some tv + eval_binop op tv1 tv2 tm = Some tv /\ val_inject f v tv. Proof. destruct op; simpl; intros. - inv H0; try discriminate; inv H1; inv H; TrivialOp. + inv H; inv H0; inv H1; TrivialExists. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - inv H0; try discriminate; inv H1; inv H; TrivialOp. + inv H; inv H0; inv H1; TrivialExists. apply Int.sub_add_l. - destruct (eq_block b1 b0); inv H4. - assert (b3 = b2) by congruence. subst b3. - unfold eq_block; rewrite zeq_true. TrivialOp. - replace delta0 with delta by congruence. - decEq. decEq. apply Int.sub_shifted. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - destruct (Int.eq i0 Int.zero); inv H1. TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - destruct (Int.eq i0 Int.zero); inv H1. TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - destruct (Int.eq i0 Int.zero); inv H1. TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - destruct (Int.eq i0 Int.zero); inv H1. TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. - inv H0; try discriminate; inv H1; inv H; TrivialOp. + simpl. destruct (zeq b1 b0); auto. + subst b1. rewrite H in H0; inv H0. + rewrite zeq_true. rewrite Int.sub_shifted. auto. + inv H; inv H0; inv H1; TrivialExists. + inv H0; try discriminate; inv H1; try discriminate. simpl in *. + destruct (Int.eq i0 Int.zero); inv H. TrivialExists. + inv H0; try discriminate; inv H1; try discriminate. simpl in *. + destruct (Int.eq i0 Int.zero); inv H. TrivialExists. + inv H0; try discriminate; inv H1; try discriminate. simpl in *. + destruct (Int.eq i0 Int.zero); inv H. TrivialExists. + inv H0; try discriminate; inv H1; try discriminate. simpl in *. + destruct (Int.eq i0 Int.zero); inv H. TrivialExists. + inv H; inv H0; inv H1; TrivialExists. + inv H; inv H0; inv H1; TrivialExists. + inv H; inv H0; inv H1; TrivialExists. + inv H; inv H0; inv H1; TrivialExists. simpl. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H; inv H0; inv H1; TrivialExists. simpl. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H; inv H0; inv H1; TrivialExists. simpl. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H; inv H0; inv H1; TrivialExists. + inv H; inv H0; inv H1; TrivialExists. + inv H; inv H0; inv H1; TrivialExists. + inv H; inv H0; inv H1; TrivialExists. + inv H; inv H0; inv H1; TrivialExists. apply val_inject_val_of_optbool. (* 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.cmpu c ofs1 ofs0)); split. - unfold eq_block; rewrite zeq_true; simpl. - 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. - (* different blocks in source *) - simpl. exists v; split; [idtac | eapply val_inject_eval_compare_mismatch; eauto]. - 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.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. + inv H; inv H0; inv H1; TrivialExists. + apply val_inject_val_of_optbool. + apply val_inject_val_of_optbool. + apply val_inject_val_of_optbool. +Opaque Int.add. + unfold Val.cmpu. simpl. + destruct (Mem.valid_pointer m b1 (Int.unsigned ofs1)) as []_eqn; simpl; auto. + destruct (Mem.valid_pointer m b0 (Int.unsigned ofs0)) as []_eqn; simpl; auto. + exploit Mem.valid_pointer_inject_val. eauto. eexact Heqb. econstructor; eauto. + intros V1. rewrite V1. + exploit Mem.valid_pointer_inject_val. eauto. eexact Heqb0. econstructor; eauto. + intros V2. rewrite V2. simpl. + destruct (zeq b1 b0). + (* same blocks *) + subst b1. rewrite H in H0; inv H0. rewrite zeq_true. + rewrite Int.translate_cmpu. apply val_inject_val_of_optbool. + eapply Mem.valid_pointer_inject_no_overflow; eauto. + eapply Mem.valid_pointer_inject_no_overflow; eauto. + (* different source blocks *) + destruct (zeq b2 b3). + exploit Mem.different_pointers_inject; eauto. intros [A|A]. + congruence. + destruct c; simpl; auto. + rewrite Int.eq_false. constructor. congruence. + rewrite Int.eq_false. constructor. congruence. + apply val_inject_val_of_optbool. (* cmpf *) - inv H0; try discriminate; inv H1; inv H; TrivialOp. + inv H; inv H0; inv H1; TrivialExists. apply val_inject_val_of_optbool. Qed. +(** * Correctness of Cminor construction functions *) + Lemma make_stackaddr_correct: forall sp te tm ofs, eval_expr tge (Vptr sp Int.zero) te tm @@ -1340,30 +1509,160 @@ Qed. (** Correctness of [make_store]. *) +Inductive val_lessdef_upto (n: Z): val -> val -> Prop := + | val_lessdef_upto_base: + forall v1 v2, Val.lessdef v1 v2 -> val_lessdef_upto n v1 v2 + | val_lessdef_upto_int: + forall n1 n2, Int.zero_ext n n1 = Int.zero_ext n n2 -> val_lessdef_upto n (Vint n1) (Vint n2). + +Hint Resolve val_lessdef_upto_base. + +Remark val_lessdef_upto_zero_ext: + forall n n' v1 v2, + 0 < n < Z_of_nat Int.wordsize -> n <= n' < Z_of_nat Int.wordsize -> + val_lessdef_upto n v1 v2 -> + val_lessdef_upto n (Val.zero_ext n' v1) v2. +Proof. + intros. inv H1. inv H2. + destruct v2; simpl; auto. + apply val_lessdef_upto_int. apply Int.zero_ext_narrow; auto. + simpl; auto. + apply val_lessdef_upto_int. rewrite <- H2. apply Int.zero_ext_narrow; auto. +Qed. + +Remark val_lessdef_upto_sign_ext: + forall n n' v1 v2, + 0 < n < Z_of_nat Int.wordsize -> n <= n' < Z_of_nat Int.wordsize -> + val_lessdef_upto n v1 v2 -> + val_lessdef_upto n (Val.sign_ext n' v1) v2. +Proof. + intros. inv H1. inv H2. + destruct v2; simpl; auto. + apply val_lessdef_upto_int. apply Int.zero_sign_ext_narrow; auto. + simpl; auto. + apply val_lessdef_upto_int. rewrite <- H2. apply Int.zero_sign_ext_narrow; auto. +Qed. + +Remark val_lessdef_upto_and: + forall n v1 v2 m, + 0 < n < Z_of_nat Int.wordsize -> + Int.eq (Int.and m (Int.repr (two_p n - 1))) (Int.repr (two_p n - 1)) = true -> + val_lessdef_upto n v1 v2 -> + val_lessdef_upto n (Val.and v1 (Vint m)) v2. +Proof. + intros. set (p := Int.repr (two_p n - 1)) in *. + generalize (Int.eq_spec (Int.and m p) p). rewrite H0; intros. + inv H1. inv H3. + destruct v2; simpl; auto. + apply val_lessdef_upto_int. repeat rewrite Int.zero_ext_and; auto. + rewrite Int.and_assoc. congruence. + simpl; auto. + apply val_lessdef_upto_int. rewrite <- H3. repeat rewrite Int.zero_ext_and; auto. + rewrite Int.and_assoc. congruence. +Qed. + +Lemma eval_uncast_int8: + forall sp te tm a x, + eval_expr tge sp te tm a x -> + exists v, eval_expr tge sp te tm (uncast_int8 a) v /\ val_lessdef_upto 8 x v. +Proof. + intros until a. functional induction (uncast_int8 a); intros. + (* cast8unsigned *) + inv H. simpl in H4; inv H4. exploit IHe; eauto. intros [v [A B]]. + exists v; split; auto. apply val_lessdef_upto_zero_ext; auto. + compute; auto. split. omega. compute; auto. + (* cast8signed *) + inv H. simpl in H4; inv H4. exploit IHe; eauto. intros [v [A B]]. + exists v; split; auto. apply val_lessdef_upto_sign_ext; auto. + compute; auto. split. omega. compute; auto. + (* cast16unsigned *) + inv H. simpl in H4; inv H4. exploit IHe; eauto. intros [v [A B]]. + exists v; split; auto. apply val_lessdef_upto_zero_ext; auto. + compute; auto. split. omega. compute; auto. + (* cast16signed *) + inv H. simpl in H4; inv H4. exploit IHe; eauto. intros [v [A B]]. + exists v; split; auto. apply val_lessdef_upto_sign_ext; auto. + compute; auto. split. omega. compute; auto. + (* and *) + inv H. inv H5. simpl in H0. inv H0. simpl in H6. inv H6. exploit IHe; eauto. intros [v [A B]]. + exists v; split; auto. apply val_lessdef_upto_and; auto. compute; auto. + (* and 2 *) + exists x; split; auto. + (* default *) + exists x; split; auto. +Qed. + +Lemma eval_uncast_int16: + forall sp te tm a x, + eval_expr tge sp te tm a x -> + exists v, eval_expr tge sp te tm (uncast_int16 a) v /\ val_lessdef_upto 16 x v. +Proof. + intros until a. functional induction (uncast_int16 a); intros. + (* cast16unsigned *) + inv H. simpl in H4; inv H4. exploit IHe; eauto. intros [v [A B]]. + exists v; split; auto. apply val_lessdef_upto_zero_ext; auto. + compute; auto. split. omega. compute; auto. + (* cast16signed *) + inv H. simpl in H4; inv H4. exploit IHe; eauto. intros [v [A B]]. + exists v; split; auto. apply val_lessdef_upto_sign_ext; auto. + compute; auto. split. omega. compute; auto. + (* and *) + inv H. inv H5. simpl in H0. inv H0. simpl in H6. inv H6. exploit IHe; eauto. intros [v [A B]]. + exists v; split; auto. apply val_lessdef_upto_and; auto. compute; auto. + (* and 2 *) + exists x; split; auto. + (* default *) + exists x; split; auto. +Qed. + +Inductive val_lessdef_upto_single: val -> val -> Prop := + | val_lessdef_upto_single_base: + forall v1 v2, Val.lessdef v1 v2 -> val_lessdef_upto_single v1 v2 + | val_lessdef_upto_single_float: + forall n1 n2, Float.singleoffloat n1 = Float.singleoffloat n2 -> val_lessdef_upto_single (Vfloat n1) (Vfloat n2). + +Hint Resolve val_lessdef_upto_single_base. + +Lemma eval_uncast_float32: + forall sp te tm a x, + eval_expr tge sp te tm a x -> + exists v, eval_expr tge sp te tm (uncast_float32 a) v /\ val_lessdef_upto_single x v. +Proof. + intros until a. functional induction (uncast_float32 a); intros. + (* singleoffloat *) + inv H. simpl in H4; inv H4. exploit IHe; eauto. intros [v [A B]]. + exists v; split; auto. + inv B. inv H. destruct v; simpl; auto. + apply val_lessdef_upto_single_float. apply Float.singleoffloat_idem. + simpl; auto. + apply val_lessdef_upto_single_float. rewrite H. apply Float.singleoffloat_idem. + (* default *) + exists x; auto. +Qed. + Inductive val_content_inject (f: meminj): memory_chunk -> val -> val -> Prop := | val_content_inject_8_signed: - forall n, - val_content_inject f Mint8signed (Vint (Int.sign_ext 8 n)) (Vint n) + forall n1 n2, Int.sign_ext 8 n1 = Int.sign_ext 8 n2 -> + val_content_inject f Mint8signed (Vint n1) (Vint n2) | val_content_inject_8_unsigned: - forall n, - val_content_inject f Mint8unsigned (Vint (Int.zero_ext 8 n)) (Vint n) + forall n1 n2, Int.zero_ext 8 n1 = Int.zero_ext 8 n2 -> + val_content_inject f Mint8unsigned (Vint n1) (Vint n2) | val_content_inject_16_signed: - forall n, - val_content_inject f Mint16signed (Vint (Int.sign_ext 16 n)) (Vint n) + forall n1 n2, Int.sign_ext 16 n1 = Int.sign_ext 16 n2 -> + val_content_inject f Mint16signed (Vint n1) (Vint n2) | val_content_inject_16_unsigned: - forall n, - val_content_inject f Mint16unsigned (Vint (Int.zero_ext 16 n)) (Vint n) - | val_content_inject_32: - forall n, - val_content_inject f Mfloat32 (Vfloat (Float.singleoffloat n)) (Vfloat n) + forall n1 n2, Int.zero_ext 16 n1 = Int.zero_ext 16 n2 -> + val_content_inject f Mint16unsigned (Vint n1) (Vint n2) + | val_content_inject_single: + forall n1 n2, Float.singleoffloat n1 = Float.singleoffloat n2 -> + val_content_inject f Mfloat32 (Vfloat n1) (Vfloat n2) | val_content_inject_base: - forall chunk v1 v2, - val_inject f v1 v2 -> + forall chunk v1 v2, val_inject f v1 v2 -> val_content_inject f chunk v1 v2. Hint Resolve val_content_inject_base. -Lemma store_arg_content_inject: +Lemma eval_store_arg: forall f sp te tm a v va chunk, eval_expr tge sp te tm a va -> val_inject f v va -> @@ -1371,20 +1670,37 @@ Lemma store_arg_content_inject: eval_expr tge sp te tm (store_arg chunk a) vb /\ val_content_inject f chunk v vb. Proof. - intros. - assert (exists vb, - eval_expr tge sp te tm a vb - /\ val_content_inject f chunk v vb). - exists va; split. assumption. constructor. assumption. - destruct a; simpl store_arg; trivial; - destruct u; trivial; - destruct chunk; trivial; - inv H; simpl in H6; inv H6; - econstructor; (split; [eauto|idtac]); - destruct v1; simpl in H0; inv H0; constructor; constructor. -Qed. - -Lemma storev_mapped_inject': + intros. + assert (DFL: forall v', Val.lessdef va v' -> val_content_inject f chunk v v'). + intros. apply val_content_inject_base. inv H1. auto. inv H0. auto. + destruct chunk; simpl. + (* int8signed *) + exploit eval_uncast_int8; eauto. intros [v' [A B]]. + exists v'; split; auto. + inv B; auto. inv H0; auto. constructor. apply Int.sign_ext_equal_if_zero_equal; auto. compute; auto. + (* int8unsigned *) + exploit eval_uncast_int8; eauto. intros [v' [A B]]. + exists v'; split; auto. + inv B; auto. inv H0; auto. constructor. auto. + (* int16signed *) + exploit eval_uncast_int16; eauto. intros [v' [A B]]. + exists v'; split; auto. + inv B; auto. inv H0; auto. constructor. apply Int.sign_ext_equal_if_zero_equal; auto. compute; auto. + (* int16unsigned *) + exploit eval_uncast_int16; eauto. intros [v' [A B]]. + exists v'; split; auto. + inv B; auto. inv H0; auto. constructor. auto. + (* int32 *) + exists va; auto. + (* float32 *) + exploit eval_uncast_float32; eauto. intros [v' [A B]]. + exists v'; split; auto. + inv B; auto. inv H0; auto. constructor. auto. + (* float64 *) + exists va; auto. +Qed. + +Lemma storev_mapped_content_inject: forall f chunk m1 a1 v1 n1 m2 a2 v2, Mem.inject f m1 m2 -> Mem.storev chunk m1 a1 v1 = Some n1 -> @@ -1400,11 +1716,11 @@ Proof. intros. rewrite <- H0. destruct a1; simpl; auto. inv H2; (eapply Mem.storev_mapped_inject; [eauto|idtac|eauto|eauto]); auto; apply H3; intros. - apply Mem.store_int8_sign_ext. - apply Mem.store_int8_zero_ext. - apply Mem.store_int16_sign_ext. - apply Mem.store_int16_zero_ext. - apply Mem.store_float32_truncate. + rewrite <- Mem.store_int8_sign_ext. rewrite H4. apply Mem.store_int8_sign_ext. + rewrite <- Mem.store_int8_zero_ext. rewrite H4. apply Mem.store_int8_zero_ext. + rewrite <- Mem.store_int16_sign_ext. rewrite H4. apply Mem.store_int16_sign_ext. + rewrite <- Mem.store_int16_zero_ext. rewrite H4. apply Mem.store_int16_zero_ext. + rewrite <- Mem.store_float32_truncate. rewrite H4. apply Mem.store_float32_truncate. Qed. Lemma make_store_correct: @@ -1422,36 +1738,87 @@ Lemma make_store_correct: /\ Mem.inject f m' tm'. Proof. intros. unfold make_store. - exploit store_arg_content_inject. eexact H0. eauto. + exploit eval_store_arg. eexact H0. eauto. intros [tv [EVAL VCINJ]]. - exploit storev_mapped_inject'; eauto. + exploit storev_mapped_content_inject; eauto. intros [tm' [STORE MEMINJ]]. exists tm'; exists tv. split. eapply step_store; eauto. auto. Qed. +(** Correctness of [make_unop]. *) + +Lemma eval_make_unop: + forall sp te tm a v op v', + eval_expr tge sp te tm a v -> + eval_unop op v = Some v' -> + exists v'', eval_expr tge sp te tm (make_unop op a) v'' /\ Val.lessdef v' v''. +Proof. + intros; unfold make_unop. + assert (DFL: exists v'', eval_expr tge sp te tm (Eunop op a) v'' /\ Val.lessdef v' v''). + exists v'; split. econstructor; eauto. auto. + destruct op; auto; simpl in H0; inv H0. +(* cast8unsigned *) + exploit eval_uncast_int8; eauto. intros [v1 [A B]]. + exists (Val.zero_ext 8 v1); split. econstructor; eauto. + inv B. apply Val.zero_ext_lessdef; auto. simpl. rewrite H0; auto. +(* cast8signed *) + exploit eval_uncast_int8; eauto. intros [v1 [A B]]. + exists (Val.sign_ext 8 v1); split. econstructor; eauto. + inv B. apply Val.sign_ext_lessdef; auto. simpl. + exploit Int.sign_ext_equal_if_zero_equal; eauto. compute; auto. intro EQ; rewrite EQ; auto. +(* cast16unsigned *) + exploit eval_uncast_int16; eauto. intros [v1 [A B]]. + exists (Val.zero_ext 16 v1); split. econstructor; eauto. + inv B. apply Val.zero_ext_lessdef; auto. simpl. rewrite H0; auto. +(* cast16signed *) + exploit eval_uncast_int16; eauto. intros [v1 [A B]]. + exists (Val.sign_ext 16 v1); split. econstructor; eauto. + inv B. apply Val.sign_ext_lessdef; auto. simpl. + exploit Int.sign_ext_equal_if_zero_equal; eauto. compute; auto. intro EQ; rewrite EQ; auto. +(* singleoffloat *) + exploit eval_uncast_float32; eauto. intros [v1 [A B]]. + exists (Val.singleoffloat v1); split. econstructor; eauto. + inv B. apply Val.singleoffloat_lessdef; auto. simpl. rewrite H0; auto. +Qed. + +Lemma make_unop_correct: + forall f sp te tm a v op v' tv, + eval_expr tge sp te tm a tv -> + eval_unop op v = Some v' -> + val_inject f v tv -> + exists tv', eval_expr tge sp te tm (make_unop op a) tv' /\ val_inject f v' tv'. +Proof. + intros. exploit eval_unop_compat; eauto. intros [tv' [A B]]. + exploit eval_make_unop; eauto. intros [tv'' [C D]]. + exists tv''; split; auto. + inv D. auto. inv B. auto. +Qed. + (** Correctness of the variable accessors [var_get], [var_addr], and [var_set]. *) Lemma var_get_correct: - forall cenv id a f tf e le te sp lo hi m cs tm b chunk v, - var_get cenv id = OK a -> + forall cenv id a app f tf e le te sp lo hi m cs tm b chunk v, + var_get cenv id = OK (a, app) -> match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> Mem.inject f m tm -> eval_var_ref ge e id b chunk -> Mem.load chunk m b 0 = Some v -> exists tv, - eval_expr tge (Vptr sp Int.zero) te tm a tv /\ - val_inject f v tv. + eval_expr tge (Vptr sp Int.zero) te tm a tv + /\ val_inject f v tv + /\ val_match_approx app v. Proof. unfold var_get; intros. assert (match_var f id e m te sp cenv!!id). inv H0. inv MENV. auto. inv H4; rewrite <- H5 in H; inv H; inv H2; try congruence. (* var_local *) + rewrite H in H6; inv H6. exists v'; split. apply eval_Evar. auto. - congruence. + split. congruence. eapply approx_of_chunk_sound; eauto. (* var_stack_scalar *) assert (b0 = b). congruence. subst b0. assert (chunk0 = chunk). congruence. subst chunk0. @@ -1460,7 +1827,7 @@ Proof. intros [tv [LOAD INJ]]. exists tv; split. eapply eval_Eload; eauto. eapply make_stackaddr_correct; eauto. - auto. + split. auto. eapply approx_of_chunk_sound; eauto. (* var_global_scalar *) simpl in *. exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. inv MG. @@ -1472,17 +1839,18 @@ Proof. exists tv; split. eapply eval_Eload; eauto. eapply make_globaladdr_correct; eauto. rewrite symbols_preserved; auto. - auto. + split. auto. eapply approx_of_chunk_sound; eauto. Qed. Lemma var_addr_correct: - forall cenv id a f tf e le te sp lo hi m cs tm b, + forall cenv id a app f tf e le te sp lo hi m cs tm b, match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> - var_addr cenv id = OK a -> + var_addr cenv id = OK (a, app) -> eval_var_addr ge e id b -> exists tv, - eval_expr tge (Vptr sp Int.zero) te tm a tv /\ - val_inject f (Vptr b Int.zero) tv. + eval_expr tge (Vptr sp Int.zero) te tm a tv + /\ val_inject f (Vptr b Int.zero) tv + /\ val_match_approx app (Vptr b Int.zero). Proof. unfold var_addr; intros. assert (match_var f id e m te sp cenv!!id). @@ -1490,20 +1858,21 @@ Proof. inv H2; rewrite <- H3 in H0; inv H0; inv H1; try congruence. (* var_stack_scalar *) exists (Vptr sp (Int.repr ofs)); split. - eapply make_stackaddr_correct. congruence. + eapply make_stackaddr_correct. + split. congruence. exact I. (* var_stack_array *) exists (Vptr sp (Int.repr ofs)); split. - eapply make_stackaddr_correct. congruence. + eapply make_stackaddr_correct. split. congruence. exact I. (* var_global_scalar *) exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. inv MG. exists (Vptr b Int.zero); split. eapply make_globaladdr_correct; eauto. rewrite symbols_preserved; auto. - econstructor; eauto. + split. econstructor; eauto. exact I. (* var_global_array *) exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. inv MG. exists (Vptr b Int.zero); split. eapply make_globaladdr_correct; eauto. rewrite symbols_preserved; auto. - econstructor; eauto. + split. econstructor; eauto. exact I. Qed. Lemma var_set_correct: @@ -2172,6 +2541,20 @@ Proof. intros. inv H0; inv H; constructor; auto. Qed. +Lemma transl_constant_correct: + forall f sp cst v, + Csharpminor.eval_constant cst = Some v -> + let (tcst, a) := transl_constant cst in + exists tv, + eval_constant tge sp tcst = Some tv + /\ val_inject f v tv + /\ val_match_approx a v. +Proof. + destruct cst; simpl; intros; inv H. + exists (Vint i); intuition. apply approx_of_int_sound. + exists (Vfloat f0); intuition. apply approx_of_float_sound. +Qed. + Lemma transl_expr_correct: forall f m tm cenv tf e le te sp lo hi cs (MINJ: Mem.inject f m tm) @@ -2180,44 +2563,58 @@ Lemma transl_expr_correct: (Mem.nextblock m) (Mem.nextblock tm)), forall a v, Csharpminor.eval_expr ge e le m a v -> - forall ta - (TR: transl_expr cenv a = OK ta), + forall ta app + (TR: transl_expr cenv a = OK (ta, app)), exists tv, eval_expr tge (Vptr sp Int.zero) te tm ta tv - /\ val_inject f v tv. + /\ val_inject f v tv + /\ val_match_approx app v. Proof. induction 3; intros; simpl in TR; try (monadInv TR). (* Evar *) eapply var_get_correct; eauto. (* Etempvar *) inv MATCH. inv MENV. exploit me_temps0; eauto. intros [tv [A B]]. - exists tv; split; auto. constructor; auto. + exists tv; split. constructor; auto. split. auto. exact I. (* Eaddrof *) eapply var_addr_correct; eauto. (* Econst *) - exploit transl_constant_correct; eauto. intros [tv [A B]]. + exploit transl_constant_correct; eauto. + destruct (transl_constant cst) as [tcst a]; inv TR. + intros [tv [A [B C]]]. exists tv; split. constructor; eauto. eauto. (* Eunop *) - exploit IHeval_expr; eauto. intros [tv1 [EVAL1 INJ1]]. - exploit eval_unop_compat; eauto. intros [tv [EVAL INJ]]. - exists tv; split. econstructor; eauto. auto. + exploit IHeval_expr; eauto. intros [tv1 [EVAL1 [INJ1 APP1]]]. + unfold Csharpminor.eval_unop in H0. + destruct (Approx.unop_is_redundant op x0) as []_eqn; inv EQ0. + (* -- eliminated *) + exploit approx_unop_is_redundant_sound; eauto. intros. + replace v with v1 by congruence. + exists tv1; auto. + (* -- preserved *) + exploit make_unop_correct; eauto. intros [tv [A B]]. + exists tv; split. auto. split. auto. eapply approx_of_unop_sound; eauto. (* Ebinop *) - exploit IHeval_expr1; eauto. intros [tv1 [EVAL1 INJ1]]. - exploit IHeval_expr2; eauto. intros [tv2 [EVAL2 INJ2]]. + exploit IHeval_expr1; eauto. intros [tv1 [EVAL1 [INJ1 APP1]]]. + exploit IHeval_expr2; eauto. intros [tv2 [EVAL2 [INJ2 APP2]]]. exploit eval_binop_compat; eauto. intros [tv [EVAL INJ]]. - exists tv; split. econstructor; eauto. auto. + exists tv; split. econstructor; eauto. split. auto. eapply approx_of_binop_sound; eauto. (* Eload *) - exploit IHeval_expr; eauto. intros [tv1 [EVAL1 INJ1]]. + exploit IHeval_expr; eauto. intros [tv1 [EVAL1 [INJ1 APP1]]]. exploit Mem.loadv_inject; eauto. intros [tv [LOAD INJ]]. - exists tv; split. econstructor; eauto. auto. + exists tv; split. econstructor; eauto. split. auto. + destruct v1; simpl in H0; try discriminate. eapply approx_of_chunk_sound; eauto. (* Econdition *) - exploit IHeval_expr1; eauto. intros [tv1 [EVAL1 INJ1]]. + exploit IHeval_expr1; eauto. intros [tv1 [EVAL1 [INJ1 APP1]]]. assert (transl_expr cenv (if vb1 then b else c) = - OK (if vb1 then x0 else x1)). + OK ((if vb1 then x1 else x3), (if vb1 then x2 else x4))). destruct vb1; auto. - exploit IHeval_expr2; eauto. intros [tv2 [EVAL2 INJ2]]. + exploit IHeval_expr2; eauto. intros [tv2 [EVAL2 [INJ2 APP2]]]. exists tv2; split. eapply eval_Econdition; eauto. - eapply bool_of_val_inject; eauto. auto. + eapply bool_of_val_inject; eauto. + split. auto. + apply val_match_approx_increasing with (if vb1 then x2 else x4); auto. + destruct vb1. apply approx_lub_ge_left. apply approx_lub_ge_right. Qed. Lemma transl_exprlist_correct: @@ -2236,7 +2633,7 @@ Lemma transl_exprlist_correct: Proof. induction 3; intros; monadInv TR. exists (@nil val); split. constructor. constructor. - exploit transl_expr_correct; eauto. intros [tv1 [EVAL1 VINJ1]]. + exploit transl_expr_correct; eauto. intros [tv1 [EVAL1 [VINJ1 APP1]]]. exploit IHeval_exprlist; eauto. intros [tv2 [EVAL2 VINJ2]]. exists (tv1 :: tv2); split. constructor; auto. constructor; auto. Qed. @@ -2669,7 +3066,7 @@ Proof. (* assign *) monadInv TR. - exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]]. + exploit transl_expr_correct; eauto. intros [tv [EVAL [VINJ APP]]]. exploit var_set_correct; eauto. intros [te' [tm' [EXEC [MINJ' [MCS' OTHER]]]]]. left; econstructor; split. @@ -2678,7 +3075,7 @@ Proof. (* set *) monadInv TR. - exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]]. + exploit transl_expr_correct; eauto. intros [tv [EVAL [VINJ APP]]]. left; econstructor; split. apply plus_one. econstructor; eauto. econstructor; eauto. @@ -2687,9 +3084,9 @@ Proof. (* store *) monadInv TR. exploit transl_expr_correct. eauto. eauto. eexact H. eauto. - intros [tv1 [EVAL1 VINJ1]]. + intros [tv1 [EVAL1 [VINJ1 APP1]]]. exploit transl_expr_correct. eauto. eauto. eexact H0. eauto. - intros [tv2 [EVAL2 VINJ2]]. + intros [tv2 [EVAL2 [VINJ2 APP2]]]. exploit make_store_correct. eexact EVAL1. eexact EVAL2. eauto. eauto. auto. auto. intros [tm' [tv' [EXEC [STORE' MINJ']]]]. left; econstructor; split. @@ -2703,7 +3100,7 @@ Proof. (* call *) simpl in H1. exploit functions_translated; eauto. intros [tfd [FIND TRANS]]. monadInv TR. - exploit transl_expr_correct; eauto. intros [tvf [EVAL1 VINJ1]]. + exploit transl_expr_correct; eauto. intros [tvf [EVAL1 [VINJ1 APP1]]]. assert (tvf = vf). exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. eapply val_inject_function_pointer; eauto. @@ -2728,8 +3125,8 @@ Proof. (* ifthenelse *) monadInv TR. - exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]]. - left; exists (State tfn (if b then x0 else x1) tk (Vptr sp Int.zero) te tm); split. + exploit transl_expr_correct; eauto. intros [tv [EVAL [VINJ APP]]]. + left; exists (State tfn (if b then x1 else x2) tk (Vptr sp Int.zero) te tm); split. apply plus_one. eapply step_ifthenelse; eauto. eapply bool_of_val_inject; eauto. econstructor; eauto. destruct b; auto. @@ -2781,7 +3178,7 @@ Proof. (* switch *) monadInv TR. left. - exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]]. + exploit transl_expr_correct; eauto. intros [tv [EVAL [VINJ APP]]]. inv VINJ. exploit switch_descent; eauto. intros [k1 [A B]]. exploit switch_ascent; eauto. intros [k2 [C D]]. @@ -2805,7 +3202,7 @@ Proof. (* return some *) monadInv TR. left. - exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]]. + exploit transl_expr_correct; eauto. intros [tv [EVAL [VINJ APP]]]. exploit match_callstack_freelist; eauto. intros [tm' [A [B C]]]. econstructor; split. apply plus_one. eapply step_return_1. eauto. eauto. diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index db5b7bc..0f7810d 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -441,11 +441,10 @@ Proof. exists (Vint n); split; auto. exists (Vptr b0 ofs); split; auto. constructor. exists (Vptr b0 ofs); split; auto. constructor. - rewrite <- Float.cmp_ne_eq. destruct (Float.cmp Cne f Float.zero) as []_eqn. - exists Vtrue; split. eapply eval_Ebinop; eauto with cshm. simpl. rewrite Heqb; auto. - constructor. apply Int.one_not_zero. - exists Vfalse; split. eapply eval_Ebinop; eauto with cshm. simpl. rewrite Heqb; auto. - constructor. + rewrite <- Float.cmp_ne_eq. + exists (Val.of_bool (Float.cmp Cne f Float.zero)); split. + econstructor; eauto with cshm. + destruct (Float.cmp Cne f Float.zero); simpl; constructor. apply Int.one_not_zero. Qed. Lemma make_neg_correct: @@ -607,15 +606,18 @@ Proof. inversion H8. eauto with cshm. (* pp ptr ptr *) inversion H10. eapply eval_Ebinop; eauto with cshm. - simpl. rewrite H3. unfold eq_block. rewrite H9. auto. + simpl. unfold Val.cmpu. simpl. rewrite H3. rewrite H9. auto. inversion H10. eapply eval_Ebinop; eauto with cshm. - simpl. rewrite H3. unfold eq_block. rewrite H9. auto. + simpl. unfold Val.cmpu. simpl. rewrite H3. rewrite H9. + destruct cmp; simpl in *; inv H; auto. (* pp ptr int *) inversion H9. eapply eval_Ebinop; eauto with cshm. - simpl. unfold eval_compare_null. rewrite H8. auto. + simpl. unfold Val.cmpu. simpl. rewrite H8. + destruct cmp; simpl in *; inv H; auto. (* pp int ptr *) inversion H9. eapply eval_Ebinop; eauto with cshm. - simpl. unfold eval_compare_null. rewrite H8. auto. + simpl. unfold Val.cmpu. simpl. rewrite H8. + destruct cmp; simpl in *; inv H; auto. (* ff *) inversion H8. eauto with cshm. (* if *) diff --git a/common/Memdata.v b/common/Memdata.v index fde8b47..47ed79e 100644 --- a/common/Memdata.v +++ b/common/Memdata.v @@ -1029,22 +1029,6 @@ Proof. apply repeat_Undef_inject_any. apply encode_val_length. Qed. -(** The identity injection has interesting properties. *) - -Definition inject_id : meminj := fun b => Some(b, 0). - -Lemma val_inject_id: - forall v1 v2, - val_inject inject_id v1 v2 <-> Val.lessdef v1 v2. -Proof. - intros; split; intros. - inv H. constructor. constructor. - unfold inject_id in H0. inv H0. rewrite Int.add_zero. constructor. - constructor. - inv H. destruct v2; econstructor. unfold inject_id; reflexivity. rewrite Int.add_zero; auto. - constructor. -Qed. - Definition memval_lessdef: memval -> memval -> Prop := memval_inject inject_id. Lemma memval_lessdef_refl: diff --git a/common/Memory.v b/common/Memory.v index 157867e..e1c68bd 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -3105,6 +3105,15 @@ Proof. eapply mi_access; eauto. auto. Qed. +Theorem valid_pointer_extends: + forall m1 m2 b ofs, + extends m1 m2 -> valid_pointer m1 b ofs = true -> valid_pointer m2 b ofs = true. +Proof. + intros. + rewrite valid_pointer_valid_access in *. + eapply valid_access_extends; eauto. +Qed. + (* Theorem bounds_extends: forall m1 m2 b, diff --git a/common/Memtype.v b/common/Memtype.v index 40e03a3..f763581 100644 --- a/common/Memtype.v +++ b/common/Memtype.v @@ -917,6 +917,9 @@ Axiom perm_extends: Axiom valid_access_extends: forall m1 m2 chunk b ofs p, extends m1 m2 -> valid_access m1 chunk b ofs p -> valid_access m2 chunk b ofs p. +Axiom valid_pointer_extends: + forall m1 m2 b ofs, + extends m1 m2 -> valid_pointer m1 b ofs = true -> valid_pointer m2 b ofs = true. (** * Memory injections *) diff --git a/common/Values.v b/common/Values.v index 4dc74b2..7fae3b7 100644 --- a/common/Values.v +++ b/common/Values.v @@ -54,8 +54,6 @@ Definition Vfalse: val := Vint Int.zero. Module Val. -Definition of_bool (b: bool): val := if b then Vtrue else Vfalse. - Definition has_type (v: val) (t: typ) : Prop := match v, t with | Vundef, _ => True @@ -115,28 +113,31 @@ Definition absf (v: val) : val := | _ => Vundef end. -Definition intoffloat (v: val) : val := +Definition maketotal (ov: option val) : val := + match ov with Some v => v | None => Vundef end. + +Definition intoffloat (v: val) : option val := match v with - | Vfloat f => match Float.intoffloat f with Some n => Vint n | None => Vundef end - | _ => Vundef + | Vfloat f => option_map Vint (Float.intoffloat f) + | _ => None end. -Definition intuoffloat (v: val) : val := +Definition intuoffloat (v: val) : option val := match v with - | Vfloat f => match Float.intuoffloat f with Some n => Vint n | None => Vundef end - | _ => Vundef + | Vfloat f => option_map Vint (Float.intuoffloat f) + | _ => None end. -Definition floatofint (v: val) : val := +Definition floatofint (v: val) : option val := match v with - | Vint n => Vfloat (Float.floatofint n) - | _ => Vundef + | Vint n => Some (Vfloat (Float.floatofint n)) + | _ => None end. -Definition floatofintu (v: val) : val := +Definition floatofintu (v: val) : option val := match v with - | Vint n => Vfloat (Float.floatofintu n) - | _ => Vundef + | Vint n => Some (Vfloat (Float.floatofintu n)) + | _ => None end. Definition floatofwords (v1 v2: val) : val := @@ -145,12 +146,20 @@ Definition floatofwords (v1 v2: val) : val := | _, _ => Vundef end. +Definition negint (v: val) : val := + match v with + | Vint n => Vint (Int.neg n) + | _ => Vundef + end. + Definition notint (v: val) : val := match v with - | Vint n => Vint (Int.xor n Int.mone) + | Vint n => Vint (Int.not n) | _ => Vundef end. +Definition of_bool (b: bool): val := if b then Vtrue else Vfalse. + Definition notbool (v: val) : val := match v with | Vint n => of_bool (Int.eq n Int.zero) @@ -199,32 +208,32 @@ Definition mul (v1 v2: val): val := | _, _ => Vundef end. -Definition divs (v1 v2: val): val := +Definition divs (v1 v2: val): option val := match v1, v2 with | Vint n1, Vint n2 => - if Int.eq n2 Int.zero then Vundef else Vint(Int.divs n1 n2) - | _, _ => Vundef + if Int.eq n2 Int.zero then None else Some(Vint(Int.divs n1 n2)) + | _, _ => None end. -Definition mods (v1 v2: val): val := +Definition mods (v1 v2: val): option val := match v1, v2 with | Vint n1, Vint n2 => - if Int.eq n2 Int.zero then Vundef else Vint(Int.mods n1 n2) - | _, _ => Vundef + if Int.eq n2 Int.zero then None else Some(Vint(Int.mods n1 n2)) + | _, _ => None end. -Definition divu (v1 v2: val): val := +Definition divu (v1 v2: val): option val := match v1, v2 with | Vint n1, Vint n2 => - if Int.eq n2 Int.zero then Vundef else Vint(Int.divu n1 n2) - | _, _ => Vundef + if Int.eq n2 Int.zero then None else Some(Vint(Int.divu n1 n2)) + | _, _ => None end. -Definition modu (v1 v2: val): val := +Definition modu (v1 v2: val): option val := match v1, v2 with | Vint n1, Vint n2 => - if Int.eq n2 Int.zero then Vundef else Vint(Int.modu n1 n2) - | _, _ => Vundef + if Int.eq n2 Int.zero then None else Some(Vint(Int.modu n1 n2)) + | _, _ => None end. Definition add_carry (v1 v2 cin: val): val := @@ -278,13 +287,13 @@ Definition shr_carry (v1 v2: val): val := | _, _ => Vundef end. -Definition shrx (v1 v2: val): val := +Definition shrx (v1 v2: val): option val := match v1, v2 with | Vint n1, Vint n2 => - if Int.ltu n2 Int.iwordsize - then Vint(Int.shrx n1 n2) - else Vundef - | _, _ => Vundef + if Int.ltu n2 (Int.repr 31) + then Some(Vint(Int.shrx n1 n2)) + else None + | _, _ => None end. Definition shru (v1 v2: val): val := @@ -335,48 +344,60 @@ Definition divf (v1 v2: val): val := | _, _ => Vundef end. -Definition cmp_mismatch (c: comparison): val := - match c with - | Ceq => Vfalse - | Cne => Vtrue - | _ => Vundef - end. +Section COMPARISONS. -Definition cmp (c: comparison) (v1 v2: val): val := +Variable valid_ptr: block -> Z -> bool. + +Definition cmp_bool (c: comparison) (v1 v2: val): option bool := match v1, v2 with - | Vint n1, Vint n2 => of_bool (Int.cmp c n1 n2) - | Vint n1, Vptr b2 ofs2 => - if Int.eq n1 Int.zero then cmp_mismatch c else Vundef - | Vptr b1 ofs1, Vptr b2 ofs2 => - if zeq b1 b2 - then of_bool (Int.cmp c ofs1 ofs2) - else cmp_mismatch c - | Vptr b1 ofs1, Vint n2 => - if Int.eq n2 Int.zero then cmp_mismatch c else Vundef - | _, _ => Vundef + | Vint n1, Vint n2 => Some (Int.cmp c n1 n2) + | _, _ => None end. -Definition cmpu (c: comparison) (v1 v2: val): val := +Definition cmp_different_blocks (c: comparison): option bool := + match c with + | Ceq => Some false + | Cne => Some true + | _ => None + end. + +Definition cmpu_bool (c: comparison) (v1 v2: val): option bool := match v1, v2 with | Vint n1, Vint n2 => - of_bool (Int.cmpu c n1 n2) + Some (Int.cmpu c n1 n2) | Vint n1, Vptr b2 ofs2 => - if Int.eq n1 Int.zero then cmp_mismatch c else Vundef + if Int.eq n1 Int.zero then cmp_different_blocks c else None | Vptr b1 ofs1, Vptr b2 ofs2 => - if zeq b1 b2 - then of_bool (Int.cmpu c ofs1 ofs2) - else cmp_mismatch c + if valid_ptr b1 (Int.unsigned ofs1) && valid_ptr b2 (Int.unsigned ofs2) then + if zeq b1 b2 + then Some (Int.cmpu c ofs1 ofs2) + else cmp_different_blocks c + else None | Vptr b1 ofs1, Vint n2 => - if Int.eq n2 Int.zero then cmp_mismatch c else Vundef - | _, _ => Vundef + if Int.eq n2 Int.zero then cmp_different_blocks c else None + | _, _ => None end. -Definition cmpf (c: comparison) (v1 v2: val): val := +Definition cmpf_bool (c: comparison) (v1 v2: val): option bool := match v1, v2 with - | Vfloat f1, Vfloat f2 => of_bool (Float.cmp c f1 f2) - | _, _ => Vundef + | Vfloat f1, Vfloat f2 => Some (Float.cmp c f1 f2) + | _, _ => None end. +Definition of_optbool (ob: option bool): val := + match ob with Some true => Vtrue | Some false => Vfalse | None => Vundef end. + +Definition cmp (c: comparison) (v1 v2: val): val := + of_optbool (cmp_bool c v1 v2). + +Definition cmpu (c: comparison) (v1 v2: val): val := + of_optbool (cmpu_bool c v1 v2). + +Definition cmpf (c: comparison) (v1 v2: val): val := + of_optbool (cmpf_bool c v1 v2). + +End COMPARISONS. + (** [load_result] is used in the memory model (library [Mem]) to post-process the results of a memory read. For instance, consider storing the integer value [0xFFF] on 1 byte at a @@ -483,6 +504,12 @@ Proof. destruct b; reflexivity. Qed. +Theorem notbool_negb_3: + forall ob, of_optbool (option_map negb ob) = notbool (of_optbool ob). +Proof. + destruct ob; auto. destruct b; auto. +Qed. + Theorem notbool_idem2: forall b, notbool(notbool(of_bool b)) = of_bool b. Proof. @@ -496,6 +523,12 @@ Proof. case (Int.eq i Int.zero); reflexivity. Qed. +Theorem notbool_idem4: + forall ob, notbool (notbool (of_optbool ob)) = of_optbool ob. +Proof. + destruct ob; auto. destruct b; auto. +Qed. + Theorem add_commut: forall x y, add x y = add y x. Proof. destruct x; destruct y; simpl; auto. @@ -612,59 +645,59 @@ Proof. Qed. Theorem mods_divs: - forall x y, mods x y = sub x (mul (divs x y) y). + forall x y z, + mods x y = Some z -> exists v, divs x y = Some v /\ z = sub x (mul v y). Proof. - destruct x; destruct y; simpl; auto. - case (Int.eq i0 Int.zero); simpl. auto. decEq. apply Int.mods_divs. + intros. destruct x; destruct y; simpl in *; try discriminate. + destruct (Int.eq i0 Int.zero); inv H. + exists (Vint (Int.divs i i0)); split; auto. + simpl. rewrite Int.mods_divs. auto. Qed. Theorem modu_divu: - forall x y, modu x y = sub x (mul (divu x y) y). + forall x y z, + modu x y = Some z -> exists v, divu x y = Some v /\ z = sub x (mul v y). Proof. - destruct x; destruct y; simpl; auto. - generalize (Int.eq_spec i0 Int.zero); - case (Int.eq i0 Int.zero); simpl. auto. - intro. decEq. apply Int.modu_divu. auto. + intros. destruct x; destruct y; simpl in *; try discriminate. + destruct (Int.eq i0 Int.zero) as []_eqn; inv H. + exists (Vint (Int.divu i i0)); split; auto. + simpl. rewrite Int.modu_divu. auto. + generalize (Int.eq_spec i0 Int.zero). rewrite Heqb; auto. Qed. Theorem divs_pow2: - forall x n logn, - Int.is_power2 n = Some logn -> - divs x (Vint n) = shrx x (Vint logn). + forall x n logn y, + Int.is_power2 n = Some logn -> Int.ltu logn (Int.repr 31) = true -> + divs x (Vint n) = Some y -> + shrx x (Vint logn) = Some y. Proof. - intros; destruct x; simpl; auto. - change 32 with (Z_of_nat Int.wordsize). - rewrite (Int.is_power2_range _ _ H). - generalize (Int.eq_spec n Int.zero); - case (Int.eq n Int.zero); intro. - subst n. compute in H. discriminate. - decEq. apply Int.divs_pow2. auto. + intros; destruct x; simpl in H1; inv H1. + destruct (Int.eq n Int.zero); inv H3. + simpl. rewrite H0. decEq. decEq. symmetry. apply Int.divs_pow2. auto. Qed. Theorem divu_pow2: - forall x n logn, + forall x n logn y, Int.is_power2 n = Some logn -> - divu x (Vint n) = shru x (Vint logn). + divu x (Vint n) = Some y -> + shru x (Vint logn) = y. Proof. - intros; destruct x; simpl; auto. - change 32 with (Z_of_nat Int.wordsize). - rewrite (Int.is_power2_range _ _ H). - generalize (Int.eq_spec n Int.zero); - case (Int.eq n Int.zero); intro. - subst n. compute in H. discriminate. - decEq. apply Int.divu_pow2. auto. + intros; destruct x; simpl in H0; inv H0. + destruct (Int.eq n Int.zero); inv H2. + simpl. + rewrite (Int.is_power2_range _ _ H). + decEq. symmetry. apply Int.divu_pow2. auto. Qed. Theorem modu_pow2: - forall x n logn, + forall x n logn y, Int.is_power2 n = Some logn -> - modu x (Vint n) = and x (Vint (Int.sub n Int.one)). + modu x (Vint n) = Some y -> + and x (Vint (Int.sub n Int.one)) = y. Proof. - intros; destruct x; simpl; auto. - generalize (Int.eq_spec n Int.zero); - case (Int.eq n Int.zero); intro. - subst n. compute in H. discriminate. - decEq. eapply Int.modu_and; eauto. + intros; destruct x; simpl in H0; inv H0. + destruct (Int.eq n Int.zero); inv H2. + simpl. decEq. symmetry. eapply Int.modu_and; eauto. Qed. Theorem and_commut: forall x y, and x y = and y x. @@ -700,7 +733,7 @@ Proof. decEq. apply Int.xor_assoc. Qed. -Theorem shl_mul: forall x y, Val.mul x (Val.shl Vone y) = Val.shl x y. +Theorem shl_mul: forall x y, mul x (shl Vone y) = shl x y. Proof. destruct x; destruct y; simpl; auto. case (Int.ltu i0 Int.iwordsize); auto. @@ -726,12 +759,32 @@ Proof. Qed. Theorem shrx_carry: - forall x y, - add (shr x y) (shr_carry x y) = shrx x y. -Proof. - destruct x; destruct y; simpl; auto. - case (Int.ltu i0 Int.iwordsize); auto. - simpl. decEq. apply Int.shrx_carry. + forall x y z, + shrx x y = Some z -> + add (shr x y) (shr_carry x y) = z. +Proof. + intros. destruct x; destruct y; simpl in H; inv H. + destruct (Int.ltu i0 (Int.repr 31)) as []_eqn; inv H1. + exploit Int.ltu_inv; eauto. change (Int.unsigned (Int.repr 31)) with 31. intros. + assert (Int.ltu i0 Int.iwordsize = true). + unfold Int.ltu. apply zlt_true. change (Int.unsigned Int.iwordsize) with 32. omega. + simpl. rewrite H0. simpl. decEq. rewrite Int.shrx_carry; auto. +Qed. + +Theorem shrx_shr: + forall x y z, + shrx x y = Some z -> + exists p, exists q, + x = Vint p /\ y = Vint q /\ + z = shr (if Int.lt p Int.zero then add x (Vint (Int.sub (Int.shl Int.one q) Int.one)) else x) (Vint q). +Proof. + intros. destruct x; destruct y; simpl in H; inv H. + destruct (Int.ltu i0 (Int.repr 31)) as []_eqn; inv H1. + exploit Int.ltu_inv; eauto. change (Int.unsigned (Int.repr 31)) with 31. intros. + assert (Int.ltu i0 Int.iwordsize = true). + unfold Int.ltu. apply zlt_true. change (Int.unsigned Int.iwordsize) with 32. omega. + exists i; exists i0; intuition. + rewrite Int.shrx_shr; auto. destruct (Int.lt i Int.zero); simpl; rewrite H0; auto. Qed. Theorem or_rolm: @@ -765,173 +818,112 @@ Proof. destruct x; destruct y; simpl; auto. decEq. apply Float.addf_commut. Qed. -Lemma negate_cmp_mismatch: - forall c, - cmp_mismatch (negate_comparison c) = notbool(cmp_mismatch c). +Theorem negate_cmp_bool: + forall c x y, cmp_bool (negate_comparison c) x y = option_map negb (cmp_bool c x y). Proof. - destruct c; reflexivity. + destruct x; destruct y; simpl; auto. rewrite Int.negate_cmp. auto. Qed. -Theorem negate_cmp: - forall c x y, - cmp (negate_comparison c) x y = notbool (cmp c x y). +Theorem negate_cmpu_bool: + forall valid_ptr c x y, + cmpu_bool valid_ptr (negate_comparison c) x y = option_map negb (cmpu_bool valid_ptr c x y). Proof. + assert (forall c, + cmp_different_blocks (negate_comparison c) = option_map negb (cmp_different_blocks c)). + destruct c; auto. destruct x; destruct y; simpl; auto. - rewrite Int.negate_cmp. apply notbool_negb_1. - case (Int.eq i Int.zero). apply negate_cmp_mismatch. reflexivity. - case (Int.eq i0 Int.zero). apply negate_cmp_mismatch. reflexivity. - case (zeq b b0); intro. - rewrite Int.negate_cmp. apply notbool_negb_1. - apply negate_cmp_mismatch. + rewrite Int.negate_cmpu. auto. + destruct (Int.eq i Int.zero); auto. + destruct (Int.eq i0 Int.zero); auto. + destruct (valid_ptr b (Int.unsigned i) && valid_ptr b0 (Int.unsigned i0)); auto. + destruct (zeq b b0); auto. rewrite Int.negate_cmpu. auto. Qed. -Theorem negate_cmpu: +Lemma not_of_optbool: + forall ob, of_optbool (option_map negb ob) = notbool (of_optbool ob). +Proof. + destruct ob; auto. destruct b; auto. +Qed. + +Theorem negate_cmp: forall c x y, - cmpu (negate_comparison c) x y = notbool (cmpu c x y). + cmp (negate_comparison c) x y = notbool (cmp c x y). Proof. - destruct x; destruct y; simpl; auto. - rewrite Int.negate_cmpu. apply notbool_negb_1. - case (Int.eq i Int.zero). apply negate_cmp_mismatch. reflexivity. - case (Int.eq i0 Int.zero). apply negate_cmp_mismatch. reflexivity. - case (zeq b b0); intro. - rewrite Int.negate_cmpu. apply notbool_negb_1. - apply negate_cmp_mismatch. + intros. unfold cmp. rewrite negate_cmp_bool. apply not_of_optbool. Qed. -Lemma swap_cmp_mismatch: - forall c, cmp_mismatch (swap_comparison c) = cmp_mismatch c. +Theorem negate_cmpu: + forall valid_ptr c x y, + cmpu valid_ptr (negate_comparison c) x y = notbool (cmpu valid_ptr c x y). Proof. - destruct c; reflexivity. + intros. unfold cmpu. rewrite negate_cmpu_bool. apply not_of_optbool. Qed. - -Theorem swap_cmp: + +Theorem swap_cmp_bool: forall c x y, - cmp (swap_comparison c) x y = cmp c y x. + cmp_bool (swap_comparison c) x y = cmp_bool c y x. Proof. - destruct x; destruct y; simpl; auto. - rewrite Int.swap_cmp. auto. - case (Int.eq i Int.zero). apply swap_cmp_mismatch. auto. - case (Int.eq i0 Int.zero). apply swap_cmp_mismatch. auto. - case (zeq b b0); intro. - subst b0. rewrite zeq_true. rewrite Int.swap_cmp. auto. - rewrite zeq_false. apply swap_cmp_mismatch. auto. + destruct x; destruct y; simpl; auto. rewrite Int.swap_cmp. auto. Qed. -Theorem swap_cmpu: - forall c x y, - cmpu (swap_comparison c) x y = cmpu c y x. +Theorem swap_cmpu_bool: + forall valid_ptr c x y, + cmpu_bool valid_ptr (swap_comparison c) x y = cmpu_bool valid_ptr c y x. Proof. + assert (forall c, cmp_different_blocks (swap_comparison c) = cmp_different_blocks c). + destruct c; auto. destruct x; destruct y; simpl; auto. rewrite Int.swap_cmpu. auto. - case (Int.eq i Int.zero). apply swap_cmp_mismatch. auto. - case (Int.eq i0 Int.zero). apply swap_cmp_mismatch. auto. - case (zeq b b0); intro. - subst b0. rewrite zeq_true. rewrite Int.swap_cmpu. auto. - rewrite zeq_false. apply swap_cmp_mismatch. auto. + case (Int.eq i Int.zero); auto. + case (Int.eq i0 Int.zero); auto. + destruct (valid_ptr b (Int.unsigned i)); destruct (valid_ptr b0 (Int.unsigned i0)); auto. + simpl. destruct (zeq b b0); subst. + rewrite zeq_true. rewrite Int.swap_cmpu. auto. + rewrite zeq_false; auto. Qed. Theorem negate_cmpf_eq: forall v1 v2, notbool (cmpf Cne v1 v2) = cmpf Ceq v1 v2. Proof. - destruct v1; destruct v2; simpl; auto. - rewrite Float.cmp_ne_eq. rewrite notbool_negb_1. - apply notbool_idem2. + destruct v1; destruct v2; auto. unfold cmpf, cmpf_bool. + rewrite Float.cmp_ne_eq. destruct (Float.cmp Ceq f f0); auto. Qed. Theorem negate_cmpf_ne: forall v1 v2, notbool (cmpf Ceq v1 v2) = cmpf Cne v1 v2. Proof. - destruct v1; destruct v2; simpl; auto. - rewrite Float.cmp_ne_eq. rewrite notbool_negb_1. auto. -Qed. - -Lemma or_of_bool: - forall b1 b2, or (of_bool b1) (of_bool b2) = of_bool (b1 || b2). -Proof. - destruct b1; destruct b2; reflexivity. + destruct v1; destruct v2; auto. unfold cmpf, cmpf_bool. + rewrite Float.cmp_ne_eq. destruct (Float.cmp Ceq f f0); auto. Qed. Theorem cmpf_le: forall v1 v2, cmpf Cle v1 v2 = or (cmpf Clt v1 v2) (cmpf Ceq v1 v2). Proof. - destruct v1; destruct v2; simpl; auto. - rewrite or_of_bool. decEq. apply Float.cmp_le_lt_eq. + destruct v1; destruct v2; auto. unfold cmpf, cmpf_bool. + rewrite Float.cmp_le_lt_eq. + destruct (Float.cmp Clt f f0); destruct (Float.cmp Ceq f f0); auto. Qed. Theorem cmpf_ge: forall v1 v2, cmpf Cge v1 v2 = or (cmpf Cgt v1 v2) (cmpf Ceq v1 v2). Proof. - destruct v1; destruct v2; simpl; auto. - rewrite or_of_bool. decEq. apply Float.cmp_ge_gt_eq. -Qed. - -Definition is_bool (v: val) := - v = Vundef \/ v = Vtrue \/ v = Vfalse. - -Lemma of_bool_is_bool: - forall b, is_bool (of_bool b). -Proof. - destruct b; unfold is_bool; simpl; tauto. -Qed. - -Lemma undef_is_bool: is_bool Vundef. -Proof. - unfold is_bool; tauto. + destruct v1; destruct v2; auto. unfold cmpf, cmpf_bool. + rewrite Float.cmp_ge_gt_eq. + destruct (Float.cmp Cgt f f0); destruct (Float.cmp Ceq f f0); auto. Qed. -Lemma cmp_mismatch_is_bool: - forall c, is_bool (cmp_mismatch c). +Lemma zero_ext_and: + forall n v, + 0 < n < Z_of_nat Int.wordsize -> + Val.zero_ext n v = Val.and v (Vint (Int.repr (two_p n - 1))). Proof. - destruct c; simpl; unfold is_bool; tauto. -Qed. - -Lemma cmp_is_bool: - forall c v1 v2, is_bool (cmp c v1 v2). -Proof. - destruct v1; destruct v2; simpl; try apply undef_is_bool. - apply of_bool_is_bool. - case (Int.eq i Int.zero). apply cmp_mismatch_is_bool. apply undef_is_bool. - case (Int.eq i0 Int.zero). apply cmp_mismatch_is_bool. apply undef_is_bool. - case (zeq b b0); intro. apply of_bool_is_bool. apply cmp_mismatch_is_bool. -Qed. - -Lemma cmpu_is_bool: - forall c v1 v2, is_bool (cmpu c v1 v2). -Proof. - destruct v1; destruct v2; simpl; try apply undef_is_bool. - apply of_bool_is_bool. - case (Int.eq i Int.zero). apply cmp_mismatch_is_bool. apply undef_is_bool. - case (Int.eq i0 Int.zero). apply cmp_mismatch_is_bool. apply undef_is_bool. - case (zeq b b0); intro. apply of_bool_is_bool. apply cmp_mismatch_is_bool. -Qed. - -Lemma cmpf_is_bool: - forall c v1 v2, is_bool (cmpf c v1 v2). -Proof. - destruct v1; destruct v2; simpl; - apply undef_is_bool || apply of_bool_is_bool. -Qed. - -Lemma notbool_is_bool: - forall v, is_bool (notbool v). -Proof. - destruct v; simpl. - apply undef_is_bool. apply of_bool_is_bool. - apply undef_is_bool. unfold is_bool; tauto. -Qed. - -Lemma notbool_xor: - forall v, is_bool v -> v = xor (notbool v) Vone. -Proof. - intros. elim H; intro. - subst v. reflexivity. - elim H0; intro; subst v; reflexivity. + intros. destruct v; simpl; auto. decEq. apply Int.zero_ext_and; auto. Qed. Lemma rolm_lt_zero: forall v, rolm v Int.one Int.one = cmp Clt v (Vint Int.zero). Proof. - intros. destruct v; simpl; auto. + intros. unfold cmp, cmp_bool; destruct v; simpl; auto. transitivity (Vint (Int.shru i (Int.repr (Z_of_nat Int.wordsize - 1)))). decEq. symmetry. rewrite Int.shru_rolm. auto. auto. rewrite Int.shru_lt_zero. destruct (Int.lt i Int.zero); auto. @@ -942,7 +934,7 @@ Lemma rolm_ge_zero: xor (rolm v Int.one Int.one) (Vint Int.one) = cmp Cge v (Vint Int.zero). Proof. intros. rewrite rolm_lt_zero. destruct v; simpl; auto. - destruct (Int.lt i Int.zero); auto. + unfold cmp; simpl. destruct (Int.lt i Int.zero); auto. Qed. (** The ``is less defined'' relation between values. @@ -953,6 +945,12 @@ Inductive lessdef: val -> val -> Prop := | lessdef_refl: forall v, lessdef v v | lessdef_undef: forall v, lessdef Vundef v. +Lemma lessdef_trans: + forall v1 v2 v3, lessdef v1 v2 -> lessdef v2 v3 -> lessdef v1 v3. +Proof. + intros. inv H. auto. constructor. +Qed. + Inductive lessdef_list: list val -> list val -> Prop := | lessdef_list_nil: lessdef_list nil nil @@ -972,6 +970,8 @@ Proof. left; congruence. tauto. tauto. Qed. +(** Compatibility of operations with the [lessdef] relation. *) + Lemma load_result_lessdef: forall chunk v1 v2, lessdef v1 v2 -> lessdef (load_result chunk v1) (load_result chunk v2). @@ -997,6 +997,37 @@ Proof. intros; inv H; simpl; auto. Qed. +Lemma add_lessdef: + forall v1 v1' v2 v2', + lessdef v1 v1' -> lessdef v2 v2' -> lessdef (add v1 v2) (add v1' v2'). +Proof. + intros. inv H. inv H0. auto. destruct v1'; simpl; auto. simpl; auto. +Qed. + +Lemma cmpu_bool_lessdef: + forall valid_ptr valid_ptr' c v1 v1' v2 v2' b, + (forall b ofs, valid_ptr b ofs = true -> valid_ptr' b ofs = true) -> + lessdef v1 v1' -> lessdef v2 v2' -> + cmpu_bool valid_ptr c v1 v2 = Some b -> + cmpu_bool valid_ptr' c v1' v2' = Some b. +Proof. + intros. + destruct v1; simpl in H2; try discriminate; + destruct v2; simpl in H2; try discriminate; + inv H0; inv H1; simpl; auto. + destruct (valid_ptr b0 (Int.unsigned i)) as []_eqn; try discriminate. + destruct (valid_ptr b1 (Int.unsigned i0)) as []_eqn; try discriminate. + rewrite (H _ _ Heqb2). rewrite (H _ _ Heqb0). auto. +Qed. + +Lemma of_optbool_lessdef: + forall ob ob', + (forall b, ob = Some b -> ob' = Some b) -> + lessdef (of_optbool ob) (of_optbool ob'). +Proof. + intros. destruct ob; simpl; auto. rewrite (H b); auto. +Qed. + End Val. (** * Values and memory injections *) @@ -1085,3 +1116,35 @@ Qed. Hint Resolve inject_incr_refl val_inject_incr val_list_inject_incr. +Lemma val_inject_lessdef: + forall v1 v2, Val.lessdef v1 v2 <-> val_inject (fun b => Some(b, 0)) v1 v2. +Proof. + intros; split; intros. + inv H; auto. destruct v2; econstructor; eauto. rewrite Int.add_zero; auto. + inv H; auto. inv H0. rewrite Int.add_zero; auto. +Qed. + +Lemma val_list_inject_lessdef: + forall vl1 vl2, Val.lessdef_list vl1 vl2 <-> val_list_inject (fun b => Some(b, 0)) vl1 vl2. +Proof. + intros; split. + induction 1; constructor; auto. apply val_inject_lessdef; auto. + induction 1; constructor; auto. apply val_inject_lessdef; auto. +Qed. + +(** The identity injection gives rise to the "less defined than" relation. *) + +Definition inject_id : meminj := fun b => Some(b, 0). + +Lemma val_inject_id: + forall v1 v2, + val_inject inject_id v1 v2 <-> Val.lessdef v1 v2. +Proof. + intros; split; intros. + inv H. constructor. constructor. + unfold inject_id in H0. inv H0. rewrite Int.add_zero. constructor. + constructor. + inv H. destruct v2; econstructor. unfold inject_id; reflexivity. rewrite Int.add_zero; auto. + constructor. +Qed. + @@ -9,7 +9,7 @@ VARIANT=`sed -n -e 's/^VARIANT=//p' Makefile.config` make -q ${1}o || { make -n ${1}o | grep -v "\\b${1}\\b" | \ (while read cmd; do - $cmd || exit 2 + sh -c "$cmd" || exit 2 done) } diff --git a/driver/Compiler.v b/driver/Compiler.v index abd3867..ce9db20 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -44,7 +44,6 @@ Require Cminorgen. Require Selection. Require RTLgen. Require Tailcall. -Require CastOptim. Require Constprop. Require CSE. Require Allocation. @@ -68,7 +67,6 @@ Require Cminorgenproof. Require Selectionproof. Require RTLgenproof. Require Tailcallproof. -Require CastOptimproof. Require Constpropproof. Require CSEproof. Require Allocproof. @@ -92,7 +90,6 @@ Parameter print_Clight: Clight.program -> unit. Parameter print_Cminor: Cminor.program -> unit. Parameter print_RTL: RTL.fundef -> unit. Parameter print_RTL_tailcall: RTL.fundef -> unit. -Parameter print_RTL_castopt: RTL.fundef -> unit. Parameter print_RTL_constprop: RTL.fundef -> unit. Parameter print_RTL_cse: RTL.fundef -> unit. Parameter print_LTLin: LTLin.fundef -> unit. @@ -141,8 +138,6 @@ Definition transf_rtl_fundef (f: RTL.fundef) : res Asm.fundef := @@ print print_RTL @@ Tailcall.transf_fundef @@ print print_RTL_tailcall - @@ CastOptim.transf_fundef - @@ print print_RTL_castopt @@ Constprop.transf_fundef @@ print print_RTL_constprop @@ CSE.transf_fundef @@ -342,7 +337,6 @@ Proof. Stackingtyping.program_typing_preserved; intros. eapply compose_forward_simulation. apply Tailcallproof.transf_program_correct. - eapply compose_forward_simulation. apply CastOptimproof.transf_program_correct. eapply compose_forward_simulation. apply Constpropproof.transf_program_correct. eapply compose_forward_simulation. apply CSEproof.transf_program_correct. eapply compose_forward_simulation. apply Allocproof.transf_program_correct. eassumption. diff --git a/extraction/extraction.v b/extraction/extraction.v index 52706ab..4861ff9 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -83,7 +83,6 @@ Extract Constant Compiler.print_Clight => "PrintClight.print_if". Extract Constant Compiler.print_Cminor => "PrintCminor.print_if". Extract Constant Compiler.print_RTL => "PrintRTL.print_rtl". Extract Constant Compiler.print_RTL_tailcall => "PrintRTL.print_tailcall". -Extract Constant Compiler.print_RTL_castopt => "PrintRTL.print_castopt". Extract Constant Compiler.print_RTL_constprop => "PrintRTL.print_constprop". Extract Constant Compiler.print_RTL_cse => "PrintRTL.print_cse". Extract Constant Compiler.print_LTLin => "PrintLTLin.print_if". @@ -295,9 +295,9 @@ Definition eval_addrmode (a: addrmode) (rs: regset) : val := SOF is (morally) the XOR of the SF and OF flags of the processor. *) -Definition compare_ints (x y: val) (rs: regset) : regset := - rs #ZF <- (Val.cmp Ceq x y) - #CF <- (Val.cmpu Clt x y) +Definition compare_ints (x y: val) (rs: regset) (m: mem): regset := + rs #ZF <- (Val.cmpu (Mem.valid_pointer m) Ceq x y) + #CF <- (Val.cmpu (Mem.valid_pointer m) Clt x y) #SOF <- (Val.cmp Clt x y) #PF <- Vundef. @@ -512,9 +512,9 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pcvtsd2ss_mf a r1 => exec_store Mfloat32 m a rs r1 | Pcvttsd2si_rf rd r1 => - Next (nextinstr (rs#rd <- (Val.intoffloat rs#r1))) m + Next (nextinstr (rs#rd <- (Val.maketotal (Val.intoffloat rs#r1)))) m | Pcvtsi2sd_fr rd r1 => - Next (nextinstr (rs#rd <- (Val.floatofint rs#r1))) m + Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofint rs#r1)))) m (** Integer arithmetic *) | Plea rd a => Next (nextinstr (rs#rd <- (eval_addrmode a rs))) m @@ -527,11 +527,17 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pimul_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.mul rs#rd (Vint n)))) m | Pdiv r1 => - Next (nextinstr_nf (rs#EAX <- (Val.divu rs#EAX (rs#EDX <- Vundef)#r1) - #EDX <- (Val.modu rs#EAX (rs#EDX <- Vundef)#r1))) m + let vn := rs#EAX in let vd := (rs#EDX <- Vundef)#r1 in + match Val.divu vn vd, Val.modu vn vd with + | Some vq, Some vr => Next (nextinstr_nf (rs#EAX <- vq #EDX <- vr)) m + | _, _ => Stuck + end | Pidiv r1 => - Next (nextinstr_nf (rs#EAX <- (Val.divs rs#EAX (rs#EDX <- Vundef)#r1) - #EDX <- (Val.mods rs#EAX (rs#EDX <- Vundef)#r1))) m + let vn := rs#EAX in let vd := (rs#EDX <- Vundef)#r1 in + match Val.divs vn vd, Val.mods vn vd with + | Some vq, Some vr => Next (nextinstr_nf (rs#EAX <- vq #EDX <- vr)) m + | _, _ => Stuck + end | Pand_rr rd r1 => Next (nextinstr_nf (rs#rd <- (Val.and rs#rd rs#r1))) m | Pand_ri rd n => @@ -561,24 +567,21 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pror_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.ror rs#rd (Vint n)))) m | Pcmp_rr r1 r2 => - Next (nextinstr (compare_ints (rs r1) (rs r2) rs)) m + Next (nextinstr (compare_ints (rs r1) (rs r2) rs m)) m | Pcmp_ri r1 n => - Next (nextinstr (compare_ints (rs r1) (Vint n) rs)) m + Next (nextinstr (compare_ints (rs r1) (Vint n) rs m)) m | Ptest_rr r1 r2 => - Next (nextinstr (compare_ints (Val.and (rs r1) (rs r2)) Vzero rs)) m + Next (nextinstr (compare_ints (Val.and (rs r1) (rs r2)) Vzero rs m)) m | Ptest_ri r1 n => - Next (nextinstr (compare_ints (Val.and (rs r1) (Vint n)) Vzero rs)) m + Next (nextinstr (compare_ints (Val.and (rs r1) (Vint n)) Vzero rs m)) m | Pcmov c rd r1 => match eval_testcond c rs with | Some true => Next (nextinstr (rs#rd <- (rs#r1))) m | Some false => Next (nextinstr rs) m - | None => Stuck + | None => Next (nextinstr (rs#rd <- Vundef)) m end | Psetcc c rd => - match eval_testcond c rs with - | Some b => Next (nextinstr (rs#ECX <- Vundef #rd <- (Val.of_bool b))) m - | None => Stuck - end + Next (nextinstr (rs#ECX <- Vundef #rd <- (Val.of_optbool (eval_testcond c rs)))) m (** Arithmetic operations over floats *) | Paddd_ff rd r1 => Next (nextinstr (rs#rd <- (Val.addf rs#rd rs#r1))) m diff --git a/ia32/Asmgenproof.v b/ia32/Asmgenproof.v index e8c6757..a49a7ff 100644 --- a/ia32/Asmgenproof.v +++ b/ia32/Asmgenproof.v @@ -844,8 +844,9 @@ Proof. 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]]]. + assert (S: Val.lessdef v (rs2 (preg_of res))) by (eapply Val.lessdef_trans; eauto). exists rs2; split. eauto. - split. rewrite <- Q in B. + split. unfold undef_op. destruct op; try (eapply agree_set_undef_mreg; eauto). eapply agree_set_undef_move_mreg; eauto. @@ -1119,8 +1120,10 @@ Proof. intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0. exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. left; eapply exec_straight_steps_goto; eauto. - intros. simpl in H2. - exploit transl_cond_correct; eauto. intros [rs' [A [B C]]]. + intros. simpl in H2. + destruct (transl_cond_correct tge tf cond args _ _ rs m' H2) + as [rs' [A [B C]]]. + unfold PregEq.t in B; rewrite EC in B. destruct (testcond_for_condition cond); simpl in *. (* simple jcc *) exists (Pjcc c1 lbl); exists k; exists rs'. @@ -1165,7 +1168,9 @@ Proof. intros; red; intros; inv MS. 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]]]. + destruct (transl_cond_correct tge tf cond args _ _ rs m' H0) + as [rs' [A [B C]]]. + unfold PregEq.t in B; rewrite EC in B. destruct (testcond_for_condition cond); simpl in *. (* simple jcc *) econstructor; split. diff --git a/ia32/Asmgenproof1.v b/ia32/Asmgenproof1.v index be40f3d..5749a0b 100644 --- a/ia32/Asmgenproof1.v +++ b/ia32/Asmgenproof1.v @@ -625,26 +625,37 @@ Qed. (** Smart constructor for division *) Lemma mk_div_correct: - forall mkinstr dsem msem r1 r2 k c rs1 m, + forall mkinstr dsem msem r1 r2 k c (rs1: regset) m vq vr, mk_div mkinstr r1 r2 k = OK c -> (forall r c rs m, exec_instr ge c (mkinstr r) rs m = - Next (nextinstr_nf (rs#EAX <- (dsem rs#EAX (rs#EDX <- Vundef)#r) - #EDX <- (msem rs#EAX (rs#EDX <- Vundef)#r))) m) -> + let vn := rs#EAX in let vd := (rs#EDX <- Vundef)#r in + match dsem vn vd, msem vn vd with + | Some vq, Some vr => Next (nextinstr_nf (rs#EAX <- vq #EDX <- vr)) m + | _, _ => Stuck + end) -> + dsem rs1#r1 rs1#r2 = Some vq -> + msem rs1#r1 rs1#r2 = Some vr -> exists rs2, exec_straight c rs1 m k rs2 m - /\ rs2#r1 = dsem rs1#r1 rs1#r2 + /\ rs2#r1 = vq /\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r. Proof. unfold mk_div; intros. destruct (ireg_eq r1 EAX). destruct (ireg_eq r2 EDX); monadInv H. (* r1=EAX r2=EDX *) - econstructor. split. eapply exec_straight_two. simpl; eauto. apply H0. auto. auto. + econstructor. split. eapply exec_straight_two. simpl; eauto. + rewrite H0. + change (nextinstr rs1 # ECX <- (rs1 EDX) EAX) with (rs1#EAX). + change ((nextinstr rs1 # ECX <- (rs1 EDX)) # EDX <- Vundef ECX) with (rs1#EDX). + rewrite H1. rewrite H2. eauto. auto. auto. split. SRes. - intros. repeat SOther. + intros. repeat SOther. (* r1=EAX r2<>EDX *) - econstructor. split. eapply exec_straight_one. apply H0. auto. - split. repeat SRes. decEq. apply Pregmap.gso. congruence. + econstructor. split. eapply exec_straight_one. rewrite H0. + replace (rs1 # EDX <- Vundef r2) with (rs1 r2). rewrite H1; rewrite H2. eauto. + symmetry. SOther. auto. + split. SRes. intros. repeat SOther. (* r1 <> EAX *) monadInv H. @@ -654,9 +665,12 @@ Proof. econstructor; split. apply exec_straight_step with rs2 m; auto. eapply exec_straight_trans. eexact A. - eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. + eapply exec_straight_three. + rewrite H0. replace (rs3 EAX) with (rs1 r1). replace (rs3 # EDX <- Vundef ECX) with (rs1 r2). + rewrite H1; rewrite H2. eauto. + simpl; eauto. simpl; eauto. auto. auto. auto. - split. repeat SRes. decEq. rewrite B; unfold rs2; SRes. SOther. + split. repeat SRes. intros. destruct (preg_eq r EAX). subst. repeat SRes. rewrite D; auto with ppcgen. repeat SOther. rewrite D; auto with ppcgen. unfold rs2; repeat SOther. @@ -665,27 +679,42 @@ Qed. (** Smart constructor for modulus *) Lemma mk_mod_correct: - forall mkinstr dsem msem r1 r2 k c rs1 m, + forall mkinstr dsem msem r1 r2 k c (rs1: regset) m vq vr, mk_mod mkinstr r1 r2 k = OK c -> (forall r c rs m, exec_instr ge c (mkinstr r) rs m = - Next (nextinstr_nf (rs#EAX <- (dsem rs#EAX (rs#EDX <- Vundef)#r) - #EDX <- (msem rs#EAX (rs#EDX <- Vundef)#r))) m) -> + let vn := rs#EAX in let vd := (rs#EDX <- Vundef)#r in + match dsem vn vd, msem vn vd with + | Some vq, Some vr => Next (nextinstr_nf (rs#EAX <- vq #EDX <- vr)) m + | _, _ => Stuck + end) -> + dsem rs1#r1 rs1#r2 = Some vq -> + msem rs1#r1 rs1#r2 = Some vr -> exists rs2, exec_straight c rs1 m k rs2 m - /\ rs2#r1 = msem rs1#r1 rs1#r2 + /\ rs2#r1 = vr /\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r. Proof. unfold mk_mod; intros. destruct (ireg_eq r1 EAX). destruct (ireg_eq r2 EDX); monadInv H. (* r1=EAX r2=EDX *) econstructor. split. eapply exec_straight_three. - simpl; eauto. apply H0. simpl; eauto. auto. auto. auto. + simpl; eauto. + rewrite H0. + change (nextinstr rs1 # ECX <- (rs1 EDX) EAX) with (rs1#EAX). + change ((nextinstr rs1 # ECX <- (rs1 EDX)) # EDX <- Vundef ECX) with (rs1#EDX). + rewrite H1. rewrite H2. eauto. + simpl; eauto. + auto. auto. auto. split. SRes. - intros. repeat SOther. + intros. repeat SOther. (* r1=EAX r2<>EDX *) - econstructor. split. eapply exec_straight_two. apply H0. simpl; eauto. auto. auto. - split. repeat SRes. decEq. apply Pregmap.gso. congruence. + econstructor. split. eapply exec_straight_two. rewrite H0. + replace (rs1 # EDX <- Vundef r2) with (rs1 r2). rewrite H1; rewrite H2. eauto. + symmetry. SOther. + simpl; eauto. + auto. auto. + split. SRes. intros. repeat SOther. (* r1 <> EAX *) monadInv H. @@ -695,57 +724,79 @@ Proof. econstructor; split. apply exec_straight_step with rs2 m; auto. eapply exec_straight_trans. eexact A. - eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. + eapply exec_straight_three. + rewrite H0. replace (rs3 EAX) with (rs1 r1). replace (rs3 # EDX <- Vundef ECX) with (rs1 r2). + rewrite H1; rewrite H2. eauto. + simpl; eauto. simpl; eauto. auto. auto. auto. - split. repeat SRes. decEq. rewrite B; unfold rs2; SRes. SOther. + split. repeat SRes. intros. destruct (preg_eq r EAX). subst. repeat SRes. rewrite D; auto with ppcgen. repeat SOther. rewrite D; auto with ppcgen. unfold rs2; repeat SOther. Qed. +Remark divs_mods_exist: + forall v1 v2, + match Val.divs v1 v2, Val.mods v1 v2 with + | Some _, Some _ => True + | None, None => True + | _, _ => False + end. +Proof. + intros. unfold Val.divs, Val.mods. destruct v1; auto. destruct v2; auto. + destruct (Int.eq i0 Int.zero); auto. +Qed. + +Remark divu_modu_exist: + forall v1 v2, + match Val.divu v1 v2, Val.modu v1 v2 with + | Some _, Some _ => True + | None, None => True + | _, _ => False + end. +Proof. + intros. unfold Val.divu, Val.modu. destruct v1; auto. destruct v2; auto. + destruct (Int.eq i0 Int.zero); auto. +Qed. + (** Smart constructor for [shrx] *) Lemma mk_shrximm_correct: - forall r1 n k c (rs1: regset) x m, + forall r1 n k c (rs1: regset) v m, mk_shrximm r1 n k = OK c -> - rs1#r1 = Vint x -> - Int.ltu n (Int.repr 31) = true -> + Val.shrx (rs1#r1) (Vint n) = Some v -> exists rs2, exec_straight c rs1 m k rs2 m - /\ rs2#r1 = Vint (Int.shrx x n) + /\ rs2#r1 = v /\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r. Proof. unfold mk_shrximm; intros. inv H. + exploit Val.shrx_shr; eauto. intros [x [y [A [B C]]]]. + inversion B; clear B; subst y; subst v; clear H0. set (tmp := if ireg_eq r1 ECX then EDX else ECX). assert (TMP1: tmp <> r1). unfold tmp; destruct (ireg_eq r1 ECX); congruence. assert (TMP2: nontemp_preg tmp = false). unfold tmp; destruct (ireg_eq r1 ECX); auto. - rewrite Int.shrx_shr; auto. set (tnm1 := Int.sub (Int.shl Int.one n) Int.one). set (x' := Int.add x tnm1). - set (rs2 := nextinstr (compare_ints (Vint x) (Vint Int.zero) rs1)). + set (rs2 := nextinstr (compare_ints (Vint x) (Vint Int.zero) rs1 m)). set (rs3 := nextinstr (rs2#tmp <- (Vint x'))). set (rs4 := nextinstr (if Int.lt x Int.zero then rs3#r1 <- (Vint x') else rs3)). set (rs5 := nextinstr_nf (rs4#r1 <- (Val.shr rs4#r1 (Vint n)))). assert (rs3#r1 = Vint x). unfold rs3. SRes. SRes. assert (rs3#tmp = Vint x'). unfold rs3. SRes. SRes. exists rs5. split. - apply exec_straight_step with rs2 m. simpl. rewrite H0. simpl. rewrite Int.and_idem. auto. auto. + apply exec_straight_step with rs2 m. simpl. rewrite A. simpl. rewrite Int.and_idem. auto. auto. apply exec_straight_step with rs3 m. simpl. - change (rs2 r1) with (rs1 r1). rewrite H0. simpl. + change (rs2 r1) with (rs1 r1). rewrite A. simpl. rewrite (Int.add_commut Int.zero tnm1). rewrite Int.add_zero. auto. auto. apply exec_straight_step with rs4 m. simpl. change (rs3 SOF) with (rs2 SOF). unfold rs2. rewrite nextinstr_inv; auto with ppcgen. - unfold compare_ints. rewrite Pregmap.gso; auto with ppcgen. rewrite Pregmap.gss. - simpl. unfold rs4. destruct (Int.lt x Int.zero); auto. rewrite H2; auto. - unfold rs4. destruct (Int.lt x Int.zero); auto. + unfold compare_ints. rewrite Pregmap.gso; auto with ppcgen. rewrite Pregmap.gss. + unfold Val.cmp. simpl. unfold rs4. destruct (Int.lt x Int.zero); simpl; auto. rewrite H0; auto. + unfold rs4. destruct (Int.lt x Int.zero); simpl; auto. apply exec_straight_one. auto. auto. split. unfold rs5. SRes. SRes. unfold rs4. rewrite nextinstr_inv; auto with ppcgen. - assert (Int.ltu n Int.iwordsize = true). - unfold Int.ltu in *. change (Int.unsigned (Int.repr 31)) with 31 in H1. - destruct (zlt (Int.unsigned n) 31); try discriminate. - change (Int.unsigned Int.iwordsize) with 32. apply zlt_true. omega. - destruct (Int.lt x Int.zero). rewrite Pregmap.gss. unfold Val.shr. rewrite H3. auto. - rewrite H. unfold Val.shr. rewrite H3. auto. + destruct (Int.lt x Int.zero). rewrite Pregmap.gss. rewrite A; auto. rewrite A; rewrite H; auto. intros. unfold rs5. repeat SOther. unfold rs4. SOther. transitivity (rs3#r). destruct (Int.lt x Int.zero). SOther. auto. unfold rs3. repeat SOther. unfold rs2. repeat SOther. @@ -904,58 +955,55 @@ Lemma transl_addressing_mode_correct: forall addr args am (rs: regset) v, transl_addressing addr args = OK am -> eval_addressing ge (rs ESP) addr (List.map rs (List.map preg_of args)) = Some v -> - eval_addrmode ge am rs = v. + Val.lessdef v (eval_addrmode ge am rs). Proof. assert (A: forall n, Int.add Int.zero n = n). intros. rewrite Int.add_commut. apply Int.add_zero. assert (B: forall n i, (if Int.eq i Int.one then Vint n else Vint (Int.mul n i)) = Vint (Int.mul n i)). - intros. generalize (Int.eq_spec i Int.one); destruct (Int.eq i Int.one); intros. + intros. predSpec Int.eq Int.eq_spec i Int.one. subst i. rewrite Int.mul_one. auto. auto. + assert (C: forall v i, + Val.lessdef (Val.mul v (Vint i)) + (if Int.eq i Int.one then v else Val.mul v (Vint i))). + intros. predSpec Int.eq Int.eq_spec i Int.one. + subst i. destruct v; simpl; auto. rewrite Int.mul_one; auto. + destruct v; simpl; auto. unfold transl_addressing; intros. - destruct addr; repeat (destruct args; try discriminate); simpl in H0. + destruct addr; repeat (destruct args; try discriminate); simpl in H0; inv H0. (* indexed *) - monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0. simpl. - destruct (rs x); inv H0; simpl. rewrite A; auto. rewrite A; auto. + monadInv H. rewrite (ireg_of_eq _ _ EQ). simpl. rewrite A; auto. (* indexed2 *) - monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0; rewrite (ireg_of_eq _ _ EQ1) in H0. simpl. - destruct (rs x); try discriminate; destruct (rs x0); inv H0; simpl. - rewrite Int.add_assoc; auto. - repeat rewrite Int.add_assoc. decEq. decEq. apply Int.add_commut. - rewrite Int.add_assoc; auto. + monadInv H. rewrite (ireg_of_eq _ _ EQ); rewrite (ireg_of_eq _ _ EQ1). simpl. + rewrite Val.add_assoc; auto. (* scaled *) - monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0. simpl. - destruct (rs x); inv H0; simpl. - rewrite B. simpl. rewrite A. auto. + monadInv H. rewrite (ireg_of_eq _ _ EQ). unfold eval_addrmode. + rewrite Val.add_permut. simpl. rewrite A. apply Val.add_lessdef; auto. (* indexed2scaled *) - monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0; rewrite (ireg_of_eq _ _ EQ1) in H0. simpl. - destruct (rs x); try discriminate; destruct (rs x0); inv H0; simpl. - rewrite B. simpl. auto. - rewrite B. simpl. auto. + monadInv H. rewrite (ireg_of_eq _ _ EQ); rewrite (ireg_of_eq _ _ EQ1); simpl. + apply Val.add_lessdef; auto. apply Val.add_lessdef; auto. (* global *) - inv H. simpl. unfold symbol_offset. destruct (Genv.find_symbol ge i); inv H0. - repeat rewrite Int.add_zero. auto. + inv H. simpl. unfold symbol_address, symbol_offset. + destruct (Genv.find_symbol ge i); simpl; auto. repeat rewrite Int.add_zero. auto. (* based *) - monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0. simpl. - destruct (rs x); inv H0; simpl. - unfold symbol_offset. destruct (Genv.find_symbol ge i); inv H1. - rewrite Int.add_zero; auto. + monadInv H. rewrite (ireg_of_eq _ _ EQ). simpl. + unfold symbol_address, symbol_offset. destruct (Genv.find_symbol ge i); simpl; auto. + rewrite Int.add_zero. rewrite Val.add_commut. auto. (* basedscaled *) - monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0. simpl. - destruct (rs x); inv H0; simpl. - rewrite B. unfold symbol_offset. destruct (Genv.find_symbol ge i0); inv H1. - simpl. rewrite Int.add_zero. auto. + monadInv H. rewrite (ireg_of_eq _ _ EQ). unfold eval_addrmode. + rewrite (Val.add_commut Vzero). rewrite Val.add_assoc. rewrite Val.add_permut. + apply Val.add_lessdef; auto. destruct (rs x); simpl; auto. rewrite B. simpl. + rewrite Int.add_zero. auto. (* instack *) - inv H; simpl. unfold offset_sp in H0. - destruct (rs ESP); inv H0. simpl. rewrite A; auto. + inv H; simpl. rewrite A; auto. Qed. (** Processor conditions and comparisons *) Lemma compare_ints_spec: - forall rs v1 v2, - let rs' := nextinstr (compare_ints v1 v2 rs) in - rs'#ZF = Val.cmp Ceq v1 v2 - /\ rs'#CF = Val.cmpu Clt v1 v2 + forall rs v1 v2 m, + let rs' := nextinstr (compare_ints v1 v2 rs m) in + rs'#ZF = Val.cmpu (Mem.valid_pointer m) Ceq v1 v2 + /\ rs'#CF = Val.cmpu (Mem.valid_pointer m) Clt v1 v2 /\ rs'#SOF = Val.cmp Clt v1 v2 /\ (forall r, nontemp_preg r = true -> rs'#r = rs#r). Proof. @@ -1012,112 +1060,69 @@ Proof. intros. rewrite <- negb_orb. rewrite <- int_not_ltu. rewrite negb_involutive. auto. Qed. -Lemma testcond_for_signed_comparison_correct_ii: - forall c n1 n2 rs, +Lemma testcond_for_signed_comparison_correct: + forall c v1 v2 rs m b, + Val.cmp_bool c v1 v2 = Some b -> eval_testcond (testcond_for_signed_comparison c) - (nextinstr (compare_ints (Vint n1) (Vint n2) rs)) = - Some(Int.cmp 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.lt n1 n2); auto. - rewrite int_not_lt. destruct (Int.lt n1 n2); destruct (Int.eq n1 n2); auto. - rewrite (int_lt_not n1 n2). destruct (Int.lt n1 n2); destruct (Int.eq n1 n2); auto. - destruct (Int.lt n1 n2); auto. -Qed. - -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). + (nextinstr (compare_ints v1 v2 rs m)) = Some b. Proof. - intros. generalize (compare_ints_spec rs (Vint n1) (Vint n2)). - set (rs' := nextinstr (compare_ints (Vint n1) (Vint n2) rs)). + intros. generalize (compare_ints_spec rs v1 v2 m). + set (rs' := nextinstr (compare_ints v1 v2 rs m)). intros [A [B [C D]]]. - unfold eval_testcond. rewrite A; rewrite B; rewrite C. + destruct v1; destruct v2; simpl in H; inv H. + unfold eval_testcond. rewrite A; rewrite B; rewrite C. unfold Val.cmp, Val.cmpu. 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. + destruct (Int.eq i i0); auto. + destruct (Int.eq i i0); auto. + destruct (Int.lt i i0); auto. + rewrite int_not_lt. destruct (Int.lt i i0); simpl; destruct (Int.eq i i0); auto. + rewrite (int_lt_not i i0). destruct (Int.lt i i0); destruct (Int.eq i i0); reflexivity. + destruct (Int.lt i i0); reflexivity. Qed. -Lemma testcond_for_unsigned_comparison_correct_pi: - forall c blk n1 n2 rs b, - eval_compare_null c n2 = Some b -> +Lemma testcond_for_unsigned_comparison_correct: + forall c v1 v2 rs m b, + Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 = Some b -> eval_testcond (testcond_for_unsigned_comparison c) - (nextinstr (compare_ints (Vptr blk n1) (Vint n2) rs)) = Some b. + (nextinstr (compare_ints v1 v2 rs m)) = Some b. Proof. - intros. - revert H. unfold eval_compare_null. - generalize (Int.eq_spec n2 Int.zero); destruct (Int.eq n2 Int.zero); intros; try discriminate. - subst n2. - generalize (compare_ints_spec rs (Vptr blk n1) (Vint Int.zero)). - set (rs' := nextinstr (compare_ints (Vptr blk n1) (Vint Int.zero) rs)). + intros. generalize (compare_ints_spec rs v1 v2 m). + set (rs' := nextinstr (compare_ints v1 v2 rs m)). intros [A [B [C D]]]. - unfold eval_testcond. rewrite A; rewrite B; rewrite C. - destruct c; simpl; try discriminate. - rewrite <- H0; auto. - rewrite <- H0; auto. -Qed. - -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_unsigned_comparison c) - (nextinstr (compare_ints (Vint n1) (Vptr blk n2) rs)) = Some b. -Proof. - intros. - revert H. unfold eval_compare_null. - generalize (Int.eq_spec n1 Int.zero); destruct (Int.eq n1 Int.zero); intros; try discriminate. - subst n1. - generalize (compare_ints_spec rs (Vint Int.zero) (Vptr blk n2)). - set (rs' := nextinstr (compare_ints (Vint Int.zero) (Vptr blk n2) rs)). - intros [A [B [C D]]]. - unfold eval_testcond. rewrite A; rewrite B; rewrite C. - destruct c; simpl; try discriminate. - rewrite <- H0; auto. - rewrite <- H0; auto. -Qed. - -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. - 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. - destruct c; simpl. - destruct (zeq b1 b2). inversion H. destruct (Int.eq n1 n2); auto. - 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.ltu n1 n2); auto. - discriminate. - destruct (zeq b1 b2). inversion H. - rewrite int_not_ltu. destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto. - discriminate. - destruct (zeq b1 b2). inversion H. - 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.ltu n1 n2); auto. - discriminate. + unfold eval_testcond. rewrite A; rewrite B; rewrite C. unfold Val.cmpu, Val.cmp. + destruct v1; destruct v2; simpl in H; inv H. +(* int int *) + destruct c; simpl; auto. + destruct (Int.eq i i0); reflexivity. + destruct (Int.eq i i0); auto. + destruct (Int.ltu i i0); auto. + rewrite int_not_ltu. destruct (Int.ltu i i0); simpl; destruct (Int.eq i i0); auto. + rewrite (int_ltu_not i i0). destruct (Int.ltu i i0); destruct (Int.eq i i0); reflexivity. + destruct (Int.ltu i i0); reflexivity. +(* int ptr *) + destruct (Int.eq i Int.zero) as []_eqn; try discriminate. + destruct c; simpl in *; inv H1. + rewrite Heqb1; reflexivity. + rewrite Heqb1; reflexivity. +(* ptr int *) + destruct (Int.eq i0 Int.zero) as []_eqn; try discriminate. + destruct c; simpl in *; inv H1. + rewrite Heqb1; reflexivity. + rewrite Heqb1; reflexivity. +(* ptr ptr *) + simpl. + destruct (Mem.valid_pointer m b0 (Int.unsigned i) && + Mem.valid_pointer m b1 (Int.unsigned i0)); try discriminate. + destruct (zeq b0 b1). + inversion H1. + destruct c; simpl; auto. + destruct (Int.eq i i0); reflexivity. + destruct (Int.eq i i0); auto. + destruct (Int.ltu i i0); auto. + rewrite int_not_ltu. destruct (Int.ltu i i0); simpl; destruct (Int.eq i i0); auto. + rewrite (int_ltu_not i i0). destruct (Int.ltu i i0); destruct (Int.eq i i0); reflexivity. + destruct (Int.ltu i i0); reflexivity. + destruct c; simpl in *; inv H1; reflexivity. Qed. Lemma compare_floats_spec: @@ -1151,7 +1156,113 @@ Definition eval_extcond (xc: extcond) (rs: regset) : option bool := end end. -Definition swap_floats (c: comparison) (n1 n2: float) : float := +(******* + +Definition swap_floats {A: Type} (c: comparison) (n1 n2: A) : A := + match c with + | Clt | Cle => n2 + | Ceq | Cne | Cgt | Cge => n1 + end. + +Lemma testcond_for_float_comparison_correct: + forall c v1 v2 rs b, + Val.cmpf_bool c v1 v2 = Some b -> + eval_extcond (testcond_for_condition (Ccompf c)) + (nextinstr (compare_floats (swap_floats c v1 v2) + (swap_floats c v2 v1) rs)) = Some b. +Proof. + intros. destruct v1; destruct v2; simpl in H; inv H. + assert (SWP: forall f1 f2, Vfloat (swap_floats c f1 f2) = swap_floats c (Vfloat f1) (Vfloat f2)). + destruct c; auto. + generalize (compare_floats_spec rs (swap_floats c f f0) (swap_floats c f0 f)). + repeat rewrite <- SWP. + set (rs' := nextinstr (compare_floats (Vfloat (swap_floats c f f0)) + (Vfloat (swap_floats c f0 f)) rs)). + intros [A [B [C D]]]. + unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C. + destruct c; simpl. +(* eq *) + rewrite Float.cmp_ne_eq. + destruct (Float.cmp Ceq f f0). auto. + simpl. destruct (Float.cmp Clt f f0 || Float.cmp Cgt f f0); auto. +(* ne *) + rewrite Float.cmp_ne_eq. + destruct (Float.cmp Ceq f f0). auto. + simpl. destruct (Float.cmp Clt f f0 || Float.cmp Cgt f f0); auto. +(* lt *) + rewrite <- (Float.cmp_swap Cge f f0). + rewrite <- (Float.cmp_swap Cne f f0). + simpl. + rewrite Float.cmp_ne_eq. rewrite Float.cmp_le_lt_eq. + caseEq (Float.cmp Clt f f0); intros; simpl. + caseEq (Float.cmp Ceq f f0); intros; simpl. + elimtype False. eapply Float.cmp_lt_eq_false; eauto. + auto. + destruct (Float.cmp Ceq f f0); auto. +(* le *) + rewrite <- (Float.cmp_swap Cge f f0). simpl. + destruct (Float.cmp Cle f f0); auto. +(* gt *) + rewrite Float.cmp_ne_eq. rewrite Float.cmp_ge_gt_eq. + caseEq (Float.cmp Cgt f f0); intros; simpl. + caseEq (Float.cmp Ceq f f0); intros; simpl. + elimtype False. eapply Float.cmp_gt_eq_false; eauto. + auto. + destruct (Float.cmp Ceq f f0); auto. +(* ge *) + destruct (Float.cmp Cge f f0); auto. +Qed. + +Lemma testcond_for_neg_float_comparison_correct: + forall c n1 n2 rs, + eval_extcond (testcond_for_condition (Cnotcompf c)) + (nextinstr (compare_floats (Vfloat (swap_floats c n1 n2)) + (Vfloat (swap_floats c n2 n1)) rs)) = + Some(negb(Float.cmp c n1 n2)). +Proof. + intros. + generalize (compare_floats_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)). + set (rs' := nextinstr (compare_floats (Vfloat (swap_floats c n1 n2)) + (Vfloat (swap_floats c n2 n1)) rs)). + intros [A [B [C D]]]. + unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C. + destruct c; simpl. +(* eq *) + rewrite Float.cmp_ne_eq. + caseEq (Float.cmp Ceq n1 n2); intros. + auto. + simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto. +(* ne *) + rewrite Float.cmp_ne_eq. + caseEq (Float.cmp Ceq n1 n2); intros. + auto. + simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto. +(* lt *) + rewrite <- (Float.cmp_swap Cge n1 n2). + rewrite <- (Float.cmp_swap Cne n1 n2). + simpl. + rewrite Float.cmp_ne_eq. rewrite Float.cmp_le_lt_eq. + caseEq (Float.cmp Clt n1 n2); intros; simpl. + caseEq (Float.cmp Ceq n1 n2); intros; simpl. + elimtype False. eapply Float.cmp_lt_eq_false; eauto. + auto. + destruct (Float.cmp Ceq n1 n2); auto. +(* le *) + rewrite <- (Float.cmp_swap Cge n1 n2). simpl. + destruct (Float.cmp Cle n1 n2); auto. +(* gt *) + rewrite Float.cmp_ne_eq. rewrite Float.cmp_ge_gt_eq. + caseEq (Float.cmp Cgt n1 n2); intros; simpl. + caseEq (Float.cmp Ceq n1 n2); intros; simpl. + elimtype False. eapply Float.cmp_gt_eq_false; eauto. + auto. + destruct (Float.cmp Ceq n1 n2); auto. +(* ge *) + destruct (Float.cmp Cge n1 n2); auto. +Qed. +***************) + +Definition swap_floats {A: Type} (c: comparison) (n1 n2: A) : A := match c with | Clt | Cle => n2 | Ceq | Cne | Cgt | Cge => n1 @@ -1253,81 +1364,95 @@ Proof. destruct (Float.cmp Cge n1 n2); auto. Qed. +Remark swap_floats_commut: + forall c x y, swap_floats c (Vfloat x) (Vfloat y) = Vfloat (swap_floats c x y). +Proof. + intros. destruct c; auto. +Qed. + +Remark compare_floats_inv: + forall vx vy rs r, + r <> CR ZF -> r <> CR CF -> r <> CR PF -> r <> CR SOF -> + compare_floats vx vy rs r = rs r. +Proof. + intros. + assert (DFL: undef_regs (CR ZF :: CR CF :: CR PF :: CR SOF :: nil) rs r = rs r). + simpl. repeat SOther. + unfold compare_floats; destruct vx; destruct vy; auto. repeat SOther. +Qed. + Lemma transl_cond_correct: - forall cond args k c rs m b, + forall cond args k c rs m, transl_cond cond args k = OK c -> - eval_condition cond (map rs (map preg_of args)) m = Some b -> exists rs', exec_straight c rs m k rs' m - /\ eval_extcond (testcond_for_condition cond) rs' = Some b + /\ match eval_condition cond (map rs (map preg_of args)) m with + | None => True + | Some b => eval_extcond (testcond_for_condition cond) rs' = Some b + end /\ forall r, nontemp_preg r = true -> rs'#r = rs r. Proof. unfold transl_cond; intros. destruct cond; repeat (destruct args; try discriminate); monadInv H. (* comp *) - simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. rewrite (ireg_of_eq _ _ EQ1) in H0. + simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. simpl in H0. FuncInv. - subst b. simpl. apply testcond_for_signed_comparison_correct_ii. + split. destruct (Val.cmp_bool c0 (rs x) (rs x0)) as []_eqn; auto. + eapply testcond_for_signed_comparison_correct; eauto. 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. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. simpl in H0. FuncInv. - subst b. simpl; apply testcond_for_unsigned_comparison_correct_ii. - simpl; apply testcond_for_unsigned_comparison_correct_ip; auto. - simpl; apply testcond_for_unsigned_comparison_correct_pi; auto. - simpl; eapply testcond_for_unsigned_comparison_correct_pp; eauto. + split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) as []_eqn; auto. + eapply testcond_for_unsigned_comparison_correct; eauto. intros. unfold compare_ints. repeat SOther. (* compimm *) - 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. simpl; apply testcond_for_signed_comparison_correct_ii. + simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int.eq_dec i Int.zero). + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split. destruct (rs x); simpl; auto. subst. rewrite Int.and_idem. + eapply testcond_for_signed_comparison_correct; eauto. + intros. unfold compare_ints. repeat SOther. + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split. destruct (Val.cmp_bool c0 (rs x) (Vint i)) as []_eqn; auto. + eapply testcond_for_signed_comparison_correct; eauto. 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. simpl; apply testcond_for_unsigned_comparison_correct_ii. - simpl; apply testcond_for_unsigned_comparison_correct_pi; auto. + simpl. rewrite (ireg_of_eq _ _ EQ). + econstructor. split. apply exec_straight_one. simpl. eauto. auto. + split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (Vint i)) as []_eqn; auto. + eapply testcond_for_unsigned_comparison_correct; eauto. 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. - remember (rs x) as v1; remember (rs x0) as v2. simpl in H0. FuncInv. - exists (nextinstr (compare_floats (Vfloat (swap_floats c0 f f0)) (Vfloat (swap_floats c0 f0 f)) rs)). + simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). + exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)). split. apply exec_straight_one. - destruct c0; unfold floatcomp, exec_instr, swap_floats; congruence. - auto. - split. subst b. apply testcond_for_float_comparison_correct. - intros. unfold compare_floats. repeat SOther. + destruct c0; simpl; auto. + unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with ppcgen. + split. destruct (rs x); destruct (rs x0); simpl; auto. + repeat rewrite swap_floats_commut. apply testcond_for_float_comparison_correct. + intros. SOther. apply compare_floats_inv; auto with ppcgen. (* notcompf *) - simpl map in H0. rewrite (freg_of_eq _ _ EQ) in H0. rewrite (freg_of_eq _ _ EQ1) in H0. - remember (rs x) as v1; remember (rs x0) as v2. simpl in H0. FuncInv. - exists (nextinstr (compare_floats (Vfloat (swap_floats c0 f f0)) (Vfloat (swap_floats c0 f0 f)) rs)). + simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). + exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)). split. apply exec_straight_one. - destruct c0; unfold floatcomp, exec_instr, swap_floats; congruence. - auto. - split. subst b. apply testcond_for_neg_float_comparison_correct. - intros. unfold compare_floats. repeat SOther. + destruct c0; simpl; auto. + unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with ppcgen. + split. destruct (rs x); destruct (rs x0); simpl; auto. + repeat rewrite swap_floats_commut. apply testcond_for_neg_float_comparison_correct. + intros. SOther. apply compare_floats_inv; auto with ppcgen. (* maskzero *) - simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. + simpl. rewrite (ireg_of_eq _ _ EQ). econstructor. split. apply exec_straight_one. simpl; eauto. auto. - split. simpl in H0. FuncInv. simpl. - generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero). - intros [A B]. rewrite A. subst b. simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto. + split. destruct (rs x); simpl; auto. + generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero m). + intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto. intros. unfold compare_ints. repeat SOther. (* masknotzero *) - simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. + simpl. rewrite (ireg_of_eq _ _ EQ). econstructor. split. apply exec_straight_one. simpl; eauto. auto. - split. simpl in H0. FuncInv. simpl. - generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero). - intros [A B]. rewrite A. subst b. simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto. + split. destruct (rs x); simpl; auto. + generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero m). + intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto. intros. unfold compare_ints. repeat SOther. Qed. @@ -1344,62 +1469,83 @@ Proof. Qed. Lemma mk_setcc_correct: - forall cond rd k rs1 m b, - eval_extcond cond rs1 = Some b -> + forall cond rd k rs1 m, exists rs2, exec_straight (mk_setcc cond rd k) rs1 m k rs2 m - /\ rs2#rd = Val.of_bool b + /\ rs2#rd = Val.of_optbool(eval_extcond cond rs1) /\ forall r, nontemp_preg r = true -> r <> rd -> rs2#r = rs1#r. Proof. intros. destruct cond; simpl in *. (* base *) econstructor; split. - apply exec_straight_one. simpl; rewrite H. eauto. auto. - split. repeat SRes. - intros. repeat SOther. + apply exec_straight_one. simpl; eauto. auto. + split. SRes. SRes. + intros; repeat SOther. (* or *) - destruct (eval_testcond c1 rs1) as [b1|]_eqn; - destruct (eval_testcond c2 rs1) as [b2|]_eqn; inv H. - assert (D: Val.or (Val.of_bool b1) (Val.of_bool b2) = Val.of_bool (b1 || b2)). - destruct b1; destruct b2; auto. + assert (Val.of_optbool + match eval_testcond c1 rs1 with + | Some b1 => + match eval_testcond c2 rs1 with + | Some b2 => Some (b1 || b2) + | None => None + end + | None => None + end = + Val.or (Val.of_optbool (eval_testcond c1 rs1)) (Val.of_optbool (eval_testcond c2 rs1))). + destruct (eval_testcond c1 rs1). destruct (eval_testcond c2 rs1). + destruct b; destruct b0; auto. + destruct b; auto. + auto. + rewrite H; clear H. destruct (ireg_eq rd EDX). subst rd. econstructor; split. eapply exec_straight_three. - simpl; rewrite Heqo; eauto. - simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. rewrite Heqo0. eauto. - simpl. eauto. + simpl; eauto. + simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto. + simpl; eauto. auto. auto. auto. split. SRes. intros. repeat SOther. econstructor; split. eapply exec_straight_three. - simpl; rewrite Heqo; eauto. - simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. rewrite Heqo0. eauto. + simpl; eauto. + simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto. simpl. eauto. auto. auto. auto. - split. repeat SRes. rewrite <- D. rewrite Val.or_commut. decEq; repeat SRes. + split. repeat SRes. rewrite Val.or_commut. decEq; repeat SRes. intros. repeat SOther. (* and *) - destruct (eval_testcond c1 rs1) as [b1|]_eqn; - destruct (eval_testcond c2 rs1) as [b2|]_eqn; inv H. - assert (D: Val.and (Val.of_bool b1) (Val.of_bool b2) = Val.of_bool (b1 && b2)). - destruct b1; destruct b2; auto. + assert (Val.of_optbool + match eval_testcond c1 rs1 with + | Some b1 => + match eval_testcond c2 rs1 with + | Some b2 => Some (b1 && b2) + | None => None + end + | None => None + end = + Val.and (Val.of_optbool (eval_testcond c1 rs1)) (Val.of_optbool (eval_testcond c2 rs1))). + destruct (eval_testcond c1 rs1). destruct (eval_testcond c2 rs1). + destruct b; destruct b0; auto. + destruct b; auto. + auto. + rewrite H; clear H. destruct (ireg_eq rd EDX). subst rd. econstructor; split. eapply exec_straight_three. - simpl; rewrite Heqo; eauto. - simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. rewrite Heqo0. eauto. - simpl. eauto. + simpl; eauto. + simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto. + simpl; eauto. auto. auto. auto. split. SRes. intros. repeat SOther. econstructor; split. eapply exec_straight_three. - simpl; rewrite Heqo; eauto. - simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. rewrite Heqo0. eauto. + simpl; eauto. + simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto. simpl. eauto. auto. auto. auto. - split. repeat SRes. rewrite <- D. rewrite Val.and_commut. decEq; repeat SRes. + split. repeat SRes. rewrite Val.and_commut. decEq; repeat SRes. intros. repeat SOther. Qed. @@ -1421,70 +1567,93 @@ Ltac TranslOp := [ apply exec_straight_one; [ simpl; eauto | auto ] | split; [ repeat SRes | intros; repeat SOther ]]. + Lemma transl_op_correct: forall op args res k c (rs: regset) m v, transl_op op args res k = OK c -> eval_operation ge (rs#ESP) op (map rs (map preg_of args)) m = Some v -> exists rs', exec_straight c rs m k rs' m - /\ rs'#(preg_of res) = v + /\ Val.lessdef v rs'#(preg_of res) /\ forall r, match op with Omove => important_preg r = true /\ r <> ST0 | _ => nontemp_preg r = true end -> r <> preg_of res -> rs' r = rs r. Proof. intros until v; intros TR EV. - rewrite <- (eval_operation_weaken _ _ _ _ _ EV). - destruct op; simpl in TR; ArgsInv; try (TranslOp; fail). + assert (SAME: + (exists rs', + exec_straight c rs m k rs' m + /\ rs'#(preg_of res) = v + /\ forall r, + match op with Omove => important_preg r = true /\ r <> ST0 | _ => nontemp_preg r = true end -> + r <> preg_of res -> rs' r = rs r) -> + exists rs', + exec_straight c rs m k rs' m + /\ Val.lessdef v rs'#(preg_of res) + /\ forall r, + match op with Omove => important_preg r = true /\ r <> ST0 | _ => nontemp_preg r = true end -> + r <> preg_of res -> rs' r = rs r). + intros [rs' [A [B C]]]. subst v. exists rs'; auto. + + destruct op; simpl in TR; ArgsInv; simpl in EV; try (inv EV); try (apply SAME; TranslOp; fail). (* move *) exploit mk_mov_correct; eauto. intros [rs2 [A [B C]]]. - exists rs2. split. eauto. split. simpl. auto. intros. destruct H; auto. + apply SAME. exists rs2. split. eauto. split. simpl. auto. intros. destruct H; auto. (* intconst *) - inv EV. destruct (Int.eq_dec i Int.zero). subst i. TranslOp. TranslOp. + apply SAME. destruct (Int.eq_dec i Int.zero). subst i. TranslOp. TranslOp. (* floatconst *) - inv EV. destruct (Float.eq_dec f Float.zero). subst f. TranslOp. TranslOp. + apply SAME. destruct (Float.eq_dec f Float.zero). subst f. TranslOp. TranslOp. (* cast8signed *) - eapply mk_intconv_correct; eauto. + apply SAME. eapply mk_intconv_correct; eauto. (* cast8unsigned *) - eapply mk_intconv_correct; eauto. + apply SAME. eapply mk_intconv_correct; eauto. (* cast16signed *) - eapply mk_intconv_correct; eauto. + apply SAME. eapply mk_intconv_correct; eauto. (* cast16unsigned *) - eapply mk_intconv_correct; eauto. + apply SAME. eapply mk_intconv_correct; eauto. (* div *) - eapply mk_div_correct; eauto. intros. simpl. eauto. + apply SAME. + specialize (divs_mods_exist (rs x0) (rs x1)). rewrite H0. + destruct (Val.mods (rs x0) (rs x1)) as [vr|]_eqn; intros; try contradiction. + eapply mk_div_correct with (dsem := Val.divs) (msem := Val.mods); eauto. (* divu *) - eapply mk_div_correct; eauto. intros. simpl. eauto. + apply SAME. + specialize (divu_modu_exist (rs x0) (rs x1)). rewrite H0. + destruct (Val.modu (rs x0) (rs x1)) as [vr|]_eqn; intros; try contradiction. + eapply mk_div_correct with (dsem := Val.divu) (msem := Val.modu); eauto. (* mod *) - eapply mk_mod_correct; eauto. intros. simpl. eauto. + apply SAME. + specialize (divs_mods_exist (rs x0) (rs x1)). rewrite H0. + destruct (Val.divs (rs x0) (rs x1)) as [vq|]_eqn; intros; try contradiction. + eapply mk_mod_correct with (dsem := Val.divs) (msem := Val.mods); eauto. (* modu *) - eapply mk_mod_correct; eauto. intros. simpl. eauto. + apply SAME. + specialize (divu_modu_exist (rs x0) (rs x1)). rewrite H0. + destruct (Val.divu (rs x0) (rs x1)) as [vq|]_eqn; intros; try contradiction. + eapply mk_mod_correct with (dsem := Val.divu) (msem := Val.modu); eauto. (* shl *) - eapply mk_shift_correct; eauto. + apply SAME. eapply mk_shift_correct; eauto. (* shr *) - eapply mk_shift_correct; eauto. + apply SAME. eapply mk_shift_correct; eauto. (* shrximm *) - remember (rs x0) as v1. FuncInv. - remember (Int.ltu i (Int.repr 31)) as L. destruct L; inv EV. - simpl. replace (Int.ltu i Int.iwordsize) with true. - apply mk_shrximm_correct; auto. - unfold Int.ltu. rewrite zlt_true; auto. - generalize (Int.ltu_inv _ _ (sym_equal HeqL)). - assert (Int.unsigned (Int.repr 31) < Int.unsigned Int.iwordsize) by (compute; auto). - omega. + apply SAME. eapply mk_shrximm_correct; eauto. (* shru *) - eapply mk_shift_correct; eauto. + apply SAME. eapply mk_shift_correct; eauto. (* lea *) exploit transl_addressing_mode_correct; eauto. intros EA. - rewrite (eval_addressing_weaken _ _ _ _ EV). rewrite <- EA. - TranslOp. + TranslOp. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss; auto. +(* intoffloat *) + apply SAME. TranslOp. rewrite H0; auto. +(* floatofint *) + apply SAME. TranslOp. rewrite H0; auto. (* condition *) - 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]]]. exploit mk_setcc_correct; eauto. intros [rs3 [S [T U]]]. exists rs3. split. eapply exec_straight_trans. eexact P. eexact S. - split. auto. + split. rewrite T. destruct (eval_condition c0 rs ## (preg_of ## args) m). + rewrite Q. auto. + simpl; auto. intros. transitivity (rs2 r); auto. Qed. @@ -1502,9 +1671,10 @@ Lemma transl_load_correct: Proof. unfold transl_load; intros. monadInv H. exploit transl_addressing_mode_correct; eauto. intro EA. + assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto. set (rs2 := nextinstr_nf (rs#(preg_of dest) <- v)). assert (exec_load ge chunk m x rs (preg_of dest) = Next rs2 m). - unfold exec_load. rewrite EA. rewrite H1. auto. + unfold exec_load. rewrite EA'. rewrite H1. auto. assert (rs2 PC = Val.add (rs PC) Vone). transitivity (Val.add ((rs#(preg_of dest) <- v) PC) Vone). auto. decEq. apply Pregmap.gso; auto with ppcgen. @@ -1524,8 +1694,9 @@ Lemma transl_store_correct: /\ forall r, nontemp_preg r = true -> rs'#r = rs#r. Proof. unfold transl_store; intros. monadInv H. - exploit transl_addressing_mode_correct; eauto. intro EA. rewrite <- EA in H1. - destruct chunk; ArgsInv. + exploit transl_addressing_mode_correct; eauto. intro EA. + assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto. + rewrite <- EA' in H1. destruct chunk; ArgsInv. (* int8signed *) eapply mk_smallstore_correct; eauto. intros. simpl. unfold exec_store. diff --git a/ia32/ConstpropOp.v b/ia32/ConstpropOp.v index 815ba0e..3d07a4d 100644 --- a/ia32/ConstpropOp.v +++ b/ia32/ConstpropOp.v @@ -32,9 +32,10 @@ Inductive approx : Type := no compile-time information is available. *) | I: int -> approx (** A known integer value. *) | F: float -> approx (** A known floating-point value. *) - | S: ident -> int -> approx. + | G: ident -> int -> approx (** The value is the address of the given global symbol plus the given integer offset. *) + | S: int -> approx. (** The value is the stack pointer plus the offset. *) (** We now define the abstract interpretations of conditions and operators over this set of approximations. For instance, the abstract interpretation @@ -44,11 +45,12 @@ Inductive approx : Type := The static approximations are defined by large pattern-matchings over the approximations of the results. We write these matchings in the - indirect style described in file [Cmconstr] to avoid excessive + indirect style described in file [SelectOp] to avoid excessive duplication of cases in proofs. *) -(* -Definition eval_static_condition (cond: condition) (vl: list approx) := +(** Original definition: +<< +Nondetfunction eval_static_condition (cond: condition) (vl: list approx) := match cond, vl with | Ccomp c, I n1 :: I n2 :: nil => Some(Int.cmp c n1 n2) | Ccompu c, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 n2) @@ -57,198 +59,175 @@ Definition eval_static_condition (cond: condition) (vl: list approx) := | Ccompf c, F n1 :: F n2 :: nil => Some(Float.cmp c n1 n2) | Cnotcompf c, F n1 :: F n2 :: nil => Some(negb(Float.cmp c n1 n2)) | Cmaskzero n, I n1 :: nil => Some(Int.eq (Int.and n1 n) Int.zero) - | Cmasknotzero n, n1::nil => Some(negb(Int.eq (Int.and n1 n) Int.zero)) + | Cmasknotzero n, I n1::nil => Some(negb(Int.eq (Int.and n1 n) Int.zero)) | _, _ => None end. +>> *) Inductive eval_static_condition_cases: forall (cond: condition) (vl: list approx), Type := - | eval_static_condition_case1: - forall c n1 n2, - eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil) - | eval_static_condition_case2: - forall c n1 n2, - eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil) - | eval_static_condition_case3: - forall c n n1, - eval_static_condition_cases (Ccompimm c n) (I n1 :: nil) - | eval_static_condition_case4: - forall c n n1, - eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil) - | eval_static_condition_case5: - forall c n1 n2, - eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil) - | eval_static_condition_case6: - forall c n1 n2, - eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil) - | eval_static_condition_case7: - forall n n1, - eval_static_condition_cases (Cmaskzero n) (I n1 :: nil) - | eval_static_condition_case8: - forall n n1, - eval_static_condition_cases (Cmasknotzero n) (I n1 :: nil) - | eval_static_condition_default: - forall (cond: condition) (vl: list approx), - eval_static_condition_cases cond vl. + | eval_static_condition_case1: forall c n1 n2, eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil) + | eval_static_condition_case2: forall c n1 n2, eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil) + | eval_static_condition_case3: forall c n n1, eval_static_condition_cases (Ccompimm c n) (I n1 :: nil) + | eval_static_condition_case4: forall c n n1, eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil) + | eval_static_condition_case5: forall c n1 n2, eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil) + | eval_static_condition_case6: forall c n1 n2, eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil) + | eval_static_condition_case7: forall n n1, eval_static_condition_cases (Cmaskzero n) (I n1 :: nil) + | eval_static_condition_case8: forall n n1, eval_static_condition_cases (Cmasknotzero n) (I n1::nil) + | eval_static_condition_default: forall (cond: condition) (vl: list approx), eval_static_condition_cases cond vl. Definition eval_static_condition_match (cond: condition) (vl: list approx) := - match cond as z1, vl as z2 return eval_static_condition_cases z1 z2 with - | Ccomp c, I n1 :: I n2 :: nil => - eval_static_condition_case1 c n1 n2 - | Ccompu c, I n1 :: I n2 :: nil => - eval_static_condition_case2 c n1 n2 - | Ccompimm c n, I n1 :: nil => - eval_static_condition_case3 c n n1 - | Ccompuimm c n, I n1 :: nil => - eval_static_condition_case4 c n n1 - | Ccompf c, F n1 :: F n2 :: nil => - eval_static_condition_case5 c n1 n2 - | Cnotcompf c, F n1 :: F n2 :: nil => - eval_static_condition_case6 c n1 n2 - | Cmaskzero n, I n1 :: nil => - eval_static_condition_case7 n n1 - | Cmasknotzero n, I n1 :: nil => - eval_static_condition_case8 n n1 - | cond, vl => - eval_static_condition_default cond vl + match cond as zz1, vl as zz2 return eval_static_condition_cases zz1 zz2 with + | Ccomp c, I n1 :: I n2 :: nil => eval_static_condition_case1 c n1 n2 + | Ccompu c, I n1 :: I n2 :: nil => eval_static_condition_case2 c n1 n2 + | Ccompimm c n, I n1 :: nil => eval_static_condition_case3 c n n1 + | Ccompuimm c n, I n1 :: nil => eval_static_condition_case4 c n n1 + | Ccompf c, F n1 :: F n2 :: nil => eval_static_condition_case5 c n1 n2 + | Cnotcompf c, F n1 :: F n2 :: nil => eval_static_condition_case6 c n1 n2 + | Cmaskzero n, I n1 :: nil => eval_static_condition_case7 n n1 + | Cmasknotzero n, I n1::nil => eval_static_condition_case8 n n1 + | cond, vl => eval_static_condition_default cond vl end. Definition eval_static_condition (cond: condition) (vl: list approx) := match eval_static_condition_match cond vl with - | eval_static_condition_case1 c n1 n2 => + | eval_static_condition_case1 c n1 n2 => (* Ccomp c, I n1 :: I n2 :: nil *) Some(Int.cmp c n1 n2) - | eval_static_condition_case2 c n1 n2 => + | eval_static_condition_case2 c n1 n2 => (* Ccompu c, I n1 :: I n2 :: nil *) Some(Int.cmpu c n1 n2) - | eval_static_condition_case3 c n n1 => + | eval_static_condition_case3 c n n1 => (* Ccompimm c n, I n1 :: nil *) Some(Int.cmp c n1 n) - | eval_static_condition_case4 c n n1 => + | eval_static_condition_case4 c n n1 => (* Ccompuimm c n, I n1 :: nil *) Some(Int.cmpu c n1 n) - | eval_static_condition_case5 c n1 n2 => + | eval_static_condition_case5 c n1 n2 => (* Ccompf c, F n1 :: F n2 :: nil *) Some(Float.cmp c n1 n2) - | eval_static_condition_case6 c n1 n2 => + | eval_static_condition_case6 c n1 n2 => (* Cnotcompf c, F n1 :: F n2 :: nil *) Some(negb(Float.cmp c n1 n2)) - | eval_static_condition_case7 n n1 => + | eval_static_condition_case7 n n1 => (* Cmaskzero n, I n1 :: nil *) Some(Int.eq (Int.and n1 n) Int.zero) - | eval_static_condition_case8 n n1 => + | eval_static_condition_case8 n n1 => (* Cmasknotzero n, I n1::nil *) Some(negb(Int.eq (Int.and n1 n) Int.zero)) | eval_static_condition_default cond vl => None end. -(* -Definition eval_static_addressing (addr: addressing) (vl: list approx) := - match op, vl with + +Definition eval_static_condition_val (cond: condition) (vl: list approx) := + match eval_static_condition cond vl with + | None => Unknown + | Some b => I(if b then Int.one else Int.zero) + end. + +Definition eval_static_intoffloat (f: float) := + match Float.intoffloat f with Some x => I x | None => Unknown end. + +(** Original definition: +<< +Nondetfunction eval_static_addressing (addr: addressing) (vl: list approx) := + match addr, vl with | Aindexed n, I n1::nil => I (Int.add n1 n) - | Aindexed n, S id ofs::nil => S id (Int.add ofs n) + | Aindexed n, G id ofs::nil => G id (Int.add ofs n) + | Aindexed n, S ofs::nil => S (Int.add ofs n) | Aindexed2 n, I n1::I n2::nil => I (Int.add (Int.add n1 n2) n) - | Aindexed2 n, S id ofs::I n2::nil => S id (Int.add (Int.add ofs n2) n) - | Aindexed2 n, I n1::S id ofs::nil => S id (Int.add (Int.add ofs n1) n) + | Aindexed2 n, G id ofs::I n2::nil => G id (Int.add (Int.add ofs n2) n) + | Aindexed2 n, I n1::G id ofs::nil => G id (Int.add (Int.add ofs n1) n) + | Aindexed2 n, S ofs::I n2::nil => S (Int.add (Int.add ofs n2) n) + | Aindexed2 n, I n1::S ofs::nil => S (Int.add (Int.add ofs n1) n) | Ascaled sc n, I n1::nil => I (Int.add (Int.mul n1 sc) n) | Aindexed2scaled sc n, I n1::I n2::nil => I (Int.add n1 (Int.add (Int.mul n2 sc) n)) - | Aindexed2scaled sc n, S id ofs::I n2::nil => S id (Int.add ofs (Int.add (Int.mul n2 sc) n)) - | Aglobal id ofs, nil => S id ofs - | Abased id ofs, I n1::nil => S id (Int.add ofs n1) - | Abasedscaled sc id ofs, I n1::nil => S id (Int.add ofs (Int.mul sc n1)) + | Aindexed2scaled sc n, G id ofs::I n2::nil => G id (Int.add ofs (Int.add (Int.mul n2 sc) n)) + | Aindexed2scaled sc n, S ofs::I n2::nil => S (Int.add ofs (Int.add (Int.mul n2 sc) n)) + | Aglobal id ofs, nil => G id ofs + | Abased id ofs, I n1::nil => G id (Int.add ofs n1) + | Abasedscaled sc id ofs, I n1::nil => G id (Int.add ofs (Int.mul sc n1)) + | Ainstack ofs, nil => S ofs | _, _ => Unknown end. +>> *) Inductive eval_static_addressing_cases: forall (addr: addressing) (vl: list approx), Type := - | eval_static_addressing_case1: - forall n n1, - eval_static_addressing_cases (Aindexed n) (I n1::nil) - | eval_static_addressing_case2: - forall n id ofs, - eval_static_addressing_cases (Aindexed n) (S id ofs::nil) - | eval_static_addressing_case3: - forall n n1 n2, - eval_static_addressing_cases (Aindexed2 n) (I n1::I n2::nil) - | eval_static_addressing_case4: - forall n id ofs n2, - eval_static_addressing_cases (Aindexed2 n) (S id ofs::I n2::nil) - | eval_static_addressing_case5: - forall n n1 id ofs, - eval_static_addressing_cases (Aindexed2 n) (I n1::S id ofs::nil) - | eval_static_addressing_case6: - forall sc n n1, - eval_static_addressing_cases (Ascaled sc n) (I n1::nil) - | eval_static_addressing_case7: - forall sc n n1 n2, - eval_static_addressing_cases (Aindexed2scaled sc n) (I n1::I n2::nil) - | eval_static_addressing_case8: - forall sc n id ofs n2, - eval_static_addressing_cases (Aindexed2scaled sc n) (S id ofs::I n2::nil) - | eval_static_addressing_case9: - forall id ofs, - eval_static_addressing_cases (Aglobal id ofs) (nil) - | eval_static_addressing_case10: - forall id ofs n1, - eval_static_addressing_cases (Abased id ofs) (I n1::nil) - | eval_static_addressing_case11: - forall sc id ofs n1, - eval_static_addressing_cases (Abasedscaled sc id ofs) (I n1::nil) - | eval_static_addressing_default: - forall (addr: addressing) (vl: list approx), - eval_static_addressing_cases addr vl. + | eval_static_addressing_case1: forall n n1, eval_static_addressing_cases (Aindexed n) (I n1::nil) + | eval_static_addressing_case2: forall n id ofs, eval_static_addressing_cases (Aindexed n) (G id ofs::nil) + | eval_static_addressing_case3: forall n ofs, eval_static_addressing_cases (Aindexed n) (S ofs::nil) + | eval_static_addressing_case4: forall n n1 n2, eval_static_addressing_cases (Aindexed2 n) (I n1::I n2::nil) + | eval_static_addressing_case5: forall n id ofs n2, eval_static_addressing_cases (Aindexed2 n) (G id ofs::I n2::nil) + | eval_static_addressing_case6: forall n n1 id ofs, eval_static_addressing_cases (Aindexed2 n) (I n1::G id ofs::nil) + | eval_static_addressing_case7: forall n ofs n2, eval_static_addressing_cases (Aindexed2 n) (S ofs::I n2::nil) + | eval_static_addressing_case8: forall n n1 ofs, eval_static_addressing_cases (Aindexed2 n) (I n1::S ofs::nil) + | eval_static_addressing_case9: forall sc n n1, eval_static_addressing_cases (Ascaled sc n) (I n1::nil) + | eval_static_addressing_case10: forall sc n n1 n2, eval_static_addressing_cases (Aindexed2scaled sc n) (I n1::I n2::nil) + | eval_static_addressing_case11: forall sc n id ofs n2, eval_static_addressing_cases (Aindexed2scaled sc n) (G id ofs::I n2::nil) + | eval_static_addressing_case12: forall sc n ofs n2, eval_static_addressing_cases (Aindexed2scaled sc n) (S ofs::I n2::nil) + | eval_static_addressing_case13: forall id ofs, eval_static_addressing_cases (Aglobal id ofs) (nil) + | eval_static_addressing_case14: forall id ofs n1, eval_static_addressing_cases (Abased id ofs) (I n1::nil) + | eval_static_addressing_case15: forall sc id ofs n1, eval_static_addressing_cases (Abasedscaled sc id ofs) (I n1::nil) + | eval_static_addressing_case16: forall ofs, eval_static_addressing_cases (Ainstack ofs) (nil) + | eval_static_addressing_default: forall (addr: addressing) (vl: list approx), eval_static_addressing_cases addr vl. Definition eval_static_addressing_match (addr: addressing) (vl: list approx) := - match addr as z1, vl as z2 return eval_static_addressing_cases z1 z2 with - | Aindexed n, I n1::nil => - eval_static_addressing_case1 n n1 - | Aindexed n, S id ofs::nil => - eval_static_addressing_case2 n id ofs - | Aindexed2 n, I n1::I n2::nil => - eval_static_addressing_case3 n n1 n2 - | Aindexed2 n, S id ofs::I n2::nil => - eval_static_addressing_case4 n id ofs n2 - | Aindexed2 n, I n1::S id ofs::nil => - eval_static_addressing_case5 n n1 id ofs - | Ascaled sc n, I n1::nil => - eval_static_addressing_case6 sc n n1 - | Aindexed2scaled sc n, I n1::I n2::nil => - eval_static_addressing_case7 sc n n1 n2 - | Aindexed2scaled sc n, S id ofs::I n2::nil => - eval_static_addressing_case8 sc n id ofs n2 - | Aglobal id ofs, nil => - eval_static_addressing_case9 id ofs - | Abased id ofs, I n1::nil => - eval_static_addressing_case10 id ofs n1 - | Abasedscaled sc id ofs, I n1::nil => - eval_static_addressing_case11 sc id ofs n1 - | addr, vl => - eval_static_addressing_default addr vl + match addr as zz1, vl as zz2 return eval_static_addressing_cases zz1 zz2 with + | Aindexed n, I n1::nil => eval_static_addressing_case1 n n1 + | Aindexed n, G id ofs::nil => eval_static_addressing_case2 n id ofs + | Aindexed n, S ofs::nil => eval_static_addressing_case3 n ofs + | Aindexed2 n, I n1::I n2::nil => eval_static_addressing_case4 n n1 n2 + | Aindexed2 n, G id ofs::I n2::nil => eval_static_addressing_case5 n id ofs n2 + | Aindexed2 n, I n1::G id ofs::nil => eval_static_addressing_case6 n n1 id ofs + | Aindexed2 n, S ofs::I n2::nil => eval_static_addressing_case7 n ofs n2 + | Aindexed2 n, I n1::S ofs::nil => eval_static_addressing_case8 n n1 ofs + | Ascaled sc n, I n1::nil => eval_static_addressing_case9 sc n n1 + | Aindexed2scaled sc n, I n1::I n2::nil => eval_static_addressing_case10 sc n n1 n2 + | Aindexed2scaled sc n, G id ofs::I n2::nil => eval_static_addressing_case11 sc n id ofs n2 + | Aindexed2scaled sc n, S ofs::I n2::nil => eval_static_addressing_case12 sc n ofs n2 + | Aglobal id ofs, nil => eval_static_addressing_case13 id ofs + | Abased id ofs, I n1::nil => eval_static_addressing_case14 id ofs n1 + | Abasedscaled sc id ofs, I n1::nil => eval_static_addressing_case15 sc id ofs n1 + | Ainstack ofs, nil => eval_static_addressing_case16 ofs + | addr, vl => eval_static_addressing_default addr vl end. Definition eval_static_addressing (addr: addressing) (vl: list approx) := match eval_static_addressing_match addr vl with - | eval_static_addressing_case1 n n1 => + | eval_static_addressing_case1 n n1 => (* Aindexed n, I n1::nil *) I (Int.add n1 n) - | eval_static_addressing_case2 n id ofs => - S id (Int.add ofs n) - | eval_static_addressing_case3 n n1 n2 => + | eval_static_addressing_case2 n id ofs => (* Aindexed n, G id ofs::nil *) + G id (Int.add ofs n) + | eval_static_addressing_case3 n ofs => (* Aindexed n, S ofs::nil *) + S (Int.add ofs n) + | eval_static_addressing_case4 n n1 n2 => (* Aindexed2 n, I n1::I n2::nil *) I (Int.add (Int.add n1 n2) n) - | eval_static_addressing_case4 n id ofs n2 => - S id (Int.add (Int.add ofs n2) n) - | eval_static_addressing_case5 n n1 id ofs => - S id (Int.add (Int.add ofs n1) n) - | eval_static_addressing_case6 sc n n1 => + | eval_static_addressing_case5 n id ofs n2 => (* Aindexed2 n, G id ofs::I n2::nil *) + G id (Int.add (Int.add ofs n2) n) + | eval_static_addressing_case6 n n1 id ofs => (* Aindexed2 n, I n1::G id ofs::nil *) + G id (Int.add (Int.add ofs n1) n) + | eval_static_addressing_case7 n ofs n2 => (* Aindexed2 n, S ofs::I n2::nil *) + S (Int.add (Int.add ofs n2) n) + | eval_static_addressing_case8 n n1 ofs => (* Aindexed2 n, I n1::S ofs::nil *) + S (Int.add (Int.add ofs n1) n) + | eval_static_addressing_case9 sc n n1 => (* Ascaled sc n, I n1::nil *) I (Int.add (Int.mul n1 sc) n) - | eval_static_addressing_case7 sc n n1 n2 => + | eval_static_addressing_case10 sc n n1 n2 => (* Aindexed2scaled sc n, I n1::I n2::nil *) I (Int.add n1 (Int.add (Int.mul n2 sc) n)) - | eval_static_addressing_case8 sc n id ofs n2 => - S id (Int.add ofs (Int.add (Int.mul n2 sc) n)) - | eval_static_addressing_case9 id ofs => - S id ofs - | eval_static_addressing_case10 id ofs n1 => - S id (Int.add ofs n1) - | eval_static_addressing_case11 sc id ofs n1 => - S id (Int.add ofs (Int.mul sc n1)) + | eval_static_addressing_case11 sc n id ofs n2 => (* Aindexed2scaled sc n, G id ofs::I n2::nil *) + G id (Int.add ofs (Int.add (Int.mul n2 sc) n)) + | eval_static_addressing_case12 sc n ofs n2 => (* Aindexed2scaled sc n, S ofs::I n2::nil *) + S (Int.add ofs (Int.add (Int.mul n2 sc) n)) + | eval_static_addressing_case13 id ofs => (* Aglobal id ofs, nil *) + G id ofs + | eval_static_addressing_case14 id ofs n1 => (* Abased id ofs, I n1::nil *) + G id (Int.add ofs n1) + | eval_static_addressing_case15 sc id ofs n1 => (* Abasedscaled sc id ofs, I n1::nil *) + G id (Int.add ofs (Int.mul sc n1)) + | eval_static_addressing_case16 ofs => (* Ainstack ofs, nil *) + S ofs | eval_static_addressing_default addr vl => Unknown end. -(* -Definition eval_static_operation (op: operation) (vl: list approx) := + +(** Original definition: +<< +Nondetfunction eval_static_operation (op: operation) (vl: list approx) := match op, vl with | Omove, v1::nil => v1 | Ointconst n, nil => I n @@ -259,7 +238,7 @@ Definition eval_static_operation (op: operation) (vl: list approx) := | Ocast16unsigned, I n1 :: nil => I(Int.zero_ext 16 n1) | Oneg, I n1 :: nil => I(Int.neg n1) | Osub, I n1 :: I n2 :: nil => I(Int.sub n1 n2) - | Osub, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 n2) + | Osub, G s1 n1 :: I n2 :: nil => G s1 (Int.sub n1 n2) | Omul, I n1 :: I n2 :: nil => I(Int.mul n1 n2) | Omulimm n, I n1 :: nil => I(Int.mul n1 n) | Odiv, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) @@ -276,7 +255,7 @@ Definition eval_static_operation (op: operation) (vl: list approx) := | Oshlimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shl n1 n) else Unknown | Oshr, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shr n1 n2) else Unknown | Oshrimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shr n1 n) else Unknown - | Oshrximm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shrx n1 n) else Unknown + | Oshrximm n, I n1 :: nil => if Int.ltu n (Int.repr 31) then I(Int.shrx n1 n) else Unknown | Oshru, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shru n1 n2) else Unknown | Oshruimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shru n1 n) else Unknown | Ororimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.ror n1 n) else Unknown @@ -288,320 +267,193 @@ Definition eval_static_operation (op: operation) (vl: list approx) := | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2) | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2) | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) - | Ointoffloat, F n1 :: nil => match Float.intoffloat n1 with Some x => I x | None => Unknown end + | Ointoffloat, F n1 :: nil => eval_static_intoffloat n1 | Ofloatofint, I n1 :: nil => F(Float.floatofint n1) - | Ocmp c, vl => match eval_static_condition c vl with None => Unknown | Some b => I(if b then Int.one else Int.zero) end + | Ocmp c, vl => eval_static_condition_val c vl | _, _ => Unknown end. +>> *) Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx), Type := - | eval_static_operation_case1: - forall v1, - eval_static_operation_cases (Omove) (v1::nil) - | eval_static_operation_case2: - forall n, - eval_static_operation_cases (Ointconst n) (nil) - | eval_static_operation_case3: - forall n, - eval_static_operation_cases (Ofloatconst n) (nil) - | eval_static_operation_case4: - forall n1, - eval_static_operation_cases (Ocast8signed) (I n1 :: nil) - | eval_static_operation_case5: - forall n1, - eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil) - | eval_static_operation_case6: - forall n1, - eval_static_operation_cases (Ocast16signed) (I n1 :: nil) - | eval_static_operation_case7: - forall n1, - eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil) - | eval_static_operation_case8: - forall n1, - eval_static_operation_cases (Oneg) (I n1 :: nil) - | eval_static_operation_case9: - forall n1 n2, - eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil) - | eval_static_operation_case10: - forall s1 n1 n2, - eval_static_operation_cases (Osub) (S s1 n1 :: I n2 :: nil) - | eval_static_operation_case11: - forall n1 n2, - eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil) - | eval_static_operation_case12: - forall n n1, - eval_static_operation_cases (Omulimm n) (I n1 :: nil) - | eval_static_operation_case13: - forall n1 n2, - eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil) - | eval_static_operation_case14: - forall n1 n2, - eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil) - | eval_static_operation_case15: - forall n1 n2, - eval_static_operation_cases (Omod) (I n1 :: I n2 :: nil) - | eval_static_operation_case16: - forall n1 n2, - eval_static_operation_cases (Omodu) (I n1 :: I n2 :: nil) - | eval_static_operation_case17: - forall n1 n2, - eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil) - | eval_static_operation_case18: - forall n n1, - eval_static_operation_cases (Oandimm n) (I n1 :: nil) - | eval_static_operation_case19: - forall n1 n2, - eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil) - | eval_static_operation_case20: - forall n n1, - eval_static_operation_cases (Oorimm n) (I n1 :: nil) - | eval_static_operation_case21: - forall n1 n2, - eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil) - | eval_static_operation_case22: - forall n n1, - eval_static_operation_cases (Oxorimm n) (I n1 :: nil) - | eval_static_operation_case23: - forall n1 n2, - eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil) - | eval_static_operation_case24: - forall n n1, - eval_static_operation_cases (Oshlimm n) (I n1 :: nil) - | eval_static_operation_case25: - forall n1 n2, - eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil) - | eval_static_operation_case26: - forall n n1, - eval_static_operation_cases (Oshrimm n) (I n1 :: nil) - | eval_static_operation_case27: - forall n n1, - eval_static_operation_cases (Oshrximm n) (I n1 :: nil) - | eval_static_operation_case28: - forall n1 n2, - eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil) - | eval_static_operation_case29: - forall n n1, - eval_static_operation_cases (Oshruimm n) (I n1 :: nil) - | eval_static_operation_case30: - forall n n1, - eval_static_operation_cases (Ororimm n) (I n1 :: nil) - | eval_static_operation_case31: - forall mode vl, - eval_static_operation_cases (Olea mode) (vl) - | eval_static_operation_case32: - forall n1, - eval_static_operation_cases (Onegf) (F n1 :: nil) - | eval_static_operation_case33: - forall n1, - eval_static_operation_cases (Oabsf) (F n1 :: nil) - | eval_static_operation_case34: - forall n1 n2, - eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil) - | eval_static_operation_case35: - forall n1 n2, - eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil) - | eval_static_operation_case36: - forall n1 n2, - eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil) - | eval_static_operation_case37: - forall n1 n2, - eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil) - | eval_static_operation_case38: - forall n1, - eval_static_operation_cases (Osingleoffloat) (F n1 :: nil) - | eval_static_operation_case39: - forall n1, - eval_static_operation_cases (Ointoffloat) (F n1 :: nil) - | eval_static_operation_case41: - forall n1, - eval_static_operation_cases (Ofloatofint) (I n1 :: nil) - | eval_static_operation_case43: - forall c vl, - eval_static_operation_cases (Ocmp c) vl - | eval_static_operation_default: - forall (op: operation) (vl: list approx), - eval_static_operation_cases op vl. + | eval_static_operation_case1: forall v1, eval_static_operation_cases (Omove) (v1::nil) + | eval_static_operation_case2: forall n, eval_static_operation_cases (Ointconst n) (nil) + | eval_static_operation_case3: forall n, eval_static_operation_cases (Ofloatconst n) (nil) + | eval_static_operation_case4: forall n1, eval_static_operation_cases (Ocast8signed) (I n1 :: nil) + | eval_static_operation_case5: forall n1, eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil) + | eval_static_operation_case6: forall n1, eval_static_operation_cases (Ocast16signed) (I n1 :: nil) + | eval_static_operation_case7: forall n1, eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil) + | eval_static_operation_case8: forall n1, eval_static_operation_cases (Oneg) (I n1 :: nil) + | eval_static_operation_case9: forall n1 n2, eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil) + | eval_static_operation_case10: forall s1 n1 n2, eval_static_operation_cases (Osub) (G s1 n1 :: I n2 :: nil) + | eval_static_operation_case11: forall n1 n2, eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil) + | eval_static_operation_case12: forall n n1, eval_static_operation_cases (Omulimm n) (I n1 :: nil) + | eval_static_operation_case13: forall n1 n2, eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil) + | eval_static_operation_case14: forall n1 n2, eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil) + | eval_static_operation_case15: forall n1 n2, eval_static_operation_cases (Omod) (I n1 :: I n2 :: nil) + | eval_static_operation_case16: forall n1 n2, eval_static_operation_cases (Omodu) (I n1 :: I n2 :: nil) + | eval_static_operation_case17: forall n1 n2, eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil) + | eval_static_operation_case18: forall n n1, eval_static_operation_cases (Oandimm n) (I n1 :: nil) + | eval_static_operation_case19: forall n1 n2, eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil) + | eval_static_operation_case20: forall n n1, eval_static_operation_cases (Oorimm n) (I n1 :: nil) + | eval_static_operation_case21: forall n1 n2, eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil) + | eval_static_operation_case22: forall n n1, eval_static_operation_cases (Oxorimm n) (I n1 :: nil) + | eval_static_operation_case23: forall n1 n2, eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil) + | eval_static_operation_case24: forall n n1, eval_static_operation_cases (Oshlimm n) (I n1 :: nil) + | eval_static_operation_case25: forall n1 n2, eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil) + | eval_static_operation_case26: forall n n1, eval_static_operation_cases (Oshrimm n) (I n1 :: nil) + | eval_static_operation_case27: forall n n1, eval_static_operation_cases (Oshrximm n) (I n1 :: nil) + | eval_static_operation_case28: forall n1 n2, eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil) + | eval_static_operation_case29: forall n n1, eval_static_operation_cases (Oshruimm n) (I n1 :: nil) + | eval_static_operation_case30: forall n n1, eval_static_operation_cases (Ororimm n) (I n1 :: nil) + | eval_static_operation_case31: forall mode vl, eval_static_operation_cases (Olea mode) (vl) + | eval_static_operation_case32: forall n1, eval_static_operation_cases (Onegf) (F n1 :: nil) + | eval_static_operation_case33: forall n1, eval_static_operation_cases (Oabsf) (F n1 :: nil) + | eval_static_operation_case34: forall n1 n2, eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil) + | eval_static_operation_case35: forall n1 n2, eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil) + | eval_static_operation_case36: forall n1 n2, eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil) + | eval_static_operation_case37: forall n1 n2, eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil) + | eval_static_operation_case38: forall n1, eval_static_operation_cases (Osingleoffloat) (F n1 :: nil) + | eval_static_operation_case39: forall n1, eval_static_operation_cases (Ointoffloat) (F n1 :: nil) + | eval_static_operation_case40: forall n1, eval_static_operation_cases (Ofloatofint) (I n1 :: nil) + | eval_static_operation_case41: forall c vl, eval_static_operation_cases (Ocmp c) (vl) + | eval_static_operation_default: forall (op: operation) (vl: list approx), eval_static_operation_cases op vl. Definition eval_static_operation_match (op: operation) (vl: list approx) := - match op as z1, vl as z2 return eval_static_operation_cases z1 z2 with - | Omove, v1::nil => - eval_static_operation_case1 v1 - | Ointconst n, nil => - eval_static_operation_case2 n - | Ofloatconst n, nil => - eval_static_operation_case3 n - | Ocast8signed, I n1 :: nil => - eval_static_operation_case4 n1 - | Ocast8unsigned, I n1 :: nil => - eval_static_operation_case5 n1 - | Ocast16signed, I n1 :: nil => - eval_static_operation_case6 n1 - | Ocast16unsigned, I n1 :: nil => - eval_static_operation_case7 n1 - | Oneg, I n1 :: nil => - eval_static_operation_case8 n1 - | Osub, I n1 :: I n2 :: nil => - eval_static_operation_case9 n1 n2 - | Osub, S s1 n1 :: I n2 :: nil => - eval_static_operation_case10 s1 n1 n2 - | Omul, I n1 :: I n2 :: nil => - eval_static_operation_case11 n1 n2 - | Omulimm n, I n1 :: nil => - eval_static_operation_case12 n n1 - | Odiv, I n1 :: I n2 :: nil => - eval_static_operation_case13 n1 n2 - | Odivu, I n1 :: I n2 :: nil => - eval_static_operation_case14 n1 n2 - | Omod, I n1 :: I n2 :: nil => - eval_static_operation_case15 n1 n2 - | Omodu, I n1 :: I n2 :: nil => - eval_static_operation_case16 n1 n2 - | Oand, I n1 :: I n2 :: nil => - eval_static_operation_case17 n1 n2 - | Oandimm n, I n1 :: nil => - eval_static_operation_case18 n n1 - | Oor, I n1 :: I n2 :: nil => - eval_static_operation_case19 n1 n2 - | Oorimm n, I n1 :: nil => - eval_static_operation_case20 n n1 - | Oxor, I n1 :: I n2 :: nil => - eval_static_operation_case21 n1 n2 - | Oxorimm n, I n1 :: nil => - eval_static_operation_case22 n n1 - | Oshl, I n1 :: I n2 :: nil => - eval_static_operation_case23 n1 n2 - | Oshlimm n, I n1 :: nil => - eval_static_operation_case24 n n1 - | Oshr, I n1 :: I n2 :: nil => - eval_static_operation_case25 n1 n2 - | Oshrimm n, I n1 :: nil => - eval_static_operation_case26 n n1 - | Oshrximm n, I n1 :: nil => - eval_static_operation_case27 n n1 - | Oshru, I n1 :: I n2 :: nil => - eval_static_operation_case28 n1 n2 - | Oshruimm n, I n1 :: nil => - eval_static_operation_case29 n n1 - | Ororimm n, I n1 :: nil => - eval_static_operation_case30 n n1 - | Olea mode, vl => - eval_static_operation_case31 mode vl - | Onegf, F n1 :: nil => - eval_static_operation_case32 n1 - | Oabsf, F n1 :: nil => - eval_static_operation_case33 n1 - | Oaddf, F n1 :: F n2 :: nil => - eval_static_operation_case34 n1 n2 - | Osubf, F n1 :: F n2 :: nil => - eval_static_operation_case35 n1 n2 - | Omulf, F n1 :: F n2 :: nil => - eval_static_operation_case36 n1 n2 - | Odivf, F n1 :: F n2 :: nil => - eval_static_operation_case37 n1 n2 - | Osingleoffloat, F n1 :: nil => - eval_static_operation_case38 n1 - | Ointoffloat, F n1 :: nil => - eval_static_operation_case39 n1 - | Ofloatofint, I n1 :: nil => - eval_static_operation_case41 n1 - | Ocmp c, vl => - eval_static_operation_case43 c vl - | op, vl => - eval_static_operation_default op vl + match op as zz1, vl as zz2 return eval_static_operation_cases zz1 zz2 with + | Omove, v1::nil => eval_static_operation_case1 v1 + | Ointconst n, nil => eval_static_operation_case2 n + | Ofloatconst n, nil => eval_static_operation_case3 n + | Ocast8signed, I n1 :: nil => eval_static_operation_case4 n1 + | Ocast8unsigned, I n1 :: nil => eval_static_operation_case5 n1 + | Ocast16signed, I n1 :: nil => eval_static_operation_case6 n1 + | Ocast16unsigned, I n1 :: nil => eval_static_operation_case7 n1 + | Oneg, I n1 :: nil => eval_static_operation_case8 n1 + | Osub, I n1 :: I n2 :: nil => eval_static_operation_case9 n1 n2 + | Osub, G s1 n1 :: I n2 :: nil => eval_static_operation_case10 s1 n1 n2 + | Omul, I n1 :: I n2 :: nil => eval_static_operation_case11 n1 n2 + | Omulimm n, I n1 :: nil => eval_static_operation_case12 n n1 + | Odiv, I n1 :: I n2 :: nil => eval_static_operation_case13 n1 n2 + | Odivu, I n1 :: I n2 :: nil => eval_static_operation_case14 n1 n2 + | Omod, I n1 :: I n2 :: nil => eval_static_operation_case15 n1 n2 + | Omodu, I n1 :: I n2 :: nil => eval_static_operation_case16 n1 n2 + | Oand, I n1 :: I n2 :: nil => eval_static_operation_case17 n1 n2 + | Oandimm n, I n1 :: nil => eval_static_operation_case18 n n1 + | Oor, I n1 :: I n2 :: nil => eval_static_operation_case19 n1 n2 + | Oorimm n, I n1 :: nil => eval_static_operation_case20 n n1 + | Oxor, I n1 :: I n2 :: nil => eval_static_operation_case21 n1 n2 + | Oxorimm n, I n1 :: nil => eval_static_operation_case22 n n1 + | Oshl, I n1 :: I n2 :: nil => eval_static_operation_case23 n1 n2 + | Oshlimm n, I n1 :: nil => eval_static_operation_case24 n n1 + | Oshr, I n1 :: I n2 :: nil => eval_static_operation_case25 n1 n2 + | Oshrimm n, I n1 :: nil => eval_static_operation_case26 n n1 + | Oshrximm n, I n1 :: nil => eval_static_operation_case27 n n1 + | Oshru, I n1 :: I n2 :: nil => eval_static_operation_case28 n1 n2 + | Oshruimm n, I n1 :: nil => eval_static_operation_case29 n n1 + | Ororimm n, I n1 :: nil => eval_static_operation_case30 n n1 + | Olea mode, vl => eval_static_operation_case31 mode vl + | Onegf, F n1 :: nil => eval_static_operation_case32 n1 + | Oabsf, F n1 :: nil => eval_static_operation_case33 n1 + | Oaddf, F n1 :: F n2 :: nil => eval_static_operation_case34 n1 n2 + | Osubf, F n1 :: F n2 :: nil => eval_static_operation_case35 n1 n2 + | Omulf, F n1 :: F n2 :: nil => eval_static_operation_case36 n1 n2 + | Odivf, F n1 :: F n2 :: nil => eval_static_operation_case37 n1 n2 + | Osingleoffloat, F n1 :: nil => eval_static_operation_case38 n1 + | Ointoffloat, F n1 :: nil => eval_static_operation_case39 n1 + | Ofloatofint, I n1 :: nil => eval_static_operation_case40 n1 + | Ocmp c, vl => eval_static_operation_case41 c vl + | op, vl => eval_static_operation_default op vl end. Definition eval_static_operation (op: operation) (vl: list approx) := match eval_static_operation_match op vl with - | eval_static_operation_case1 v1 => + | eval_static_operation_case1 v1 => (* Omove, v1::nil *) v1 - | eval_static_operation_case2 n => + | eval_static_operation_case2 n => (* Ointconst n, nil *) I n - | eval_static_operation_case3 n => + | eval_static_operation_case3 n => (* Ofloatconst n, nil *) F n - | eval_static_operation_case4 n1 => + | eval_static_operation_case4 n1 => (* Ocast8signed, I n1 :: nil *) I(Int.sign_ext 8 n1) - | eval_static_operation_case5 n1 => + | eval_static_operation_case5 n1 => (* Ocast8unsigned, I n1 :: nil *) I(Int.zero_ext 8 n1) - | eval_static_operation_case6 n1 => + | eval_static_operation_case6 n1 => (* Ocast16signed, I n1 :: nil *) I(Int.sign_ext 16 n1) - | eval_static_operation_case7 n1 => + | eval_static_operation_case7 n1 => (* Ocast16unsigned, I n1 :: nil *) I(Int.zero_ext 16 n1) - | eval_static_operation_case8 n1 => + | eval_static_operation_case8 n1 => (* Oneg, I n1 :: nil *) I(Int.neg n1) - | eval_static_operation_case9 n1 n2 => + | eval_static_operation_case9 n1 n2 => (* Osub, I n1 :: I n2 :: nil *) I(Int.sub n1 n2) - | eval_static_operation_case10 s1 n1 n2 => - S s1 (Int.sub n1 n2) - | eval_static_operation_case11 n1 n2 => + | eval_static_operation_case10 s1 n1 n2 => (* Osub, G s1 n1 :: I n2 :: nil *) + G s1 (Int.sub n1 n2) + | eval_static_operation_case11 n1 n2 => (* Omul, I n1 :: I n2 :: nil *) I(Int.mul n1 n2) - | eval_static_operation_case12 n n1 => + | eval_static_operation_case12 n n1 => (* Omulimm n, I n1 :: nil *) I(Int.mul n1 n) - | eval_static_operation_case13 n1 n2 => + | eval_static_operation_case13 n1 n2 => (* Odiv, I n1 :: I n2 :: nil *) if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) - | eval_static_operation_case14 n1 n2 => + | eval_static_operation_case14 n1 n2 => (* Odivu, I n1 :: I n2 :: nil *) if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) - | eval_static_operation_case15 n1 n2 => + | eval_static_operation_case15 n1 n2 => (* Omod, I n1 :: I n2 :: nil *) if Int.eq n2 Int.zero then Unknown else I(Int.mods n1 n2) - | eval_static_operation_case16 n1 n2 => + | eval_static_operation_case16 n1 n2 => (* Omodu, I n1 :: I n2 :: nil *) if Int.eq n2 Int.zero then Unknown else I(Int.modu n1 n2) - | eval_static_operation_case17 n1 n2 => + | eval_static_operation_case17 n1 n2 => (* Oand, I n1 :: I n2 :: nil *) I(Int.and n1 n2) - | eval_static_operation_case18 n n1 => + | eval_static_operation_case18 n n1 => (* Oandimm n, I n1 :: nil *) I(Int.and n1 n) - | eval_static_operation_case19 n1 n2 => + | eval_static_operation_case19 n1 n2 => (* Oor, I n1 :: I n2 :: nil *) I(Int.or n1 n2) - | eval_static_operation_case20 n n1 => + | eval_static_operation_case20 n n1 => (* Oorimm n, I n1 :: nil *) I(Int.or n1 n) - | eval_static_operation_case21 n1 n2 => + | eval_static_operation_case21 n1 n2 => (* Oxor, I n1 :: I n2 :: nil *) I(Int.xor n1 n2) - | eval_static_operation_case22 n n1 => + | eval_static_operation_case22 n n1 => (* Oxorimm n, I n1 :: nil *) I(Int.xor n1 n) - | eval_static_operation_case23 n1 n2 => + | eval_static_operation_case23 n1 n2 => (* Oshl, I n1 :: I n2 :: nil *) if Int.ltu n2 Int.iwordsize then I(Int.shl n1 n2) else Unknown - | eval_static_operation_case24 n n1 => + | eval_static_operation_case24 n n1 => (* Oshlimm n, I n1 :: nil *) if Int.ltu n Int.iwordsize then I(Int.shl n1 n) else Unknown - | eval_static_operation_case25 n1 n2 => + | eval_static_operation_case25 n1 n2 => (* Oshr, I n1 :: I n2 :: nil *) if Int.ltu n2 Int.iwordsize then I(Int.shr n1 n2) else Unknown - | eval_static_operation_case26 n n1 => + | eval_static_operation_case26 n n1 => (* Oshrimm n, I n1 :: nil *) if Int.ltu n Int.iwordsize then I(Int.shr n1 n) else Unknown - | eval_static_operation_case27 n n1 => + | eval_static_operation_case27 n n1 => (* Oshrximm n, I n1 :: nil *) if Int.ltu n (Int.repr 31) then I(Int.shrx n1 n) else Unknown - | eval_static_operation_case28 n1 n2 => + | eval_static_operation_case28 n1 n2 => (* Oshru, I n1 :: I n2 :: nil *) if Int.ltu n2 Int.iwordsize then I(Int.shru n1 n2) else Unknown - | eval_static_operation_case29 n n1 => + | eval_static_operation_case29 n n1 => (* Oshruimm n, I n1 :: nil *) if Int.ltu n Int.iwordsize then I(Int.shru n1 n) else Unknown - | eval_static_operation_case30 n n1 => + | eval_static_operation_case30 n n1 => (* Ororimm n, I n1 :: nil *) if Int.ltu n Int.iwordsize then I(Int.ror n1 n) else Unknown - | eval_static_operation_case31 mode vl => + | eval_static_operation_case31 mode vl => (* Olea mode, vl *) eval_static_addressing mode vl - | eval_static_operation_case32 n1 => + | eval_static_operation_case32 n1 => (* Onegf, F n1 :: nil *) F(Float.neg n1) - | eval_static_operation_case33 n1 => + | eval_static_operation_case33 n1 => (* Oabsf, F n1 :: nil *) F(Float.abs n1) - | eval_static_operation_case34 n1 n2 => + | eval_static_operation_case34 n1 n2 => (* Oaddf, F n1 :: F n2 :: nil *) F(Float.add n1 n2) - | eval_static_operation_case35 n1 n2 => + | eval_static_operation_case35 n1 n2 => (* Osubf, F n1 :: F n2 :: nil *) F(Float.sub n1 n2) - | eval_static_operation_case36 n1 n2 => + | eval_static_operation_case36 n1 n2 => (* Omulf, F n1 :: F n2 :: nil *) F(Float.mul n1 n2) - | eval_static_operation_case37 n1 n2 => + | eval_static_operation_case37 n1 n2 => (* Odivf, F n1 :: F n2 :: nil *) F(Float.div n1 n2) - | eval_static_operation_case38 n1 => + | eval_static_operation_case38 n1 => (* Osingleoffloat, F n1 :: nil *) F(Float.singleoffloat n1) - | eval_static_operation_case39 n1 => - match Float.intoffloat n1 with Some x => I x | None => Unknown end - | eval_static_operation_case41 n1 => + | eval_static_operation_case39 n1 => (* Ointoffloat, F n1 :: nil *) + eval_static_intoffloat n1 + | eval_static_operation_case40 n1 => (* Ofloatofint, I n1 :: nil *) F(Float.floatofint n1) - | eval_static_operation_case43 c vl => - match eval_static_condition c vl with - | None => Unknown - | Some b => I(if b then Int.one else Int.zero) - end + | eval_static_operation_case41 c vl => (* Ocmp c, vl *) + eval_static_condition_val c vl | eval_static_operation_default op vl => Unknown end. + (** * Operator strength reduction *) (** We now define auxiliary functions for strength reduction of @@ -613,146 +465,178 @@ Section STRENGTH_REDUCTION. Variable app: reg -> approx. -Definition intval (r: reg) : option int := - match app r with I n => Some n | _ => None end. - -Inductive cond_strength_reduction_cases: condition -> list reg -> Type := - | csr_case1: - forall c r1 r2, - cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) - | csr_case2: - forall c r1 r2, - cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) - | csr_default: - forall c rl, - cond_strength_reduction_cases c rl. - -Definition cond_strength_reduction_match (cond: condition) (rl: list reg) := - match cond as x, rl as y return cond_strength_reduction_cases x y with - | Ccomp c, r1 :: r2 :: nil => - csr_case1 c r1 r2 - | Ccompu c, r1 :: r2 :: nil => - csr_case2 c r1 r2 - | cond, rl => - csr_default cond rl +(** Original definition: +<< +Nondetfunction cond_strength_reduction + (cond: condition) (args: list reg) (vl: list approx) := + match cond, args, vl with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompimm c n2, r1 :: nil) + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompuimm c n2, r1 :: nil) + | _, _, _ => + (cond, args) + end. +>> +*) + +Inductive cond_strength_reduction_cases: forall (cond: condition) (args: list reg) (vl: list approx), Type := + | cond_strength_reduction_case1: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | cond_strength_reduction_case2: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_case3: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | cond_strength_reduction_case4: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_default: forall (cond: condition) (args: list reg) (vl: list approx), cond_strength_reduction_cases cond args vl. + +Definition cond_strength_reduction_match (cond: condition) (args: list reg) (vl: list approx) := + match cond as zz1, args as zz2, vl as zz3 return cond_strength_reduction_cases zz1 zz2 zz3 with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case1 c r1 r2 n1 v2 + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case2 c r1 r2 v1 n2 + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case3 c r1 r2 n1 v2 + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case4 c r1 r2 v1 n2 + | cond, args, vl => cond_strength_reduction_default cond args vl end. -Definition cond_strength_reduction - (cond: condition) (args: list reg) : condition * list reg := - match cond_strength_reduction_match cond args with - | csr_case1 c r1 r2 => - match intval r1, intval r2 with - | Some n, _ => - (Ccompimm (swap_comparison c) n, r2 :: nil) - | _, Some n => - (Ccompimm c n, r1 :: nil) - | _, _ => - (cond, args) - end - | csr_case2 c r1 r2 => - match intval r1, intval r2 with - | Some n, _ => - (Ccompuimm (swap_comparison c) n, r2 :: nil) - | _, Some n => - (Ccompuimm c n, r1 :: nil) - | _, _ => - (cond, args) - end - | csr_default cond args => +Definition cond_strength_reduction (cond: condition) (args: list reg) (vl: list approx) := + match cond_strength_reduction_match cond args vl with + | cond_strength_reduction_case1 c r1 r2 n1 v2 => (* Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case2 c r1 r2 v1 n2 => (* Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompimm c n2, r1 :: nil) + | cond_strength_reduction_case3 c r1 r2 n1 v2 => (* Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case4 c r1 r2 v1 n2 => (* Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompuimm c n2, r1 :: nil) + | cond_strength_reduction_default cond args vl => (cond, args) end. -(* -Definition addr_strength_reduction (addr: addressing) (args: list reg) := - match addr, args with - | Aindexed ofs, r1 :: nil => (* Aindexed *) - | Aindexed2 ofs, r1 :: r2 :: nil => (* Aindexed2 *) - | Aindexed2scaled sc ofs, r1 :: r2 :: nil => (* Aindexed2scaled *) - | Abased id ofs, r1 :: nil => (* Abased *) - | Abasedscaled sc id ofs, r1 :: nil => (* Abasedscaled *) - | _, _ => (* default *) + +(** Original definition: +<< +Nondetfunction addr_strength_reduction + (addr: addressing) (args: list reg) (vl: list approx) := + match addr, args, vl with + + | Aindexed ofs, r1 :: nil, G symb n :: nil => + (Aglobal symb (Int.add n ofs), nil) + | Aindexed ofs, r1 :: nil, S n :: nil => + (Ainstack (Int.add n ofs), nil) + + | Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil => + (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: G symb n2 :: nil => + (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, S n1 :: I n2 :: nil => + (Ainstack (Int.add (Int.add n1 n2) ofs), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: S n2 :: nil => + (Ainstack (Int.add (Int.add n1 n2) ofs), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil => + (Abased symb (Int.add n1 ofs), r2 :: nil) + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: G symb n2 :: nil => + (Abased symb (Int.add n2 ofs), r1 :: nil) + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Aindexed (Int.add n1 ofs), r2 :: nil) + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Aindexed (Int.add n2 ofs), r1 :: nil) + + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil => + (Aglobal symb (Int.add (Int.add n1 (Int.mul n2 sc)) ofs), nil) + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil => + (Abasedscaled sc symb (Int.add n1 ofs), r2 :: nil) + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Aindexed (Int.add (Int.mul n2 sc) ofs), r1 :: nil) + + | Abased id ofs, r1 :: nil, I n1 :: nil => + (Aglobal id (Int.add ofs n1), nil) + + | Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil => + (Aglobal id (Int.add ofs (Int.mul sc n1)), nil) + + | _, _ => + (addr, args) end. +>> *) -Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg), Type := - | addr_strength_reduction_case1: - forall ofs r1, - addr_strength_reduction_cases (Aindexed ofs) (r1 :: nil) - | addr_strength_reduction_case2: - forall ofs r1 r2, - addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) - | addr_strength_reduction_case3: - forall sc ofs r1 r2, - addr_strength_reduction_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) - | addr_strength_reduction_case4: - forall id ofs r1, - addr_strength_reduction_cases (Abased id ofs) (r1 :: nil) - | addr_strength_reduction_case5: - forall sc id ofs r1, - addr_strength_reduction_cases (Abasedscaled sc id ofs) (r1 :: nil) - | addr_strength_reduction_default: - forall (addr: addressing) (args: list reg), - addr_strength_reduction_cases addr args. - -Definition addr_strength_reduction_match (addr: addressing) (args: list reg) := - match addr as z1, args as z2 return addr_strength_reduction_cases z1 z2 with - | Aindexed ofs, r1 :: nil => - addr_strength_reduction_case1 ofs r1 - | Aindexed2 ofs, r1 :: r2 :: nil => - addr_strength_reduction_case2 ofs r1 r2 - | Aindexed2scaled sc ofs, r1 :: r2 :: nil => - addr_strength_reduction_case3 sc ofs r1 r2 - | Abased id ofs, r1 :: nil => - addr_strength_reduction_case4 id ofs r1 - | Abasedscaled sc id ofs, r1 :: nil => - addr_strength_reduction_case5 sc id ofs r1 - | addr, args => - addr_strength_reduction_default addr args +Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg) (vl: list approx), Type := + | addr_strength_reduction_case1: forall ofs r1 symb n, addr_strength_reduction_cases (Aindexed ofs) (r1 :: nil) (G symb n :: nil) + | addr_strength_reduction_case2: forall ofs r1 n, addr_strength_reduction_cases (Aindexed ofs) (r1 :: nil) (S n :: nil) + | addr_strength_reduction_case3: forall ofs r1 r2 symb n1 n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (G symb n1 :: I n2 :: nil) + | addr_strength_reduction_case4: forall ofs r1 r2 n1 symb n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (I n1 :: G symb n2 :: nil) + | addr_strength_reduction_case5: forall ofs r1 r2 n1 n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (S n1 :: I n2 :: nil) + | addr_strength_reduction_case6: forall ofs r1 r2 n1 n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (I n1 :: S n2 :: nil) + | addr_strength_reduction_case7: forall ofs r1 r2 symb n1 v2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (G symb n1 :: v2 :: nil) + | addr_strength_reduction_case8: forall ofs r1 r2 v1 symb n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (v1 :: G symb n2 :: nil) + | addr_strength_reduction_case9: forall ofs r1 r2 n1 v2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | addr_strength_reduction_case10: forall ofs r1 r2 v1 n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | addr_strength_reduction_case11: forall sc ofs r1 r2 symb n1 n2, addr_strength_reduction_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (G symb n1 :: I n2 :: nil) + | addr_strength_reduction_case12: forall sc ofs r1 r2 symb n1 v2, addr_strength_reduction_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (G symb n1 :: v2 :: nil) + | addr_strength_reduction_case13: forall sc ofs r1 r2 v1 n2, addr_strength_reduction_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | addr_strength_reduction_case14: forall id ofs r1 n1, addr_strength_reduction_cases (Abased id ofs) (r1 :: nil) (I n1 :: nil) + | addr_strength_reduction_case15: forall sc id ofs r1 n1, addr_strength_reduction_cases (Abasedscaled sc id ofs) (r1 :: nil) (I n1 :: nil) + | addr_strength_reduction_default: forall (addr: addressing) (args: list reg) (vl: list approx), addr_strength_reduction_cases addr args vl. + +Definition addr_strength_reduction_match (addr: addressing) (args: list reg) (vl: list approx) := + match addr as zz1, args as zz2, vl as zz3 return addr_strength_reduction_cases zz1 zz2 zz3 with + | Aindexed ofs, r1 :: nil, G symb n :: nil => addr_strength_reduction_case1 ofs r1 symb n + | Aindexed ofs, r1 :: nil, S n :: nil => addr_strength_reduction_case2 ofs r1 n + | Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil => addr_strength_reduction_case3 ofs r1 r2 symb n1 n2 + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: G symb n2 :: nil => addr_strength_reduction_case4 ofs r1 r2 n1 symb n2 + | Aindexed2 ofs, r1 :: r2 :: nil, S n1 :: I n2 :: nil => addr_strength_reduction_case5 ofs r1 r2 n1 n2 + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: S n2 :: nil => addr_strength_reduction_case6 ofs r1 r2 n1 n2 + | Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil => addr_strength_reduction_case7 ofs r1 r2 symb n1 v2 + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: G symb n2 :: nil => addr_strength_reduction_case8 ofs r1 r2 v1 symb n2 + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => addr_strength_reduction_case9 ofs r1 r2 n1 v2 + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => addr_strength_reduction_case10 ofs r1 r2 v1 n2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil => addr_strength_reduction_case11 sc ofs r1 r2 symb n1 n2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil => addr_strength_reduction_case12 sc ofs r1 r2 symb n1 v2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => addr_strength_reduction_case13 sc ofs r1 r2 v1 n2 + | Abased id ofs, r1 :: nil, I n1 :: nil => addr_strength_reduction_case14 id ofs r1 n1 + | Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil => addr_strength_reduction_case15 sc id ofs r1 n1 + | addr, args, vl => addr_strength_reduction_default addr args vl end. -Definition addr_strength_reduction (addr: addressing) (args: list reg) := - match addr_strength_reduction_match addr args with - | addr_strength_reduction_case1 ofs r1 => - (* Aindexed *) - match app r1 with - | S symb n => (Aglobal symb (Int.add ofs n), nil) - | _ => (addr, args) - end - | addr_strength_reduction_case2 ofs r1 r2 => - (* Aindexed2 *) - match app r1, app r2 with - | S symb n1, I n2 => (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) - | I n1, S symb n2 => (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) - | S symb n1, _ => (Abased symb (Int.add n1 ofs), r2 :: nil) - | _, S symb n2 => (Abased symb (Int.add n2 ofs), r1 :: nil) - | I n1, _ => (Aindexed (Int.add n1 ofs), r2 :: nil) - | _, I n2 => (Aindexed (Int.add n2 ofs), r1 :: nil) - | _, _ => (addr, args) - end - | addr_strength_reduction_case3 sc ofs r1 r2 => - (* Aindexed2scaled *) - match app r1, app r2 with - | S symb n1, I n2 => (Aglobal symb (Int.add (Int.add n1 (Int.mul n2 sc)) ofs), nil) - | S symb n1, _ => (Abasedscaled sc symb (Int.add n1 ofs), r2 :: nil) - | _, I n2 => (Aindexed (Int.add (Int.mul n2 sc) ofs), r1 :: nil) - | _, _ => (addr, args) - end - | addr_strength_reduction_case4 id ofs r1 => - (* Abased *) - match app r1 with - | I n1 => (Aglobal id (Int.add ofs n1), nil) - | _ => (addr, args) - end - | addr_strength_reduction_case5 sc id ofs r1 => - (* Abasedscaled *) - match app r1 with - | I n1 => (Aglobal id (Int.add ofs (Int.mul sc n1)), nil) - | _ => (addr, args) - end - | addr_strength_reduction_default addr args => +Definition addr_strength_reduction (addr: addressing) (args: list reg) (vl: list approx) := + match addr_strength_reduction_match addr args vl with + | addr_strength_reduction_case1 ofs r1 symb n => (* Aindexed ofs, r1 :: nil, G symb n :: nil *) + (Aglobal symb (Int.add n ofs), nil) + | addr_strength_reduction_case2 ofs r1 n => (* Aindexed ofs, r1 :: nil, S n :: nil *) + (Ainstack (Int.add n ofs), nil) + | addr_strength_reduction_case3 ofs r1 r2 symb n1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil *) + (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) + | addr_strength_reduction_case4 ofs r1 r2 n1 symb n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: G symb n2 :: nil *) + (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) + | addr_strength_reduction_case5 ofs r1 r2 n1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, S n1 :: I n2 :: nil *) + (Ainstack (Int.add (Int.add n1 n2) ofs), nil) + | addr_strength_reduction_case6 ofs r1 r2 n1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: S n2 :: nil *) + (Ainstack (Int.add (Int.add n1 n2) ofs), nil) + | addr_strength_reduction_case7 ofs r1 r2 symb n1 v2 => (* Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil *) + (Abased symb (Int.add n1 ofs), r2 :: nil) + | addr_strength_reduction_case8 ofs r1 r2 v1 symb n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, v1 :: G symb n2 :: nil *) + (Abased symb (Int.add n2 ofs), r1 :: nil) + | addr_strength_reduction_case9 ofs r1 r2 n1 v2 => (* Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Aindexed (Int.add n1 ofs), r2 :: nil) + | addr_strength_reduction_case10 ofs r1 r2 v1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Aindexed (Int.add n2 ofs), r1 :: nil) + | addr_strength_reduction_case11 sc ofs r1 r2 symb n1 n2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil *) + (Aglobal symb (Int.add (Int.add n1 (Int.mul n2 sc)) ofs), nil) + | addr_strength_reduction_case12 sc ofs r1 r2 symb n1 v2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil *) + (Abasedscaled sc symb (Int.add n1 ofs), r2 :: nil) + | addr_strength_reduction_case13 sc ofs r1 r2 v1 n2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Aindexed (Int.add (Int.mul n2 sc) ofs), r1 :: nil) + | addr_strength_reduction_case14 id ofs r1 n1 => (* Abased id ofs, r1 :: nil, I n1 :: nil *) + (Aglobal id (Int.add ofs n1), nil) + | addr_strength_reduction_case15 sc id ofs r1 n1 => (* Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil *) + (Aglobal id (Int.add ofs (Int.mul sc n1)), nil) + | addr_strength_reduction_default addr args vl => (addr, args) end. + Definition make_addimm (n: int) (r: reg) := if Int.eq n Int.zero then (Omove, r :: nil) @@ -800,211 +684,122 @@ Definition make_xorimm (n: int) (r: reg) := then (Omove, r :: nil) else (Oxorimm n, r :: nil). -(* -Definition op_strength_reduction (op: operation) (args: list reg) := - match op, args with - | Osub, r1 :: r2 :: nil => (* Osub *) - | Omul, r1 :: r2 :: nil => (* Omul *) - | Odiv, r1 :: r2 :: nil => (* Odiv *) - | Odivu, r1 :: r2 :: nil => (* Odivu *) - | Omodu, r1 :: r2 :: nil => (* Omodu *) - | Oand, r1 :: r2 :: nil => (* Oand *) - | Oor, r1 :: r2 :: nil => (* Oor *) - | Oxor, r1 :: r2 :: nil => (* Oxor *) - | Oshl, r1 :: r2 :: nil => (* Oshl *) - | Oshr, r1 :: r2 :: nil => (* Oshr *) - | Oshru, r1 :: r2 :: nil => (* Oshru *) - | Olea addr, args => (* Olea *) - | Ocmp c, args => (* Ocmp *) - | _, _ => (* default *) +Definition make_divimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => if Int.ltu l (Int.repr 31) + then (Oshrximm l, r1 :: nil) + else (Odiv, r1 :: r2 :: nil) + | None => (Odiv, r1 :: r2 :: nil) + end. + +Definition make_divuimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => make_shruimm l r1 + | None => (Odivu, r1 :: r2 :: nil) end. -*) -Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg), Type := - | op_strength_reduction_case2: - forall r1 r2, - op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) - | op_strength_reduction_case3: - forall r1 r2, - op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) - | op_strength_reduction_case4: - forall r1 r2, - op_strength_reduction_cases (Odiv) (r1 :: r2 :: nil) - | op_strength_reduction_case5: - forall r1 r2, - op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) - | op_strength_reduction_case7: - forall r1 r2, - op_strength_reduction_cases (Omodu) (r1 :: r2 :: nil) - | op_strength_reduction_case8: - forall r1 r2, - op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) - | op_strength_reduction_case9: - forall r1 r2, - op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) - | op_strength_reduction_case10: - forall r1 r2, - op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) - | op_strength_reduction_case11: - forall r1 r2, - op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) - | op_strength_reduction_case12: - forall r1 r2, - op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) - | op_strength_reduction_case13: - forall r1 r2, - op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) - | op_strength_reduction_case14: - forall addr args, - op_strength_reduction_cases (Olea addr) (args) - | op_strength_reduction_case15: - forall c args, - op_strength_reduction_cases (Ocmp c) (args) - | op_strength_reduction_default: - forall (op: operation) (args: list reg), - op_strength_reduction_cases op args. - -Definition op_strength_reduction_match (op: operation) (args: list reg) := - match op as z1, args as z2 return op_strength_reduction_cases z1 z2 with - | Osub, r1 :: r2 :: nil => - op_strength_reduction_case2 r1 r2 - | Omul, r1 :: r2 :: nil => - op_strength_reduction_case3 r1 r2 - | Odiv, r1 :: r2 :: nil => - op_strength_reduction_case4 r1 r2 - | Odivu, r1 :: r2 :: nil => - op_strength_reduction_case5 r1 r2 - | Omodu, r1 :: r2 :: nil => - op_strength_reduction_case7 r1 r2 - | Oand, r1 :: r2 :: nil => - op_strength_reduction_case8 r1 r2 - | Oor, r1 :: r2 :: nil => - op_strength_reduction_case9 r1 r2 - | Oxor, r1 :: r2 :: nil => - op_strength_reduction_case10 r1 r2 - | Oshl, r1 :: r2 :: nil => - op_strength_reduction_case11 r1 r2 - | Oshr, r1 :: r2 :: nil => - op_strength_reduction_case12 r1 r2 - | Oshru, r1 :: r2 :: nil => - op_strength_reduction_case13 r1 r2 - | Olea addr, args => - op_strength_reduction_case14 addr args - | Ocmp c, args => - op_strength_reduction_case15 c args - | op, args => - op_strength_reduction_default op args +Definition make_moduimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) + | None => (Omodu, r1 :: r2 :: nil) end. (** We must be careful to preserve 2-address constraints over the RTL code, which means that commutative operations cannot be specialized if their first argument is a constant. *) -Definition op_strength_reduction (op: operation) (args: list reg) := - match op_strength_reduction_match op args with - | op_strength_reduction_case2 r1 r2 => - (* Osub *) - match intval r2 with - | Some n => make_addimm (Int.neg n) r1 - | _ => (op, args) - end - | op_strength_reduction_case3 r1 r2 => - (* Omul *) - match intval r2 with - | Some n => make_mulimm n r1 - | _ => (op, args) - end - | op_strength_reduction_case4 r1 r2 => - (* Odiv *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => if Int.ltu l (Int.repr 31) - then (Oshrximm l, r1 :: nil) - else (op, args) - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case5 r1 r2 => - (* Odivu *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => make_shruimm l r1 - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case7 r1 r2 => - (* Omodu *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case8 r1 r2 => - (* Oand *) - match intval r2 with - | Some n => make_andimm n r1 - | _ => (op, args) - end - | op_strength_reduction_case9 r1 r2 => - (* Oor *) - match intval r2 with - | Some n => make_orimm n r1 - | _ => (op, args) - end - | op_strength_reduction_case10 r1 r2 => - (* Oxor *) - match intval r2 with - | Some n => make_xorimm n r1 - | _ => (op, args) - end - | op_strength_reduction_case11 r1 r2 => - (* Oshl *) - match intval r2 with - | Some n => - if Int.ltu n Int.iwordsize - then make_shlimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case12 r1 r2 => - (* Oshr *) - match intval r2 with - | Some n => - if Int.ltu n Int.iwordsize - then make_shrimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case13 r1 r2 => - (* Oshru *) - match intval r2 with - | Some n => - if Int.ltu n Int.iwordsize - then make_shruimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case14 addr args => - (* Olea *) - let (addr', args') := addr_strength_reduction addr args in +(** Original definition: +<< +Nondetfunction op_strength_reduction + (op: operation) (args: list reg) (vl: list approx) := + match op, args, vl with + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 + | Olea addr, args, vl => + let (addr', args') := addr_strength_reduction addr args vl in (Olea addr', args') - | op_strength_reduction_case15 c args => - (* Ocmp *) - let (c', args') := cond_strength_reduction c args in + | Ocmp c, args, vl => + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args') - | op_strength_reduction_default op args => - (* default *) + | _, _, _ => (op, args) + end. +>> +*) + +Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg) (vl: list approx), Type := + | op_strength_reduction_case1: forall r1 r2 v1 n2, op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case2: forall r1 r2 v1 n2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case3: forall r1 r2 v1 n2, op_strength_reduction_cases (Odiv) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case4: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case5: forall r1 r2 v1 n2, op_strength_reduction_cases (Omodu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case6: forall r1 r2 v1 n2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case7: forall r1 r2 v1 n2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case8: forall r1 r2 v1 n2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case9: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case10: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case11: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case12: forall addr args vl, op_strength_reduction_cases (Olea addr) (args) (vl) + | op_strength_reduction_case13: forall c args vl, op_strength_reduction_cases (Ocmp c) (args) (vl) + | op_strength_reduction_default: forall (op: operation) (args: list reg) (vl: list approx), op_strength_reduction_cases op args vl. + +Definition op_strength_reduction_match (op: operation) (args: list reg) (vl: list approx) := + match op as zz1, args as zz2, vl as zz3 return op_strength_reduction_cases zz1 zz2 zz3 with + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case1 r1 r2 v1 n2 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case2 r1 r2 v1 n2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case3 r1 r2 v1 n2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case4 r1 r2 v1 n2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case5 r1 r2 v1 n2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case6 r1 r2 v1 n2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case7 r1 r2 v1 n2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case8 r1 r2 v1 n2 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case9 r1 r2 v1 n2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case10 r1 r2 v1 n2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case11 r1 r2 v1 n2 + | Olea addr, args, vl => op_strength_reduction_case12 addr args vl + | Ocmp c, args, vl => op_strength_reduction_case13 c args vl + | op, args, vl => op_strength_reduction_default op args vl + end. + +Definition op_strength_reduction (op: operation) (args: list reg) (vl: list approx) := + match op_strength_reduction_match op args vl with + | op_strength_reduction_case1 r1 r2 v1 n2 => (* Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_addimm (Int.neg n2) r1 + | op_strength_reduction_case2 r1 r2 v1 n2 => (* Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_mulimm n2 r1 + | op_strength_reduction_case3 r1 r2 v1 n2 => (* Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_divimm n2 r1 r2 + | op_strength_reduction_case4 r1 r2 v1 n2 => (* Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_divuimm n2 r1 r2 + | op_strength_reduction_case5 r1 r2 v1 n2 => (* Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_moduimm n2 r1 r2 + | op_strength_reduction_case6 r1 r2 v1 n2 => (* Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_andimm n2 r1 + | op_strength_reduction_case7 r1 r2 v1 n2 => (* Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_orimm n2 r1 + | op_strength_reduction_case8 r1 r2 v1 n2 => (* Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_xorimm n2 r1 + | op_strength_reduction_case9 r1 r2 v1 n2 => (* Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shlimm n2 r1 + | op_strength_reduction_case10 r1 r2 v1 n2 => (* Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shrimm n2 r1 + | op_strength_reduction_case11 r1 r2 v1 n2 => (* Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shruimm n2 r1 + | op_strength_reduction_case12 addr args vl => (* Olea addr, args, vl *) + let (addr', args') := addr_strength_reduction addr args vl in (Olea addr', args') + | op_strength_reduction_case13 c args vl => (* Ocmp c, args, vl *) + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args') + | op_strength_reduction_default op args vl => (op, args) end. + End STRENGTH_REDUCTION. diff --git a/ia32/ConstpropOpproof.v b/ia32/ConstpropOpproof.v index 79e1537..afb284a 100644 --- a/ia32/ConstpropOpproof.v +++ b/ia32/ConstpropOpproof.v @@ -30,6 +30,7 @@ Require Import Constprop. Section ANALYSIS. Variable ge: genv. +Variable sp: val. (** We first show that the dataflow analysis is correct with respect to the dynamic semantics: the approximations (sets of values) @@ -43,7 +44,8 @@ Definition val_match_approx (a: approx) (v: val) : Prop := | Unknown => True | I p => v = Vint p | F p => v = Vfloat p - | S symb ofs => exists b, Genv.find_symbol ge symb = Some b /\ v = Vptr b ofs + | G symb ofs => v = symbol_address ge symb ofs + | S ofs => v = Val.add sp (Vint ofs) | _ => False end. @@ -62,12 +64,10 @@ Ltac SimplVMA := simpl in H; (try subst v); SimplVMA | H: (val_match_approx (F _) ?v) |- _ => simpl in H; (try subst v); SimplVMA - | H: (val_match_approx (S _ _) ?v) |- _ => - simpl in H; - (try (elim H; - let b := fresh "b" in let A := fresh in let B := fresh in - (intros b [A B]; subst v; clear H))); - SimplVMA + | H: (val_match_approx (G _ _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA + | H: (val_match_approx (S _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA | _ => idtac end. @@ -75,9 +75,9 @@ Ltac SimplVMA := Ltac InvVLMA := match goal with | H: (val_list_match_approx nil ?vl) |- _ => - inversion H + inv H | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ => - inversion H; SimplVMA; InvVLMA + inv H; SimplVMA; InvVLMA | _ => idtac end. @@ -99,28 +99,39 @@ Proof. InvVLMA; simpl; congruence. Qed. +Remark shift_symbol_address: + forall symb ofs n, + symbol_address ge symb (Int.add ofs n) = Val.add (symbol_address ge symb ofs) (Vint n). +Proof. + unfold symbol_address; intros. destruct (Genv.find_symbol ge symb); auto. +Qed. + Lemma eval_static_addressing_correct: - forall addr sp al vl v, + forall addr al vl v, val_list_match_approx al vl -> eval_addressing ge sp addr vl = Some v -> val_match_approx (eval_static_addressing addr al) v. Proof. intros until v. unfold eval_static_addressing. case (eval_static_addressing_match addr al); intros; - InvVLMA; simpl in *; FuncInv; try congruence. - inv H4. exists b0; auto. - inv H4. inv H14. exists b0; auto. - inv H4. inv H13. exists b0; auto. - inv H4. inv H14. exists b0; auto. - destruct (Genv.find_symbol ge id); inv H0. exists b; auto. - inv H4. destruct (Genv.find_symbol ge id); inv H0. exists b; auto. - inv H4. destruct (Genv.find_symbol ge id); inv H0. - exists b; split; auto. rewrite Int.mul_commut; auto. - auto. + InvVLMA; simpl in *; FuncInv; try subst v; auto. + rewrite shift_symbol_address; auto. + rewrite Val.add_assoc. auto. + repeat rewrite shift_symbol_address. auto. + fold (Val.add (Vint n1) (symbol_address ge id ofs)). + repeat rewrite shift_symbol_address. repeat rewrite Val.add_assoc. rewrite Val.add_permut. auto. + repeat rewrite Val.add_assoc. decEq; simpl. rewrite Int.add_assoc. auto. + fold (Val.add (Vint n1) (Val.add sp (Vint ofs))). + rewrite Val.add_assoc. rewrite Val.add_permut. rewrite Val.add_assoc. + simpl. rewrite Int.add_assoc; auto. + rewrite shift_symbol_address. auto. + rewrite Val.add_assoc. auto. + rewrite shift_symbol_address. auto. + rewrite shift_symbol_address. rewrite Int.mul_commut; auto. Qed. Lemma eval_static_operation_correct: - forall op sp al vl m v, + forall op al vl m v, val_list_match_approx al vl -> eval_operation ge sp op vl m = Some v -> val_match_approx (eval_static_operation op al) v. @@ -128,65 +139,29 @@ Proof. intros until v. unfold eval_static_operation. case (eval_static_operation_match op al); intros; - InvVLMA; simpl in *; FuncInv; try congruence. - - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - - exists b. split. auto. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - destruct (Int.ltu n Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. - - replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - destruct (Int.ltu n Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. - - destruct (Int.ltu n (Int.repr 31)). - injection H0; intro; subst v. simpl. congruence. discriminate. - - replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - destruct (Int.ltu n Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. - - destruct (Int.ltu n Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. - + InvVLMA; simpl in *; FuncInv; try subst v; auto. + + rewrite Int.sub_add_opp. rewrite shift_symbol_address. rewrite Val.sub_add_opp. auto. + destruct (Int.eq n2 Int.zero); inv H0; simpl; auto. + destruct (Int.eq n2 Int.zero); inv H0; simpl; auto. + destruct (Int.eq n2 Int.zero); inv H0; simpl; auto. + destruct (Int.eq n2 Int.zero); inv H0; simpl; auto. + destruct (Int.ltu n2 Int.iwordsize); simpl; auto. + destruct (Int.ltu n Int.iwordsize); simpl; auto. + destruct (Int.ltu n2 Int.iwordsize); simpl; auto. + destruct (Int.ltu n Int.iwordsize); simpl; auto. + destruct (Int.ltu n (Int.repr 31)); inv H0. simpl; auto. + destruct (Int.ltu n2 Int.iwordsize); simpl; auto. + destruct (Int.ltu n Int.iwordsize); simpl; auto. + destruct (Int.ltu n Int.iwordsize); simpl; auto. eapply eval_static_addressing_correct; eauto. - - rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence. - - inv H4. destruct (Float.intoffloat f); inv H0. red; auto. - - caseEq (eval_static_condition c vl0). - intros. generalize (eval_static_condition_correct _ _ _ m _ H H1). - intro. rewrite H2 in H0. - destruct b; injection H0; intro; subst v; simpl; auto. - intros; simpl; auto. - - auto. + unfold eval_static_intoffloat. + destruct (Float.intoffloat n1) as []_eqn; simpl in H0; inv H0. + simpl; auto. + unfold eval_static_condition_val. destruct (eval_static_condition c vl0) as [b|]_eqn. + rewrite (eval_static_condition_correct _ _ _ m _ H Heqo). + destruct b; simpl; auto. + simpl; auto. Qed. (** * Correctness of strength reduction *) @@ -199,299 +174,248 @@ Qed. Section STRENGTH_REDUCTION. -Variable app: reg -> approx. -Variable sp: val. +Variable app: D.t. Variable rs: regset. Variable m: mem. -Hypothesis MATCH: forall r, val_match_approx (app r) rs#r. +Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r. -Lemma intval_correct: - forall r n, - intval app r = Some n -> rs#r = Vint n. -Proof. - intros until n. - unfold intval. caseEq (app r); intros; try discriminate. - generalize (MATCH r). unfold val_match_approx. rewrite H. - congruence. -Qed. +Ltac InvApproxRegs := + match goal with + | [ H: _ :: _ = _ :: _ |- _ ] => + injection H; clear H; intros; InvApproxRegs + | [ H: ?v = approx_reg app ?r |- _ ] => + generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs + | _ => idtac + end. Lemma cond_strength_reduction_correct: - forall cond args, - let (cond', args') := cond_strength_reduction app cond args in + forall cond args vl, + vl = approx_regs app args -> + let (cond', args') := cond_strength_reduction cond args vl in eval_condition cond' rs##args' m = eval_condition cond rs##args m. Proof. - intros. unfold cond_strength_reduction. - case (cond_strength_reduction_match cond args); intros. - caseEq (intval app r1); intros. - simpl. rewrite (intval_correct _ _ H). - destruct (rs#r2); auto. rewrite Int.swap_cmp. auto. - 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. + intros until vl. unfold cond_strength_reduction. + case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVMA. + rewrite H0. apply Val.swap_cmp_bool. + rewrite H. auto. + rewrite H0. apply Val.swap_cmpu_bool. + rewrite H. auto. auto. Qed. -Ltac KnownApprox := - match goal with - | H: ?approx ?r = ?a |- _ => - generalize (MATCH r); rewrite H; intro; clear H; KnownApprox - | _ => idtac - end. - Lemma addr_strength_reduction_correct: - forall addr args, - let (addr', args') := addr_strength_reduction app addr args in + forall addr args vl, + vl = approx_regs app args -> + let (addr', args') := addr_strength_reduction addr args vl in eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args. Proof. - intros. - - unfold addr_strength_reduction. destruct (addr_strength_reduction_match addr args). - - generalize (MATCH r1); caseEq (app r1); intros; auto. - simpl in H0. destruct H0 as [b [A B]]. simpl. rewrite A; rewrite B. - rewrite Int.add_commut; auto. - - generalize (MATCH r1) (MATCH r2); caseEq (app r1); auto; caseEq (app r2); auto; - simpl val_match_approx; intros; try contradiction; simpl. - rewrite H2. destruct (rs#r1); auto. rewrite Int.add_assoc; auto. rewrite Int.add_assoc; auto. - destruct H2 as [b [A B]]. rewrite A; rewrite B. - destruct (rs#r1); auto. repeat rewrite Int.add_assoc. decEq. decEq. decEq. apply Int.add_commut. - rewrite H1. destruct (rs#r2); auto. - rewrite Int.add_assoc; auto. rewrite Int.add_permut. auto. - rewrite Int.add_assoc; auto. - rewrite H1; rewrite H2. rewrite Int.add_permut. rewrite Int.add_assoc. auto. - rewrite H1; rewrite H2. auto. - destruct H2 as [b [A B]]. rewrite A; rewrite B. rewrite H1. do 3 decEq. apply Int.add_commut. - rewrite H1; auto. - rewrite H1; auto. - destruct H1 as [b [A B]]. rewrite A; rewrite B. destruct (rs#r2); auto. - repeat rewrite Int.add_assoc. do 3 decEq. apply Int.add_commut. - destruct H1 as [b [A B]]. rewrite A; rewrite B; rewrite H2. auto. - rewrite H2. destruct (rs#r1); auto. - destruct H1 as [b [A B]]. destruct H2 as [b' [A' B']]. - rewrite A; rewrite B; rewrite B'. auto. - - generalize (MATCH r1) (MATCH r2); caseEq (app r1); auto; caseEq (app r2); auto; - simpl val_match_approx; intros; try contradiction; simpl. - rewrite H2. destruct (rs#r1); auto. - rewrite H1; rewrite H2. auto. - rewrite H1. auto. - destruct H1 as [b [A B]]. rewrite A; rewrite B. - destruct (rs#r2); auto. rewrite Int.add_assoc. do 3 decEq. apply Int.add_commut. - destruct H1 as [b [A B]]. rewrite A; rewrite B; rewrite H2. rewrite Int.add_assoc. auto. - rewrite H2. destruct (rs#r1); auto. - destruct H1 as [b [A B]]. destruct H2 as [b' [A' B']]. - rewrite A; rewrite B; rewrite B'. auto. - - generalize (MATCH r1); caseEq (app r1); auto; - simpl val_match_approx; intros; try contradiction; simpl. - rewrite H0. auto. - - generalize (MATCH r1); caseEq (app r1); auto; - simpl val_match_approx; intros; try contradiction; simpl. - rewrite H0. rewrite Int.mul_commut. auto. - + intros until vl. unfold addr_strength_reduction. + destruct (addr_strength_reduction_match addr args vl); simpl; intros; InvApproxRegs; SimplVMA. + rewrite shift_symbol_address; congruence. + rewrite H. rewrite Val.add_assoc; auto. + rewrite H; rewrite H0. repeat rewrite shift_symbol_address. auto. + rewrite H; rewrite H0. rewrite Int.add_assoc. rewrite Int.add_permut. repeat rewrite shift_symbol_address. + rewrite Val.add_assoc. rewrite Val.add_permut. auto. + rewrite H; rewrite H0. repeat rewrite Val.add_assoc. rewrite Int.add_assoc. auto. + rewrite H; rewrite H0. repeat rewrite Val.add_assoc. rewrite Val.add_permut. + rewrite Int.add_assoc. auto. + rewrite H0. rewrite shift_symbol_address. repeat rewrite Val.add_assoc. + decEq; decEq. apply Val.add_commut. + rewrite H. rewrite shift_symbol_address. repeat rewrite Val.add_assoc. + rewrite (Val.add_permut (rs#r1)). decEq; decEq. apply Val.add_commut. + rewrite H0. rewrite Val.add_assoc. rewrite Val.add_permut. auto. + rewrite H. rewrite Val.add_assoc. auto. + rewrite H; rewrite H0. rewrite Int.add_assoc. repeat rewrite shift_symbol_address. auto. + rewrite H0. rewrite shift_symbol_address. rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. + rewrite H. auto. + rewrite H. rewrite shift_symbol_address. auto. + rewrite H. rewrite shift_symbol_address. rewrite Int.mul_commut; auto. auto. Qed. +Lemma make_addimm_correct: + forall n r, + let (op, args) := make_addimm n r in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v. +Proof. + intros. unfold make_addimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto. + exists (Val.add rs#r (Vint n)); auto. +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) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1, + let (op, args) := make_shlimm n r1 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v. Proof. intros; unfold make_shlimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shl_zero in H. congruence. - simpl in *. auto. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto. + econstructor; split. simpl. eauto. auto. 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) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1, + let (op, args) := make_shrimm n r1 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v. Proof. intros; unfold make_shrimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shr_zero in H. congruence. - assumption. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto. + econstructor; split; eauto. simpl. auto. 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) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1, + let (op, args) := make_shruimm n r1 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v. Proof. intros; unfold make_shruimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shru_zero in H. congruence. - assumption. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto. + econstructor; split; eauto. simpl. congruence. 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) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1, + let (op, args) := make_mulimm n r1 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v. Proof. intros; unfold make_mulimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in H0. FuncInv. rewrite Int.mul_zero in H. simpl. congruence. - generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros. - subst n. simpl in H1. simpl. FuncInv. rewrite Int.mul_one in H0. congruence. - caseEq (Int.is_power2 n); intros. - replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil) m) - with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil) m). - apply make_shlimm_correct. - simpl. generalize (Int.is_power2_range _ _ H1). - change (Z_of_nat Int.wordsize) with 32. intro. rewrite H2. - destruct rs#r; auto. rewrite (Int.mul_pow2 i0 _ _ H1). auto. - exact H2. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto. + destruct (Int.is_power2 n) as []_eqn; intros. + rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). apply make_shlimm_correct; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_divimm_correct: + forall n r1 r2 v, + Val.divs rs#r1 rs#r2 = Some v -> + rs#r2 = Vint n -> + let (op, args) := make_divimm n r1 r2 in + exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divimm. + destruct (Int.is_power2 n) as []_eqn. + destruct (Int.ltu i (Int.repr 31)) as []_eqn. + exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divuimm_correct: + forall n r1 r2 v, + Val.divu rs#r1 rs#r2 = Some v -> + rs#r2 = Vint n -> + let (op, args) := make_divuimm n r1 r2 in + exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divuimm. + destruct (Int.is_power2 n) as []_eqn. + replace v with (Val.shru rs#r1 (Vint i)). + eapply make_shruimm_correct; eauto. + eapply Val.divu_pow2; eauto. congruence. + exists v; auto. +Qed. + +Lemma make_moduimm_correct: + forall n r1 r2 v, + Val.modu rs#r1 rs#r2 = Some v -> + rs#r2 = Vint n -> + let (op, args) := make_moduimm n r1 r2 in + exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_moduimm. + destruct (Int.is_power2 n) as []_eqn. + exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence. + exists v; auto. Qed. Lemma make_andimm_correct: - forall n r v, + forall n r, let (op, args) := make_andimm n r in - eval_operation ge sp Oand (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v. Proof. intros; unfold make_andimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.and_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. rewrite Int.and_mone in H0. congruence. - exact H1. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto. + econstructor; split; eauto. auto. Qed. Lemma make_orimm_correct: - forall n r v, + forall n r, let (op, args) := make_orimm n r in - eval_operation ge sp Oor (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v. Proof. intros; unfold make_orimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.or_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. rewrite Int.or_mone in H0. congruence. - exact H1. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto. + econstructor; split; eauto. auto. Qed. Lemma make_xorimm_correct: - forall n r v, + forall n r, let (op, args) := make_xorimm n r in - eval_operation ge sp Oxor (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v. Proof. intros; unfold make_xorimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.xor_zero in H. congruence. - exact H0. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto. + econstructor; split; eauto. auto. Qed. Lemma op_strength_reduction_correct: - forall op args v, - let (op', args') := op_strength_reduction app op args in + forall op args vl v, + vl = approx_regs app args -> eval_operation ge sp op rs##args m = Some v -> - eval_operation ge sp op' rs##args' m = Some v. + let (op', args') := op_strength_reduction op args vl in + exists w, eval_operation ge sp op' rs##args' m = Some w /\ Val.lessdef v w. Proof. - intros; unfold op_strength_reduction; - case (op_strength_reduction_match op args); intros; simpl List.map. - (* Osub *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). - unfold make_addimm. generalize (Int.eq_spec (Int.neg i) Int.zero). - destruct (Int.eq (Int.neg i) (Int.zero)); intros. - assert (i = Int.zero). rewrite <- (Int.neg_involutive i). rewrite H0. reflexivity. - subst i. simpl in *. destruct (rs#r1); inv H1; rewrite Int.sub_zero_l; auto. - simpl in *. destruct (rs#r1); inv H1; rewrite Int.sub_add_opp; auto. - auto. - (* Omul *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). apply make_mulimm_correct. - assumption. - (* Odiv *) - caseEq (intval app r2); intros. - caseEq (Int.is_power2 i); intros. - caseEq (Int.ltu i0 (Int.repr 31)); intros. - rewrite (intval_correct _ _ H) in H2. - simpl in *; FuncInv. destruct (Int.eq i Int.zero). congruence. - rewrite H1. rewrite (Int.divs_pow2 i1 _ _ H0) in H2. auto. - assumption. - assumption. - assumption. - (* Odivu *) - 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) 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). - generalize (Int.eq_spec i Int.zero); case (Int.eq i Int.zero); intros. - subst i. discriminate. - rewrite (Int.divu_pow2 i1 _ _ H0). auto. - assumption. - assumption. - (* Omodu *) - caseEq (intval app r2); intros. - caseEq (Int.is_power2 i); intros. - rewrite (intval_correct _ _ H) in H1. - simpl in *; FuncInv. destruct (Int.eq i Int.zero). congruence. - rewrite (Int.modu_and i1 _ _ H0) in H1. auto. - assumption. - assumption. - - (* Oand *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). apply make_andimm_correct. - assumption. - (* Oor *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). apply make_orimm_correct. - assumption. - (* Oxor *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). apply make_xorimm_correct. - assumption. - (* Oshl *) - caseEq (intval app r2); intros. - caseEq (Int.ltu i Int.iwordsize); intros. - rewrite (intval_correct _ _ H). apply make_shlimm_correct. - assumption. - assumption. - (* Oshr *) - caseEq (intval app r2); intros. - caseEq (Int.ltu i Int.iwordsize); intros. - rewrite (intval_correct _ _ H). apply make_shrimm_correct. - assumption. - assumption. - (* Oshru *) - caseEq (intval app r2); intros. - caseEq (Int.ltu i Int.iwordsize); intros. - rewrite (intval_correct _ _ H). apply make_shruimm_correct. - assumption. - assumption. - (* Olea *) - generalize (addr_strength_reduction_correct addr args0). - destruct (addr_strength_reduction app addr args0) as [addr' args']. - intros. simpl in *. congruence. - (* Ocmp *) - generalize (cond_strength_reduction_correct c args0). - destruct (cond_strength_reduction app c args0). - simpl. intro. rewrite H. auto. - (* default *) - assumption. + intros until v; unfold op_strength_reduction; + case (op_strength_reduction_match op args vl); simpl; intros. +(* sub *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. rewrite Val.sub_add_opp. apply make_addimm_correct; auto. +(* mul *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_mulimm_correct; auto. +(* divs *) + assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto. + apply make_divimm_correct; auto. +(* divu *) + assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto. + apply make_divuimm_correct; auto. +(* modu *) + assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto. + apply make_moduimm_correct; auto. +(* and *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_andimm_correct; auto. +(* or *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_orimm_correct; auto. +(* xor *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_xorimm_correct; auto. +(* shl *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shlimm_correct; auto. +(* shr *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shrimm_correct; auto. +(* shru *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shruimm_correct; auto. +(* lea *) + generalize (addr_strength_reduction_correct addr args0 vl0 H). + destruct (addr_strength_reduction addr args0 vl0) as [addr' args']. + intro EQ. exists v; split; auto. simpl. congruence. +(* cond *) + generalize (cond_strength_reduction_correct c args0 vl0 H). + destruct (cond_strength_reduction c args0 vl0) as [c' args']; intros. + rewrite <- H1 in H0; auto. econstructor; split; eauto. +(* default *) + exists v; auto. Qed. End STRENGTH_REDUCTION. @@ -114,6 +114,7 @@ Inductive operation : Type := (** Derived operators. *) Definition Oaddrsymbol (id: ident) (ofs: int) : operation := Olea (Aglobal id ofs). +Definition Oaddrstack (ofs: int) : operation := Olea (Ainstack ofs). Definition Oaddimm (n: int) : operation := Olea (Aindexed n). (** Comparison functions (used in module [CSE]). *) @@ -136,97 +137,52 @@ Proof. apply eq_addressing. Qed. -(** Evaluation of conditions, operators and addressing modes applied - to lists of values. Return [None] when the computation is undefined: - wrong number of arguments, arguments of the wrong types, undefined - operations such as division by zero. [eval_condition] returns a boolean, - [eval_operation] and [eval_addressing] return a value. *) +(** * Evaluation functions *) -Definition eval_compare_mismatch (c: comparison) : option bool := - match c with Ceq => Some false | Cne => Some true | _ => None end. +Definition symbol_address (F V: Type) (genv: Genv.t F V) (id: ident) (ofs: int) : val := + match Genv.find_symbol genv id with + | Some b => Vptr b ofs + | None => Vundef + end. -Definition eval_compare_null (c: comparison) (n: int) : option bool := - if Int.eq n Int.zero then eval_compare_mismatch c else None. +(** Evaluation of conditions, operators and addressing modes applied + to lists of values. Return [None] when the computation can trigger an + error, e.g. integer division by zero. [eval_condition] returns a boolean, + [eval_operation] and [eval_addressing] return a value. *) -Definition eval_condition (cond: condition) (vl: list val) (m: mem): - option bool := +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) - | 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) - | 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 => - Some (negb (Float.cmp c f1 f2)) - | Cmaskzero n, Vint n1 :: nil => - Some (Int.eq (Int.and n1 n) Int.zero) - | Cmasknotzero n, Vint n1 :: nil => - Some (negb (Int.eq (Int.and n1 n) Int.zero)) - | _, _ => - None - end. - -Definition offset_sp (sp: val) (delta: int) : option val := - match sp with - | Vptr b n => Some (Vptr b (Int.add n delta)) - | _ => None + | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 + | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 + | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n) + | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n) + | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2 + | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2) + | Cmaskzero n, Vint n1 :: nil => Some (Int.eq (Int.and n1 n) Int.zero) + | Cmasknotzero n, Vint n1 :: nil => Some (negb (Int.eq (Int.and n1 n) Int.zero)) + | _, _ => None end. Definition eval_addressing (F V: Type) (genv: Genv.t F V) (sp: val) (addr: addressing) (vl: list val) : option val := match addr, vl with - | Aindexed n, Vint n1 :: nil => - Some (Vint (Int.add n1 n)) - | Aindexed n, Vptr b1 n1 :: nil => - Some (Vptr b1 (Int.add n1 n)) - | Aindexed2 n, Vint n1 :: Vint n2 :: nil => - Some (Vint (Int.add (Int.add n1 n2) n)) - | Aindexed2 n, Vptr b1 n1 :: Vint n2 :: nil => - Some (Vptr b1 (Int.add (Int.add n1 n2) n)) - | Aindexed2 n, Vint n1 :: Vptr b2 n2 :: nil => - Some (Vptr b2 (Int.add (Int.add n2 n1) n)) - | Ascaled sc ofs, Vint n1 :: nil => - Some (Vint (Int.add (Int.mul n1 sc) ofs)) - | Aindexed2scaled sc ofs, Vint n1 :: Vint n2 :: nil => - Some (Vint (Int.add n1 (Int.add (Int.mul n2 sc) ofs))) - | Aindexed2scaled sc ofs, Vptr b1 n1 :: Vint n2 :: nil => - Some (Vptr b1 (Int.add n1 (Int.add (Int.mul n2 sc) ofs))) + | Aindexed n, v1::nil => + Some (Val.add v1 (Vint n)) + | Aindexed2 n, v1::v2::nil => + Some (Val.add (Val.add v1 v2) (Vint n)) + | Ascaled sc ofs, v1::nil => + Some (Val.add (Val.mul v1 (Vint sc)) (Vint ofs)) + | Aindexed2scaled sc ofs, v1::v2::nil => + Some(Val.add v1 (Val.add (Val.mul v2 (Vint sc)) (Vint ofs))) | Aglobal s ofs, nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b ofs) - end - | Abased s ofs, Vint n1 :: nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b (Int.add ofs n1)) - end - | Abasedscaled sc s ofs, Vint n1 :: nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b (Int.add ofs (Int.mul n1 sc))) - end + Some (symbol_address genv s ofs) + | Abased s ofs, v1::nil => + Some (Val.add (symbol_address genv s ofs) v1) + | Abasedscaled sc s ofs, v1::nil => + Some (Val.add (symbol_address genv s ofs) (Val.mul v1 (Vint sc))) | Ainstack ofs, nil => - offset_sp sp ofs + Some(Val.add sp (Vint ofs)) | _, _ => None end. @@ -241,78 +197,42 @@ Definition eval_operation | Ocast8unsigned, v1 :: nil => Some (Val.zero_ext 8 v1) | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) | Ocast16unsigned, v1 :: nil => Some (Val.zero_ext 16 v1) - | Oneg, Vint n1 :: nil => Some (Vint (Int.neg n1)) - | Osub, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub n1 n2)) - | Osub, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.sub n1 n2)) - | Osub, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if eq_block b1 b2 then Some (Vint (Int.sub n1 n2)) else None - | Omul, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.mul n1 n2)) - | Omulimm n, Vint n1 :: nil => Some (Vint (Int.mul n1 n)) - | Odiv, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divs n1 n2)) - | Odivu, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2)) - | Omod, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.mods n1 n2)) - | Omodu, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.modu n1 n2)) - | Oand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 n2)) - | Oandimm n, Vint n1 :: nil => Some (Vint (Int.and n1 n)) - | Oor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 n2)) - | Oorimm n, Vint n1 :: nil => Some (Vint (Int.or n1 n)) - | Oxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 n2)) - | Oxorimm n, Vint n1 :: nil => Some (Vint (Int.xor n1 n)) - | Oshl, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shl n1 n2)) else None - | Oshlimm n, Vint n1 :: nil => - if Int.ltu n Int.iwordsize then Some (Vint (Int.shl n1 n)) else None - | Oshr, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shr n1 n2)) else None - | Oshrimm n, Vint n1 :: nil => - if Int.ltu n Int.iwordsize then Some (Vint (Int.shr n1 n)) else None - | Oshrximm n, Vint n1 :: nil => - if Int.ltu n (Int.repr 31) then Some (Vint (Int.shrx n1 n)) else None - | Oshru, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shru n1 n2)) else None - | Oshruimm n, Vint n1 :: nil => - if Int.ltu n Int.iwordsize then Some (Vint (Int.shru n1 n)) else None - | Ororimm n, Vint n1 :: nil => - if Int.ltu n Int.iwordsize then Some (Vint (Int.ror n1 n)) else None - | Olea addr, _ => - eval_addressing genv sp addr vl - | Onegf, Vfloat f1 :: nil => Some (Vfloat (Float.neg f1)) - | Oabsf, Vfloat f1 :: nil => Some (Vfloat (Float.abs f1)) - | Oaddf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.add f1 f2)) - | Osubf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.sub f1 f2)) - | Omulf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.mul f1 f2)) - | Odivf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.div f1 f2)) - | Osingleoffloat, v1 :: nil => - Some (Val.singleoffloat v1) - | Ointoffloat, Vfloat f1 :: nil => - option_map Vint (Float.intoffloat f1) - | Ofloatofint, Vint n1 :: nil => - Some (Vfloat (Float.floatofint n1)) - | Ocmp c, _ => - match eval_condition c vl m with - | None => None - | Some false => Some Vfalse - | Some true => Some Vtrue - end + | Oneg, v1::nil => Some (Val.neg v1) + | Osub, v1::v2::nil => Some (Val.sub v1 v2) + | Omul, v1::v2::nil => Some (Val.mul v1 v2) + | Omulimm n, v1::nil => Some (Val.mul v1 (Vint n)) + | Odiv, v1::v2::nil => Val.divs v1 v2 + | Odivu, v1::v2::nil => Val.divu v1 v2 + | Omod, v1::v2::nil => Val.mods v1 v2 + | Omodu, v1::v2::nil => Val.modu v1 v2 + | Oand, v1::v2::nil => Some(Val.and v1 v2) + | Oandimm n, v1::nil => Some (Val.and v1 (Vint n)) + | Oor, v1::v2::nil => Some(Val.or v1 v2) + | Oorimm n, v1::nil => Some (Val.or v1 (Vint n)) + | Oxor, v1::v2::nil => Some(Val.xor v1 v2) + | Oxorimm n, v1::nil => Some (Val.xor v1 (Vint n)) + | Oshl, v1::v2::nil => Some (Val.shl v1 v2) + | Oshlimm n, v1::nil => Some (Val.shl v1 (Vint n)) + | Oshr, v1::v2::nil => Some (Val.shr v1 v2) + | Oshrimm n, v1::nil => Some (Val.shr v1 (Vint n)) + | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Oshru, v1::v2::nil => Some (Val.shru v1 v2) + | Oshruimm n, v1::nil => Some (Val.shru v1 (Vint n)) + | Ororimm n, v1::nil => Some (Val.ror v1 (Vint n)) + | Olea addr, _ => eval_addressing genv sp addr vl + | Onegf, v1::nil => Some(Val.negf v1) + | Oabsf, v1::nil => Some(Val.absf v1) + | Oaddf, v1::v2::nil => Some(Val.addf v1 v2) + | Osubf, v1::v2::nil => Some(Val.subf v1 v2) + | Omulf, v1::v2::nil => Some(Val.mulf v1 v2) + | Odivf, v1::v2::nil => Some(Val.divf v1 v2) + | Osingleoffloat, v1::nil => Some(Val.singleoffloat v1) + | Ointoffloat, v1::nil => Val.intoffloat v1 + | Ofloatofint, v1::nil => Val.floatofint v1 + | Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m)) | _, _ => None end. -Definition negate_condition (cond: condition): condition := - match cond with - | Ccomp c => Ccomp(negate_comparison c) - | Ccompu c => Ccompu(negate_comparison c) - | Ccompimm c n => Ccompimm (negate_comparison c) n - | Ccompuimm c n => Ccompuimm (negate_comparison c) n - | Ccompf c => Cnotcompf c - | Cnotcompf c => Ccompf c - | Cmaskzero n => Cmasknotzero n - | Cmasknotzero n => Cmaskzero n - end. - Ltac FuncInv := match goal with | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => @@ -325,104 +245,7 @@ Ltac FuncInv := idtac end. -Remark eval_negate_compare_mismatch: - forall c b, - eval_compare_mismatch c = Some b -> - eval_compare_mismatch (negate_comparison c) = Some (negb b). -Proof. - intros until b. unfold eval_compare_mismatch. - destruct c; intro EQ; inv EQ; auto. -Qed. - -Remark eval_negate_compare_null: - forall c i b, - eval_compare_null c i = Some b -> - eval_compare_null (negate_comparison c) i = Some (negb b). -Proof. - unfold eval_compare_null; intros. - destruct (Int.eq i Int.zero). apply eval_negate_compare_mismatch; auto. congruence. -Qed. - -Lemma eval_negate_condition: - forall (cond: condition) (vl: list val) (b: bool) (m: mem), - eval_condition cond vl m = Some b -> - eval_condition (negate_condition cond) vl m = Some (negb b). -Proof. - intros. - destruct cond; simpl in H; FuncInv; try subst b; simpl. - rewrite Int.negate_cmp. auto. - rewrite Int.negate_cmpu. auto. - apply eval_negate_compare_null; auto. - apply eval_negate_compare_null; auto. - 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_cmp. auto. - rewrite Int.negate_cmpu. auto. - apply eval_negate_compare_null; auto. - auto. - rewrite negb_elim. auto. - auto. - rewrite negb_elim. auto. -Qed. - -(** [eval_operation] and [eval_addressing] depend on a global environment - for resolving references to global symbols. We show that they give - the same results if a global environment is replaced by another that - assigns the same addresses to the same symbols. *) - -Section GENV_TRANSF. - -Variable F1 F2 V1 V2: Type. -Variable ge1: Genv.t F1 V1. -Variable ge2: Genv.t F2 V2. -Hypothesis agree_on_symbols: - forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. - -Lemma eval_addressing_preserved: - forall sp addr vl, - eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. -Proof. - intros. - unfold eval_addressing; destruct addr; try rewrite agree_on_symbols; - reflexivity. -Qed. - -Lemma eval_operation_preserved: - forall sp op vl m, - eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. -Proof. - intros. - unfold eval_operation; destruct op; try rewrite agree_on_symbols; auto. - apply eval_addressing_preserved. -Qed. - -End GENV_TRANSF. - -(** Recognition of move operations. *) - -Definition is_move_operation - (A: Type) (op: operation) (args: list A) : option A := - match op, args with - | Omove, arg :: nil => Some arg - | _, _ => None - end. - -Lemma is_move_operation_correct: - forall (A: Type) (op: operation) (args: list A) (a: A), - is_move_operation op args = Some a -> - op = Omove /\ args = a :: nil. -Proof. - intros until a. unfold is_move_operation; destruct op; - try (intros; discriminate). - destruct args. intros; discriminate. - destruct args. intros. intuition congruence. - intros; discriminate. -Qed. - -(** Static typing of conditions, operators and addressing modes. *) +(** * Static typing of conditions, operators and addressing modes. *) Definition type_of_condition (c: condition) : list typ := match c with @@ -505,12 +328,18 @@ Lemma type_of_addressing_sound: forall addr vl sp v, eval_addressing genv sp addr vl = Some v -> Val.has_type v Tint. -Proof. - intros. destruct addr; simpl in H; FuncInv; try subst v; try exact I. - destruct (Genv.find_symbol genv i); inv H; exact I. - destruct (Genv.find_symbol genv i); inv H; exact I. - destruct (Genv.find_symbol genv i0); inv H; exact I. - unfold offset_sp in H. destruct sp; inv H; exact I. +Proof with (try exact I). + intros. destruct addr; simpl in H; FuncInv; subst; simpl. + destruct v0... + destruct v0... destruct v1... destruct v1... + destruct v0... + destruct v0... destruct v1... destruct v1... + unfold symbol_address; destruct (Genv.find_symbol genv i)... + unfold symbol_address; destruct (Genv.find_symbol genv i)... + unfold symbol_address; destruct (Genv.find_symbol genv i)... destruct v0... + destruct v0... + unfold symbol_address; destruct (Genv.find_symbol genv i0)... destruct v0... + destruct sp... Qed. Lemma type_of_operation_sound: @@ -518,46 +347,49 @@ Lemma type_of_operation_sound: op <> Omove -> eval_operation genv sp op vl m = Some v -> Val.has_type v (snd (type_of_operation op)). -Proof. +Proof with (try exact I). intros. - destruct op; simpl in H0; FuncInv; try subst v; try exact I. + destruct op; simpl in H0; FuncInv; subst; simpl. congruence. - destruct v0; exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct (eq_block b b0). injection H0; intro; subst v; exact I. - discriminate. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i (Int.repr 31)). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - simpl. eapply type_of_addressing_sound; eauto. - destruct v0; exact I. - destruct (Float.intoffloat f); simpl in H0; inv H0. exact I. - destruct (eval_condition c vl). - destruct b; injection H0; intro; subst v; exact I. - discriminate. + exact I. + exact I. + destruct v0... + destruct v0... + destruct v0... + destruct v0... + destruct v0... + destruct v0; destruct v1... simpl. destruct (zeq b b0)... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... + destruct v0; simpl in H0; try discriminate. destruct (Int.ltu i (Int.repr 31)); inv H0... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... + destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... + eapply type_of_addressing_sound; eauto. + destruct v0... + destruct v0... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0... + destruct v0; simpl in H0; inv H0. destruct (Float.intoffloat f); inv H2... + destruct v0; simpl in H0; inv H0... + destruct (eval_condition c vl m); simpl... destruct b... Qed. Lemma type_of_chunk_correct: @@ -575,292 +407,61 @@ Qed. End SOUNDNESS. -(** Alternate definition of [eval_condition], [eval_op], [eval_addressing] - as total functions that return [Vundef] when not applicable - (instead of [None]). Used in the proof of [Asmgen]. *) +(** * Manipulating and transforming operations *) -Section EVAL_OP_TOTAL. - -Variable F V: Type. -Variable genv: Genv.t F V. - -Definition find_symbol_offset (id: ident) (ofs: int) : val := - match Genv.find_symbol genv id with - | Some b => Vptr b ofs - | None => Vundef - end. - -Definition eval_condition_total (cond: condition) (vl: list val) : val := - match cond, vl with - | Ccomp c, v1::v2::nil => Val.cmp c v1 v2 - | Ccompu c, v1::v2::nil => Val.cmpu c v1 v2 - | Ccompimm c n, v1::nil => Val.cmp c v1 (Vint n) - | Ccompuimm c n, v1::nil => Val.cmpu c v1 (Vint n) - | Ccompf c, v1::v2::nil => Val.cmpf c v1 v2 - | Cnotcompf c, v1::v2::nil => Val.notbool(Val.cmpf c v1 v2) - | Cmaskzero n, v1::nil => Val.notbool (Val.and v1 (Vint n)) - | Cmasknotzero n, v1::nil => Val.notbool(Val.notbool (Val.and v1 (Vint n))) - | _, _ => Vundef - end. - -Definition eval_addressing_total - (sp: val) (addr: addressing) (vl: list val) : val := - match addr, vl with - | Aindexed n, v1::nil => Val.add v1 (Vint n) - | Aindexed2 n, v1::v2::nil => Val.add (Val.add v1 v2) (Vint n) - | Ascaled sc ofs, v1::nil => Val.add (Val.mul v1 (Vint sc)) (Vint ofs) - | Aindexed2scaled sc ofs, v1::v2::nil => - Val.add v1 (Val.add (Val.mul v2 (Vint sc)) (Vint ofs)) - | Aglobal s ofs, nil => find_symbol_offset s ofs - | Abased s ofs, v1::nil => Val.add (find_symbol_offset s ofs) v1 - | Abasedscaled sc s ofs, v1::nil => Val.add (find_symbol_offset s ofs) (Val.mul v1 (Vint sc)) - | Ainstack ofs, nil => Val.add sp (Vint ofs) - | _, _ => Vundef - end. +(** Recognition of move operations. *) -Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val := - match op, vl with - | Omove, v1::nil => v1 - | Ointconst n, nil => Vint n - | Ofloatconst n, nil => Vfloat n - | Ocast8signed, v1::nil => Val.sign_ext 8 v1 - | Ocast8unsigned, v1::nil => Val.zero_ext 8 v1 - | Ocast16signed, v1::nil => Val.sign_ext 16 v1 - | Ocast16unsigned, v1::nil => Val.zero_ext 16 v1 - | Oneg, v1::nil => Val.neg v1 - | Osub, v1::v2::nil => Val.sub v1 v2 - | Omul, v1::v2::nil => Val.mul v1 v2 - | Omulimm n, v1::nil => Val.mul v1 (Vint n) - | Odiv, v1::v2::nil => Val.divs v1 v2 - | Odivu, v1::v2::nil => Val.divu v1 v2 - | Omod, v1::v2::nil => Val.mods v1 v2 - | Omodu, v1::v2::nil => Val.modu v1 v2 - | Oand, v1::v2::nil => Val.and v1 v2 - | Oandimm n, v1::nil => Val.and v1 (Vint n) - | Oor, v1::v2::nil => Val.or v1 v2 - | Oorimm n, v1::nil => Val.or v1 (Vint n) - | Oxor, v1::v2::nil => Val.xor v1 v2 - | Oxorimm n, v1::nil => Val.xor v1 (Vint n) - | Oshl, v1::v2::nil => Val.shl v1 v2 - | Oshlimm n, v1::nil => Val.shl v1 (Vint n) - | Oshr, v1::v2::nil => Val.shr v1 v2 - | Oshrimm n, v1::nil => Val.shr v1 (Vint n) - | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) - | Oshru, v1::v2::nil => Val.shru v1 v2 - | Oshruimm n, v1::nil => Val.shru v1 (Vint n) - | Ororimm n, v1::nil => Val.ror v1 (Vint n) - | Olea addr, _ => eval_addressing_total sp addr vl - | Onegf, v1::nil => Val.negf v1 - | Oabsf, v1::nil => Val.absf v1 - | Oaddf, v1::v2::nil => Val.addf v1 v2 - | Osubf, v1::v2::nil => Val.subf v1 v2 - | Omulf, v1::v2::nil => Val.mulf v1 v2 - | Odivf, v1::v2::nil => Val.divf v1 v2 - | Osingleoffloat, v1::nil => Val.singleoffloat v1 - | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ofloatofint, v1::nil => Val.floatofint v1 - | Ocmp c, _ => eval_condition_total c vl - | _, _ => Vundef +Definition is_move_operation + (A: Type) (op: operation) (args: list A) : option A := + match op, args with + | Omove, arg :: nil => Some arg + | _, _ => None end. -Lemma eval_compare_mismatch_weaken: - forall c b, - eval_compare_mismatch c = Some b -> - Val.cmp_mismatch c = Val.of_bool b. -Proof. - unfold eval_compare_mismatch. intros. destruct c; inv H; auto. -Qed. - -Lemma eval_compare_null_weaken: - forall n c b, - eval_compare_null c n = Some b -> - (if Int.eq n Int.zero then Val.cmp_mismatch c else Vundef) = Val.of_bool b. -Proof. - unfold eval_compare_null. - intros. destruct (Int.eq n Int.zero). apply eval_compare_mismatch_weaken. auto. - discriminate. -Qed. - -Lemma eval_condition_weaken: - 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. - symmetry. apply Val.notbool_negb_1. - symmetry. apply Val.notbool_negb_1. -Qed. - -Lemma eval_addressing_weaken: - forall sp addr vl v, - eval_addressing genv sp addr vl = Some v -> - eval_addressing_total sp addr vl = v. -Proof. - intros. - unfold eval_addressing in H; destruct addr; FuncInv; - try subst v; simpl; try reflexivity. - unfold find_symbol_offset. destruct (Genv.find_symbol genv i); congruence. - unfold find_symbol_offset. destruct (Genv.find_symbol genv i); simpl; congruence. - unfold find_symbol_offset. destruct (Genv.find_symbol genv i0); simpl; congruence. - unfold offset_sp in H. destruct sp; simpl; congruence. -Qed. - -Lemma eval_operation_weaken: - forall sp op vl v m, - eval_operation genv sp op vl m = Some v -> - eval_operation_total sp op vl = v. -Proof. - intros. - unfold eval_operation in H; destruct op; FuncInv; - try subst v; try reflexivity; simpl. - unfold eq_block in H. destruct (zeq b b0); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.ltu i0 Int.iwordsize); congruence. - destruct (Int.ltu i Int.iwordsize); congruence. - destruct (Int.ltu i0 Int.iwordsize); congruence. - destruct (Int.ltu i Int.iwordsize); congruence. - unfold Int.ltu in *. destruct (zlt (Int.unsigned i) (Int.unsigned (Int.repr 31))). - rewrite zlt_true. congruence. eapply Zlt_trans. eauto. compute; auto. - congruence. - destruct (Int.ltu i0 Int.iwordsize); congruence. - destruct (Int.ltu i Int.iwordsize); congruence. - 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 m); intros; rewrite H0 in H. - replace v with (Val.of_bool b). - eapply eval_condition_weaken; eauto. - destruct b; simpl; congruence. - discriminate. -Qed. - -Lemma eval_condition_total_is_bool: - forall cond vl, Val.is_bool (eval_condition_total cond vl). +Lemma is_move_operation_correct: + forall (A: Type) (op: operation) (args: list A) (a: A), + is_move_operation op args = Some a -> + op = Omove /\ args = a :: nil. Proof. - intros; destruct cond; - destruct vl; try apply Val.undef_is_bool; - destruct vl; try apply Val.undef_is_bool; - try (destruct vl; try apply Val.undef_is_bool); simpl. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmpf_is_bool. - apply Val.notbool_is_bool. - apply Val.notbool_is_bool. - apply Val.notbool_is_bool. + intros until a. unfold is_move_operation; destruct op; + try (intros; discriminate). + destruct args. intros; discriminate. + destruct args. intros. intuition congruence. + intros; discriminate. Qed. -End EVAL_OP_TOTAL. - -(** Compatibility of the evaluation functions with the - ``is less defined'' relation over values. *) - -Section EVAL_LESSDEF. - -Variable F V: Type. -Variable genv: Genv.t F V. - -Ltac InvLessdef := - match goal with - | [ H: Val.lessdef (Vint _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef (Vfloat _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef (Vptr _ _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef_list nil _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef_list (_ :: _) _ |- _ ] => - inv H; InvLessdef - | _ => idtac - end. - -Lemma eval_condition_lessdef: - forall cond vl1 vl2 b m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. 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. +(** [negate_condition cond] returns a condition that is logically + equivalent to the negation of [cond]. *) -Ltac TrivialExists := - match goal with - | [ |- exists v2, Some ?v1 = Some v2 /\ Val.lessdef ?v1 v2 ] => - exists v1; split; [auto | constructor] - | _ => idtac +Definition negate_condition (cond: condition): condition := + match cond with + | Ccomp c => Ccomp(negate_comparison c) + | Ccompu c => Ccompu(negate_comparison c) + | Ccompimm c n => Ccompimm (negate_comparison c) n + | Ccompuimm c n => Ccompuimm (negate_comparison c) n + | Ccompf c => Cnotcompf c + | Cnotcompf c => Ccompf c + | Cmaskzero n => Cmasknotzero n + | Cmasknotzero n => Cmaskzero n end. -Lemma eval_addressing_lessdef: - forall sp addr vl1 vl2 v1, - Val.lessdef_list vl1 vl2 -> - eval_addressing genv sp addr vl1 = Some v1 -> - exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. -Proof. - intros. destruct addr; simpl in *; FuncInv; InvLessdef; TrivialExists. - destruct (Genv.find_symbol genv i); inv H0. TrivialExists. - destruct (Genv.find_symbol genv i); inv H0. TrivialExists. - destruct (Genv.find_symbol genv i0); inv H0. TrivialExists. - exists v1; auto. -Qed. - -Lemma eval_operation_lessdef: - forall sp op vl1 vl2 v1 m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> - eval_operation genv sp op vl1 m1 = Some v1 -> - exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. +Lemma eval_negate_condition: + 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 op; simpl in *; FuncInv; InvLessdef; TrivialExists. - exists v2; 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 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. - destruct (eval_condition c vl1 m1) as [] _eqn. - rewrite (eval_condition_lessdef c H H0 Heqo). - destruct b; inv H1; TrivialExists. - discriminate. + intros. + destruct cond; simpl in H; FuncInv; simpl. + rewrite Val.negate_cmp_bool; rewrite H; auto. + rewrite Val.negate_cmpu_bool; rewrite H; auto. + rewrite Val.negate_cmp_bool; rewrite H; auto. + rewrite Val.negate_cmpu_bool; rewrite H; auto. + rewrite H; auto. + destruct (Val.cmpf_bool c v v0); simpl in H; inv H. rewrite negb_elim; auto. + rewrite H0; auto. + rewrite <- H0. rewrite negb_elim; auto. Qed. -End EVAL_LESSDEF. - (** Shifting stack-relative references. This is used in [Stacking]. *) Definition shift_stack_addressing (delta: int) (addr: addressing) := @@ -887,132 +488,24 @@ 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. +Lemma eval_shift_stack_addressing: + forall F V (ge: Genv.t F V) sp addr vl delta, + eval_addressing ge sp (shift_stack_addressing delta addr) vl = + eval_addressing ge (Val.add sp (Vint delta)) addr vl. Proof. - intros. destruct addr; simpl 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. + intros. destruct addr; simpl; auto. + rewrite Val.add_assoc. simpl. auto. 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. +Lemma eval_shift_stack_operation: + forall F V (ge: Genv.t F V) sp op vl m delta, + eval_operation ge sp (shift_stack_operation delta op) vl m = + eval_operation ge (Val.add sp (Vint delta)) op vl m. Proof. - intros. destruct op; simpl 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. + intros. destruct op; simpl; auto. + apply eval_shift_stack_addressing. 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 @@ -1037,6 +530,7 @@ Proof. intros. simpl. auto. Qed. + (** Two-address operations. Return [true] if the first argument and the result must be in the same location. *) @@ -1109,7 +603,387 @@ Lemma op_depends_on_memory_correct: eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. intros until m2. destruct op; simpl; try congruence. - destruct c; simpl; congruence. + destruct c; simpl; try congruence. reflexivity. Qed. +(** * Invariance and compatibility properties. *) + +(** [eval_operation] and [eval_addressing] depend on a global environment + for resolving references to global symbols. We show that they give + the same results if a global environment is replaced by another that + assigns the same addresses to the same symbols. *) + +Section GENV_TRANSF. + +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. +Hypothesis agree_on_symbols: + forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. + +Lemma eval_addressing_preserved: + forall sp addr vl, + eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. +Proof. + intros. + unfold eval_addressing, symbol_address; destruct addr; try rewrite agree_on_symbols; + reflexivity. +Qed. + +Lemma eval_operation_preserved: + forall sp op vl m, + eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. +Proof. + intros. + unfold eval_operation; destruct op; auto. + apply eval_addressing_preserved. +Qed. + +End GENV_TRANSF. + +(** Compatibility of the evaluation functions with value injections. *) + +Section EVAL_COMPAT. + +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. + +Hypothesis symbol_address_inj: + forall id ofs, + val_inject f (symbol_address genv id ofs) (symbol_address genv id ofs). + +Variable m1: mem. +Variable m2: mem. + +Hypothesis valid_pointer_inj: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + +Hypothesis valid_pointer_no_overflow: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + +Hypothesis valid_different_pointers_inj: + forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)). + +Ltac InvInject := + match goal with + | [ H: val_inject _ (Vint _) _ |- _ ] => + inv H; InvInject + | [ H: val_inject _ (Vfloat _) _ |- _ ] => + inv H; InvInject + | [ H: val_inject _ (Vptr _ _) _ |- _ ] => + inv H; InvInject + | [ H: val_list_inject _ nil _ |- _ ] => + inv H; InvInject + | [ H: val_list_inject _ (_ :: _) _ |- _ ] => + inv H; InvInject + | _ => idtac + end. + +Remark val_add_inj: + forall v1 v1' v2 v2', + val_inject f v1 v1' -> val_inject f v2 v2' -> val_inject f (Val.add v1 v2) (Val.add v1' v2'). +Proof. + intros. inv H; inv H0; simpl; econstructor; eauto. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. +Qed. + +Lemma eval_condition_inj: + forall cond vl1 vl2 b, + val_list_inject f vl1 vl2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. +Opaque Int.add. + assert (CMPU: + forall c v1 v2 v1' v2' b, + val_inject f v1 v1' -> + val_inject f v2 v2' -> + Val.cmpu_bool (Mem.valid_pointer m1) c v1 v2 = Some b -> + Val.cmpu_bool (Mem.valid_pointer m2) c v1' v2' = Some b). + intros. inv H; simpl in H1; try discriminate; inv H0; simpl in H1; try discriminate; simpl; auto. + destruct (Mem.valid_pointer m1 b1 (Int.unsigned ofs1)) as []_eqn; try discriminate. + destruct (Mem.valid_pointer m1 b0 (Int.unsigned ofs0)) as []_eqn; try discriminate. + rewrite (valid_pointer_inj _ H2 Heqb4). + rewrite (valid_pointer_inj _ H Heqb0). simpl. + destruct (zeq b1 b0); simpl in H1. + inv H1. rewrite H in H2; inv H2. rewrite zeq_true. + decEq. apply Int.translate_cmpu. + eapply valid_pointer_no_overflow; eauto. + eapply valid_pointer_no_overflow; eauto. + exploit valid_different_pointers_inj; eauto. intros P. + destruct (zeq b2 b3); auto. + destruct P. congruence. + destruct c; simpl in H1; inv H1. + simpl; decEq. rewrite Int.eq_false; auto. congruence. + simpl; decEq. rewrite Int.eq_false; auto. congruence. + + intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. + inv H3; inv H2; simpl in H0; inv H0; auto. + eauto. + inv H3; simpl in H0; inv H0; auto. + eauto. + inv H3; inv H2; simpl in H0; inv H0; auto. + inv H3; inv H2; simpl in H0; inv H0; auto. +Qed. + +Ltac TrivialExists := + match goal with + | [ |- exists v2, Some ?v1 = Some v2 /\ val_inject _ _ v2 ] => + exists v1; split; auto + | _ => idtac + end. + +Lemma eval_addressing_inj: + forall addr sp1 vl1 sp2 vl2 v1, + val_inject f sp1 sp2 -> + val_list_inject f vl1 vl2 -> + eval_addressing genv sp1 addr vl1 = Some v1 -> + exists v2, eval_addressing genv sp2 addr vl2 = Some v2 /\ val_inject f v1 v2. +Proof. + intros. destruct addr; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + apply val_add_inj; auto. + apply val_add_inj; auto. apply val_add_inj; auto. + apply val_add_inj; auto. inv H4; simpl; auto. + apply val_add_inj; auto. apply val_add_inj; auto. inv H2; simpl; auto. + apply val_add_inj; auto. + apply val_add_inj; auto. inv H4; simpl; auto. + apply val_add_inj; auto. +Qed. + +Lemma eval_operation_inj: + forall op sp1 vl1 sp2 vl2 v1, + val_inject f sp1 sp2 -> + val_list_inject f vl1 vl2 -> + eval_operation genv sp1 op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp2 op vl2 m2 = Some v2 /\ val_inject f v1 v2. +Proof. + intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. econstructor; eauto. + rewrite Int.sub_add_l. auto. + destruct (zeq b1 b0); auto. subst. rewrite H1 in H0. inv H0. rewrite zeq_true. + rewrite Int.sub_shifted. auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. + inv H4; simpl in H1; try discriminate. simpl. + destruct (Int.ltu i (Int.repr 31)); inv H1. TrivialExists. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. + inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. + eapply eval_addressing_inj; eauto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl in H1; inv H1. simpl. destruct (Float.intoffloat f0); simpl in H2; inv H2. + exists (Vint i); auto. + inv H4; simpl in H1; inv H1. simpl. TrivialExists. + subst v1. destruct (eval_condition c vl1 m1) as []_eqn. + exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. + destruct b; simpl; constructor. + simpl; constructor. +Qed. + +End EVAL_COMPAT. + +(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) + +Section EVAL_LESSDEF. + +Variable F V: Type. +Variable genv: Genv.t F V. + +Remark valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. +Proof. + intros. inv H0. rewrite Int.add_zero. eapply Mem.valid_pointer_extends; eauto. +Qed. + +Remark valid_pointer_no_overflow_extends: + forall m1 b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. +Proof. + intros. inv H. rewrite Zplus_0_r. apply Int.unsigned_range_2. +Qed. + +Remark valid_different_pointers_extends: + forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + Some(b1, 0) = Some (b1', delta1) -> + Some(b2, 0) = Some (b2', delta2) -> + b1' <> b2' \/ + Int.unsigned(Int.add ofs1 (Int.repr delta1)) <> Int.unsigned(Int.add ofs2 (Int.repr delta2)). +Proof. + intros. inv H2; inv H3. auto. +Qed. + +Lemma eval_condition_lessdef: + forall cond vl1 vl2 b m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1). + apply valid_pointer_extends; auto. + apply valid_pointer_no_overflow_extends; auto. + apply valid_different_pointers_extends; auto. + rewrite <- val_list_inject_lessdef. eauto. auto. +Qed. + +Lemma eval_operation_lessdef: + forall sp op vl1 vl2 v1 m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_operation genv sp op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. rewrite val_list_inject_lessdef in H. + assert (exists v2 : val, + eval_operation genv sp op vl2 m2 = Some v2 + /\ val_inject (fun b => Some(b, 0)) v1 v2). + eapply eval_operation_inj with (m1 := m1) (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + apply valid_pointer_extends; auto. + apply valid_pointer_no_overflow_extends; auto. + apply valid_different_pointers_extends; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + +Lemma eval_addressing_lessdef: + forall sp addr vl1 vl2 v1, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = Some v1 -> + exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. rewrite val_list_inject_lessdef in H. + assert (exists v2 : val, + eval_addressing genv sp addr vl2 = Some v2 + /\ val_inject (fun b => Some(b, 0)) v1 v2). + eapply eval_addressing_inj with (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + +End EVAL_LESSDEF. + +(** Compatibility of the evaluation functions with memory injections. *) + +Section EVAL_INJECT. + +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. +Hypothesis globals: meminj_preserves_globals genv f. +Variable sp1: block. +Variable sp2: block. +Variable delta: Z. +Hypothesis sp_inj: f sp1 = Some(sp2, delta). + +Remark symbol_address_inject: + forall id ofs, val_inject f (symbol_address genv id ofs) (symbol_address genv id ofs). +Proof. + intros. unfold symbol_address. destruct (Genv.find_symbol genv id) as []_eqn; auto. + exploit (proj1 globals); eauto. intros. + econstructor; eauto. rewrite Int.add_zero; auto. +Qed. + +Lemma eval_condition_inject: + forall cond vl1 vl2 b m1 m2, + val_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. eapply eval_condition_inj with (f := f) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. +Qed. + +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. + rewrite eval_shift_stack_addressing. simpl. + eapply eval_addressing_inj with (sp1 := Vptr sp1 Int.zero); eauto. + exact symbol_address_inject. +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. + rewrite eval_shift_stack_operation. simpl. + eapply eval_operation_inj with (sp1 := Vptr sp1 Int.zero) (m1 := m1); eauto. + exact symbol_address_inject. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. +Qed. + +End EVAL_INJECT. diff --git a/ia32/SelectOp.v b/ia32/SelectOp.v deleted file mode 100644 index c1f5703..0000000 --- a/ia32/SelectOp.v +++ /dev/null @@ -1,839 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Instruction selection for operators *) - -(** The instruction selection pass recognizes opportunities for using - combined arithmetic and logical operations and addressing modes - offered by the target processor. For instance, the expression [x + 1] - can take advantage of the "immediate add" instruction of the processor, - and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned - into a "rotate and mask" instruction. - - This file defines functions for building CminorSel expressions and - statements, especially expressions consisting of operator - applications. These functions examine their arguments to choose - cheaper forms of operators whenever possible. - - For instance, [add e1 e2] will return a CminorSel expression semantically - equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a - [Oaddimm] operator if one of the arguments is an integer constant, - or suppress the addition altogether if one of the arguments is the - null integer. In passing, we perform operator reassociation - ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount - of constant propagation. - - On top of the "smart constructor" functions defined below, - module [Selection] implements the actual instruction selection pass. -*) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Cminor. -Require Import Op. -Require Import CminorSel. - -Open Local Scope cminorsel_scope. - -(** ** Constants **) - -Definition addrsymbol (id: ident) (ofs: int) := - Eop (Olea (Aglobal id ofs)) Enil. - -Definition addrstack (ofs: int) := - Eop (Olea (Ainstack ofs)) Enil. - -(** ** Boolean negation *) - -Definition notbool_base (e: expr) := - Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil). - -Fixpoint notbool (e: expr) {struct e} : expr := - match e with - | Eop (Ointconst n) Enil => - Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil - | Eop (Ocmp cond) args => - Eop (Ocmp (negate_condition cond)) args - | Econdition e1 e2 e3 => - Econdition e1 (notbool e2) (notbool e3) - | _ => - notbool_base e - end. - -(** ** Integer addition and pointer addition *) - -Definition offset_addressing (a: addressing) (ofs: int) : addressing := - match a with - | Aindexed n => Aindexed (Int.add n ofs) - | Aindexed2 n => Aindexed2 (Int.add n ofs) - | Ascaled sc n => Ascaled sc (Int.add n ofs) - | Aindexed2scaled sc n => Aindexed2scaled sc (Int.add n ofs) - | Aglobal id n => Aglobal id (Int.add n ofs) - | Abased id n => Abased id (Int.add n ofs) - | Abasedscaled sc id n => Abasedscaled sc id (Int.add n ofs) - | Ainstack n => Ainstack (Int.add n ofs) - end. - -(** Addition of an integer constant *) - -(* -Definition addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match e with - | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil - | Eop (Olea addr) args => Eop (Olea (offset_addressing addr n)) args - | _ => Eop (Olea (Aindexed n)) (e ::: Enil) - end. -*) - -Inductive addimm_cases: forall (e: expr), Type := - | addimm_case1: - forall m, - addimm_cases (Eop (Ointconst m) Enil) - | addimm_case2: - forall addr args, - addimm_cases (Eop (Olea addr) args) - | addimm_default: - forall (e: expr), - addimm_cases e. - -Definition addimm_match (e: expr) := - match e as z1 return addimm_cases z1 with - | Eop (Ointconst m) Enil => - addimm_case1 m - | Eop (Olea addr) args => - addimm_case2 addr args - | e => - addimm_default e - end. - -Definition addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match addimm_match e with - | addimm_case1 m => - Eop (Ointconst(Int.add n m)) Enil - | addimm_case2 addr args => - Eop (Olea (offset_addressing addr n)) args - | addimm_default e => - Eop (Olea (Aindexed n)) (e ::: Enil) - end. - -(** Addition of two integer or pointer expressions *) - -(* -Definition add (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 - | t1, Eop (Ointconst n2) Enil => addimm n2 t1 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => Eop (Olea (Aindexed2 (Int.add n1 n2))) (t1:::t2:::Enil) - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t1:::t2:::Enil) - | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t2:::t1:::Enil) - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil) => Eop (Olea (Abased id (Int.add ofs n1))) (t1:::Enil) - | Eop (Olea (Aglobal id ofs)) Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => Eop (Olea (Abased id (Int.add ofs n2))) (t2:::Enil) - | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil) => Eop (Olea (Abasedscaled sc id (Int.add ofs n1))) (t1:::Enil) - | Eop (Olea (Aglobal id ofs)) Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => Eop (Olea (Abasedscaled sc id (Int.add ofs n2))) (t2:::Enil) - | Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 => Eop (Olea (Aindexed2scaled sc n)) (t2:::t1:::Enil) - | t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) => Eop (Olea (Aindexed2scaled sc n)) (t1:::t2:::Enil) - | Eop (Olea (Aindexed n)) (t1:::Enil), t2 => Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) - | t1, Eop (Olea (Aindexed n)) (t2:::Enil) => Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) - | _, _ => Eop (Olea (Aindexed2 Int.zero)) (e1:::e2:::Enil) - end. -*) - -Inductive add_cases: forall (e1: expr) (e2: expr), Type := - | add_case1: - forall n1 t2, - add_cases (Eop (Ointconst n1) Enil) (t2) - | add_case2: - forall t1 n2, - add_cases (t1) (Eop (Ointconst n2) Enil) - | add_case3: - forall n1 t1 n2 t2, - add_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Aindexed n2)) (t2:::Enil)) - | add_case4: - forall n1 t1 sc n2 t2, - add_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Ascaled sc n2)) (t2:::Enil)) - | add_case5: - forall sc n1 t1 n2 t2, - add_cases (Eop (Olea (Ascaled sc n1)) (t1:::Enil)) (Eop (Olea (Aindexed n2)) (t2:::Enil)) - | add_case6: - forall n1 t1 id ofs, - add_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Aglobal id ofs)) Enil) - | add_case7: - forall id ofs n2 t2, - add_cases (Eop (Olea (Aglobal id ofs)) Enil) (Eop (Olea (Aindexed n2)) (t2:::Enil)) - | add_case8: - forall sc n1 t1 id ofs, - add_cases (Eop (Olea (Ascaled sc n1)) (t1:::Enil)) (Eop (Olea (Aglobal id ofs)) Enil) - | add_case9: - forall id ofs sc n2 t2, - add_cases (Eop (Olea (Aglobal id ofs)) Enil) (Eop (Olea (Ascaled sc n2)) (t2:::Enil)) - | add_case10: - forall sc n t1 t2, - add_cases (Eop (Olea (Ascaled sc n)) (t1:::Enil)) (t2) - | add_case11: - forall t1 sc n t2, - add_cases (t1) (Eop (Olea (Ascaled sc n)) (t2:::Enil)) - | add_case12: - forall n t1 t2, - add_cases (Eop (Olea (Aindexed n)) (t1:::Enil)) (t2) - | add_case13: - forall t1 n t2, - add_cases (t1) (Eop (Olea (Aindexed n)) (t2:::Enil)) - | add_default: - forall (e1: expr) (e2: expr), - add_cases e1 e2. - -Definition add_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return add_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - add_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => - add_case2 t1 n2 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => - add_case3 n1 t1 n2 t2 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => - add_case4 n1 t1 sc n2 t2 - | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => - add_case5 sc n1 t1 n2 t2 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => - add_case6 n1 t1 id ofs - | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Aindexed n2)) (t2:::Enil) => - add_case7 id ofs n2 t2 - | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => - add_case8 sc n1 t1 id ofs - | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Ascaled sc n2)) (t2:::Enil) => - add_case9 id ofs sc n2 t2 - | Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 => - add_case10 sc n t1 t2 - | t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) => - add_case11 t1 sc n t2 - | Eop (Olea (Aindexed n)) (t1:::Enil), t2 => - add_case12 n t1 t2 - | t1, Eop (Olea (Aindexed n)) (t2:::Enil) => - add_case13 t1 n t2 - | e1, e2 => - add_default e1 e2 - end. - -Definition add (e1: expr) (e2: expr) := - match add_match e1 e2 with - | add_case1 n1 t2 => - addimm n1 t2 - | add_case2 t1 n2 => - addimm n2 t1 - | add_case3 n1 t1 n2 t2 => - Eop (Olea (Aindexed2 (Int.add n1 n2))) (t1:::t2:::Enil) - | add_case4 n1 t1 sc n2 t2 => - Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t1:::t2:::Enil) - | add_case5 sc n1 t1 n2 t2 => - Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t2:::t1:::Enil) - | add_case6 n1 t1 id ofs => - Eop (Olea (Abased id (Int.add ofs n1))) (t1:::Enil) - | add_case7 id ofs n2 t2 => - Eop (Olea (Abased id (Int.add ofs n2))) (t2:::Enil) - | add_case8 sc n1 t1 id ofs => - Eop (Olea (Abasedscaled sc id (Int.add ofs n1))) (t1:::Enil) - | add_case9 id ofs sc n2 t2 => - Eop (Olea (Abasedscaled sc id (Int.add ofs n2))) (t2:::Enil) - | add_case10 sc n t1 t2 => - Eop (Olea (Aindexed2scaled sc n)) (t2:::t1:::Enil) - | add_case11 t1 sc n t2 => - Eop (Olea (Aindexed2scaled sc n)) (t1:::t2:::Enil) - | add_case12 n t1 t2 => - Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) - | add_case13 t1 n t2 => - Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) - | add_default e1 e2 => - Eop (Olea (Aindexed2 Int.zero)) (e1:::e2:::Enil) - end. - -(** ** Integer and pointer subtraction *) - -(* -Definition sub (e1: expr) (e2: expr) := - match e1, e2 with - | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 => addimm n1 (Eop Osub (t1:::t2:::Enil)) - | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) - | _, _ => Eop Osub (e1:::e2:::Enil) - end. -*) - -Inductive sub_cases: forall (e1: expr) (e2: expr), Type := - | sub_case1: - forall t1 n2, - sub_cases (t1) (Eop (Ointconst n2) Enil) - | sub_case2: - forall n1 t1 n2 t2, - sub_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Aindexed n2)) (t2:::Enil)) - | sub_case3: - forall n1 t1 t2, - sub_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (t2) - | sub_case4: - forall t1 n2 t2, - sub_cases (t1) (Eop (Olea (Aindexed n2)) (t2:::Enil)) - | sub_default: - forall (e1: expr) (e2: expr), - sub_cases e1 e2. - -Definition sub_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return sub_cases z1 z2 with - | t1, Eop (Ointconst n2) Enil => - sub_case1 t1 n2 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => - sub_case2 n1 t1 n2 t2 - | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 => - sub_case3 n1 t1 t2 - | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) => - sub_case4 t1 n2 t2 - | e1, e2 => - sub_default e1 e2 - end. - -Definition sub (e1: expr) (e2: expr) := - match sub_match e1 e2 with - | sub_case1 t1 n2 => - addimm (Int.neg n2) t1 - | sub_case2 n1 t1 n2 t2 => - addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | sub_case3 n1 t1 t2 => - addimm n1 (Eop Osub (t1:::t2:::Enil)) - | sub_case4 t1 n2 t2 => - addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) - | sub_default e1 e2 => - Eop Osub (e1:::e2:::Enil) - end. - -(** ** Immediate shifts *) - -Definition shift_is_scale (n: int) : bool := - Int.eq n (Int.repr 1) || Int.eq n (Int.repr 2) || Int.eq n (Int.repr 3). - -(* -Definition shlimm (e1: expr) := - if Int.eq n Int.zero then e1 else - match e1 with - | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shl n1 n)) - | Eop (Oshlimm n1) (t1:::Enil) => if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - | Eop (Olea (Aindexed n1)) (t1:::Enil) => if shift_is_scale n then Eop (Olea (Ascaled (Int.shl Int.one n) (Int.shl n1 n))) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - | _ => if shift_is_scale n then Eop (Olea (Ascaled (Int.shl Int.one n) Int.zero) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - end. -*) - -Inductive shlimm_cases: forall (e1: expr), Type := - | shlimm_case1: - forall n1, - shlimm_cases (Eop (Ointconst n1) Enil) - | shlimm_case2: - forall n1 t1, - shlimm_cases (Eop (Oshlimm n1) (t1:::Enil)) - | shlimm_case3: - forall n1 t1, - shlimm_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) - | shlimm_default: - forall (e1: expr), - shlimm_cases e1. - -Definition shlimm_match (e1: expr) := - match e1 as z1 return shlimm_cases z1 with - | Eop (Ointconst n1) Enil => - shlimm_case1 n1 - | Eop (Oshlimm n1) (t1:::Enil) => - shlimm_case2 n1 t1 - | Eop (Olea (Aindexed n1)) (t1:::Enil) => - shlimm_case3 n1 t1 - | e1 => - shlimm_default e1 - end. - -Definition shlimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else - match shlimm_match e1 with - | shlimm_case1 n1 => - Eop (Ointconst(Int.shl n1 n)) Enil - | shlimm_case2 n1 t1 => - if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - | shlimm_case3 n1 t1 => - if shift_is_scale n then Eop (Olea (Ascaled (Int.shl Int.one n) (Int.shl n1 n))) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - | shlimm_default e1 => - if shift_is_scale n then Eop (Olea (Ascaled (Int.shl Int.one n) Int.zero)) (e1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - end. - -(* -Definition shruimm (e1: expr) := - if Int.eq n Int.zero then e1 else - match e1 with - | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shru n1 n)) - | Eop (Oshruimm n1) (t1:::Enil) => if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) else Eop (Oshruimm n) (e1:::Enil) - | _ => Eop (Oshruimm n) (e1:::Enil) - end. -*) - -Inductive shruimm_cases: forall (e1: expr), Type := - | shruimm_case1: - forall n1, - shruimm_cases (Eop (Ointconst n1) Enil) - | shruimm_case2: - forall n1 t1, - shruimm_cases (Eop (Oshruimm n1) (t1:::Enil)) - | shruimm_default: - forall (e1: expr), - shruimm_cases e1. - -Definition shruimm_match (e1: expr) := - match e1 as z1 return shruimm_cases z1 with - | Eop (Ointconst n1) Enil => - shruimm_case1 n1 - | Eop (Oshruimm n1) (t1:::Enil) => - shruimm_case2 n1 t1 - | e1 => - shruimm_default e1 - end. - -Definition shruimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else - match shruimm_match e1 with - | shruimm_case1 n1 => - Eop (Ointconst(Int.shru n1 n)) Enil - | shruimm_case2 n1 t1 => - if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) else Eop (Oshruimm n) (e1:::Enil) - | shruimm_default e1 => - Eop (Oshruimm n) (e1:::Enil) - end. - -(* -Definition shrimm (e1: expr) := - if Int.eq n Int.zero then e1 else - match e1 with - | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shr n1 n)) Enil - | Eop (Oshrimm n1) (t1:::Enil) => if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil) - | _ => Eop (Oshrimm n) (e1:::Enil) - end. -*) - -Inductive shrimm_cases: forall (e1: expr), Type := - | shrimm_case1: - forall n1, - shrimm_cases (Eop (Ointconst n1) Enil) - | shrimm_case2: - forall n1 t1, - shrimm_cases (Eop (Oshrimm n1) (t1:::Enil)) - | shrimm_default: - forall (e1: expr), - shrimm_cases e1. - -Definition shrimm_match (e1: expr) := - match e1 as z1 return shrimm_cases z1 with - | Eop (Ointconst n1) Enil => - shrimm_case1 n1 - | Eop (Oshrimm n1) (t1:::Enil) => - shrimm_case2 n1 t1 - | e1 => - shrimm_default e1 - end. - -Definition shrimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else - match shrimm_match e1 with - | shrimm_case1 n1 => - Eop (Ointconst(Int.shr n1 n)) Enil - | shrimm_case2 n1 t1 => - if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil) - | shrimm_default e1 => - Eop (Oshrimm n) (e1:::Enil) - end. - -(** ** Integer multiply *) - -Definition mulimm_base (n1: int) (e2: expr) := - match Int.one_bits n1 with - | i :: nil => - shlimm e2 i - | i :: j :: nil => - Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) - | _ => - Eop (Omulimm n1) (e2:::Enil) - end. - -(* -Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then - Eop (Ointconst Int.zero) Enil - else if Int.eq n1 Int.one then - e2 - else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil - | Eop (Olea (Aindexed n2)) (t2:::Enil) => if mul_is_scale n1 then Eop (Olea (Ascaled n1 (Int.mul n1 n2))) (t2:::Enil) else addimm (Int.mul n1 n2) (mulimm_base n1 t2) - | _ => mulimm_base n1 e2 - end. - -Definition mulimm (e2: expr) := - match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil - | Eop (Olea (Aindexed n2)) (t2:::Enil) => if mul_is_scale n1 then Eop (Olea (Ascaled n1 (Int.mul n1 n2))) (t2:::Enil) else addimm (Int.mul n1 n2) (mulimm_base n1 t2) - | _ => mulimm_base n1 e2 - end. -*) - -Inductive mulimm_cases: forall (e2: expr), Type := - | mulimm_case1: - forall n2, - mulimm_cases (Eop (Ointconst n2) Enil) - | mulimm_case2: - forall n2 t2, - mulimm_cases (Eop (Olea (Aindexed n2)) (t2:::Enil)) - | mulimm_default: - forall (e2: expr), - mulimm_cases e2. - -Definition mulimm_match (e2: expr) := - match e2 as z1 return mulimm_cases z1 with - | Eop (Ointconst n2) Enil => - mulimm_case1 n2 - | Eop (Olea (Aindexed n2)) (t2:::Enil) => - mulimm_case2 n2 t2 - | e2 => - mulimm_default e2 - end. - -Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then - Eop (Ointconst Int.zero) Enil - else if Int.eq n1 Int.one then - e2 - else match mulimm_match e2 with - | mulimm_case1 n2 => - Eop (Ointconst(Int.mul n1 n2)) Enil - | mulimm_case2 n2 t2 => - addimm (Int.mul n1 n2) (mulimm_base n1 t2) - | mulimm_default e2 => - mulimm_base n1 e2 - end. - -(* -Definition mul (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 - | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 - | _, _ => Eop Omul (e1:::e2:::Enil) - end. -*) - -Inductive mul_cases: forall (e1: expr) (e2: expr), Type := - | mul_case1: - forall (n1: int) (t2: expr), - mul_cases (Eop (Ointconst n1) Enil) (t2) - | mul_case2: - forall (t1: expr) (n2: int), - mul_cases (t1) (Eop (Ointconst n2) Enil) - | mul_default: - forall (e1: expr) (e2: expr), - mul_cases e1 e2. - -Definition mul_match_aux (e1: expr) (e2: expr) := - match e2 as z2 return mul_cases e1 z2 with - | Eop (Ointconst n2) Enil => - mul_case2 e1 n2 - | e2 => - mul_default e1 e2 - end. - -Definition mul_match (e1: expr) (e2: expr) := - match e1 as z1 return mul_cases z1 e2 with - | Eop (Ointconst n1) Enil => - mul_case1 n1 e2 - | e1 => - mul_match_aux e1 e2 - end. - -Definition mul (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => - mulimm n1 t2 - | mul_case2 t1 n2 => - mulimm n2 t1 - | mul_default e1 e2 => - Eop Omul (e1:::e2:::Enil) - end. - -(** ** Bitwise and, or, xor *) - -Definition orimm (n: int) (e: expr) := - if Int.eq n Int.zero then e - else if Int.eq n Int.mone then Eop (Ointconst Int.mone) Enil - else Eop (Oorimm n) (e:::Enil). - -Definition same_expr_pure (e1 e2: expr) := - match e1, e2 with - | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false - | _, _ => false - end. - -(* -Definition or (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 - | t1, Eop (Ointconst n2) Enil => orimm n2 t1 - | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil)) => ... - | Eop (Oshruimm n2) (t2:::Enil)), Eop (Oshlimm n1) (t1:::Enil) => ... - | _, _ => Eop Oor (e1:::e2:::Enil) - end. -*) - -Inductive or_cases: forall (e1: expr) (e2: expr), Type := - | or_case1: - forall n1 t2, - or_cases (Eop (Ointconst n1) Enil) (t2) - | or_case2: - forall t1 n2, - or_cases (t1) (Eop (Ointconst n2) Enil) - | or_case3: - forall n1 t1 n2 t2, - or_cases (Eop (Oshlimm n1) (t1:::Enil)) (Eop (Oshruimm n2) (t2:::Enil)) - | or_case4: - forall n2 t2 n1 t1, - or_cases (Eop (Oshruimm n2) (t2:::Enil)) (Eop (Oshlimm n1) (t1:::Enil)) - | or_default: - forall (e1: expr) (e2: expr), - or_cases e1 e2. - -Definition or_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return or_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - or_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => - or_case2 t1 n2 - | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => - or_case3 n1 t1 n2 t2 - | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => - or_case4 n2 t2 n1 t1 - | e1, e2 => - or_default e1 e2 - end. - -Definition or (e1: expr) (e2: expr) := - match or_match e1 e2 with - | or_case1 n1 t2 => - orimm n1 t2 - | or_case2 t1 n2 => - orimm n2 t1 - | or_case3 n1 t1 n2 t2 => - if Int.eq (Int.add n1 n2) Int.iwordsize - && same_expr_pure t1 t2 - then Eop (Ororimm n2) (t1:::Enil) - else Eop Oor (e1:::e2:::Enil) - | or_case4 n2 t2 n1 t1 => - if Int.eq (Int.add n1 n2) Int.iwordsize - && same_expr_pure t1 t2 - then Eop (Ororimm n2) (t1:::Enil) - else Eop Oor (e1:::e2:::Enil) - | or_default e1 e2 => - Eop Oor (e1:::e2:::Enil) - end. - -Definition andimm (n: int) (e: expr) := - if Int.eq n Int.zero then Eop (Ointconst Int.zero) Enil - else if Int.eq n Int.mone then e - else Eop (Oandimm n) (e:::Enil). - -Definition and (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => - andimm n1 t2 - | mul_case2 t1 n2 => - andimm n2 t1 - | mul_default e1 e2 => - Eop Oand (e1:::e2:::Enil) - end. - -Definition xorimm (n: int) (e: expr) := - if Int.eq n Int.zero then e - else Eop (Oxorimm n) (e:::Enil). - -Definition xor (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => - xorimm n1 t2 - | mul_case2 t1 n2 => - xorimm n2 t1 - | mul_default e1 e2 => - Eop Oxor (e1:::e2:::Enil) - end. - -(** ** General shifts *) - -Inductive shift_cases: forall (e1: expr), Type := - | shift_case1: - forall (n2: int), - shift_cases (Eop (Ointconst n2) Enil) - | shift_default: - forall (e1: expr), - shift_cases e1. - -Definition shift_match (e1: expr) := - match e1 as z1 return shift_cases z1 with - | Eop (Ointconst n2) Enil => - shift_case1 n2 - | e1 => - shift_default e1 - end. - -Definition shl (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shlimm e1 n2 - | shift_default e2 => - Eop Oshl (e1:::e2:::Enil) - end. - -Definition shru (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shruimm e1 n2 - | shift_default e2 => - Eop Oshru (e1:::e2:::Enil) - end. - -Definition shr (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shrimm e1 n2 - | shift_default e2 => - Eop Oshr (e1:::e2:::Enil) - end. - -(** ** Comparisons *) - -Inductive comp_cases: forall (e1: expr) (e2: expr), Type := - | comp_case1: - forall n1 t2, - comp_cases (Eop (Ointconst n1) Enil) (t2) - | comp_case2: - forall t1 n2, - comp_cases (t1) (Eop (Ointconst n2) Enil) - | comp_default: - forall (e1: expr) (e2: expr), - comp_cases e1 e2. - -Definition comp_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return comp_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - comp_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => - comp_case2 t1 n2 - | e1, e2 => - comp_default e1 e2 - end. - -Definition comp (c: comparison) (e1: expr) (e2: expr) := - match comp_match e1 e2 with - | comp_case1 n1 t2 => - Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2 ::: Enil) - | comp_case2 t1 n2 => - Eop (Ocmp (Ccompimm c n2)) (t1 ::: Enil) - | comp_default e1 e2 => - Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) - end. - -Definition compu (c: comparison) (e1: expr) (e2: expr) := - match comp_match e1 e2 with - | comp_case1 n1 t2 => - Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2 ::: Enil) - | comp_case2 t1 n2 => - Eop (Ocmp (Ccompuimm c n2)) (t1 ::: Enil) - | comp_default e1 e2 => - Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) - end. - -Definition compf (c: comparison) (e1: expr) (e2: expr) := - Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). - -(** ** Other operators, not optimized. *) - -Definition cast8unsigned (e: expr) := Eop Ocast8unsigned (e ::: Enil). -Definition cast8signed (e: expr) := Eop Ocast8signed (e ::: Enil). -Definition cast16unsigned (e: expr) := Eop Ocast16unsigned (e ::: Enil). -Definition cast16signed (e: expr) := Eop Ocast16signed (e ::: Enil). -Definition divu (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). -Definition modu (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). -Definition divs (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). -Definition mods (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). -Definition negint (e: expr) := Eop Oneg (e ::: Enil). -Definition notint (e: expr) := Eop (Oxorimm Int.mone) (e ::: Enil). -Definition negf (e: expr) := Eop Onegf (e ::: Enil). -Definition absf (e: expr) := Eop Oabsf (e ::: Enil). -Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). -Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). -Definition floatofint (e: expr) := Eop Ofloatofint (e ::: Enil). -Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). -Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). -Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). -Definition divf (e1 e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil). - -(** ** Conversions between unsigned ints and floats *) - -Definition intuoffloat (e: expr) := - let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in - Elet e - (Econdition (CEcond (Ccompf Clt) (Eletvar O ::: f ::: Enil)) - (intoffloat (Eletvar O)) - (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar O) f)))). - -Definition floatofintu (e: expr) := - let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in - Elet e - (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil)) - (floatofint (Eletvar O)) - (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f)). - -(** ** Addressing modes *) - -(* -Definition addressing (e: expr) := - match e with - | Eop (Olea addr) args => (addr, args) - | _ => (Aindexed Int.zero, e:::Enil) - end. -*) - -Inductive addressing_cases: forall (e: expr), Type := - | addressing_case1: - forall addr args, - addressing_cases (Eop (Olea addr) args) - | addressing_default: - forall (e: expr), - addressing_cases e. - -Definition addressing_match (e: expr) := - match e as z1 return addressing_cases z1 with - | Eop (Olea addr) args => - addressing_case1 addr args - | e => - addressing_default e - end. - -Definition addressing (chunk: memory_chunk) (e: expr) := - match addressing_match e with - | addressing_case1 addr args => - (addr, args) - | addressing_default e => - (Aindexed Int.zero, e:::Enil) - end. - diff --git a/ia32/SelectOp.vp b/ia32/SelectOp.vp new file mode 100644 index 0000000..71dc83b --- /dev/null +++ b/ia32/SelectOp.vp @@ -0,0 +1,416 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for operators *) + +(** The instruction selection pass recognizes opportunities for using + combined arithmetic and logical operations and addressing modes + offered by the target processor. For instance, the expression [x + 1] + can take advantage of the "immediate add" instruction of the processor, + and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned + into a "rotate and mask" instruction. + + This file defines functions for building CminorSel expressions and + statements, especially expressions consisting of operator + applications. These functions examine their arguments to choose + cheaper forms of operators whenever possible. + + For instance, [add e1 e2] will return a CminorSel expression semantically + equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a + [Oaddimm] operator if one of the arguments is an integer constant, + or suppress the addition altogether if one of the arguments is the + null integer. In passing, we perform operator reassociation + ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount + of constant propagation. + + On top of the "smart constructor" functions defined below, + module [Selection] implements the actual instruction selection pass. +*) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Cminor. +Require Import Op. +Require Import CminorSel. + +Open Local Scope cminorsel_scope. + +(** ** Constants **) + +Definition addrsymbol (id: ident) (ofs: int) := + Eop (Olea (Aglobal id ofs)) Enil. + +Definition addrstack (ofs: int) := + Eop (Olea (Ainstack ofs)) Enil. + +(** ** Integer logical negation *) + +Definition notint (e: expr) := Eop (Oxorimm Int.mone) (e ::: Enil). + +(** ** Boolean negation *) + +Fixpoint notbool (e: expr) {struct e} : expr := + let default := Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil) in + match e with + | Eop (Ointconst n) Enil => + Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil + | Eop (Ocmp cond) args => + Eop (Ocmp (negate_condition cond)) args + | Econdition e1 e2 e3 => + Econdition e1 (notbool e2) (notbool e3) + | _ => + default + end. + +(** ** Integer addition and pointer addition *) + +Definition offset_addressing (a: addressing) (ofs: int) : addressing := + match a with + | Aindexed n => Aindexed (Int.add n ofs) + | Aindexed2 n => Aindexed2 (Int.add n ofs) + | Ascaled sc n => Ascaled sc (Int.add n ofs) + | Aindexed2scaled sc n => Aindexed2scaled sc (Int.add n ofs) + | Aglobal id n => Aglobal id (Int.add n ofs) + | Abased id n => Abased id (Int.add n ofs) + | Abasedscaled sc id n => Abasedscaled sc id (Int.add n ofs) + | Ainstack n => Ainstack (Int.add n ofs) + end. + +Nondetfunction addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else + match e with + | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil + | Eop (Olea addr) args => Eop (Olea (offset_addressing addr n)) args + | _ => Eop (Olea (Aindexed n)) (e ::: Enil) + end. + +Nondetfunction add (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 + | t1, Eop (Ointconst n2) Enil => addimm n2 t1 + | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => + Eop (Olea (Aindexed2 (Int.add n1 n2))) (t1:::t2:::Enil) + | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => + Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t1:::t2:::Enil) + | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => + Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t2:::t1:::Enil) + | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => + Eop (Olea (Abased id (Int.add ofs n1))) (t1:::Enil) + | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Aindexed n2)) (t2:::Enil) => + Eop (Olea (Abased id (Int.add ofs n2))) (t2:::Enil) + | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => + Eop (Olea (Abasedscaled sc id (Int.add ofs n1))) (t1:::Enil) + | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Ascaled sc n2)) (t2:::Enil) => + Eop (Olea (Abasedscaled sc id (Int.add ofs n2))) (t2:::Enil) + | Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 => + Eop (Olea (Aindexed2scaled sc n)) (t2:::t1:::Enil) + | t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) => + Eop (Olea (Aindexed2scaled sc n)) (t1:::t2:::Enil) + | Eop (Olea (Aindexed n)) (t1:::Enil), t2 => + Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) + | t1, Eop (Olea (Aindexed n)) (t2:::Enil) => + Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) + | _, _ => + Eop (Olea (Aindexed2 Int.zero)) (e1:::e2:::Enil) + end. + +(** ** Integer and pointer subtraction *) + +Nondetfunction sub (e1: expr) (e2: expr) := + match e1, e2 with + | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1 + | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 => + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) => + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | _, _ => + Eop Osub (e1:::e2:::Enil) + end. + +Definition negint (e: expr) := Eop Oneg (e ::: Enil). + +(** ** Immediate shifts *) + +Definition shift_is_scale (n: int) : bool := + Int.eq n (Int.repr 1) || Int.eq n (Int.repr 2) || Int.eq n (Int.repr 3). + +Nondetfunction shlimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else + match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst(Int.shl n1 n)) Enil + | Eop (Oshlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshlimm n) (e1:::Enil) + | Eop (Olea (Aindexed n1)) (t1:::Enil) => + if shift_is_scale n + then Eop (Olea (Ascaled (Int.shl Int.one n) (Int.shl n1 n))) (t1:::Enil) + else Eop (Oshlimm n) (e1:::Enil) + | _ => + if shift_is_scale n + then Eop (Olea (Ascaled (Int.shl Int.one n) Int.zero)) (e1:::Enil) + else Eop (Oshlimm n) (e1:::Enil) + end. + +Nondetfunction shruimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else + match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst(Int.shru n1 n)) Enil + | Eop (Oshruimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshruimm n) (e1:::Enil) + | _ => + Eop (Oshruimm n) (e1:::Enil) + end. + +Nondetfunction shrimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else + match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst(Int.shr n1 n)) Enil + | Eop (Oshrimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrimm n) (e1:::Enil) + | _ => + Eop (Oshrimm n) (e1:::Enil) + end. + +(** ** Integer multiply *) + +Definition mulimm_base (n1: int) (e2: expr) := + match Int.one_bits n1 with + | i :: nil => + shlimm e2 i + | i :: j :: nil => + Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) + | _ => + Eop (Omulimm n1) (e2:::Enil) + end. + +Nondetfunction mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.one then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst(Int.mul n1 n2)) Enil + | Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | _ => mulimm_base n1 e2 + end. + +Nondetfunction mul (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 + | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 + | _, _ => Eop Omul (e1:::e2:::Enil) + end. + +(** ** Bitwise and, or, xor *) + +Nondetfunction andimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.mone then e2 + else match e2 with + | Eop (Ointconst n2) Enil => + Eop (Ointconst (Int.and n1 n2)) Enil + | Eop (Oandimm n2) (t2:::Enil) => + Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | Eop Ocast8unsigned (t2:::Enil) => + Eop (Oandimm (Int.and n1 (Int.repr 255))) (t2:::Enil) + | Eop Ocast16unsigned (t2:::Enil) => + Eop (Oandimm (Int.and n1 (Int.repr 65535))) (t2:::Enil) + | _ => + Eop (Oandimm n1) (e2:::Enil) + end. + +Nondetfunction and (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 + | t1, Eop (Ointconst n2) Enil => andimm n2 t1 + | _, _ => Eop Oand (e1:::e2:::Enil) + end. + +Nondetfunction orimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 + else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil + else match e2 with + | Eop (Ointconst n2) Enil => + Eop (Ointconst (Int.or n1 n2)) Enil + | Eop (Oorimm n2) (t2:::Enil) => + Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | _ => + Eop (Oorimm n1) (e2:::Enil) + end. + +Definition same_expr_pure (e1 e2: expr) := + match e1, e2 with + | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false + | _, _ => false + end. + +Nondetfunction or (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 + | t1, Eop (Ointconst n2) Enil => orimm n2 t1 + | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => + if Int.eq (Int.add n1 n2) Int.iwordsize + && same_expr_pure t1 t2 + then Eop (Ororimm n2) (t1:::Enil) + else Eop Oor (e1:::e2:::Enil) + | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => + if Int.eq (Int.add n1 n2) Int.iwordsize + && same_expr_pure t1 t2 + then Eop (Ororimm n2) (t1:::Enil) + else Eop Oor (e1:::e2:::Enil) + | _, _ => + Eop Oor (e1:::e2:::Enil) + end. + +Nondetfunction xorimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 + else match e2 with + | Eop (Ointconst n2) Enil => + Eop (Ointconst (Int.xor n1 n2)) Enil + | Eop (Oxorimm n2) (t2:::Enil) => + Eop (Oxorimm (Int.xor n1 n2)) (t2:::Enil) + | _ => + Eop (Oxorimm n1) (e2:::Enil) + end. + +Nondetfunction xor (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2 + | t1, Eop (Ointconst n2) Enil => xorimm n2 t1 + | _, _ => Eop Oxor (e1:::e2:::Enil) + end. + +(** ** Integer division and modulus *) + +Definition divu (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). +Definition modu (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). +Definition divs (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). +Definition mods (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). + +(** ** General shifts *) + +Nondetfunction shl (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shlimm e1 n2 + | _ => Eop Oshl (e1:::e2:::Enil) + end. + +Nondetfunction shr (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shrimm e1 n2 + | _ => Eop Oshr (e1:::e2:::Enil) + end. + +Nondetfunction shru (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shruimm e1 n2 + | _ => Eop Oshru (e1:::e2:::Enil) + end. + +(** ** Floating-point arithmetic *) + +Definition negf (e: expr) := Eop Onegf (e ::: Enil). +Definition absf (e: expr) := Eop Oabsf (e ::: Enil). +Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). +Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). +Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). +Definition divf (e1 e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil). + +(** ** Comparisons *) + +Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2 ::: Enil) + | t1, Eop (Ointconst n2) Enil => + Eop (Ocmp (Ccompimm c n2)) (t1 ::: Enil) + | _, _ => + Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) + end. + +Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2 ::: Enil) + | t1, Eop (Ointconst n2) Enil => + Eop (Ocmp (Ccompuimm c n2)) (t1 ::: Enil) + | _, _ => + Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) + end. + +Definition compf (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). + +(** ** Integer conversions *) + +Nondetfunction cast8unsigned (e: expr) := + match e with + | Eop (Oandimm n) (t:::Enil) => + Eop (Oandimm (Int.and (Int.repr 255) n)) (t:::Enil) + | _ => + Eop Ocast8unsigned (e:::Enil) + end. + +Definition cast8signed (e: expr) := Eop Ocast8signed (e ::: Enil). + +Nondetfunction cast16unsigned (e: expr) := + match e with + | Eop (Oandimm n) (t:::Enil) => + Eop (Oandimm (Int.and (Int.repr 65535) n)) (t:::Enil) + | _ => + Eop Ocast16unsigned (e:::Enil) + end. + +Definition cast16signed (e: expr) := Eop Ocast16signed (e ::: Enil). + +(** Floating-point conversions *) + +Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). +Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). +Definition floatofint (e: expr) := Eop Ofloatofint (e ::: Enil). + +Definition intuoffloat (e: expr) := + let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in + Elet e + (Econdition (CEcond (Ccompf Clt) (Eletvar O ::: f ::: Enil)) + (intoffloat (Eletvar O)) + (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar O) f)))). + +Definition floatofintu (e: expr) := + let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in + Elet e + (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil)) + (floatofint (Eletvar O)) + (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f)). + +(** ** Addressing modes *) + +Nondetfunction addressing (chunk: memory_chunk) (e: expr) := + match e with + | Eop (Olea addr) args => (addr, args) + | _ => (Aindexed Int.zero, e:::Enil) + end. + diff --git a/ia32/SelectOpproof.v b/ia32/SelectOpproof.v index 82bca26..f14b6a9 100644 --- a/ia32/SelectOpproof.v +++ b/ia32/SelectOpproof.v @@ -44,8 +44,6 @@ Variable m: mem. Ltac EvalOp := eapply eval_Eop; eauto with evalexpr. -Ltac TrivialOp cstr := unfold cstr; intros; EvalOp. - Ltac InvEval1 := match goal with | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => @@ -78,6 +76,12 @@ Ltac InvEval2 := Ltac InvEval := InvEval1; InvEval2; InvEval2. +Ltac TrivialExists := + match goal with + | [ |- exists v, _ /\ Val.lessdef ?a v ] => exists a; split; [EvalOp | auto] + end. + + (** * Correctness of the smart constructors *) (** We now show that the code generated by "smart constructor" functions @@ -100,66 +104,70 @@ Ltac InvEval := InvEval1; InvEval2; InvEval2. by the smart constructor. *) +Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. + +Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := + forall le a x b y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. + Theorem eval_addrsymbol: - forall le id ofs b, - Genv.find_symbol ge id = Some b -> - eval_expr ge sp e m le (addrsymbol id ofs) (Vptr b ofs). + forall le id ofs, + exists v, eval_expr ge sp e m le (addrsymbol id ofs) v /\ Val.lessdef (symbol_address ge id ofs) v. Proof. - intros. unfold addrsymbol. econstructor. constructor. - simpl. rewrite H. auto. + intros. unfold addrsymbol. econstructor; split. + EvalOp. simpl; eauto. + auto. Qed. Theorem eval_addrstack: - forall le ofs b n, - sp = Vptr b n -> - eval_expr ge sp e m le (addrstack ofs) (Vptr b (Int.add n ofs)). + forall le ofs, + exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.add sp (Vint ofs)) v. Proof. - intros. unfold addrstack. econstructor. constructor. - simpl. unfold offset_sp. rewrite H. auto. + intros. unfold addrstack. econstructor; split. + EvalOp. simpl; eauto. + auto. Qed. -Lemma eval_notbool_base: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_expr ge sp e m le (notbool_base a) (Val.of_bool (negb b)). -Proof. - TrivialOp notbool_base. simpl. - inv H0. - rewrite Int.eq_false; auto. - rewrite Int.eq_true; auto. - reflexivity. +Theorem eval_notint: unary_constructor_sound notint Val.notint. +Proof. + unfold notint; red; intros. TrivialExists. Qed. -Hint Resolve Val.bool_of_true_val Val.bool_of_false_val - Val.bool_of_true_val_inv Val.bool_of_false_val_inv: valboolof. - -Theorem eval_notbool: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_expr ge sp e m le (notbool a) (Val.of_bool (negb b)). +Theorem eval_notbool: unary_constructor_sound notbool Val.notbool. Proof. - induction a; simpl; intros; try (eapply eval_notbool_base; eauto). - destruct o; try (eapply eval_notbool_base; eauto). - - destruct e0. InvEval. - inv H0. rewrite Int.eq_false; auto. - simpl; eauto with evalexpr. - rewrite Int.eq_true; simpl; eauto with evalexpr. - eapply eval_notbool_base; eauto. + assert (DFL: + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (Eop (Ocmp (Ccompuimm Ceq Int.zero)) (a ::: Enil)) v + /\ Val.lessdef (Val.notbool x) v). + intros. TrivialExists. simpl. destruct x; simpl; auto. - inv H. eapply eval_Eop; eauto. - 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). - destruct b; reflexivity. + red. induction a; simpl; intros; eauto. destruct o; eauto. +(* intconst *) + destruct e0; eauto. InvEval. TrivialExists. simpl. destruct (Int.eq i Int.zero); auto. +(* cmp *) + inv H. simpl in H5. + destruct (eval_condition c vl m) as []_eqn. + TrivialExists. simpl. rewrite (eval_negate_condition _ _ _ Heqo). destruct b; inv H5; auto. + inv H5. simpl. + destruct (eval_condition (negate_condition c) vl m) as []_eqn. + destruct b; [exists Vtrue | exists Vfalse]; split; auto; EvalOp; simpl. rewrite Heqo0; auto. rewrite Heqo0; auto. + exists Vundef; split; auto; EvalOp; simpl. rewrite Heqo0; auto. +(* condition *) + inv H. destruct v1. + exploit IHa1; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. + exploit IHa2; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. +Qed. - inv H. eapply eval_Econdition; eauto. - destruct v1; eauto. +Lemma shift_symbol_address: + forall id ofs n, symbol_address ge id (Int.add ofs n) = Val.add (symbol_address ge id ofs) (Vint n). +Proof. + intros. unfold symbol_address. destruct (Genv.find_symbol); auto. Qed. Lemma eval_offset_addressing: @@ -168,322 +176,247 @@ Lemma eval_offset_addressing: eval_addressing ge sp (offset_addressing addr n) args = Some (Val.add v (Vint n)). Proof. intros. destruct addr; simpl in *; FuncInv; subst; simpl. - rewrite Int.add_assoc. auto. - rewrite Int.add_assoc. auto. - rewrite <- Int.add_assoc. auto. - rewrite <- Int.add_assoc. auto. - rewrite <- Int.add_assoc. auto. - rewrite <- Int.add_assoc. auto. - rewrite <- Int.add_assoc. decEq. decEq. repeat rewrite Int.add_assoc. auto. - decEq. decEq. repeat rewrite Int.add_assoc. auto. - destruct (Genv.find_symbol ge i); inv H. auto. - destruct (Genv.find_symbol ge i); inv H. simpl. - repeat rewrite Int.add_assoc. decEq. decEq. decEq. apply Int.add_commut. - destruct (Genv.find_symbol ge i0); inv H. simpl. - repeat rewrite Int.add_assoc. decEq. decEq. decEq. apply Int.add_commut. - unfold offset_sp in *. destruct sp; inv H. simpl. rewrite Int.add_assoc. auto. + rewrite Val.add_assoc. auto. + repeat rewrite Val.add_assoc. auto. + rewrite Val.add_assoc. auto. + repeat rewrite Val.add_assoc. auto. + rewrite shift_symbol_address. auto. + rewrite shift_symbol_address. repeat rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. + rewrite shift_symbol_address. repeat rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. + rewrite Val.add_assoc. auto. Qed. Theorem eval_addimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (addimm n a) (Vint (Int.add x n)). -Proof. - unfold addimm; intros until x. - generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. - subst n. rewrite Int.add_zero. auto. - case (addimm_match a); intros; InvEval. - EvalOp. simpl. rewrite Int.add_commut. auto. - inv H0. EvalOp. simpl. rewrite (eval_offset_addressing _ _ _ _ H6). auto. - EvalOp. -Qed. - -Theorem eval_addimm_ptr: - forall le n a b ofs, - eval_expr ge sp e m le a (Vptr b ofs) -> - eval_expr ge sp e m le (addimm n a) (Vptr b (Int.add ofs n)). -Proof. - unfold addimm; intros until ofs. - generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. - subst n. rewrite Int.add_zero. auto. - case (addimm_match a); intros; InvEval. - inv H0. EvalOp. simpl. rewrite (eval_offset_addressing _ _ _ _ H6). auto. - EvalOp. -Qed. - -Theorem eval_add: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (add a b) (Vint (Int.add x y)). -Proof. - intros until y. + forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)). +Proof. + red; unfold addimm; intros until x. + predSpec Int.eq Int.eq_spec n Int.zero. + subst n. intros. exists x; split; auto. + destruct x; simpl; auto. rewrite Int.add_zero. auto. rewrite Int.add_zero. auto. + case (addimm_match a); intros; InvEval; simpl. + TrivialExists; simpl. rewrite Int.add_commut. auto. + inv H0. simpl in H6. TrivialExists. simpl. eapply eval_offset_addressing; eauto. + TrivialExists. +Qed. + +Theorem eval_add: binary_constructor_sound add Val.add. +Proof. + red; intros until y. unfold add; case (add_match a b); intros; InvEval. - rewrite Int.add_commut. apply eval_addimm. auto. - apply eval_addimm. auto. - subst. EvalOp. simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - subst. EvalOp. simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - subst. EvalOp. simpl. decEq. decEq. - rewrite Int.add_permut. rewrite Int.add_assoc. decEq. apply Int.add_permut. - destruct (Genv.find_symbol ge id); inv H0. - destruct (Genv.find_symbol ge id); inv H0. - destruct (Genv.find_symbol ge id); inv H0. - destruct (Genv.find_symbol ge id); inv H0. - subst. EvalOp. simpl. rewrite Int.add_commut. auto. - subst. EvalOp. - subst. EvalOp. simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. EvalOp. simpl. decEq. decEq. apply Int.add_assoc. - EvalOp. simpl. rewrite Int.add_zero. auto. -Qed. - -Theorem eval_add_ptr: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (add a b) (Vptr p (Int.add x y)). -Proof. - intros until y. unfold add; case (add_match a b); intros; InvEval. - apply eval_addimm_ptr; auto. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - destruct (Genv.find_symbol ge id); inv H0. - subst. EvalOp; simpl. destruct (Genv.find_symbol ge id); inv H0. - decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. EvalOp; simpl. destruct (Genv.find_symbol ge id); inv H0. - decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. EvalOp. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. auto. - EvalOp; simpl. rewrite Int.add_zero. auto. -Qed. - -Theorem eval_add_ptr_2: - forall le a b x p y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vptr p y) -> - eval_expr ge sp e m le (add a b) (Vptr p (Int.add y x)). -Proof. - intros until y. unfold add; case (add_match a b); intros; InvEval. - apply eval_addimm_ptr; auto. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. - rewrite (Int.add_commut n1 n2). apply Int.add_permut. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. - rewrite (Int.add_commut n1 n2). apply Int.add_permut. - subst. EvalOp; simpl. destruct (Genv.find_symbol ge id); inv H0. - decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut. - destruct (Genv.find_symbol ge id); inv H0. - subst. EvalOp; simpl. destruct (Genv.find_symbol ge id); inv H0. - decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. EvalOp. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. auto. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - EvalOp; simpl. rewrite Int.add_zero. auto. -Qed. - -Theorem eval_sub: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - rewrite Int.sub_add_opp. - apply eval_addimm. assumption. - replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm. EvalOp. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm. EvalOp. - subst x. rewrite Int.sub_add_l. auto. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm. EvalOp. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. -Qed. - -Theorem eval_sub_ptr_int: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (sub a b) (Vptr p (Int.sub x y)). -Proof. - intros until y. + rewrite Val.add_commut. apply eval_addimm; auto. + apply eval_addimm; auto. + subst. TrivialExists. simpl. rewrite Val.add_permut_4. auto. + subst. TrivialExists. simpl. rewrite Val.add_assoc. decEq; decEq. rewrite Val.add_permut. auto. + subst. TrivialExists. simpl. rewrite Val.add_permut_4. rewrite <- Val.add_permut. rewrite <- Val.add_assoc. auto. + subst. TrivialExists. simpl. rewrite shift_symbol_address. + rewrite Val.add_commut. rewrite Val.add_assoc. decEq. decEq. apply Val.add_commut. + subst. TrivialExists. simpl. rewrite shift_symbol_address. rewrite Val.add_assoc. + decEq; decEq. apply Val.add_commut. + subst. TrivialExists. simpl. rewrite shift_symbol_address. rewrite Val.add_commut. + rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. + subst. TrivialExists. simpl. rewrite shift_symbol_address. + rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. + subst. TrivialExists. simpl. rewrite Val.add_permut. rewrite Val.add_assoc. + decEq; decEq. apply Val.add_commut. + subst. TrivialExists. + subst. TrivialExists. simpl. repeat rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. + subst. TrivialExists. simpl. rewrite Val.add_assoc; auto. + TrivialExists. simpl. destruct x; destruct y; simpl; auto; rewrite Int.add_zero; auto. +Qed. + +Theorem eval_sub: binary_constructor_sound sub Val.sub. +Proof. + red; intros until y. unfold sub; case (sub_match a b); intros; InvEval. - rewrite Int.sub_add_opp. - apply eval_addimm_ptr. assumption. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm_ptr. EvalOp. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm_ptr. EvalOp. - subst x. rewrite Int.sub_add_l. auto. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm_ptr. EvalOp. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. -Qed. - -Theorem eval_sub_ptr_ptr: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vptr p y) -> - eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm. EvalOp. - simpl; unfold eq_block. subst b0; subst b1; rewrite zeq_true. auto. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm. EvalOp. - simpl. unfold eq_block. rewrite zeq_true. auto. - subst x. rewrite Int.sub_add_l. auto. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm. EvalOp. - simpl. unfold eq_block. rewrite zeq_true. auto. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. simpl. unfold eq_block. rewrite zeq_true. auto. + rewrite Val.sub_add_opp. apply eval_addimm; auto. + subst. rewrite Val.sub_add_l. rewrite Val.sub_add_r. + rewrite Val.add_assoc. simpl. rewrite Int.add_commut. rewrite <- Int.sub_add_opp. + apply eval_addimm; EvalOp. + subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp. + subst. rewrite Val.sub_add_r. apply eval_addimm; EvalOp. + TrivialExists. +Qed. + +Theorem eval_negint: unary_constructor_sound negint (fun v => Val.sub Vzero v). +Proof. + red; intros. unfold negint. TrivialExists. Qed. Theorem eval_shlimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n Int.iwordsize = true -> - eval_expr ge sp e m le (shlimm a n) (Vint (Int.shl x n)). -Proof. - intros until x; unfold shlimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero). - intros. subst n. rewrite Int.shl_zero. auto. - case (shlimm_match a); intros. - InvEval. EvalOp. - case_eq (Int.ltu (Int.add n n1) Int.iwordsize); intros. - InvEval. revert H8. case_eq (Int.ltu n1 Int.iwordsize); intros; inv H8. - EvalOp. simpl. rewrite H2. rewrite Int.shl_shl; auto; rewrite Int.add_commut; auto. - EvalOp. simpl. rewrite H1; auto. - InvEval. subst. - destruct (shift_is_scale n). - EvalOp. simpl. decEq. decEq. - rewrite (Int.shl_mul (Int.add i n1)); auto. rewrite (Int.shl_mul n1); auto. - rewrite Int.mul_add_distr_l. auto. - EvalOp. constructor. EvalOp. simpl. eauto. constructor. simpl. rewrite H1. auto. + forall n, unary_constructor_sound (fun a => shlimm a n) + (fun x => Val.shl x (Vint n)). +Proof. + red; intros until x. unfold shlimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shl_zero; auto. + destruct (shlimm_match a); intros; InvEval. + exists (Vint (Int.shl n1 n)); split. EvalOp. + simpl. destruct (Int.ltu n Int.iwordsize); auto. + destruct (Int.ltu (Int.add n n1) Int.iwordsize) as []_eqn. + exists (Val.shl v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) as []_eqn; simpl; auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; simpl; auto. + rewrite Int.add_commut. rewrite Int.shl_shl; auto. rewrite Int.add_commut; auto. + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + subst. destruct (shift_is_scale n). + econstructor; split. EvalOp. simpl. eauto. + destruct v1; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + rewrite Int.shl_mul. rewrite Int.mul_add_distr_l. rewrite (Int.shl_mul n1). auto. + TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. auto. destruct (shift_is_scale n). - EvalOp. simpl. decEq. decEq. - rewrite Int.add_zero. symmetry. apply Int.shl_mul. - EvalOp. simpl. rewrite H1; auto. + econstructor; split. EvalOp. simpl. eauto. + destruct x; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + rewrite Int.add_zero. rewrite Int.shl_mul. auto. + TrivialExists. Qed. Theorem eval_shruimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n Int.iwordsize = true -> - eval_expr ge sp e m le (shruimm a n) (Vint (Int.shru x n)). -Proof. - intros until x; unfold shruimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero). - intros. subst n. rewrite Int.shru_zero. auto. - case (shruimm_match a); intros. - InvEval. EvalOp. - case_eq (Int.ltu (Int.add n n1) Int.iwordsize); intros. - InvEval. revert H8. case_eq (Int.ltu n1 Int.iwordsize); intros; inv H8. - EvalOp. simpl. rewrite H2. rewrite Int.shru_shru; auto; rewrite Int.add_commut; auto. - EvalOp. simpl. rewrite H1; auto. - EvalOp. simpl. rewrite H1; auto. + forall n, unary_constructor_sound (fun a => shruimm a n) + (fun x => Val.shru x (Vint n)). +Proof. + red; intros until x. unfold shruimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto. + destruct (shruimm_match a); intros; InvEval. + exists (Vint (Int.shru n1 n)); split. EvalOp. + simpl. destruct (Int.ltu n Int.iwordsize); auto. + destruct (Int.ltu (Int.add n n1) Int.iwordsize) as []_eqn. + exists (Val.shru v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) as []_eqn; simpl; auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; simpl; auto. + rewrite Int.add_commut. rewrite Int.shru_shru; auto. rewrite Int.add_commut; auto. + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + TrivialExists. Qed. Theorem eval_shrimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n Int.iwordsize = true -> - eval_expr ge sp e m le (shrimm a n) (Vint (Int.shr x n)). -Proof. - intros until x; unfold shrimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero). - intros. subst n. rewrite Int.shr_zero. auto. - case (shrimm_match a); intros. - InvEval. EvalOp. - case_eq (Int.ltu (Int.add n n1) Int.iwordsize); intros. - InvEval. revert H8. case_eq (Int.ltu n1 Int.iwordsize); intros; inv H8. - EvalOp. simpl. rewrite H2. rewrite Int.shr_shr; auto; rewrite Int.add_commut; auto. - EvalOp. simpl. rewrite H1; auto. - EvalOp. simpl. rewrite H1; auto. + forall n, unary_constructor_sound (fun a => shrimm a n) + (fun x => Val.shr x (Vint n)). +Proof. + red; intros until x. unfold shrimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto. + destruct (shrimm_match a); intros; InvEval. + exists (Vint (Int.shr n1 n)); split. EvalOp. + simpl. destruct (Int.ltu n Int.iwordsize); auto. + destruct (Int.ltu (Int.add n n1) Int.iwordsize) as []_eqn. + exists (Val.shr v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) as []_eqn; simpl; auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; simpl; auto. + rewrite Int.add_commut. rewrite Int.shr_shr; auto. rewrite Int.add_commut; auto. + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + TrivialExists. Qed. Lemma eval_mulimm_base: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (mulimm_base n a) (Vint (Int.mul x n)). + forall n, unary_constructor_sound (mulimm_base n) (fun x => Val.mul x (Vint n)). Proof. - intros; unfold mulimm_base. + intros; red; intros; unfold mulimm_base. generalize (Int.one_bits_decomp n). generalize (Int.one_bits_range n). destruct (Int.one_bits n). - intros. EvalOp. + intros. TrivialExists. destruct l. intros. rewrite H1. simpl. - rewrite Int.add_zero. rewrite <- Int.shl_mul. - apply eval_shlimm. auto. auto with coqlib. + rewrite Int.add_zero. + replace (Vint (Int.shl Int.one i)) with (Val.shl Vone (Vint i)). rewrite Val.shl_mul. + apply eval_shlimm. auto. simpl. rewrite H0; auto with coqlib. destruct l. - intros. apply eval_Elet with (Vint x). auto. - rewrite H1. simpl. rewrite Int.add_zero. - rewrite Int.mul_add_distr_r. - apply eval_add. - rewrite <- Int.shl_mul. apply eval_shlimm. constructor. auto. auto with coqlib. - rewrite <- Int.shl_mul. apply eval_shlimm. constructor. auto. auto with coqlib. - intros. EvalOp. + intros. rewrite H1. simpl. + exploit (eval_shlimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]]. + exploit (eval_shlimm i0 (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]]. + exploit eval_add. eexact A1. eexact A2. intros [v3 [A3 B3]]. + exists v3; split. econstructor; eauto. + rewrite Int.add_zero. + replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one i0))) + with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint i0))). + rewrite Val.mul_add_distr_r. + repeat rewrite Val.shl_mul. + apply Val.lessdef_trans with (Val.add v1 v2); auto. apply Val.add_lessdef; auto. + simpl. repeat rewrite H0; auto with coqlib. + intros. TrivialExists. Qed. Theorem eval_mulimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (mulimm n a) (Vint (Int.mul x n)). -Proof. - intros until x; unfold mulimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.mul_zero. intros. EvalOp. - generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intro. - subst n. rewrite Int.mul_one. auto. + forall n, unary_constructor_sound (mulimm n) (fun x => Val.mul x (Vint n)). +Proof. + intros; red; intros until x; unfold mulimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.mul_zero. auto. + predSpec Int.eq Int.eq_spec n Int.one. + intros. exists x; split; auto. + destruct x; simpl; auto. subst n. rewrite Int.mul_one. auto. case (mulimm_match a); intros; InvEval. - EvalOp. rewrite Int.mul_commut. reflexivity. - subst. rewrite Int.mul_add_distr_l. - rewrite (Int.mul_commut n n2). apply eval_addimm. apply eval_mulimm_base. auto. - apply eval_mulimm_base. assumption. + TrivialExists. simpl. rewrite Int.mul_commut; auto. + subst. rewrite Val.mul_add_distr_l. + exploit eval_mulimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]]. + exploit (eval_addimm (Int.mul n n2) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]]. + exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.add_lessdef; eauto. + rewrite Val.mul_commut; auto. + apply eval_mulimm_base; auto. Qed. -Theorem eval_mul: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (mul a b) (Vint (Int.mul x y)). +Theorem eval_mul: binary_constructor_sound mul Val.mul. Proof. - intros until y. + red; intros until y. unfold mul; case (mul_match a b); intros; InvEval. - rewrite Int.mul_commut. apply eval_mulimm. auto. + rewrite Val.mul_commut. apply eval_mulimm. auto. apply eval_mulimm. auto. - EvalOp. + TrivialExists. Qed. -Lemma eval_orimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (orimm n a) (Vint (Int.or x n)). +Theorem eval_andimm: + forall n, unary_constructor_sound (andimm n) (fun x => Val.and x (Vint n)). Proof. - intros. unfold orimm. - predSpec Int.eq Int.eq_spec n Int.zero. - subst n. rewrite Int.or_zero. auto. + intros; red; intros until x. unfold andimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.and_zero. auto. + predSpec Int.eq Int.eq_spec n Int.mone. + intros. exists x; split; auto. + destruct x; simpl; auto. subst n. rewrite Int.and_mone. auto. + case (andimm_match a); intros; InvEval. + TrivialExists. simpl. rewrite Int.and_commut; auto. + subst. TrivialExists. simpl. rewrite Val.and_assoc. rewrite Int.and_commut. auto. + subst. rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. + rewrite Int.and_commut. auto. compute; auto. + subst. rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. + rewrite Int.and_commut. auto. compute; auto. + TrivialExists. +Qed. + +Theorem eval_and: binary_constructor_sound and Val.and. +Proof. + red; intros until y; unfold and; case (and_match a b); intros; InvEval. + rewrite Val.and_commut. apply eval_andimm; auto. + apply eval_andimm; auto. + TrivialExists. +Qed. + +Theorem eval_orimm: + forall n, unary_constructor_sound (orimm n) (fun x => Val.or x (Vint n)). +Proof. + intros; red; intros until x. unfold orimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists x; split. auto. + destruct x; simpl; auto. subst n. rewrite Int.or_zero. auto. predSpec Int.eq Int.eq_spec n Int.mone. - subst n. rewrite Int.or_mone. EvalOp. - EvalOp. + intros. exists (Vint Int.mone); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.or_mone. auto. + destruct (orimm_match a); intros; InvEval. + TrivialExists. simpl. rewrite Int.or_commut; auto. + subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists. + TrivialExists. Qed. Remark eval_same_expr: @@ -501,432 +434,283 @@ Proof. discriminate. Qed. -Theorem eval_or: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (or a b) (Vint (Int.or x y)). -Proof. - intros until y; unfold or; case (or_match a b); intros; InvEval. - - rewrite Int.or_commut. apply eval_orimm; auto. - apply eval_orimm; auto. - - revert H7; case_eq (Int.ltu n1 Int.iwordsize); intros; inv H7. - revert H6; case_eq (Int.ltu n2 Int.iwordsize); intros; inv H6. - caseEq (Int.eq (Int.add n1 n2) Int.iwordsize - && same_expr_pure t1 t2); intro. - destruct (andb_prop _ _ H1). - generalize (Int.eq_spec (Int.add n1 n2) Int.iwordsize); rewrite H4; intros. - exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. - EvalOp. simpl. rewrite H0. rewrite <- Int.or_ror; auto. - EvalOp. econstructor. EvalOp. simpl. rewrite H; eauto. - econstructor. EvalOp. simpl. rewrite H0; eauto. constructor. - simpl. auto. - - revert H7; case_eq (Int.ltu n2 Int.iwordsize); intros; inv H7. - revert H6; case_eq (Int.ltu n1 Int.iwordsize); intros; inv H6. - caseEq (Int.eq (Int.add n1 n2) Int.iwordsize - && same_expr_pure t1 t2); intro. - destruct (andb_prop _ _ H1). - generalize (Int.eq_spec (Int.add n1 n2) Int.iwordsize); rewrite H4; intros. - exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. - EvalOp. simpl. rewrite H. rewrite Int.or_commut. rewrite <- Int.or_ror; auto. - EvalOp. econstructor. EvalOp. simpl. rewrite H; eauto. - econstructor. EvalOp. simpl. rewrite H0; eauto. constructor. - simpl. auto. +Lemma eval_or: binary_constructor_sound or Val.or. +Proof. + red; intros until y; unfold or; case (or_match a b); intros. +(* intconst *) + InvEval. rewrite Val.or_commut. apply eval_orimm; auto. + InvEval. apply eval_orimm; auto. +(* shlimm - shruimm *) + destruct (Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2) as []_eqn. + destruct (andb_prop _ _ Heqb0). + generalize (Int.eq_spec (Int.add n1 n2) Int.iwordsize); rewrite H1; intros EQ. + InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. + exists (Val.ror v0 (Vint n2)); split. EvalOp. + destruct v0; simpl; auto. + destruct (Int.ltu n1 Int.iwordsize) as []_eqn; auto. + destruct (Int.ltu n2 Int.iwordsize) as []_eqn; auto. + simpl. rewrite <- Int.or_ror; auto. + TrivialExists. +(* shruimm - shlimm *) + destruct (Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2) as []_eqn. + destruct (andb_prop _ _ Heqb0). + generalize (Int.eq_spec (Int.add n1 n2) Int.iwordsize); rewrite H1; intros EQ. + InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. + exists (Val.ror v1 (Vint n2)); split. EvalOp. + destruct v1; simpl; auto. + destruct (Int.ltu n2 Int.iwordsize) as []_eqn; auto. + destruct (Int.ltu n1 Int.iwordsize) as []_eqn; auto. + simpl. rewrite Int.or_commut. rewrite <- Int.or_ror; auto. + TrivialExists. +(* default *) + TrivialExists. +Qed. + +Theorem eval_xorimm: + forall n, unary_constructor_sound (xorimm n) (fun x => Val.xor x (Vint n)). +Proof. + intros; red; intros until x. unfold xorimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists x; split. auto. + destruct x; simpl; auto. subst n. rewrite Int.xor_zero. auto. + destruct (xorimm_match a); intros; InvEval. + TrivialExists. simpl. rewrite Int.xor_commut; auto. + subst. rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. TrivialExists. + TrivialExists. +Qed. + +Theorem eval_xor: binary_constructor_sound xor Val.xor. +Proof. + red; intros until y; unfold xor; case (xor_match a b); intros; InvEval. + rewrite Val.xor_commut. apply eval_xorimm; auto. + apply eval_xorimm; auto. + TrivialExists. +Qed. - EvalOp. +Theorem eval_divs: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divs x y = Some z -> + exists v, eval_expr ge sp e m le (divs a b) v /\ Val.lessdef z v. +Proof. + intros. unfold divs. exists z; split. EvalOp. auto. Qed. -Lemma eval_andimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (andimm n a) (Vint (Int.and x n)). +Theorem eval_divu: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divu x y = Some z -> + exists v, eval_expr ge sp e m le (divu a b) v /\ Val.lessdef z v. Proof. - intros. unfold andimm. - predSpec Int.eq Int.eq_spec n Int.zero. - subst n. rewrite Int.and_zero. EvalOp. - predSpec Int.eq Int.eq_spec n Int.mone. - subst n. rewrite Int.and_mone. auto. - EvalOp. + intros. unfold divu. exists z; split. EvalOp. auto. Qed. -Theorem eval_and: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (and a b) (Vint (Int.and x y)). +Theorem eval_mods: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.mods x y = Some z -> + exists v, eval_expr ge sp e m le (mods a b) v /\ Val.lessdef z v. Proof. - intros until y; unfold and. case (mul_match a b); intros. - InvEval. rewrite Int.and_commut. apply eval_andimm; auto. - InvEval. apply eval_andimm; auto. - EvalOp. + intros. unfold mods. exists z; split. EvalOp. auto. Qed. -Lemma eval_xorimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (xorimm n a) (Vint (Int.xor x n)). +Theorem eval_modu: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.modu x y = Some z -> + exists v, eval_expr ge sp e m le (modu a b) v /\ Val.lessdef z v. Proof. - intros. unfold xorimm. - predSpec Int.eq Int.eq_spec n Int.zero. - subst n. rewrite Int.xor_zero. auto. - EvalOp. + intros. unfold modu. exists z; split. EvalOp. auto. Qed. -Theorem eval_xor: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (xor a b) (Vint (Int.xor x y)). +Theorem eval_shl: binary_constructor_sound shl Val.shl. Proof. - intros until y; unfold xor. case (mul_match a b); intros. - InvEval. rewrite Int.xor_commut. apply eval_xorimm; auto. - InvEval. apply eval_xorimm; auto. - EvalOp. + red; intros until y; unfold shl; case (shl_match b); intros. + InvEval. apply eval_shlimm; auto. + TrivialExists. Qed. -Theorem eval_divu: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (divu a b) (Vint (Int.divu x y)). +Theorem eval_shr: binary_constructor_sound shr Val.shr. Proof. - intros; unfold divu; EvalOp. - simpl. rewrite Int.eq_false; auto. + red; intros until y; unfold shr; case (shr_match b); intros. + InvEval. apply eval_shrimm; auto. + TrivialExists. Qed. -Theorem eval_modu: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (modu a b) (Vint (Int.modu x y)). +Theorem eval_shru: binary_constructor_sound shru Val.shru. Proof. - intros; unfold modu; EvalOp. - simpl. rewrite Int.eq_false; auto. + red; intros until y; unfold shru; case (shru_match b); intros. + InvEval. apply eval_shruimm; auto. + TrivialExists. Qed. -Theorem eval_divs: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (divs a b) (Vint (Int.divs x y)). +Theorem eval_negf: unary_constructor_sound negf Val.negf. Proof. - TrivialOp divs. simpl. - predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. + red; intros. TrivialExists. Qed. -Theorem eval_mods: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (mods a b) (Vint (Int.mods x y)). +Theorem eval_absf: unary_constructor_sound absf Val.absf. Proof. - TrivialOp mods. simpl. - predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. + red; intros. TrivialExists. Qed. -Theorem eval_shl: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y Int.iwordsize = true -> - eval_expr ge sp e m le (shl a b) (Vint (Int.shl x y)). +Theorem eval_addf: binary_constructor_sound addf Val.addf. Proof. - intros until y; unfold shl; case (shift_match b); intros. - InvEval. apply eval_shlimm; auto. - EvalOp. simpl. rewrite H1. auto. + red; intros; TrivialExists. +Qed. + +Theorem eval_subf: binary_constructor_sound subf Val.subf. +Proof. + red; intros; TrivialExists. Qed. -Theorem eval_shru: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y Int.iwordsize = true -> - eval_expr ge sp e m le (shru a b) (Vint (Int.shru x y)). +Theorem eval_mulf: binary_constructor_sound mulf Val.mulf. Proof. - intros until y; unfold shru; case (shift_match b); intros. - InvEval. apply eval_shruimm; auto. - EvalOp. simpl. rewrite H1. auto. + red; intros; TrivialExists. Qed. -Theorem eval_shr: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y Int.iwordsize = true -> - eval_expr ge sp e m le (shr a b) (Vint (Int.shr x y)). +Theorem eval_divf: binary_constructor_sound divf Val.divf. Proof. - intros until y; unfold shr; case (shift_match b); intros. - InvEval. apply eval_shrimm; auto. - EvalOp. simpl. rewrite H1. auto. + red; intros; TrivialExists. Qed. 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) -> - eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x y)). -Proof. - intros until y. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. -Qed. - -Theorem eval_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 -> - match eval_compare_null c x with - | Some true => Some Vtrue - | Some false => Some Vfalse - | None => None (A:=val) - end = Some v. -Proof. - unfold Cminor.eval_compare_null, eval_compare_null; intros. - destruct (Int.eq x Int.zero); try discriminate. - destruct c; try discriminate; auto. -Qed. - -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 (compu c a b) v. -Proof. - intros until v. - 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. - -Remark eval_compare_null_swap: - forall c x, - Cminor.eval_compare_null (swap_comparison c) x = - Cminor.eval_compare_null c x. -Proof. - intros. unfold Cminor.eval_compare_null. - destruct (Int.eq x Int.zero). destruct c; auto. auto. -Qed. - -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 (compu c a b) v. -Proof. - intros until v. - 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_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 (compu c a b) (Val.of_bool(Int.cmpu c x2 y2)). -Proof. - intros until y2. - 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_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 (compu c a b) v. -Proof. - intros until y2. - unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto. - destruct c; simpl in H3; inv H3; auto. + forall c, binary_constructor_sound (comp c) (Val.cmp c). +Proof. + intros; red; intros until y. unfold comp; case (comp_match a b); intros; InvEval. + TrivialExists. simpl. rewrite Val.swap_cmp_bool. auto. + TrivialExists. + TrivialExists. Qed. -Theorem eval_compf: - forall le c a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (compf c a b) (Val.of_bool(Float.cmp c x y)). +Theorem eval_compu: + forall c, binary_constructor_sound (compu c) (Val.cmpu (Mem.valid_pointer m) c). Proof. - intros. unfold compf. EvalOp. simpl. - destruct (Float.cmp c x y); reflexivity. + intros; red; intros until y. unfold compu; case (compu_match a b); intros; InvEval. + TrivialExists. simpl. rewrite Val.swap_cmpu_bool. auto. + TrivialExists. + TrivialExists. Qed. -Theorem eval_cast8signed: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v). -Proof. intros; unfold cast8signed; EvalOp. Qed. - -Theorem eval_cast8unsigned: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v). -Proof. intros; unfold cast8unsigned; EvalOp. Qed. - -Theorem eval_cast16signed: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v). -Proof. intros; unfold cast16signed; EvalOp. Qed. +Theorem eval_compf: + forall c, binary_constructor_sound (compf c) (Val.cmpf c). +Proof. + intros; red; intros. unfold compf. TrivialExists. +Qed. -Theorem eval_cast16unsigned: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v). -Proof. intros; unfold cast16unsigned; EvalOp. Qed. -Theorem eval_singleoffloat: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v). -Proof. intros; unfold singleoffloat; EvalOp. Qed. +Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8). +Proof. + red; intros. unfold cast8signed. TrivialExists. +Qed. -Theorem eval_notint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (notint a) (Vint (Int.xor x Int.mone)). -Proof. intros; unfold notint; EvalOp. Qed. +Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). +Proof. + red; intros until x. unfold cast8unsigned. destruct (cast8unsigned_match a); intros; InvEval. + subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc. + rewrite Int.and_commut. TrivialExists. compute; auto. + TrivialExists. +Qed. -Theorem eval_negint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (negint a) (Vint (Int.neg x)). -Proof. intros; unfold negint; EvalOp. Qed. +Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). +Proof. + red; intros. unfold cast16signed. TrivialExists. +Qed. -Theorem eval_negf: - forall le a x, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le (negf a) (Vfloat (Float.neg x)). -Proof. intros; unfold negf; EvalOp. Qed. +Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). +Proof. + red; intros until x. unfold cast16unsigned. destruct (cast16unsigned_match a); intros; InvEval. + subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc. + rewrite Int.and_commut. TrivialExists. compute; auto. + TrivialExists. +Qed. -Theorem eval_absf: - forall le a x, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le (absf a) (Vfloat (Float.abs x)). -Proof. intros; unfold absf; EvalOp. Qed. +Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. +Proof. + red; intros. unfold singleoffloat. TrivialExists. +Qed. Theorem eval_intoffloat: - forall le a x n, - eval_expr ge sp e m le a (Vfloat x) -> - Float.intoffloat x = Some n -> - eval_expr ge sp e m le (intoffloat a) (Vint n). + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v. Proof. - intros; unfold intoffloat; EvalOp. - simpl. rewrite H0. auto. + intros; unfold intoffloat. TrivialExists. Qed. Theorem eval_floatofint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (floatofint a) (Vfloat (Float.floatofint x)). -Proof. intros; unfold floatofint; EvalOp. Qed. - -Theorem eval_addf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (addf a b) (Vfloat (Float.add x y)). -Proof. intros; unfold addf; EvalOp. Qed. - -Theorem eval_subf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (subf a b) (Vfloat (Float.sub x y)). -Proof. intros; unfold subf; EvalOp. Qed. - -Theorem eval_mulf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (mulf a b) (Vfloat (Float.mul x y)). -Proof. intros; unfold mulf; EvalOp. Qed. - -Theorem eval_divf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (divf a b) (Vfloat (Float.div x y)). -Proof. intros; unfold divf; EvalOp. Qed. + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofint x = Some y -> + exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v. +Proof. + intros; unfold floatofint. TrivialExists. +Qed. Theorem eval_intuoffloat: - forall le a x n, - eval_expr ge sp e m le a (Vfloat x) -> - Float.intuoffloat x = Some n -> - eval_expr ge sp e m le (intuoffloat a) (Vint n). -Proof. - intros. unfold intuoffloat. + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intuoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. +Proof. + intros. destruct x; simpl in H0; try discriminate. + destruct (Float.intuoffloat f) as [n|]_eqn; simpl in H0; inv H0. + exists (Vint n); split; auto. + unfold intuoffloat. econstructor. eauto. set (im := Int.repr Int.half_modulus). set (fm := Float.floatofintu im). - assert (eval_expr ge sp e m (Vfloat x :: le) (Eletvar O) (Vfloat x)). + assert (eval_expr ge sp e m (Vfloat f :: le) (Eletvar O) (Vfloat f)). constructor. auto. - apply eval_Econdition with (v1 := Float.cmp Clt x fm). + apply eval_Econdition with (v1 := Float.cmp Clt f fm). econstructor. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. simpl. auto. - caseEq (Float.cmp Clt x fm); intros. + destruct (Float.cmp Clt f fm) as []_eqn. exploit Float.intuoffloat_intoffloat_1; eauto. intro EQ. EvalOp. simpl. rewrite EQ; auto. exploit Float.intuoffloat_intoffloat_2; eauto. intro EQ. replace n with (Int.add (Int.sub n Float.ox8000_0000) Float.ox8000_0000). - apply eval_addimm. eapply eval_intoffloat; eauto. - apply eval_subf; auto. EvalOp. + exploit (eval_addimm Float.ox8000_0000 (Vfloat f :: le) + (intoffloat + (subf (Eletvar 0) + (Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil)))). + unfold intoffloat, subf. + EvalOp. constructor. EvalOp. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. + simpl. eauto. constructor. simpl. rewrite EQ. simpl; eauto. + intros [v [A B]]. simpl in B. inv B. auto. rewrite Int.sub_add_opp. rewrite Int.add_assoc. apply Int.add_zero. Qed. Theorem eval_floatofintu: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (floatofintu a) (Vfloat (Float.floatofintu x)). + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofintu x = Some y -> + exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v. Proof. - intros. unfold floatofintu. + intros. destruct x; simpl in H0; try discriminate. inv H0. + exists (Vfloat (Float.floatofintu i)); split; auto. econstructor. eauto. set (fm := Float.floatofintu Float.ox8000_0000). - assert (eval_expr ge sp e m (Vint x :: le) (Eletvar O) (Vint x)). + assert (eval_expr ge sp e m (Vint i :: le) (Eletvar O) (Vint i)). constructor. auto. - apply eval_Econdition with (v1 := Int.ltu x Float.ox8000_0000). + apply eval_Econdition with (v1 := Int.ltu i Float.ox8000_0000). econstructor. constructor. eauto. constructor. simpl. auto. - caseEq (Int.ltu x Float.ox8000_0000); intros. + destruct (Int.ltu i Float.ox8000_0000) as []_eqn. rewrite Float.floatofintu_floatofint_1; auto. - apply eval_floatofint; auto. - rewrite Float.floatofintu_floatofint_2; auto. - fold fm. apply eval_addf. apply eval_floatofint. - rewrite Int.sub_add_opp. apply eval_addimm; auto. - EvalOp. + unfold floatofint. EvalOp. + exploit (eval_addimm (Int.neg Float.ox8000_0000) (Vint i :: le) (Eletvar 0)); eauto. + simpl. intros [v [A B]]. inv B. + unfold addf. EvalOp. + constructor. unfold floatofint. EvalOp. simpl; eauto. + constructor. EvalOp. simpl; eauto. constructor. simpl; eauto. + fold fm. rewrite Float.floatofintu_floatofint_2; auto. + rewrite Int.sub_add_opp. auto. Qed. Theorem eval_addressing: diff --git a/lib/Integers.v b/lib/Integers.v index 75bc63d..9f58de3 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -243,15 +243,6 @@ Definition shr (x y: int): int := let sx := fun i => fx (if zlt i (Z_of_nat wordsize) then i else Z_of_nat wordsize - 1) in repr (Z_of_bits wordsize sx (unsigned y)). -(** Viewed as signed divisions by powers of two, [shrx] rounds towards - zero, while [shr] rounds towards minus infinity. *) - -Definition shrx (x y: int): int := - divs x (shl one y). - -Definition shr_carry (x y: int) := - sub (shrx x y) (shr x y). - Definition rol (x y: int) : int := let fx := bits_of_Z wordsize (unsigned x) in let rx := fun i => fx (Zmod i (Z_of_nat wordsize)) in @@ -264,6 +255,17 @@ Definition ror (x y: int) : int := Definition rolm (x a m: int): int := and (rol x a) m. +(** Viewed as signed divisions by powers of two, [shrx] rounds towards + zero, while [shr] rounds towards minus infinity. *) + +Definition shrx (x y: int): int := + divs x (shl one y). + +(** [shr_carry x y] is 1 if [x] is negative and at least one 1 bit is shifted away. *) + +Definition shr_carry (x y: int) := + if lt x zero && negb (eq (and x (sub (shl one y) one)) zero) then one else zero. + (** Zero and sign extensions *) Definition zero_ext (n: Z) (x: int) : int := @@ -1789,6 +1791,34 @@ Proof. apply two_p_m1_range. omega. Qed. +Theorem and_shr_shru: + forall x y z, + and (shr x z) (shru y z) = shru (and x y) z. +Proof. + intros. unfold and, shr, shru, bitwise_binop. + repeat rewrite unsigned_repr; auto with ints. + decEq; apply Z_of_bits_exten; intros. + repeat rewrite Zplus_0_r. + rewrite bits_of_Z_of_bits_gen; auto. + rewrite bits_of_Z_of_bits_gen; auto. + generalize (unsigned_range z); intros. + destruct (zlt (i + unsigned z) (Z_of_nat wordsize)). + rewrite bits_of_Z_of_bits_gen. + repeat rewrite Zplus_0_r. auto. omega. + set (b := bits_of_Z wordsize (unsigned x) (Z_of_nat wordsize - 1)). + repeat rewrite bits_of_Z_above; auto. apply andb_false_r. +Qed. + +Theorem shr_and_shru_and: + forall x y z, + shru (shl z y) y = z -> + and (shr x y) z = and (shru x y) z. +Proof. + intros. + rewrite <- H. + rewrite and_shru. rewrite and_shr_shru. auto. +Qed. + (** ** Properties of rotations *) Theorem shl_rolm: @@ -2404,15 +2434,6 @@ Qed. (** ** Properties of [shrx] (signed division by a power of 2) *) -Theorem shrx_carry: - forall x y, - add (shr x y) (shr_carry x y) = shrx x y. -Proof. - intros. unfold shr_carry. - rewrite sub_add_opp. rewrite add_permut. - rewrite add_neg_zero. apply add_zero. -Qed. - Lemma Zdiv_round_Zdiv: forall x y, y > 0 -> @@ -2436,8 +2457,7 @@ Qed. Theorem shrx_shr: forall x y, ltu y (repr (Z_of_nat wordsize - 1)) = true -> - shrx x y = - shr (if lt x zero then add x (sub (shl one y) one) else x) y. + shrx x y = shr (if lt x zero then add x (sub (shl one y) one) else x) y. Proof. intros. rewrite shr_div_two_p. unfold shrx. unfold divs. exploit ltu_inv; eauto. rewrite unsigned_repr. @@ -2474,6 +2494,69 @@ Proof. generalize wordsize_pos wordsize_max_unsigned; omega. Qed. +Lemma Zdiv_shift: + forall x y, y > 0 -> + (x + (y - 1)) / y = x / y + if zeq (Zmod x y) 0 then 0 else 1. +Proof. + intros. generalize (Z_div_mod_eq x y H). generalize (Z_mod_lt x y H). + set (q := x / y). set (r := x mod y). intros. + destruct (zeq r 0). + apply Zdiv_unique with (y - 1). rewrite H1. rewrite e. ring. omega. + apply Zdiv_unique with (r - 1). rewrite H1. ring. omega. +Qed. + +Theorem shrx_carry: + forall x y, + ltu y (repr (Z_of_nat wordsize - 1)) = true -> + shrx x y = add (shr x y) (shr_carry x y). +Proof. + intros. rewrite shrx_shr; auto. unfold shr_carry. + unfold lt. set (sx := signed x). rewrite signed_zero. + destruct (zlt sx 0); simpl. + 2: rewrite add_zero; auto. + set (uy := unsigned y). + assert (0 <= uy < Z_of_nat wordsize - 1). + exploit ltu_inv; eauto. rewrite unsigned_repr. auto. + generalize wordsize_pos wordsize_max_unsigned; omega. + assert (shl one y = repr (two_p uy)). + rewrite shl_mul_two_p. rewrite mul_commut. apply mul_one. + assert (and x (sub (shl one y) one) = modu x (repr (two_p uy))). + symmetry. rewrite H1. apply modu_and with (logn := y). + rewrite is_power2_two_p. unfold uy. rewrite repr_unsigned. auto. + omega. + rewrite H2. rewrite H1. + repeat rewrite shr_div_two_p. fold sx. fold uy. + assert (two_p uy > 0). apply two_p_gt_ZERO. omega. + assert (two_p uy < modulus). + rewrite modulus_power. apply two_p_monotone_strict. omega. + assert (two_p uy < half_modulus). + rewrite half_modulus_power. + apply two_p_monotone_strict. auto. + assert (two_p uy < modulus). + rewrite modulus_power. apply two_p_monotone_strict. omega. + assert (sub (repr (two_p uy)) one = repr (two_p uy - 1)). + unfold sub. apply eqm_samerepr. apply eqm_sub. apply eqm_sym; apply eqm_unsigned_repr. + rewrite unsigned_one. apply eqm_refl. + rewrite H7. rewrite add_signed. fold sx. + rewrite (signed_repr (two_p uy - 1)). rewrite signed_repr. + unfold modu. rewrite unsigned_repr. + unfold eq. rewrite unsigned_zero. rewrite unsigned_repr. + assert (unsigned x mod two_p uy = sx mod two_p uy). + apply eqmod_mod_eq; auto. apply eqmod_divides with modulus. + fold eqm. unfold sx. apply eqm_sym. apply eqm_signed_unsigned. + unfold modulus. rewrite two_power_nat_two_p. + exists (two_p (Z_of_nat wordsize - uy)). rewrite <- two_p_is_exp. + decEq. omega. omega. omega. + rewrite H8. rewrite Zdiv_shift; auto. + unfold add. apply eqm_samerepr. apply eqm_add. + apply eqm_unsigned_repr. + destruct (zeq (sx mod two_p uy) 0); simpl; apply eqmod_mod; apply modulus_pos. + generalize (Z_mod_lt (unsigned x) (two_p uy) H3). unfold max_unsigned. omega. + unfold max_unsigned; omega. + generalize (signed_range x). fold sx. intros. split. omega. unfold max_signed. omega. + generalize min_signed_neg. unfold max_signed. omega. +Qed. + (** ** Properties of integer zero extension and sign extension. *) Section EXTENSIONS. @@ -2740,6 +2823,30 @@ Proof. rewrite bits_of_Z_of_bits. apply zlt_false. omega. omega. Qed. +Theorem zero_ext_narrow: + forall x n n', + 0 < n < Z_of_nat wordsize -> n <= n' < Z_of_nat wordsize -> + zero_ext n (zero_ext n' x) = zero_ext n x. +Proof. + intros. unfold zero_ext. + repeat rewrite unsigned_repr; auto with ints. + decEq; apply Z_of_bits_exten; intros; rewrite Zplus_0_r. + destruct (zlt i n); auto. + rewrite bits_of_Z_of_bits; auto. apply zlt_true. omega. +Qed. + +Theorem zero_sign_ext_narrow: + forall x n n', + 0 < n < Z_of_nat wordsize -> n <= n' < Z_of_nat wordsize -> + zero_ext n (sign_ext n' x) = zero_ext n x. +Proof. + intros. unfold sign_ext, zero_ext. + repeat rewrite unsigned_repr; auto with ints. + decEq; apply Z_of_bits_exten; intros; rewrite Zplus_0_r. + destruct (zlt i n); auto. + rewrite bits_of_Z_of_bits; auto. apply zlt_true. omega. +Qed. + (** ** Properties of [one_bits] (decomposition in sum of powers of two) *) Theorem one_bits_range: @@ -11,7 +11,7 @@ VARIANT=$ARCH/`sed -n -e 's/^VARIANT=//p' Makefile.config` make -q ${1}o || { make -n ${1}o | grep -v "\\b${1}\\b" | \ (while read cmd; do - $cmd || exit 2 + sh -c "$cmd" || exit 2 done) } COQPROGNAME="coqtop" diff --git a/powerpc/Asm.v b/powerpc/Asm.v index 321b074..7174f79 100644 --- a/powerpc/Asm.v +++ b/powerpc/Asm.v @@ -496,10 +496,10 @@ Definition compare_sint (rs: regset) (v1 v2: val) := #CR0_2 <- (Val.cmp Ceq v1 v2) #CR0_3 <- Vundef. -Definition compare_uint (rs: regset) (v1 v2: val) := - rs#CR0_0 <- (Val.cmpu Clt v1 v2) - #CR0_1 <- (Val.cmpu Cgt v1 v2) - #CR0_2 <- (Val.cmpu Ceq v1 v2) +Definition compare_uint (rs: regset) (m: mem) (v1 v2: val) := + rs#CR0_0 <- (Val.cmpu (Mem.valid_pointer m) Clt v1 v2) + #CR0_1 <- (Val.cmpu (Mem.valid_pointer m) Cgt v1 v2) + #CR0_2 <- (Val.cmpu (Mem.valid_pointer m) Ceq v1 v2) #CR0_3 <- Vundef. Definition compare_float (rs: regset) (v1 v2: val) := @@ -596,9 +596,9 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | _ => Error end | Pcmplw r1 r2 => - OK (nextinstr (compare_uint rs rs#r1 rs#r2)) m + OK (nextinstr (compare_uint rs m rs#r1 rs#r2)) m | Pcmplwi r1 cst => - OK (nextinstr (compare_uint rs rs#r1 (const_low cst))) m + OK (nextinstr (compare_uint rs m rs#r1 (const_low cst))) m | Pcmpw r1 r2 => OK (nextinstr (compare_sint rs rs#r1 rs#r2)) m | Pcmpwi r1 cst => @@ -606,9 +606,9 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pcror bd b1 b2 => OK (nextinstr (rs#(reg_of_crbit bd) <- (Val.or rs#(reg_of_crbit b1) rs#(reg_of_crbit b2)))) m | Pdivw rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.divs rs#r1 rs#r2))) m + OK (nextinstr (rs#rd <- (Val.maketotal (Val.divs rs#r1 rs#r2)))) m | Pdivwu rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.divu rs#r1 rs#r2))) m + OK (nextinstr (rs#rd <- (Val.maketotal (Val.divu rs#r1 rs#r2)))) m | Peqv rd r1 r2 => OK (nextinstr (rs#rd <- (Val.notint (Val.xor rs#r1 rs#r2)))) m | Pextsb rd r1 => @@ -635,7 +635,7 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pfcmpu r1 r2 => OK (nextinstr (compare_float rs rs#r1 rs#r2)) m | Pfcti rd r1 => - OK (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.intoffloat rs#r1))) m + OK (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.maketotal (Val.intoffloat rs#r1)))) m | Pfdiv rd r1 r2 => OK (nextinstr (rs#rd <- (Val.divf rs#r1 rs#r2))) m | Pfmadd rd r1 r2 r3 => diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v index 790b2b9..6d1a1fc 100644 --- a/powerpc/Asmgen.v +++ b/powerpc/Asmgen.v @@ -69,7 +69,7 @@ Definition addimm (r1 r2: ireg) (n: int) (k: code) := Paddis r1 r2 (Cint (high_s n)) :: Paddi r1 r1 (Cint (low_s n)) :: k. -Definition andimm (r1 r2: ireg) (n: int) (k: code) := +Definition andimm_base (r1 r2: ireg) (n: int) (k: code) := if Int.eq (high_u n) Int.zero then Pandi_ r1 r2 (Cint n) :: k else if Int.eq (low_u n) Int.zero then @@ -77,6 +77,12 @@ Definition andimm (r1 r2: ireg) (n: int) (k: code) := else loadimm GPR0 n (Pand_ r1 r2 GPR0 :: k). +Definition andimm (r1 r2: ireg) (n: int) (k: code) := + if is_rlw_mask n then + Prlwinm r1 r2 Int.zero n :: k + else + andimm_base r1 r2 n k. + Definition orimm (r1 r2: ireg) (n: int) (k: code) := if Int.eq (high_u n) Int.zero then Pori r1 r2 (Cint n) :: k @@ -95,6 +101,12 @@ Definition xorimm (r1 r2: ireg) (n: int) (k: code) := Pxoris r1 r2 (Cint (high_u n)) :: Pxori r1 r1 (Cint (low_u n)) :: k. +Definition rolm (r1 r2: ireg) (amount mask: int) (k: code) := + if is_rlw_mask mask then + Prlwinm r1 r2 amount mask :: k + else + Prlwinm r1 r2 amount Int.mone :: andimm_base r1 r1 mask k. + (** Accessing slots in the stack frame. *) Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) := @@ -166,9 +178,9 @@ Definition transl_cond | Cnotcompf cmp, a1 :: a2 :: nil => floatcomp cmp (freg_of a1) (freg_of a2) k | Cmaskzero n, a1 :: nil => - andimm GPR0 (ireg_of a1) n k + andimm_base GPR0 (ireg_of a1) n k | Cmasknotzero n, a1 :: nil => - andimm GPR0 (ireg_of a1) n k + andimm_base GPR0 (ireg_of a1) n k | _, _ => k (**r never happens for well-typed code *) end. @@ -302,12 +314,8 @@ Definition transl_op addimm (ireg_of r) GPR1 n k | Ocast8signed, a1 :: nil => Pextsb (ireg_of r) (ireg_of a1) :: k - | Ocast8unsigned, a1 :: nil => - Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 255) :: k | Ocast16signed, a1 :: nil => Pextsh (ireg_of r) (ireg_of a1) :: k - | Ocast16unsigned, a1 :: nil => - Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 65535) :: k | Oadd, a1 :: a2 :: nil => Padd (ireg_of r) (ireg_of a1) (ireg_of a2) :: k | Oaddimm n, a1 :: nil => @@ -360,7 +368,7 @@ Definition transl_op | Oshru, a1 :: a2 :: nil => Psrw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k | Orolm amount mask, a1 :: nil => - Prlwinm (ireg_of r) (ireg_of a1) amount mask :: k + rolm (ireg_of r) (ireg_of a1) amount mask k | Oroli amount mask, a1 :: a2 :: nil => if mreg_eq a1 r then (**r should always be true *) Prlwimi (ireg_of r) (ireg_of a2) amount mask :: k diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v index 27b2108..e7b7385 100644 --- a/powerpc/Asmgenproof.v +++ b/powerpc/Asmgenproof.v @@ -343,12 +343,21 @@ Proof. Qed. Hint Rewrite addimm_label: labels. +Remark andimm_base_label: + forall r1 r2 n k, find_label lbl (andimm_base r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold andimm_base. + case (Int.eq (high_u n) Int.zero). reflexivity. + case (Int.eq (low_u n) Int.zero). reflexivity. + autorewrite with labels. reflexivity. +Qed. +Hint Rewrite andimm_base_label: labels. + Remark andimm_label: forall r1 r2 n k, find_label lbl (andimm r1 r2 n k) = find_label lbl k. Proof. intros; unfold andimm. - case (Int.eq (high_u n) Int.zero). reflexivity. - case (Int.eq (low_u n) Int.zero). reflexivity. + case (is_rlw_mask n). reflexivity. autorewrite with labels. reflexivity. Qed. Hint Rewrite andimm_label: labels. @@ -371,6 +380,15 @@ Proof. Qed. Hint Rewrite xorimm_label: labels. +Remark rolm_label: + forall r1 r2 amount mask k, find_label lbl (rolm r1 r2 amount mask k) = find_label lbl k. +Proof. + intros; unfold rolm. + case (is_rlw_mask mask). reflexivity. + simpl. autorewrite with labels. auto. +Qed. +Hint Rewrite rolm_label: labels. + Remark loadind_label: forall base ofs ty dst k, find_label lbl (loadind base ofs ty dst k) = find_label lbl k. Proof. @@ -405,7 +423,7 @@ Proof. case (Int.eq (high_u i) Int.zero). reflexivity. autorewrite with labels; reflexivity. apply floatcomp_label. apply floatcomp_label. - apply andimm_label. apply andimm_label. + apply andimm_base_label. apply andimm_base_label. Qed. Hint Rewrite transl_cond_label: labels. diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v index 0b7f4d0..77a19af 100644 --- a/powerpc/Asmgenproof1.v +++ b/powerpc/Asmgenproof1.v @@ -595,11 +595,11 @@ Proof. Qed. Lemma compare_uint_spec: - forall rs v1 v2, - let rs1 := nextinstr (compare_uint rs v1 v2) in - rs1#CR0_0 = Val.cmpu Clt v1 v2 - /\ rs1#CR0_1 = Val.cmpu Cgt v1 v2 - /\ rs1#CR0_2 = Val.cmpu Ceq v1 v2 + forall rs m v1 v2, + let rs1 := nextinstr (compare_uint rs m v1 v2) in + rs1#CR0_0 = Val.cmpu (Mem.valid_pointer m) Clt v1 v2 + /\ rs1#CR0_1 = Val.cmpu (Mem.valid_pointer m) Cgt v1 v2 + /\ rs1#CR0_2 = Val.cmpu (Mem.valid_pointer m) Ceq v1 v2 /\ forall r', r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> r' <> PC -> rs1#r' = rs#r'. Proof. intros. unfold rs1. @@ -687,17 +687,17 @@ Qed. (** And integer immediate. *) -Lemma andimm_correct: +Lemma andimm_base_correct: forall r1 r2 n k (rs : regset) m, r2 <> GPR0 -> let v := Val.and rs#r2 (Vint n) in exists rs', - exec_straight (andimm r1 r2 n k) rs m k rs' m + exec_straight (andimm_base r1 r2 n k) rs m k rs' m /\ rs'#r1 = v /\ rs'#CR0_2 = Val.cmp Ceq v Vzero /\ forall r', is_data_reg r' = true -> r' <> r1 -> rs'#r' = rs#r'. Proof. - intros. unfold andimm. + intros. unfold andimm_base. case (Int.eq (high_u n) Int.zero). (* andi *) exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)). @@ -734,6 +734,25 @@ Proof. intros. rewrite D; auto with ppcgen. SIMP. Qed. +Lemma andimm_correct: + forall r1 r2 n k (rs : regset) m, + r2 <> GPR0 -> + exists rs', + exec_straight (andimm r1 r2 n k) rs m k rs' m + /\ rs'#r1 = Val.and rs#r2 (Vint n) + /\ forall r', is_data_reg r' = true -> r' <> r1 -> rs'#r' = rs#r'. +Proof. + intros. unfold andimm. destruct (is_rlw_mask n). + (* turned into rlw *) + exists (nextinstr (rs#r1 <- (Val.and rs#r2 (Vint n)))). + split. apply exec_straight_one. simpl. rewrite Val.rolm_zero. auto. reflexivity. + split. SIMP. apply Pregmap.gss. + intros. SIMP. apply Pregmap.gso; auto with ppcgen. + (* andimm_base *) + destruct (andimm_base_correct r1 r2 n k rs m) as [rs' [A [B [C D]]]]; auto. + exists rs'; auto. +Qed. + (** Or integer immediate. *) Lemma orimm_correct: @@ -797,6 +816,33 @@ Proof. intros. repeat SIMP. Qed. +(** Rotate and mask. *) + +Lemma rolm_correct: + forall r1 r2 amount mask k (rs : regset) m, + r1 <> GPR0 -> + exists rs', + exec_straight (rolm r1 r2 amount mask k) rs m k rs' m + /\ rs'#r1 = Val.rolm rs#r2 amount mask + /\ forall r', is_data_reg r' = true -> r' <> r1 -> rs'#r' = rs#r'. +Proof. + intros. unfold rolm. destruct (is_rlw_mask mask). + (* rlwinm *) + exists (nextinstr (rs#r1 <- (Val.rolm rs#r2 amount mask))). + split. apply exec_straight_one; auto. + split. SIMP. apply Pregmap.gss. + intros. SIMP. apply Pregmap.gso; auto. + (* rlwinm ; andimm *) + set (rs1 := nextinstr (rs#r1 <- (Val.rolm rs#r2 amount Int.mone))). + destruct (andimm_base_correct r1 r1 mask k rs1 m) as [rs' [A [B [C D]]]]; auto. + exists rs'. + split. eapply exec_straight_step; eauto. auto. auto. + split. rewrite B. unfold rs1. SIMP. rewrite Pregmap.gss. + destruct (rs r2); simpl; auto. unfold Int.rolm. rewrite Int.and_assoc. + decEq; decEq; decEq. rewrite Int.and_commut. apply Int.and_mone. + intros. rewrite D; auto. unfold rs1; SIMP. apply Pregmap.gso; auto. +Qed. + (** Indexed memory loads. *) Lemma loadind_correct: @@ -947,13 +993,14 @@ Lemma transl_cond_correct_1: exec_straight (transl_cond cond args k) rs m k rs' m /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) = (if snd (crbit_for_cond cond) - then eval_condition_total cond (map rs (map preg_of args)) - else Val.notbool (eval_condition_total cond (map rs (map preg_of args)))) + then Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m) + else Val.notbool (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m))) /\ forall r, is_data_reg r = true -> rs'#r = rs#r. Proof. intros. destruct cond; simpl in H; TypeInv; simpl; UseTypeInfo. (* Ccomp *) + fold (Val.cmp c (rs (ireg_of m0)) (rs (ireg_of m1))). destruct (compare_sint_spec rs (rs (ireg_of m0)) (rs (ireg_of m1))) as [A [B [C D]]]. econstructor; split. @@ -962,7 +1009,8 @@ Proof. case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto. auto with ppcgen. (* Ccompu *) - destruct (compare_uint_spec rs (rs (ireg_of m0)) (rs (ireg_of m1))) + fold (Val.cmpu (Mem.valid_pointer m) c (rs (ireg_of m0)) (rs (ireg_of m1))). + destruct (compare_uint_spec rs m (rs (ireg_of m0)) (rs (ireg_of m1))) as [A [B [C D]]]. econstructor; split. apply exec_straight_one. simpl; reflexivity. reflexivity. @@ -970,6 +1018,7 @@ Proof. case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto. auto with ppcgen. (* Ccompimm *) + fold (Val.cmp c (rs (ireg_of m0)) (Vint i)). case (Int.eq (high_s i) Int.zero). destruct (compare_sint_spec rs (rs (ireg_of m0)) (Vint i)) as [A [B [C D]]]. @@ -992,8 +1041,9 @@ Proof. case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto. intros. rewrite H; rewrite D; auto with ppcgen. (* Ccompuimm *) + fold (Val.cmpu (Mem.valid_pointer m) c (rs (ireg_of m0)) (Vint i)). case (Int.eq (high_u i) Int.zero). - destruct (compare_uint_spec rs (rs (ireg_of m0)) (Vint i)) + destruct (compare_uint_spec rs m (rs (ireg_of m0)) (Vint i)) as [A [B [C D]]]. econstructor; split. apply exec_straight_one. simpl. eauto. reflexivity. @@ -1002,10 +1052,10 @@ Proof. auto with ppcgen. generalize (loadimm_correct GPR0 i (Pcmplw (ireg_of m0) GPR0 :: k) rs m). intros [rs1 [EX1 [RES1 OTH1]]]. - destruct (compare_uint_spec rs1 (rs (ireg_of m0)) (Vint i)) + destruct (compare_uint_spec rs1 m (rs (ireg_of m0)) (Vint i)) as [A [B [C D]]]. assert (rs1 (ireg_of m0) = rs (ireg_of m0)). apply OTH1; auto with ppcgen. - exists (nextinstr (compare_uint rs1 (rs1 (ireg_of m0)) (Vint i))). + exists (nextinstr (compare_uint rs1 m (rs1 (ireg_of m0)) (Vint i))). split. eapply exec_straight_trans. eexact EX1. apply exec_straight_one. simpl. rewrite RES1; rewrite H; auto. reflexivity. @@ -1013,32 +1063,33 @@ Proof. case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto. intros. rewrite H; rewrite D; auto with ppcgen. (* Ccompf *) + fold (Val.cmpf c (rs (freg_of m0)) (rs (freg_of m1))). destruct (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m) as [rs' [EX [RES OTH]]]. exists rs'. split. auto. split. apply RES. auto with ppcgen. (* Cnotcompf *) + rewrite Val.notbool_negb_3. rewrite Val.notbool_idem4. + fold (Val.cmpf c (rs (freg_of m0)) (rs (freg_of m1))). destruct (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m) as [rs' [EX [RES OTH]]]. exists rs'. split. auto. - split. rewrite RES. - assert (forall v1 v2, Val.notbool (Val.notbool (Val.cmpf c v1 v2)) = Val.cmpf c v1 v2). - intros v1 v2; unfold Val.cmpf; destruct v1; destruct v2; auto. - apply Val.notbool_idem2. - rewrite H. case (snd (crbit_for_fcmp c)); simpl; auto. + split. rewrite RES. destruct (snd (crbit_for_fcmp c)); auto. auto with ppcgen. (* Cmaskzero *) - destruct (andimm_correct GPR0 (ireg_of m0) i k rs m) + destruct (andimm_base_correct GPR0 (ireg_of m0) i k rs m) as [rs' [A [B [C D]]]]. auto with ppcgen. exists rs'. split. assumption. - split. rewrite C. auto. + split. rewrite C. destruct (rs (ireg_of m0)); auto. auto with ppcgen. (* Cmasknotzero *) - destruct (andimm_correct GPR0 (ireg_of m0) i k rs m) + destruct (andimm_base_correct GPR0 (ireg_of m0) i k rs m) as [rs' [A [B [C D]]]]. auto with ppcgen. exists rs'. split. assumption. - split. rewrite C. rewrite Val.notbool_idem3. reflexivity. + split. rewrite C. destruct (rs (ireg_of m0)); auto. + fold (option_map negb (Some (Int.eq (Int.and i0 i) Int.zero))). + rewrite Val.notbool_negb_3. rewrite Val.notbool_idem4. auto. auto with ppcgen. Qed. @@ -1055,9 +1106,10 @@ Lemma transl_cond_correct_2: /\ forall r, is_data_reg r = true -> rs'#r = rs#r. Proof. intros. - assert (eval_condition_total cond rs ## (preg_of ## args) = Val.of_bool b). - apply eval_condition_weaken with m. auto. - rewrite <- H1. eapply transl_cond_correct_1; eauto. + replace (Val.of_bool b) + with (Val.of_optbool (eval_condition cond rs ## (preg_of ## args) m)). + eapply transl_cond_correct_1; eauto. + rewrite H0; auto. Qed. Lemma transl_cond_correct: @@ -1128,46 +1180,43 @@ Proof. Qed. Lemma transl_cond_op_correct: - forall cond args r k rs m b, + forall cond args r k rs m, mreg_type r = Tint -> map mreg_type args = type_of_condition cond -> - eval_condition cond (map rs (map preg_of args)) m = Some b -> exists rs', exec_straight (transl_cond_op cond args r k) rs m k rs' m - /\ rs'#(ireg_of r) = Val.of_bool b + /\ rs'#(ireg_of r) = Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m) /\ forall r', is_data_reg r' = true -> r' <> ireg_of r -> rs'#r' = rs#r'. Proof. intros until args. unfold transl_cond_op. destruct (classify_condition cond args); - intros until b; intros TY1 TY2 EV; simpl in TY2. + intros until m; intros TY1 TY2; simpl in TY2. (* eq 0 *) - inv TY2. simpl in EV. unfold preg_of in *; rewrite H0 in *. + inv TY2. simpl. unfold preg_of; rewrite H0. econstructor; split. eapply exec_straight_two; simpl; reflexivity. - split. repeat SIMP. destruct (rs (ireg_of r)); inv EV. simpl. + split. repeat SIMP. destruct (rs (ireg_of r)); simpl; auto. apply add_carry_eq0. intros; repeat SIMP. (* ne 0 *) - inv TY2. simpl in EV. unfold preg_of in *; rewrite H0 in *. + inv TY2. simpl. unfold preg_of; rewrite H0. econstructor; split. eapply exec_straight_two; simpl; reflexivity. split. repeat SIMP. rewrite gpr_or_zero_not_zero; auto with ppcgen. - destruct (rs (ireg_of r)); inv EV. simpl. + destruct (rs (ireg_of r)); simpl; auto. apply add_carry_ne0. intros; repeat SIMP. (* ge 0 *) - inv TY2. simpl in EV. unfold preg_of in *; rewrite H0 in *. + inv TY2. simpl. unfold preg_of; rewrite H0. econstructor; split. eapply exec_straight_two; simpl; reflexivity. - split. repeat SIMP. rewrite Val.rolm_ge_zero. - destruct (rs (ireg_of r)); simpl; congruence. + split. repeat SIMP. rewrite Val.rolm_ge_zero. auto. intros; repeat SIMP. (* lt 0 *) - inv TY2. simpl in EV. unfold preg_of in *; rewrite H0 in *. + inv TY2. simpl. unfold preg_of; rewrite H0. econstructor; split. apply exec_straight_one; simpl; reflexivity. - split. repeat SIMP. rewrite Val.rolm_lt_zero. - destruct (rs (ireg_of r)); simpl; congruence. + split. repeat SIMP. rewrite Val.rolm_lt_zero. auto. intros; repeat SIMP. (* default *) set (bit := fst (crbit_for_cond c)). @@ -1177,7 +1226,7 @@ Proof. (if isset then k else Pxori (ireg_of r) (ireg_of r) (Cint Int.one) :: k)). - generalize (transl_cond_correct_2 c rl k1 rs m b TY2 EV). + generalize (transl_cond_correct_1 c rl k1 rs m TY2). fold bit; fold isset. intros [rs1 [EX1 [RES1 AG1]]]. destruct isset. @@ -1188,7 +1237,8 @@ Proof. (* bit clear *) econstructor; split. eapply exec_straight_trans. eexact EX1. unfold k1. eapply exec_straight_two; simpl; reflexivity. - split. repeat SIMP. rewrite RES1. destruct b; compute; reflexivity. + split. repeat SIMP. rewrite RES1. + destruct (eval_condition c rs ## (preg_of ## rl) m). destruct b; auto. auto. intros; repeat SIMP. Qed. @@ -1210,26 +1260,23 @@ Lemma transl_op_correct_aux: match op with Omove => is_data_reg r = true | _ => is_nontemp_reg r = true end -> r <> preg_of res -> rs'#r = rs#r. Proof. - intros. - exploit eval_operation_weaken; eauto. intro EV. - inv H. + intros until v; intros WT EV. + inv WT. (* Omove *) - simpl in *. + simpl in *. inv EV. exists (nextinstr (rs#(preg_of res) <- (rs#(preg_of r1)))). - split. unfold preg_of. rewrite <- H2. + split. unfold preg_of. rewrite <- H0. destruct (mreg_type r1); apply exec_straight_one; auto. split. repeat SIMP. intros; repeat SIMP. (* Other instructions *) - destruct op; simpl; simpl in H5; injection H5; clear H5; intros; - TypeInv; simpl in *; UseTypeInfo; try (TranslOpSimpl). - (* Omove again *) - congruence. + destruct op; simpl; simpl in H3; injection H3; clear H3; intros; + TypeInv; simpl in *; UseTypeInfo; inv EV; try (TranslOpSimpl). (* Ointconst *) destruct (loadimm_correct (ireg_of res) i k rs m) as [rs' [A [B C]]]. exists rs'. split. auto. split. auto. auto with ppcgen. (* Oaddrsymbol *) - change (find_symbol_offset ge i i0) with (symbol_offset ge i i0) in *. - set (v' := symbol_offset ge i i0) in *. + change (symbol_address ge i i0) with (symbol_offset ge i i0). + set (v' := symbol_offset ge i i0). caseEq (symbol_is_small_data i i0); intro SD. (* small data *) econstructor; split. apply exec_straight_one; simpl; reflexivity. @@ -1249,18 +1296,6 @@ Opaque Val.add. destruct (addimm_correct (ireg_of res) GPR1 i k rs m) as [rs' [EX [RES OTH]]]. auto with ppcgen. congruence. exists rs'; auto with ppcgen. - (* Ocast8unsigned *) - econstructor; split. apply exec_straight_one; simpl; reflexivity. - split. repeat SIMP. - destruct (rs (ireg_of m0)); simpl; auto. - rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto. - intros; repeat SIMP. - (* Ocast16unsigned *) - econstructor; split. apply exec_straight_one; simpl; reflexivity. - split. repeat SIMP. - destruct (rs (ireg_of m0)); simpl; auto. - rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto. - intros; repeat SIMP. (* Oaddimm *) destruct (addimm_correct (ireg_of res) (ireg_of m0) i k rs m) as [rs' [A [B C]]]; auto with ppcgen. exists rs'; auto with ppcgen. @@ -1280,6 +1315,14 @@ Opaque Val.add. eapply exec_straight_trans. eexact EX. apply exec_straight_one; simpl; reflexivity. split. repeat SIMP. rewrite RES. rewrite OTH; auto with ppcgen. intros; repeat SIMP. + (* Odivs *) + replace v with (Val.maketotal (Val.divs (rs (ireg_of m0)) (rs (ireg_of m1)))). + TranslOpSimpl. + rewrite H2; auto. + (* Odivu *) + replace v with (Val.maketotal (Val.divu (rs (ireg_of m0)) (rs (ireg_of m1)))). + TranslOpSimpl. + rewrite H2; auto. (* Oand *) set (v' := Val.and (rs (ireg_of m0)) (rs (ireg_of m1))) in *. pose (rs1 := rs#(ireg_of res) <- v'). @@ -1289,7 +1332,7 @@ Opaque Val.add. split. rewrite D; auto with ppcgen. unfold rs1. SIMP. intros. rewrite D; auto with ppcgen. unfold rs1. SIMP. (* Oandimm *) - destruct (andimm_correct (ireg_of res) (ireg_of m0) i k rs m) as [rs' [A [B [C D]]]]; auto with ppcgen. + destruct (andimm_correct (ireg_of res) (ireg_of m0) i k rs m) as [rs' [A [B C]]]; auto with ppcgen. exists rs'; auto with ppcgen. (* Oorimm *) destruct (orimm_correct (ireg_of res) (ireg_of m0) i k rs m) as [rs' [A [B C]]]. @@ -1300,19 +1343,24 @@ Opaque Val.add. (* Oshrximm *) econstructor; split. eapply exec_straight_two; simpl; reflexivity. - split. repeat SIMP. apply Val.shrx_carry. + split. repeat SIMP. apply Val.shrx_carry. auto. intros; repeat SIMP. + (* Orolm *) + destruct (rolm_correct (ireg_of res) (ireg_of m0) i i0 k rs m) as [rs' [A [B C]]]; auto with ppcgen. + exists rs'; auto with ppcgen. (* Oroli *) destruct (mreg_eq m0 res). subst m0. TranslOpSimpl. econstructor; split. eapply exec_straight_three; simpl; reflexivity. split. repeat SIMP. intros; repeat SIMP. + (* Ointoffloat *) + replace v with (Val.maketotal (Val.intoffloat (rs (freg_of m0)))). + TranslOpSimpl. + rewrite H2; auto. (* Ocmp *) - destruct (eval_condition c rs ## (preg_of ## args) m) as [ b | ] _eqn; try discriminate. - destruct (transl_cond_op_correct c args res k rs m b) as [rs' [A [B C]]]; auto. - exists rs'; intuition auto with ppcgen. - rewrite B. destruct b; inv H0; auto. + destruct (transl_cond_op_correct c args res k rs m) as [rs' [A [B C]]]; auto. + exists rs'; auto with ppcgen. Qed. Lemma transl_op_correct: @@ -1340,14 +1388,14 @@ Lemma transl_load_store_correct: forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) addr args (temp: ireg) k ms sp rs m ms' m', (forall cst (r1: ireg) (rs1: regset) k, - eval_addressing_total ge sp addr (map rs (map preg_of args)) = - Val.add (gpr_or_zero rs1 r1) (const_low ge cst) -> + eval_addressing ge sp addr (map rs (map preg_of args)) = + Some(Val.add (gpr_or_zero rs1 r1) (const_low ge cst)) -> (forall (r: preg), r <> PC -> r <> temp -> rs1 r = rs r) -> exists rs', exec_straight (mk1 cst r1 :: k) rs1 m k rs' m' /\ agree ms' sp rs') -> (forall (r1 r2: ireg) k, - eval_addressing_total ge sp addr (map rs (map preg_of args)) = Val.add rs#r1 rs#r2 -> + eval_addressing ge sp addr (map rs (map preg_of args)) = Some(Val.add rs#r1 rs#r2) -> exists rs', exec_straight (mk2 r1 r2 :: k) rs m k rs' m' /\ agree ms' sp rs') -> @@ -1386,7 +1434,7 @@ Transparent Val.add. (* Aglobal from small data *) apply H. rewrite gpr_or_zero_zero. simpl const_low. rewrite small_data_area_addressing; auto. simpl. - unfold find_symbol_offset, symbol_offset. + unfold symbol_address, symbol_offset. destruct (Genv.find_symbol ge i); auto. rewrite Int.add_zero. auto. auto. (* Aglobal general case *) @@ -1396,7 +1444,7 @@ Transparent Val.add. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. unfold const_high, const_low. set (v := symbol_offset ge i i0). - symmetry. rewrite Val.add_commut. unfold v. apply low_high_half. + symmetry. rewrite Val.add_commut. unfold v. rewrite low_high_half. auto. discriminate. intros; unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. intros [rs' [EX' AG']]. @@ -1414,8 +1462,8 @@ Transparent Val.add. rewrite Val.add_assoc. unfold const_high, const_low. set (v := symbol_offset ge i i0). - symmetry. rewrite Val.add_commut. decEq. - unfold v. rewrite Val.add_commut. apply low_high_half. + symmetry. rewrite Val.add_commut. decEq. decEq. + unfold v. rewrite Val.add_commut. rewrite low_high_half. auto. UseTypeInfo. auto. discriminate. intros. unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. intros [rs' [EX' AG']]. @@ -1465,12 +1513,11 @@ Proof. exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto. intros [a' [A B]]. exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - exploit eval_addressing_weaken. eexact A. intro E. rewrite <- E in C. apply transl_load_store_correct with ms; auto. (* mk1 *) intros. exists (nextinstr (rs1#(preg_of dst) <- v')). split. apply exec_straight_one. rewrite H. - unfold load1. rewrite <- H6. rewrite C. auto. + unfold load1. rewrite A in H6. inv H6. rewrite C. auto. unfold nextinstr. SIMP. decEq. SIMP. apply sym_not_equal; auto with ppcgen. apply agree_set_mreg with rs1. apply agree_undef_temps with rs; auto with ppcgen. @@ -1479,7 +1526,7 @@ Proof. (* mk2 *) intros. exists (nextinstr (rs#(preg_of dst) <- v')). split. apply exec_straight_one. rewrite H0. - unfold load2. rewrite <- H6. rewrite C. auto. + unfold load2. rewrite A in H6. inv H6. rewrite C. auto. unfold nextinstr. SIMP. decEq. SIMP. apply sym_not_equal; auto with ppcgen. apply agree_set_mreg with rs. apply agree_undef_temps with rs; auto with ppcgen. @@ -1521,13 +1568,12 @@ Proof. intros [a' [A B]]. assert (Z: Val.lessdef (ms src) (rs (preg_of src))). eapply preg_val; eauto. exploit Mem.storev_extends; eauto. intros [m1' [C D]]. - exploit eval_addressing_weaken. eexact A. intro E. rewrite <- E in C. exists m1'; split; auto. apply transl_load_store_correct with ms; auto. (* mk1 *) intros. exploit (H cst r1 rs1 (nextinstr rs1) m1'). - unfold store1. rewrite <- H6. + unfold store1. rewrite A in H6. inv H6. replace (rs1 (preg_of src)) with (rs (preg_of src)). rewrite C. auto. symmetry. apply H7. auto with ppcgen. @@ -1541,7 +1587,7 @@ Proof. (* mk2 *) intros. exploit (H0 r1 r2 rs (nextinstr rs) m1'). - unfold store2. rewrite <- H6. rewrite C. auto. + unfold store2. rewrite A in H6. inv H6. rewrite C. auto. intros [rs3 [U V]]. exists rs3; split. apply exec_straight_one. auto. rewrite V; auto with ppcgen. diff --git a/powerpc/Asmgenretaddr.v b/powerpc/Asmgenretaddr.v index adc1529..081336c 100644 --- a/powerpc/Asmgenretaddr.v +++ b/powerpc/Asmgenretaddr.v @@ -112,6 +112,11 @@ Lemma addimm_tail: Proof. unfold addimm; intros; IsTail. Qed. Hint Resolve addimm_tail: ppcretaddr. +Lemma andimm_base_tail: + forall r1 r2 n k, is_tail k (andimm_base r1 r2 n k). +Proof. unfold andimm_base; intros; IsTail. Qed. +Hint Resolve andimm_base_tail: ppcretaddr. + Lemma andimm_tail: forall r1 r2 n k, is_tail k (andimm r1 r2 n k). Proof. unfold andimm; intros; IsTail. Qed. @@ -127,6 +132,11 @@ Lemma xorimm_tail: Proof. unfold xorimm; intros; IsTail. Qed. Hint Resolve xorimm_tail: ppcretaddr. +Lemma rolm_tail: + forall r1 r2 amount mask k, is_tail k (rolm r1 r2 amount mask k). +Proof. unfold rolm; intros; IsTail. Qed. +Hint Resolve rolm_tail: ppcretaddr. + Lemma loadind_tail: forall base ofs ty dst k, is_tail k (loadind base ofs ty dst k). Proof. unfold loadind; intros. destruct ty; IsTail. Qed. diff --git a/powerpc/ConstpropOp.v b/powerpc/ConstpropOp.v deleted file mode 100644 index 07a1872..0000000 --- a/powerpc/ConstpropOp.v +++ /dev/null @@ -1,856 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Static analysis and strength reduction for operators - and conditions. This is the machine-dependent part of [Constprop]. *) - -Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Op. -Require Import Registers. - -(** * Static analysis *) - -(** To each pseudo-register at each program point, the static analysis - associates a compile-time approximation taken from the following set. *) - -Inductive approx : Type := - | Novalue: approx (** No value possible, code is unreachable. *) - | Unknown: approx (** All values are possible, - no compile-time information is available. *) - | I: int -> approx (** A known integer value. *) - | F: float -> approx (** A known floating-point value. *) - | S: ident -> int -> approx. - (** The value is the address of the given global - symbol plus the given integer offset. *) - -(** We now define the abstract interpretations of conditions and operators - over this set of approximations. For instance, the abstract interpretation - of the operator [Oaddf] applied to two expressions [a] and [b] is - [F(Float.add f g)] if [a] and [b] have static approximations [Vfloat f] - and [Vfloat g] respectively, and [Unknown] otherwise. - - The static approximations are defined by large pattern-matchings over - the approximations of the results. We write these matchings in the - indirect style described in file [Cmconstr] to avoid excessive - duplication of cases in proofs. *) - -(* -Definition eval_static_condition (cond: condition) (vl: list approx) := - match cond, vl with - | Ccomp c, I n1 :: I n2 :: nil => Some(Int.cmp c n1 n2) - | Ccompu c, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 n2) - | Ccompimm c n, I n1 :: nil => Some(Int.cmp c n1 n) - | Ccompuimm c n, I n1 :: nil => Some(Int.cmpu c n1 n) - | Ccompf c, F n1 :: F n2 :: nil => Some(Float.cmp c n1 n2) - | Cnotcompf c, F n1 :: F n2 :: nil => Some(negb(Float.cmp c n1 n2)) - | Cmaskzero n, I n1 :: nil => Some(Int.eq (Int.and n1 n) Int.zero) - | Cmasknotzero n, n1::nil => Some(negb(Int.eq (Int.and n1 n) Int.zero)) - | _, _ => None - end. -*) - -Inductive eval_static_condition_cases: forall (cond: condition) (vl: list approx), Type := - | eval_static_condition_case1: - forall c n1 n2, - eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil) - | eval_static_condition_case2: - forall c n1 n2, - eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil) - | eval_static_condition_case3: - forall c n n1, - eval_static_condition_cases (Ccompimm c n) (I n1 :: nil) - | eval_static_condition_case4: - forall c n n1, - eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil) - | eval_static_condition_case5: - forall c n1 n2, - eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil) - | eval_static_condition_case6: - forall c n1 n2, - eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil) - | eval_static_condition_case7: - forall n n1, - eval_static_condition_cases (Cmaskzero n) (I n1 :: nil) - | eval_static_condition_case8: - forall n n1, - eval_static_condition_cases (Cmasknotzero n) (I n1 :: nil) - | eval_static_condition_default: - forall (cond: condition) (vl: list approx), - eval_static_condition_cases cond vl. - -Definition eval_static_condition_match (cond: condition) (vl: list approx) := - match cond as z1, vl as z2 return eval_static_condition_cases z1 z2 with - | Ccomp c, I n1 :: I n2 :: nil => - eval_static_condition_case1 c n1 n2 - | Ccompu c, I n1 :: I n2 :: nil => - eval_static_condition_case2 c n1 n2 - | Ccompimm c n, I n1 :: nil => - eval_static_condition_case3 c n n1 - | Ccompuimm c n, I n1 :: nil => - eval_static_condition_case4 c n n1 - | Ccompf c, F n1 :: F n2 :: nil => - eval_static_condition_case5 c n1 n2 - | Cnotcompf c, F n1 :: F n2 :: nil => - eval_static_condition_case6 c n1 n2 - | Cmaskzero n, I n1 :: nil => - eval_static_condition_case7 n n1 - | Cmasknotzero n, I n1 :: nil => - eval_static_condition_case8 n n1 - | cond, vl => - eval_static_condition_default cond vl - end. - -Definition eval_static_condition (cond: condition) (vl: list approx) := - match eval_static_condition_match cond vl with - | eval_static_condition_case1 c n1 n2 => - Some(Int.cmp c n1 n2) - | eval_static_condition_case2 c n1 n2 => - Some(Int.cmpu c n1 n2) - | eval_static_condition_case3 c n n1 => - Some(Int.cmp c n1 n) - | eval_static_condition_case4 c n n1 => - Some(Int.cmpu c n1 n) - | eval_static_condition_case5 c n1 n2 => - Some(Float.cmp c n1 n2) - | eval_static_condition_case6 c n1 n2 => - Some(negb(Float.cmp c n1 n2)) - | eval_static_condition_case7 n n1 => - Some(Int.eq (Int.and n1 n) Int.zero) - | eval_static_condition_case8 n n1 => - Some(negb(Int.eq (Int.and n1 n) Int.zero)) - | eval_static_condition_default cond vl => - None - end. - -(* -Definition eval_static_operation (op: operation) (vl: list approx) := - match op, vl with - | Omove, v1::nil => v1 - | Ointconst n, nil => I n - | Ofloatconst n, nil => F n - | Oaddrsymbol s n, nil => S s n - | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n) - | Ocast8unsigned, I n1 :: nil => I(Int.zero_ext 8 n) - | Ocast16signed, I n1 :: nil => I(Int.sign_ext 16 n) - | Ocast16unsigned, I n1 :: nil => I(Int.zero_ext 16 n) - | Oadd, I n1 :: I n2 :: nil => I(Int.add n1 n2) - | Oadd, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 n2) - | Oaddimm n, I n1 :: nil => I (Int.add n1 n) - | Oaddimm n, S s1 n1 :: nil => S s1 (Int.add n1 n) - | Osub, I n1 :: I n2 :: nil => I(Int.sub n1 n2) - | Osub, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 n2) - | Osubimm n, I n1 :: nil => I (Int.sub n n1) - | Omul, I n1 :: I n2 :: nil => I(Int.mul n1 n2) - | Omulimm n, I n1 :: nil => I(Int.mul n1 n) - | Odiv, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) - | Odivu, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) - | Oand, I n1 :: I n2 :: nil => I(Int.and n1 n2) - | Oandimm n, I n1 :: nil => I(Int.and n1 n) - | Oor, I n1 :: I n2 :: nil => I(Int.or n1 n2) - | Oorimm n, I n1 :: nil => I(Int.or n1 n) - | Oxor, I n1 :: I n2 :: nil => I(Int.xor n1 n2) - | Oxorimm n, I n1 :: nil => I(Int.xor n1 n) - | Onand, I n1 :: I n2 :: nil => I(Int.xor (Int.and n1 n2) Int.mone) - | Onor, I n1 :: I n2 :: nil => I(Int.xor (Int.or n1 n2) Int.mone) - | Onxor, I n1 :: I n2 :: nil => I(Int.xor (Int.xor n1 n2) Int.mone) - | Oshl, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shl n1 n2) else Unknown - | Oshr, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shr n1 n2) else Unknown - | Oshrimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shr n1 n) else Unknown - | Oshrximm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shrx n1 n) else Unknown - | Oshru, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shru n1 n2) else Unknown - | Orolm amount mask, I n1 :: nil => I(Int.rolm n1 amount mask) - | Onegf, F n1 :: nil => F(Float.neg n1) - | Oabsf, F n1 :: nil => F(Float.abs n1) - | Oaddf, F n1 :: F n2 :: nil => F(Float.add n1 n2) - | Osubf, F n1 :: F n2 :: nil => F(Float.sub n1 n2) - | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2) - | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2) - | Omuladdf, F n1 :: F n2 :: F n3 :: nil => F(Float.add (Float.mul n1 n2) n3) - | Omulsubf, F n1 :: F n2 :: F n3 :: nil => F(Float.sub (Float.mul n1 n2) n3) - | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) - | Ointoffloat, F n1 :: nil => match Float.intoffloat n1 with Some x => I x | None => Unknown end - | Ofloatofwords, I n1 :: I n2 :: nil => F(Float.from_words n1 n2) - | Ocmp c, vl => - match eval_static_condition c vl with - | None => Unknown - | Some b => I(if b then Int.one else Int.zero) - end - | _, _ => Unknown - end. -*) - -Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx), Type := - | eval_static_operation_case1: - forall v1, - eval_static_operation_cases (Omove) (v1::nil) - | eval_static_operation_case2: - forall n, - eval_static_operation_cases (Ointconst n) (nil) - | eval_static_operation_case3: - forall n, - eval_static_operation_cases (Ofloatconst n) (nil) - | eval_static_operation_case4: - forall s n, - eval_static_operation_cases (Oaddrsymbol s n) (nil) - | eval_static_operation_case6: - forall n1, - eval_static_operation_cases (Ocast8signed) (I n1 :: nil) - | eval_static_operation_case7: - forall n1, - eval_static_operation_cases (Ocast16signed) (I n1 :: nil) - | eval_static_operation_case8: - forall n1 n2, - eval_static_operation_cases (Oadd) (I n1 :: I n2 :: nil) - | eval_static_operation_case9: - forall s1 n1 n2, - eval_static_operation_cases (Oadd) (S s1 n1 :: I n2 :: nil) - | eval_static_operation_case11: - forall n n1, - eval_static_operation_cases (Oaddimm n) (I n1 :: nil) - | eval_static_operation_case12: - forall n s1 n1, - eval_static_operation_cases (Oaddimm n) (S s1 n1 :: nil) - | eval_static_operation_case13: - forall n1 n2, - eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil) - | eval_static_operation_case14: - forall s1 n1 n2, - eval_static_operation_cases (Osub) (S s1 n1 :: I n2 :: nil) - | eval_static_operation_case15: - forall n n1, - eval_static_operation_cases (Osubimm n) (I n1 :: nil) - | eval_static_operation_case16: - forall n1 n2, - eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil) - | eval_static_operation_case17: - forall n n1, - eval_static_operation_cases (Omulimm n) (I n1 :: nil) - | eval_static_operation_case18: - forall n1 n2, - eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil) - | eval_static_operation_case19: - forall n1 n2, - eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil) - | eval_static_operation_case20: - forall n1 n2, - eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil) - | eval_static_operation_case21: - forall n n1, - eval_static_operation_cases (Oandimm n) (I n1 :: nil) - | eval_static_operation_case22: - forall n1 n2, - eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil) - | eval_static_operation_case23: - forall n n1, - eval_static_operation_cases (Oorimm n) (I n1 :: nil) - | eval_static_operation_case24: - forall n1 n2, - eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil) - | eval_static_operation_case25: - forall n n1, - eval_static_operation_cases (Oxorimm n) (I n1 :: nil) - | eval_static_operation_case26: - forall n1 n2, - eval_static_operation_cases (Onand) (I n1 :: I n2 :: nil) - | eval_static_operation_case27: - forall n1 n2, - eval_static_operation_cases (Onor) (I n1 :: I n2 :: nil) - | eval_static_operation_case28: - forall n1 n2, - eval_static_operation_cases (Onxor) (I n1 :: I n2 :: nil) - | eval_static_operation_case29: - forall n1 n2, - eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil) - | eval_static_operation_case30: - forall n1 n2, - eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil) - | eval_static_operation_case31: - forall n n1, - eval_static_operation_cases (Oshrimm n) (I n1 :: nil) - | eval_static_operation_case32: - forall n n1, - eval_static_operation_cases (Oshrximm n) (I n1 :: nil) - | eval_static_operation_case33: - forall n1 n2, - eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil) - | eval_static_operation_case34: - forall amount mask n1, - eval_static_operation_cases (Orolm amount mask) (I n1 :: nil) - | eval_static_operation_case35: - forall n1, - eval_static_operation_cases (Onegf) (F n1 :: nil) - | eval_static_operation_case36: - forall n1, - eval_static_operation_cases (Oabsf) (F n1 :: nil) - | eval_static_operation_case37: - forall n1 n2, - eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil) - | eval_static_operation_case38: - forall n1 n2, - eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil) - | eval_static_operation_case39: - forall n1 n2, - eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil) - | eval_static_operation_case40: - forall n1 n2, - eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil) - | eval_static_operation_case41: - forall n1 n2 n3, - eval_static_operation_cases (Omuladdf) (F n1 :: F n2 :: F n3 :: nil) - | eval_static_operation_case42: - forall n1 n2 n3, - eval_static_operation_cases (Omulsubf) (F n1 :: F n2 :: F n3 :: nil) - | eval_static_operation_case43: - forall n1, - eval_static_operation_cases (Osingleoffloat) (F n1 :: nil) - | eval_static_operation_case44: - forall n1, - eval_static_operation_cases (Ointoffloat) (F n1 :: nil) - | eval_static_operation_case45: - forall n1 n2, - eval_static_operation_cases (Ofloatofwords) (I n1 :: I n2 :: nil) - | eval_static_operation_case47: - forall c vl, - eval_static_operation_cases (Ocmp c) (vl) - | eval_static_operation_case48: - forall n1, - eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil) - | eval_static_operation_case49: - forall n1, - eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil) - | eval_static_operation_default: - forall (op: operation) (vl: list approx), - eval_static_operation_cases op vl. - -Definition eval_static_operation_match (op: operation) (vl: list approx) := - match op as z1, vl as z2 return eval_static_operation_cases z1 z2 with - | Omove, v1::nil => - eval_static_operation_case1 v1 - | Ointconst n, nil => - eval_static_operation_case2 n - | Ofloatconst n, nil => - eval_static_operation_case3 n - | Oaddrsymbol s n, nil => - eval_static_operation_case4 s n - | Ocast8signed, I n1 :: nil => - eval_static_operation_case6 n1 - | Ocast16signed, I n1 :: nil => - eval_static_operation_case7 n1 - | Oadd, I n1 :: I n2 :: nil => - eval_static_operation_case8 n1 n2 - | Oadd, S s1 n1 :: I n2 :: nil => - eval_static_operation_case9 s1 n1 n2 - | Oaddimm n, I n1 :: nil => - eval_static_operation_case11 n n1 - | Oaddimm n, S s1 n1 :: nil => - eval_static_operation_case12 n s1 n1 - | Osub, I n1 :: I n2 :: nil => - eval_static_operation_case13 n1 n2 - | Osub, S s1 n1 :: I n2 :: nil => - eval_static_operation_case14 s1 n1 n2 - | Osubimm n, I n1 :: nil => - eval_static_operation_case15 n n1 - | Omul, I n1 :: I n2 :: nil => - eval_static_operation_case16 n1 n2 - | Omulimm n, I n1 :: nil => - eval_static_operation_case17 n n1 - | Odiv, I n1 :: I n2 :: nil => - eval_static_operation_case18 n1 n2 - | Odivu, I n1 :: I n2 :: nil => - eval_static_operation_case19 n1 n2 - | Oand, I n1 :: I n2 :: nil => - eval_static_operation_case20 n1 n2 - | Oandimm n, I n1 :: nil => - eval_static_operation_case21 n n1 - | Oor, I n1 :: I n2 :: nil => - eval_static_operation_case22 n1 n2 - | Oorimm n, I n1 :: nil => - eval_static_operation_case23 n n1 - | Oxor, I n1 :: I n2 :: nil => - eval_static_operation_case24 n1 n2 - | Oxorimm n, I n1 :: nil => - eval_static_operation_case25 n n1 - | Onand, I n1 :: I n2 :: nil => - eval_static_operation_case26 n1 n2 - | Onor, I n1 :: I n2 :: nil => - eval_static_operation_case27 n1 n2 - | Onxor, I n1 :: I n2 :: nil => - eval_static_operation_case28 n1 n2 - | Oshl, I n1 :: I n2 :: nil => - eval_static_operation_case29 n1 n2 - | Oshr, I n1 :: I n2 :: nil => - eval_static_operation_case30 n1 n2 - | Oshrimm n, I n1 :: nil => - eval_static_operation_case31 n n1 - | Oshrximm n, I n1 :: nil => - eval_static_operation_case32 n n1 - | Oshru, I n1 :: I n2 :: nil => - eval_static_operation_case33 n1 n2 - | Orolm amount mask, I n1 :: nil => - eval_static_operation_case34 amount mask n1 - | Onegf, F n1 :: nil => - eval_static_operation_case35 n1 - | Oabsf, F n1 :: nil => - eval_static_operation_case36 n1 - | Oaddf, F n1 :: F n2 :: nil => - eval_static_operation_case37 n1 n2 - | Osubf, F n1 :: F n2 :: nil => - eval_static_operation_case38 n1 n2 - | Omulf, F n1 :: F n2 :: nil => - eval_static_operation_case39 n1 n2 - | Odivf, F n1 :: F n2 :: nil => - eval_static_operation_case40 n1 n2 - | Omuladdf, F n1 :: F n2 :: F n3 :: nil => - eval_static_operation_case41 n1 n2 n3 - | Omulsubf, F n1 :: F n2 :: F n3 :: nil => - eval_static_operation_case42 n1 n2 n3 - | Osingleoffloat, F n1 :: nil => - eval_static_operation_case43 n1 - | Ointoffloat, F n1 :: nil => - eval_static_operation_case44 n1 - | Ofloatofwords, I n1 :: I n2 :: nil => - eval_static_operation_case45 n1 n2 - | Ocmp c, vl => - eval_static_operation_case47 c vl - | Ocast8unsigned, I n1 :: nil => - eval_static_operation_case48 n1 - | Ocast16unsigned, I n1 :: nil => - eval_static_operation_case49 n1 - | op, vl => - eval_static_operation_default op vl - end. - -Definition eval_static_operation (op: operation) (vl: list approx) := - match eval_static_operation_match op vl with - | eval_static_operation_case1 v1 => - v1 - | eval_static_operation_case2 n => - I n - | eval_static_operation_case3 n => - F n - | eval_static_operation_case4 s n => - S s n - | eval_static_operation_case6 n1 => - I(Int.sign_ext 8 n1) - | eval_static_operation_case7 n1 => - I(Int.sign_ext 16 n1) - | eval_static_operation_case8 n1 n2 => - I(Int.add n1 n2) - | eval_static_operation_case9 s1 n1 n2 => - S s1 (Int.add n1 n2) - | eval_static_operation_case11 n n1 => - I (Int.add n1 n) - | eval_static_operation_case12 n s1 n1 => - S s1 (Int.add n1 n) - | eval_static_operation_case13 n1 n2 => - I(Int.sub n1 n2) - | eval_static_operation_case14 s1 n1 n2 => - S s1 (Int.sub n1 n2) - | eval_static_operation_case15 n n1 => - I (Int.sub n n1) - | eval_static_operation_case16 n1 n2 => - I(Int.mul n1 n2) - | eval_static_operation_case17 n n1 => - I(Int.mul n1 n) - | eval_static_operation_case18 n1 n2 => - if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) - | eval_static_operation_case19 n1 n2 => - if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) - | eval_static_operation_case20 n1 n2 => - I(Int.and n1 n2) - | eval_static_operation_case21 n n1 => - I(Int.and n1 n) - | eval_static_operation_case22 n1 n2 => - I(Int.or n1 n2) - | eval_static_operation_case23 n n1 => - I(Int.or n1 n) - | eval_static_operation_case24 n1 n2 => - I(Int.xor n1 n2) - | eval_static_operation_case25 n n1 => - I(Int.xor n1 n) - | eval_static_operation_case26 n1 n2 => - I(Int.xor (Int.and n1 n2) Int.mone) - | eval_static_operation_case27 n1 n2 => - I(Int.xor (Int.or n1 n2) Int.mone) - | eval_static_operation_case28 n1 n2 => - I(Int.xor (Int.xor n1 n2) Int.mone) - | eval_static_operation_case29 n1 n2 => - if Int.ltu n2 Int.iwordsize then I(Int.shl n1 n2) else Unknown - | eval_static_operation_case30 n1 n2 => - if Int.ltu n2 Int.iwordsize then I(Int.shr n1 n2) else Unknown - | eval_static_operation_case31 n n1 => - if Int.ltu n Int.iwordsize then I(Int.shr n1 n) else Unknown - | eval_static_operation_case32 n n1 => - if Int.ltu n Int.iwordsize then I(Int.shrx n1 n) else Unknown - | eval_static_operation_case33 n1 n2 => - if Int.ltu n2 Int.iwordsize then I(Int.shru n1 n2) else Unknown - | eval_static_operation_case34 amount mask n1 => - I(Int.rolm n1 amount mask) - | eval_static_operation_case35 n1 => - F(Float.neg n1) - | eval_static_operation_case36 n1 => - F(Float.abs n1) - | eval_static_operation_case37 n1 n2 => - F(Float.add n1 n2) - | eval_static_operation_case38 n1 n2 => - F(Float.sub n1 n2) - | eval_static_operation_case39 n1 n2 => - F(Float.mul n1 n2) - | eval_static_operation_case40 n1 n2 => - F(Float.div n1 n2) - | eval_static_operation_case41 n1 n2 n3 => - F(Float.add (Float.mul n1 n2) n3) - | eval_static_operation_case42 n1 n2 n3 => - F(Float.sub (Float.mul n1 n2) n3) - | eval_static_operation_case43 n1 => - F(Float.singleoffloat n1) - | eval_static_operation_case44 n1 => - match Float.intoffloat n1 with Some x => I x | None => Unknown end - | eval_static_operation_case45 n1 n2 => - F(Float.from_words n1 n2) - | eval_static_operation_case47 c vl => - match eval_static_condition c vl with - | None => Unknown - | Some b => I(if b then Int.one else Int.zero) - end - | eval_static_operation_case48 n1 => - I(Int.zero_ext 8 n1) - | eval_static_operation_case49 n1 => - I(Int.zero_ext 16 n1) - | eval_static_operation_default op vl => - Unknown - end. - -(** * Operator strength reduction *) - -(** We now define auxiliary functions for strength reduction of - operators and addressing modes: replacing an operator with a cheaper - one if some of its arguments are statically known. These are again - large pattern-matchings expressed in indirect style. *) - -Section STRENGTH_REDUCTION. - -Variable app: reg -> approx. - -Definition intval (r: reg) : option int := - match app r with I n => Some n | _ => None end. - -Inductive cond_strength_reduction_cases: condition -> list reg -> Type := - | csr_case1: - forall c r1 r2, - cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) - | csr_case2: - forall c r1 r2, - cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) - | csr_default: - forall c rl, - cond_strength_reduction_cases c rl. - -Definition cond_strength_reduction_match (cond: condition) (rl: list reg) := - match cond as x, rl as y return cond_strength_reduction_cases x y with - | Ccomp c, r1 :: r2 :: nil => - csr_case1 c r1 r2 - | Ccompu c, r1 :: r2 :: nil => - csr_case2 c r1 r2 - | cond, rl => - csr_default cond rl - end. - -Definition cond_strength_reduction - (cond: condition) (args: list reg) : condition * list reg := - match cond_strength_reduction_match cond args with - | csr_case1 c r1 r2 => - match intval r1, intval r2 with - | Some n, _ => - (Ccompimm (swap_comparison c) n, r2 :: nil) - | _, Some n => - (Ccompimm c n, r1 :: nil) - | _, _ => - (cond, args) - end - | csr_case2 c r1 r2 => - match intval r1, intval r2 with - | Some n, _ => - (Ccompuimm (swap_comparison c) n, r2 :: nil) - | _, Some n => - (Ccompuimm c n, r1 :: nil) - | _, _ => - (cond, args) - end - | csr_default cond args => - (cond, args) - end. - -Definition make_addimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Oaddimm n, r :: nil). - -Definition make_shlimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Orolm n (Int.shl Int.mone n), r :: nil). - -Definition make_shrimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Oshrimm n, r :: nil). - -Definition make_shruimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Orolm (Int.sub Int.iwordsize n) (Int.shru Int.mone n), r :: nil). - -Definition make_mulimm (n: int) (r: reg) := - if Int.eq n Int.zero then - (Ointconst Int.zero, nil) - else if Int.eq n Int.one then - (Omove, r :: nil) - else - match Int.is_power2 n with - | Some l => make_shlimm l r - | None => (Omulimm n, r :: nil) - end. - -Definition make_andimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Ointconst Int.zero, nil) - else if Int.eq n Int.mone then (Omove, r :: nil) - else (Oandimm n, r :: nil). - -Definition make_orimm (n: int) (r: reg) := - if Int.eq n Int.zero then (Omove, r :: nil) - else if Int.eq n Int.mone then (Ointconst Int.mone, nil) - else (Oorimm n, r :: nil). - -Definition make_xorimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Oxorimm n, r :: nil). - -Inductive op_strength_reduction_cases: operation -> list reg -> Type := - | op_strength_reduction_case1: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oadd (r1 :: r2 :: nil) - | op_strength_reduction_case2: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Osub (r1 :: r2 :: nil) - | op_strength_reduction_case3: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Omul (r1 :: r2 :: nil) - | op_strength_reduction_case4: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Odiv (r1 :: r2 :: nil) - | op_strength_reduction_case5: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Odivu (r1 :: r2 :: nil) - | op_strength_reduction_case6: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oand (r1 :: r2 :: nil) - | op_strength_reduction_case7: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oor (r1 :: r2 :: nil) - | op_strength_reduction_case8: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oxor (r1 :: r2 :: nil) - | op_strength_reduction_case9: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oshl (r1 :: r2 :: nil) - | op_strength_reduction_case10: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oshr (r1 :: r2 :: nil) - | op_strength_reduction_case11: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oshru (r1 :: r2 :: nil) - | op_strength_reduction_case12: - forall (c: condition) (rl: list reg), - op_strength_reduction_cases (Ocmp c) rl - | op_strength_reduction_default: - forall (op: operation) (args: list reg), - op_strength_reduction_cases op args. - -Definition op_strength_reduction_match (op: operation) (args: list reg) := - match op as z1, args as z2 return op_strength_reduction_cases z1 z2 with - | Oadd, r1 :: r2 :: nil => - op_strength_reduction_case1 r1 r2 - | Osub, r1 :: r2 :: nil => - op_strength_reduction_case2 r1 r2 - | Omul, r1 :: r2 :: nil => - op_strength_reduction_case3 r1 r2 - | Odiv, r1 :: r2 :: nil => - op_strength_reduction_case4 r1 r2 - | Odivu, r1 :: r2 :: nil => - op_strength_reduction_case5 r1 r2 - | Oand, r1 :: r2 :: nil => - op_strength_reduction_case6 r1 r2 - | Oor, r1 :: r2 :: nil => - op_strength_reduction_case7 r1 r2 - | Oxor, r1 :: r2 :: nil => - op_strength_reduction_case8 r1 r2 - | Oshl, r1 :: r2 :: nil => - op_strength_reduction_case9 r1 r2 - | Oshr, r1 :: r2 :: nil => - op_strength_reduction_case10 r1 r2 - | Oshru, r1 :: r2 :: nil => - op_strength_reduction_case11 r1 r2 - | Ocmp c, rl => - op_strength_reduction_case12 c rl - | op, args => - op_strength_reduction_default op args - end. - -Definition op_strength_reduction (op: operation) (args: list reg) := - match op_strength_reduction_match op args with - | op_strength_reduction_case1 r1 r2 => (* Oadd *) - match intval r1, intval r2 with - | Some n, _ => make_addimm n r2 - | _, Some n => make_addimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case2 r1 r2 => (* Osub *) - match intval r1, intval r2 with - | Some n, _ => (Osubimm n, r2 :: nil) - | _, Some n => make_addimm (Int.neg n) r1 - | _, _ => (op, args) - end - | op_strength_reduction_case3 r1 r2 => (* Omul *) - match intval r1, intval r2 with - | Some n, _ => make_mulimm n r2 - | _, Some n => make_mulimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case4 r1 r2 => (* Odiv *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => (Oshrximm l, r1 :: nil) - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case5 r1 r2 => (* Odivu *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => make_shruimm l r1 - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case6 r1 r2 => (* Oand *) - match intval r1, intval r2 with - | Some n, _ => make_andimm n r2 - | _, Some n => make_andimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case7 r1 r2 => (* Oor *) - match intval r1, intval r2 with - | Some n, _ => make_orimm n r2 - | _, Some n => make_orimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case8 r1 r2 => (* Oxor *) - match intval r1, intval r2 with - | Some n, _ => make_xorimm n r2 - | _, Some n => make_xorimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case9 r1 r2 => (* Oshl *) - match intval r2 with - | Some n => - if Int.ltu n Int.iwordsize - then make_shlimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case10 r1 r2 => (* Oshr *) - match intval r2 with - | Some n => - if Int.ltu n Int.iwordsize - then make_shrimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case11 r1 r2 => (* Oshru *) - match intval r2 with - | Some n => - if Int.ltu n Int.iwordsize - then make_shruimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case12 c args => (* Ocmp *) - let (c', args') := cond_strength_reduction c args in - (Ocmp c', args') - | op_strength_reduction_default op args => (* default *) - (op, args) - end. - -Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg), Type := - | addr_strength_reduction_case1: - forall (r1: reg) (r2: reg), - addr_strength_reduction_cases (Aindexed2) (r1 :: r2 :: nil) - | addr_strength_reduction_case2: - forall (symb: ident) (ofs: int) (r1: reg), - addr_strength_reduction_cases (Abased symb ofs) (r1 :: nil) - | addr_strength_reduction_case3: - forall n r1, - addr_strength_reduction_cases (Aindexed n) (r1 :: nil) - | addr_strength_reduction_default: - forall (addr: addressing) (args: list reg), - addr_strength_reduction_cases addr args. - -Definition addr_strength_reduction_match (addr: addressing) (args: list reg) := - match addr as z1, args as z2 return addr_strength_reduction_cases z1 z2 with - | Aindexed2, r1 :: r2 :: nil => - addr_strength_reduction_case1 r1 r2 - | Abased symb ofs, r1 :: nil => - addr_strength_reduction_case2 symb ofs r1 - | Aindexed n, r1 :: nil => - addr_strength_reduction_case3 n r1 - | addr, args => - addr_strength_reduction_default addr args - end. - -Definition addr_strength_reduction (addr: addressing) (args: list reg) := - match addr_strength_reduction_match addr args with - | addr_strength_reduction_case1 r1 r2 => (* Aindexed2 *) - match app r1, app r2 with - | S symb n1, I n2 => (Aglobal symb (Int.add n1 n2), nil) - | S symb n1, _ => (Abased symb n1, r2 :: nil) - | I n1, S symb n2 => (Aglobal symb (Int.add n1 n2), nil) - | I n1, _ => (Aindexed n1, r2 :: nil) - | _, S symb n2 => (Abased symb n2, r1 :: nil) - | _, I n2 => (Aindexed n2, r1 :: nil) - | _, _ => (addr, args) - end - | addr_strength_reduction_case2 symb ofs r1 => (* Abased *) - match intval r1 with - | Some n => (Aglobal symb (Int.add ofs n), nil) - | _ => (addr, args) - end - | addr_strength_reduction_case3 n r1 => (* Aindexed *) - match app r1 with - | S symb ofs => (Aglobal symb (Int.add ofs n), nil) - | _ => (addr, args) - end - | addr_strength_reduction_default addr args => (* default *) - (addr, args) - end. - -End STRENGTH_REDUCTION. diff --git a/powerpc/ConstpropOp.vp b/powerpc/ConstpropOp.vp new file mode 100644 index 0000000..22e89e3 --- /dev/null +++ b/powerpc/ConstpropOp.vp @@ -0,0 +1,277 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Static analysis and strength reduction for operators + and conditions. This is the machine-dependent part of [Constprop]. *) + +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Op. +Require Import Registers. + +(** * Static analysis *) + +(** To each pseudo-register at each program point, the static analysis + associates a compile-time approximation taken from the following set. *) + +Inductive approx : Type := + | Novalue: approx (** No value possible, code is unreachable. *) + | Unknown: approx (** All values are possible, + no compile-time information is available. *) + | I: int -> approx (** A known integer value. *) + | F: float -> approx (** A known floating-point value. *) + | G: ident -> int -> approx + (** The value is the address of the given global + symbol plus the given integer offset. *) + | S: int -> approx. (** The value is the stack pointer plus the offset. *) + +(** We now define the abstract interpretations of conditions and operators + over this set of approximations. For instance, the abstract interpretation + of the operator [Oaddf] applied to two expressions [a] and [b] is + [F(Float.add f g)] if [a] and [b] have static approximations [Vfloat f] + and [Vfloat g] respectively, and [Unknown] otherwise. + + The static approximations are defined by large pattern-matchings over + the approximations of the results. We write these matchings in the + indirect style described in file [SelectOp] to avoid excessive + duplication of cases in proofs. *) + +Nondetfunction eval_static_condition (cond: condition) (vl: list approx) := + match cond, vl with + | Ccomp c, I n1 :: I n2 :: nil => Some(Int.cmp c n1 n2) + | Ccompu c, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 n2) + | Ccompimm c n, I n1 :: nil => Some(Int.cmp c n1 n) + | Ccompuimm c n, I n1 :: nil => Some(Int.cmpu c n1 n) + | Ccompf c, F n1 :: F n2 :: nil => Some(Float.cmp c n1 n2) + | Cnotcompf c, F n1 :: F n2 :: nil => Some(negb(Float.cmp c n1 n2)) + | Cmaskzero n, I n1 :: nil => Some(Int.eq (Int.and n1 n) Int.zero) + | Cmasknotzero n, I n1::nil => Some(negb(Int.eq (Int.and n1 n) Int.zero)) + | _, _ => None + end. + +Definition eval_static_condition_val (cond: condition) (vl: list approx) := + match eval_static_condition cond vl with + | None => Unknown + | Some b => I(if b then Int.one else Int.zero) + end. + +Definition eval_static_intoffloat (f: float) := + match Float.intoffloat f with Some x => I x | None => Unknown end. + +Nondetfunction eval_static_operation (op: operation) (vl: list approx) := + match op, vl with + | Omove, v1::nil => v1 + | Ointconst n, nil => I n + | Ofloatconst n, nil => F n + | Oaddrsymbol s n, nil => G s n + | Oaddrstack n, nil => S n + | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n1) + | Ocast16signed, I n1 :: nil => I(Int.sign_ext 16 n1) + | Oadd, I n1 :: I n2 :: nil => I(Int.add n1 n2) + | Oadd, G s1 n1 :: I n2 :: nil => G s1 (Int.add n1 n2) + | Oadd, I n1 :: G s2 n2 :: nil => G s2 (Int.add n1 n2) + | Oadd, S n1 :: I n2 :: nil => S (Int.add n1 n2) + | Oadd, I n1 :: S n2 :: nil => S (Int.add n1 n2) + | Oaddimm n, I n1 :: nil => I (Int.add n1 n) + | Oaddimm n, G s1 n1 :: nil => G s1 (Int.add n1 n) + | Oaddimm n, S n1 :: nil => S (Int.add n1 n) + | Osub, I n1 :: I n2 :: nil => I(Int.sub n1 n2) + | Osub, G s1 n1 :: I n2 :: nil => G s1 (Int.sub n1 n2) + | Osub, S n1 :: I n2 :: nil => S (Int.sub n1 n2) + | Osubimm n, I n1 :: nil => I (Int.sub n n1) + | Omul, I n1 :: I n2 :: nil => I(Int.mul n1 n2) + | Omulimm n, I n1 :: nil => I(Int.mul n1 n) + | Odiv, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) + | Odivu, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) + | Oand, I n1 :: I n2 :: nil => I(Int.and n1 n2) + | Oandimm n, I n1 :: nil => I(Int.and n1 n) + | Oor, I n1 :: I n2 :: nil => I(Int.or n1 n2) + | Oorimm n, I n1 :: nil => I(Int.or n1 n) + | Oxor, I n1 :: I n2 :: nil => I(Int.xor n1 n2) + | Oxorimm n, I n1 :: nil => I(Int.xor n1 n) + | Onand, I n1 :: I n2 :: nil => I(Int.xor (Int.and n1 n2) Int.mone) + | Onor, I n1 :: I n2 :: nil => I(Int.xor (Int.or n1 n2) Int.mone) + | Onxor, I n1 :: I n2 :: nil => I(Int.xor (Int.xor n1 n2) Int.mone) + | Oshl, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shl n1 n2) else Unknown + | Oshr, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shr n1 n2) else Unknown + | Oshrimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shr n1 n) else Unknown + | Oshrximm n, I n1 :: nil => if Int.ltu n (Int.repr 31) then I(Int.shrx n1 n) else Unknown + | Oshru, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shru n1 n2) else Unknown + | Orolm amount mask, I n1 :: nil => I(Int.rolm n1 amount mask) + | Oroli amount mask, I n1 :: I n2 :: nil => I(Int.or (Int.and n1 (Int.not mask)) (Int.rolm n2 amount mask)) + | Onegf, F n1 :: nil => F(Float.neg n1) + | Oabsf, F n1 :: nil => F(Float.abs n1) + | Oaddf, F n1 :: F n2 :: nil => F(Float.add n1 n2) + | Osubf, F n1 :: F n2 :: nil => F(Float.sub n1 n2) + | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2) + | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2) + | Omuladdf, F n1 :: F n2 :: F n3 :: nil => F(Float.add (Float.mul n1 n2) n3) + | Omulsubf, F n1 :: F n2 :: F n3 :: nil => F(Float.sub (Float.mul n1 n2) n3) + | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) + | Ointoffloat, F n1 :: nil => eval_static_intoffloat n1 + | Ofloatofwords, I n1 :: I n2 :: nil => F(Float.from_words n1 n2) + | Ocmp c, vl => eval_static_condition_val c vl + | _, _ => Unknown + end. + +(** * Operator strength reduction *) + +(** We now define auxiliary functions for strength reduction of + operators and addressing modes: replacing an operator with a cheaper + one if some of its arguments are statically known. These are again + large pattern-matchings expressed in indirect style. *) + +Section STRENGTH_REDUCTION. + +Nondetfunction cond_strength_reduction + (cond: condition) (args: list reg) (vl: list approx) := + match cond, args, vl with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompimm c n2, r1 :: nil) + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompuimm c n2, r1 :: nil) + | _, _, _ => + (cond, args) + end. + +Definition make_addimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Oaddimm n, r :: nil). + +Definition make_shlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then + (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then + (Orolm n (Int.shl Int.mone n), r1 :: nil) + else + (Oshl, r1 :: r2 :: nil). + +Definition make_shrimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then + (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then + (Oshrimm n, r1 :: nil) + else + (Oshr, r1 :: r2 :: nil). + +Definition make_shruimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then + (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then + (Orolm (Int.sub Int.iwordsize n) (Int.shru Int.mone n), r1 :: nil) + else + (Oshru, r1 :: r2 :: nil). + +Definition make_mulimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then + (Ointconst Int.zero, nil) + else if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => (Orolm l (Int.shl Int.mone l), r1 :: nil) + | None => (Omulimm n, r1 :: nil) + end. + +Definition make_divimm (n: int) (r1 r2: reg) := + match Int.is_power2 n with + | Some l => if Int.ltu l (Int.repr 31) + then (Oshrximm l, r1 :: nil) + else (Odiv, r1 :: r2 :: nil) + | None => (Odiv, r1 :: r2 :: nil) + end. + +Definition make_divuimm (n: int) (r1 r2: reg) := + match Int.is_power2 n with + | Some l => (Orolm (Int.sub Int.iwordsize l) (Int.shru Int.mone l), r1 :: nil) + | None => (Odivu, r1 :: r2 :: nil) + end. + +Definition make_andimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Ointconst Int.zero, nil) + else if Int.eq n Int.mone then (Omove, r :: nil) + else (Oandimm n, r :: nil). + +Definition make_orimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else if Int.eq n Int.mone then (Ointconst Int.mone, nil) + else (Oorimm n, r :: nil). + +Definition make_xorimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Oxorimm n, r :: nil). + +Nondetfunction op_strength_reduction + (op: operation) (args: list reg) (vl: list approx) := + match op, args, vl with + | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_addimm n1 r2 + | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm n2 r1 + | Osub, r1 :: r2 :: nil, I n1 :: v2 :: nil => (Osubimm n1, r2 :: nil) + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 + | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 r1 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 r2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 + | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 + | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 + | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 + | Ocmp c, args, vl => + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args') + | _, _, _ => (op, args) + end. + +Nondetfunction addr_strength_reduction + (addr: addressing) (args: list reg) (vl: list approx) := + match addr, args, vl with + | Aindexed2, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil => + (Aglobal symb (Int.add n1 n2), nil) + | Aindexed2, r1 :: r2 :: nil, I n1 :: G symb n2 :: nil => + (Aglobal symb (Int.add n1 n2), nil) + | Aindexed2, r1 :: r2 :: nil, S n1 :: I n2 :: nil => + (Ainstack (Int.add n1 n2), nil) + | Aindexed2, r1 :: r2 :: nil, I n1 :: S n2 :: nil => + (Ainstack (Int.add n1 n2), nil) + | Aindexed2, r1 :: r2 :: nil, G symb n1 :: v2 :: nil => + (Abased symb n1, r2 :: nil) + | Aindexed2, r1 :: r2 :: nil, v1 :: G symb n2 :: nil => + (Abased symb n2, r1 :: nil) + | Aindexed2, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Aindexed n1, r2 :: nil) + | Aindexed2, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Aindexed n2, r1 :: nil) + | Abased symb ofs, r1 :: nil, I n1 :: nil => + (Aglobal symb (Int.add ofs n1), nil) + | Aindexed n, r1 :: nil, G symb n1 :: nil => + (Aglobal symb (Int.add n1 n), nil) + | Aindexed n, r1 :: nil, S n1 :: nil => + (Ainstack (Int.add n1 n), nil) + | _, _, _ => + (addr, args) + end. + +End STRENGTH_REDUCTION. diff --git a/powerpc/ConstpropOpproof.v b/powerpc/ConstpropOpproof.v index bf065b7..36444b3 100644 --- a/powerpc/ConstpropOpproof.v +++ b/powerpc/ConstpropOpproof.v @@ -30,6 +30,7 @@ Require Import Constprop. Section ANALYSIS. Variable ge: genv. +Variable sp: val. (** We first show that the dataflow analysis is correct with respect to the dynamic semantics: the approximations (sets of values) @@ -43,7 +44,8 @@ Definition val_match_approx (a: approx) (v: val) : Prop := | Unknown => True | I p => v = Vint p | F p => v = Vfloat p - | S symb ofs => exists b, Genv.find_symbol ge symb = Some b /\ v = Vptr b ofs + | G symb ofs => v = symbol_address ge symb ofs + | S ofs => v = Val.add sp (Vint ofs) | _ => False end. @@ -62,12 +64,10 @@ Ltac SimplVMA := simpl in H; (try subst v); SimplVMA | H: (val_match_approx (F _) ?v) |- _ => simpl in H; (try subst v); SimplVMA - | H: (val_match_approx (S _ _) ?v) |- _ => - simpl in H; - (try (elim H; - let b := fresh "b" in let A := fresh in let B := fresh in - (intros b [A B]; subst v; clear H))); - SimplVMA + | H: (val_match_approx (G _ _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA + | H: (val_match_approx (S _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA | _ => idtac end. @@ -75,9 +75,9 @@ Ltac SimplVMA := Ltac InvVLMA := match goal with | H: (val_list_match_approx nil ?vl) |- _ => - inversion H + inv H | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ => - inversion H; SimplVMA; InvVLMA + inv H; SimplVMA; InvVLMA | _ => idtac end. @@ -99,8 +99,15 @@ Proof. InvVLMA; simpl; congruence. Qed. +Remark shift_symbol_address: + forall symb ofs n, + symbol_address ge symb (Int.add ofs n) = Val.add (symbol_address ge symb ofs) (Vint n). +Proof. + unfold symbol_address; intros. destruct (Genv.find_symbol ge symb); auto. +Qed. + Lemma eval_static_operation_correct: - forall op sp al vl m v, + forall op al vl m v, val_list_match_approx al vl -> eval_operation ge sp op vl m = Some v -> val_match_approx (eval_static_operation op al) v. @@ -108,57 +115,44 @@ Proof. intros until v. unfold eval_static_operation. case (eval_static_operation_match op al); intros; - InvVLMA; simpl in *; FuncInv; try congruence. - - destruct (Genv.find_symbol ge s). exists b. intuition congruence. - congruence. - - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - - exists b. split. auto. congruence. - exists b. split. auto. congruence. - exists b. split. auto. congruence. + InvVLMA; simpl in *; FuncInv; try subst v; auto. - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. + rewrite shift_symbol_address; auto. - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. + rewrite Int.add_commut. rewrite shift_symbol_address. rewrite Val.add_commut. auto. - subst v. unfold Int.not. congruence. - subst v. unfold Int.not. congruence. - subst v. unfold Int.not. congruence. + rewrite Int.add_commut; auto. - replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + rewrite Val.add_assoc. rewrite Int.add_commut. auto. - replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + change (Val.add (Vint n1) (Val.add sp (Vint n2)) = Val.add sp (Vint (Int.add n1 n2))). + rewrite Val.add_permut. auto. - destruct (Int.ltu n Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. + rewrite shift_symbol_address; auto. - destruct (Int.ltu n Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. + rewrite Val.add_assoc; auto. - replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + unfold symbol_address. destruct (Genv.find_symbol ge s1); auto. - rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence. + rewrite Val.sub_add_opp. rewrite Val.add_assoc. simpl. rewrite Int.sub_add_opp. auto. - inv H4. destruct (Float.intoffloat f); simpl in H0; inv H0. red; auto. + destruct (Int.eq n2 Int.zero); inv H0; simpl; auto. + destruct (Int.eq n2 Int.zero); inv H0; simpl; auto. - caseEq (eval_static_condition c vl0). - intros. generalize (eval_static_condition_correct _ _ _ m _ H H1). - intro. rewrite H2 in H0. - destruct b; injection H0; intro; subst v; simpl; auto. - intros; simpl; auto. + destruct (Int.ltu n2 Int.iwordsize); simpl; auto. + destruct (Int.ltu n2 Int.iwordsize); simpl; auto. + destruct (Int.ltu n Int.iwordsize); simpl; auto. + destruct (Int.ltu n (Int.repr 31)); inv H0. simpl; auto. + destruct (Int.ltu n2 Int.iwordsize); simpl; auto. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + unfold eval_static_intoffloat. destruct (Float.intoffloat n1); simpl in H0; inv H0. + simpl; auto. - auto. + unfold eval_static_condition_val, Val.of_optbool. + destruct (eval_static_condition c vl0) as []_eqn. + rewrite (eval_static_condition_correct _ _ _ m _ H Heqo). + destruct b; simpl; auto. + simpl; auto. Qed. (** * Correctness of strength reduction *) @@ -171,352 +165,243 @@ Qed. Section STRENGTH_REDUCTION. -Variable app: reg -> approx. -Variable sp: val. +Variable app: D.t. Variable rs: regset. Variable m: mem. -Hypothesis MATCH: forall r, val_match_approx (app r) rs#r. +Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r. -Lemma intval_correct: - forall r n, - intval app r = Some n -> rs#r = Vint n. -Proof. - intros until n. - unfold intval. caseEq (app r); intros; try discriminate. - generalize (MATCH r). unfold val_match_approx. rewrite H. - congruence. -Qed. +Ltac InvApproxRegs := + match goal with + | [ H: _ :: _ = _ :: _ |- _ ] => + injection H; clear H; intros; InvApproxRegs + | [ H: ?v = approx_reg app ?r |- _ ] => + generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs + | _ => idtac + end. Lemma cond_strength_reduction_correct: - forall cond args, - let (cond', args') := cond_strength_reduction app cond args in + forall cond args vl, + vl = approx_regs app args -> + let (cond', args') := cond_strength_reduction cond args vl in eval_condition cond' rs##args' m = eval_condition cond rs##args m. Proof. - intros. unfold cond_strength_reduction. - case (cond_strength_reduction_match cond args); intros. - caseEq (intval app r1); intros. - simpl. rewrite (intval_correct _ _ H). - destruct (rs#r2); auto. rewrite Int.swap_cmp. auto. - 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. + intros until vl. unfold cond_strength_reduction. + case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVMA. + rewrite H0. apply Val.swap_cmp_bool. + rewrite H. auto. + rewrite H0. apply Val.swap_cmpu_bool. + rewrite H. auto. auto. Qed. Lemma make_addimm_correct: - forall n r v, + forall n r, let (op, args) := make_addimm n r in - eval_operation ge sp Oadd (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v. Proof. - intros; unfold make_addimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.add_zero in H. congruence. - rewrite Int.add_zero in H. congruence. - exact H0. + intros. unfold make_addimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto. + exists (Val.add rs#r (Vint n)); auto. 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) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1 r2, + rs#r2 = Vint n -> + let (op, args) := make_shlimm n r1 r2 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v. Proof. intros; unfold make_shlimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shl_zero in H. congruence. - simpl in *. FuncInv. caseEq (Int.ltu n Int.iwordsize); intros. - rewrite H1 in H0. rewrite Int.shl_rolm in H0. auto. exact H1. - rewrite H1 in H0. discriminate. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; intros. + rewrite Val.shl_rolm; auto. econstructor; split; eauto. auto. + econstructor; split; eauto. simpl. congruence. 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) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1 r2, + rs#r2 = Vint n -> + let (op, args) := make_shrimm n r1 r2 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v. Proof. intros; unfold make_shrimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shr_zero in H. congruence. - assumption. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn. + econstructor; split; eauto. simpl. auto. + econstructor; split; eauto. simpl. congruence. 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) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1 r2, + rs#r2 = Vint n -> + let (op, args) := make_shruimm n r1 r2 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v. Proof. intros; unfold make_shruimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shru_zero in H. congruence. - simpl in *. FuncInv. caseEq (Int.ltu n Int.iwordsize); intros. - rewrite H1 in H0. rewrite Int.shru_rolm in H0. auto. exact H1. - rewrite H1 in H0. discriminate. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; intros. + rewrite Val.shru_rolm; auto. econstructor; split; eauto. auto. + econstructor; split; eauto. simpl. congruence. 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) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1 r2, + rs#r2 = Vint n -> + let (op, args) := make_mulimm n r1 r2 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v. Proof. intros; unfold make_mulimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in H0. FuncInv. rewrite Int.mul_zero in H. simpl. congruence. - generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros. - subst n. simpl in H1. simpl. FuncInv. rewrite Int.mul_one in H0. congruence. - caseEq (Int.is_power2 n); intros. - replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil) m) - with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil) m). - apply make_shlimm_correct. - simpl. generalize (Int.is_power2_range _ _ H1). - change (Z_of_nat Int.wordsize) with 32. intro. rewrite H2. - destruct rs#r; auto. rewrite (Int.mul_pow2 i0 _ _ H1). auto. - exact H2. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto. + destruct (Int.is_power2 n) as []_eqn; intros. + rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). rewrite Val.shl_rolm. + econstructor; split; eauto. auto. + eapply Int.is_power2_range; eauto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_divimm_correct: + forall n r1 r2 v, + Val.divs rs#r1 rs#r2 = Some v -> + rs#r2 = Vint n -> + let (op, args) := make_divimm n r1 r2 in + exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divimm. + destruct (Int.is_power2 n) as []_eqn. + destruct (Int.ltu i (Int.repr 31)) as []_eqn. + exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divuimm_correct: + forall n r1 r2 v, + Val.divu rs#r1 rs#r2 = Some v -> + rs#r2 = Vint n -> + let (op, args) := make_divuimm n r1 r2 in + exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divuimm. + destruct (Int.is_power2 n) as []_eqn. + econstructor; split. simpl; eauto. + exploit Int.is_power2_range; eauto. intros RANGE. + rewrite <- Val.shru_rolm; auto. rewrite H0 in H. + destruct (rs#r1); simpl in *; inv H. + destruct (Int.eq n Int.zero); inv H2. + rewrite RANGE. rewrite (Int.divu_pow2 i0 _ _ Heqo). auto. + exists v; auto. Qed. Lemma make_andimm_correct: - forall n r v, + forall n r, let (op, args) := make_andimm n r in - eval_operation ge sp Oand (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v. Proof. intros; unfold make_andimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.and_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. rewrite Int.and_mone in H0. congruence. - exact H1. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto. + econstructor; split; eauto. auto. Qed. Lemma make_orimm_correct: - forall n r v, + forall n r, let (op, args) := make_orimm n r in - eval_operation ge sp Oor (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v. Proof. intros; unfold make_orimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.or_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. rewrite Int.or_mone in H0. congruence. - exact H1. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto. + econstructor; split; eauto. auto. Qed. Lemma make_xorimm_correct: - forall n r v, + forall n r, let (op, args) := make_xorimm n r in - eval_operation ge sp Oxor (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v. Proof. intros; unfold make_xorimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.xor_zero in H. congruence. - exact H0. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto. + econstructor; split; eauto. auto. Qed. Lemma op_strength_reduction_correct: - forall op args v, - let (op', args') := op_strength_reduction app op args in + forall op args vl v, + vl = approx_regs app args -> eval_operation ge sp op rs##args m = Some v -> - eval_operation ge sp op' rs##args' m = Some v. + let (op', args') := op_strength_reduction op args vl in + exists w, eval_operation ge sp op' rs##args' m = Some w /\ Val.lessdef v w. 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) 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. - rewrite (intval_correct _ _ H0). apply make_addimm_correct. - assumption. - (* Osub *) - caseEq (intval app r1); intros. - 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) 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) 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. - rewrite (intval_correct _ _ H0). apply make_mulimm_correct. - assumption. - (* Odiv *) - caseEq (intval app r2); intros. - caseEq (Int.is_power2 i); intros. - rewrite (intval_correct _ _ H) in H1. - simpl in *; FuncInv. destruct (Int.eq i Int.zero). congruence. - change 32 with (Z_of_nat Int.wordsize). - rewrite (Int.is_power2_range _ _ H0). - rewrite (Int.divs_pow2 i1 _ _ H0) in H1. auto. - assumption. - assumption. - (* Odivu *) - 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) 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). - rewrite (Int.is_power2_range _ _ H0). - generalize (Int.eq_spec i Int.zero); case (Int.eq i Int.zero); intros. - subst i. discriminate. - rewrite (Int.divu_pow2 i1 _ _ H0). auto. - assumption. - assumption. - (* Oand *) - caseEq (intval app r1); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oand (Vint i :: rs # r2 :: nil) m) - with (eval_operation ge sp Oand (rs # r2 :: Vint i :: nil) m). - apply make_andimm_correct. - simpl. destruct rs#r2; auto. rewrite Int.and_commut; auto. - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H0). apply make_andimm_correct. - assumption. - (* Oor *) - caseEq (intval app r1); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oor (Vint i :: rs # r2 :: nil) m) - with (eval_operation ge sp Oor (rs # r2 :: Vint i :: nil) m). - apply make_orimm_correct. - simpl. destruct rs#r2; auto. rewrite Int.or_commut; auto. - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H0). apply make_orimm_correct. - assumption. - (* Oxor *) - caseEq (intval app r1); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oxor (Vint i :: rs # r2 :: nil) m) - with (eval_operation ge sp Oxor (rs # r2 :: Vint i :: nil) m). - apply make_xorimm_correct. - simpl. destruct rs#r2; auto. rewrite Int.xor_commut; auto. - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H0). apply make_xorimm_correct. - assumption. - (* Oshl *) - caseEq (intval app r2); intros. - caseEq (Int.ltu i Int.iwordsize); intros. - rewrite (intval_correct _ _ H). apply make_shlimm_correct. - assumption. - assumption. - (* Oshr *) - caseEq (intval app r2); intros. - caseEq (Int.ltu i Int.iwordsize); intros. - rewrite (intval_correct _ _ H). apply make_shrimm_correct. - assumption. - assumption. - (* Oshru *) - caseEq (intval app r2); intros. - caseEq (Int.ltu i Int.iwordsize); intros. - rewrite (intval_correct _ _ H). apply make_shruimm_correct. - assumption. - assumption. - (* Ocmp *) - generalize (cond_strength_reduction_correct c rl). - destruct (cond_strength_reduction app c rl). - simpl. intro. rewrite H. auto. - (* default *) - assumption. + intros until v; unfold op_strength_reduction; + case (op_strength_reduction_match op args vl); simpl; intros. +(* add *) + InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.add_commut. apply make_addimm_correct. + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_addimm_correct. +(* sub *) + InvApproxRegs; SimplVMA. inv H0. rewrite H1. econstructor; split; eauto. + InvApproxRegs; SimplVMA. inv H0. rewrite H. rewrite Val.sub_add_opp. apply make_addimm_correct. +(* mul *) + InvApproxRegs; SimplVMA. inv H0. rewrite H1. rewrite Val.mul_commut. apply make_mulimm_correct; auto. + InvApproxRegs; SimplVMA. inv H0. rewrite H. apply make_mulimm_correct; auto. +(* divs *) + assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto. + apply make_divimm_correct; auto. +(* divu *) + assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto. + apply make_divuimm_correct; auto. +(* and *) + InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.and_commut. apply make_andimm_correct. + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_andimm_correct. +(* or *) + InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.or_commut. apply make_orimm_correct. + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_orimm_correct. +(* xor *) + InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.xor_commut. apply make_xorimm_correct. + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_xorimm_correct. +(* shl *) + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shlimm_correct; auto. +(* shr *) + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shrimm_correct; auto. +(* shru *) + InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shruimm_correct; auto. +(* cmp *) + generalize (cond_strength_reduction_correct c args0 vl0). + destruct (cond_strength_reduction c args0 vl0) as [c' args']; intros. + rewrite <- H1 in H0; auto. econstructor; split; eauto. +(* default *) + exists v; auto. Qed. - -Ltac KnownApprox := - match goal with - | H: ?approx ?r = ?a |- _ => - generalize (MATCH r); rewrite H; intro; clear H; KnownApprox - | _ => idtac - end. Lemma addr_strength_reduction_correct: - forall addr args, - let (addr', args') := addr_strength_reduction app addr args in + forall addr args vl, + vl = approx_regs app args -> + let (addr', args') := addr_strength_reduction addr args vl in eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args. Proof. - intros. - - (* Useful lemmas *) - assert (A0: forall r1 r2, - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r2 :: r1 :: nil))). - intros. simpl. destruct (rs#r1); destruct (rs#r2); auto; - rewrite Int.add_commut; auto. - - assert (A1: forall r1 r2 n, - val_match_approx (I n) rs#r2 -> - eval_addressing ge sp (Aindexed n) (rs ## (r1 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros; simpl in *. rewrite H. auto. - - assert (A2: forall r1 r2 n, - val_match_approx (I n) rs#r1 -> - eval_addressing ge sp (Aindexed n) (rs ## (r2 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros. rewrite A0. apply A1. auto. - - assert (A3: forall r1 r2 id ofs, - val_match_approx (S id ofs) rs#r1 -> - eval_addressing ge sp (Abased id ofs) (rs ## (r2 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros. elim H. intros b [A B]. simpl. rewrite A; rewrite B. auto. - - assert (A4: forall r1 r2 id ofs, - val_match_approx (S id ofs) rs#r2 -> - eval_addressing ge sp (Abased id ofs) (rs ## (r1 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros. rewrite A0. apply A3. auto. - - assert (A5: forall r1 r2 id ofs n, - val_match_approx (S id ofs) rs#r1 -> - val_match_approx (I n) rs#r2 -> - eval_addressing ge sp (Aglobal id (Int.add ofs n)) nil = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros. elim H. intros b [A B]. simpl. rewrite A; rewrite B. - simpl in H0. rewrite H0. auto. - - unfold addr_strength_reduction; - case (addr_strength_reduction_match addr args); intros. - - (* Aindexed2 *) - caseEq (app r1); intros; - caseEq (app r2); intros; - try reflexivity; KnownApprox; auto. - rewrite A0. rewrite Int.add_commut. apply A5; auto. - - (* Abased *) - caseEq (intval app r1); intros. - simpl; rewrite (intval_correct _ _ H). auto. + intros until vl. unfold addr_strength_reduction. + destruct (addr_strength_reduction_match addr args vl); simpl; intros; InvApproxRegs; SimplVMA. + rewrite H; rewrite H0. rewrite shift_symbol_address. auto. + rewrite H; rewrite H0. rewrite Int.add_commut. rewrite shift_symbol_address. rewrite Val.add_commut; auto. + rewrite H; rewrite H0. rewrite Val.add_assoc; auto. + rewrite H; rewrite H0. rewrite Val.add_permut; auto. + rewrite H0. auto. + rewrite H. rewrite Val.add_commut. auto. + rewrite H0. rewrite Val.add_commut; auto. + rewrite H; auto. + rewrite H. rewrite shift_symbol_address. auto. + rewrite H. rewrite shift_symbol_address. auto. + rewrite H. rewrite Val.add_assoc. auto. auto. - - (* Aindexed *) - caseEq (app r1); intros; auto. - simpl; KnownApprox. - elim H0. intros b [A B]. rewrite A; rewrite B. auto. - - (* default *) - reflexivity. Qed. End STRENGTH_REDUCTION. diff --git a/powerpc/Op.v b/powerpc/Op.v index 7bd4247..68b349e 100644 --- a/powerpc/Op.v +++ b/powerpc/Op.v @@ -59,9 +59,7 @@ Inductive operation : Type := | Oaddrstack: int -> operation (**r [rd] is set to the stack pointer plus the given offset *) (*c Integer arithmetic: *) | Ocast8signed: operation (**r [rd] is 8-bit sign extension of [r1] *) - | Ocast8unsigned: operation (**r [rd] is 8-bit zero extension of [r1] *) | Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *) - | Ocast16unsigned: operation (**r [rd] is 16-bit zero extension of [r1] *) | Oadd: operation (**r [rd = r1 + r2] *) | Oaddimm: int -> operation (**r [rd = r1 + n] *) | Osub: operation (**r [rd = r1 - r2] *) @@ -131,138 +129,80 @@ Proof. decide equality. Qed. -(** Evaluation of conditions, operators and addressing modes applied - to lists of values. Return [None] when the computation is undefined: - wrong number of arguments, arguments of the wrong types, undefined - operations such as division by zero. [eval_condition] returns a boolean, - [eval_operation] and [eval_addressing] return a value. *) +(** * Evaluation functions *) -Definition eval_compare_mismatch (c: comparison) : option bool := - match c with Ceq => Some false | Cne => Some true | _ => None end. +Definition symbol_address (F V: Type) (genv: Genv.t F V) (id: ident) (ofs: int) : val := + match Genv.find_symbol genv id with + | Some b => Vptr b ofs + | None => Vundef + end. -Definition eval_compare_null (c: comparison) (n: int) : option bool := - if Int.eq n Int.zero then eval_compare_mismatch c else None. +(** Evaluation of conditions, operators and addressing modes applied + to lists of values. Return [None] when the computation can trigger an + error, e.g. integer division by zero. [eval_condition] returns a boolean, + [eval_operation] and [eval_addressing] return a value. *) -Definition eval_condition (cond: condition) (vl: list val) (m: mem): - option bool := +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) - | 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) - | 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 => - Some (negb (Float.cmp c f1 f2)) - | Cmaskzero n, Vint n1 :: nil => - Some (Int.eq (Int.and n1 n) Int.zero) - | Cmasknotzero n, Vint n1 :: nil => - Some (negb (Int.eq (Int.and n1 n) Int.zero)) - | _, _ => - None - end. - -Definition offset_sp (sp: val) (delta: int) : option val := - match sp with - | Vptr b n => Some (Vptr b (Int.add n delta)) - | _ => None + | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 + | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 + | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n) + | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n) + | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2 + | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2) + | Cmaskzero n, Vint n1 :: nil => Some (Int.eq (Int.and n1 n) Int.zero) + | Cmasknotzero n, Vint n1 :: nil => Some (negb (Int.eq (Int.and n1 n) Int.zero)) + | _, _ => None end. Definition eval_operation - (F V: Type) (genv: Genv.t F V) (sp: val) - (op: operation) (vl: list val) (m: mem): option val := + (F V: Type) (genv: Genv.t F V) (sp: val) + (op: operation) (vl: list val) (m: mem): option val := match op, vl with | Omove, v1::nil => Some v1 | Ointconst n, nil => Some (Vint n) | Ofloatconst n, nil => Some (Vfloat n) - | Oaddrsymbol s ofs, nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b ofs) - end - | Oaddrstack ofs, nil => offset_sp sp ofs - | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1) - | Ocast8unsigned, v1 :: nil => Some (Val.zero_ext 8 v1) - | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) - | Ocast16unsigned, v1 :: nil => Some (Val.zero_ext 16 v1) - | Oadd, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.add n1 n2)) - | Oadd, Vint n1 :: Vptr b2 n2 :: nil => Some (Vptr b2 (Int.add n2 n1)) - | Oadd, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.add n1 n2)) - | Oaddimm n, Vint n1 :: nil => Some (Vint (Int.add n1 n)) - | Oaddimm n, Vptr b1 n1 :: nil => Some (Vptr b1 (Int.add n1 n)) - | Osub, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub n1 n2)) - | Osub, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.sub n1 n2)) - | Osub, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if eq_block b1 b2 then Some (Vint (Int.sub n1 n2)) else None - | Osubimm n, Vint n1 :: nil => Some (Vint (Int.sub n n1)) - | Omul, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.mul n1 n2)) - | Omulimm n, Vint n1 :: nil => Some (Vint (Int.mul n1 n)) - | Odiv, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divs n1 n2)) - | Odivu, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2)) - | Oand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 n2)) - | Oandimm n, Vint n1 :: nil => Some (Vint (Int.and n1 n)) - | Oor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 n2)) - | Oorimm n, Vint n1 :: nil => Some (Vint (Int.or n1 n)) - | Oxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 n2)) - | Oxorimm n, Vint n1 :: nil => Some (Vint (Int.xor n1 n)) - | Onand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.and n1 n2))) - | Onor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.or n1 n2))) - | Onxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.xor n1 n2))) - | Oshl, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shl n1 n2)) else None - | Oshr, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shr n1 n2)) else None - | Oshrimm n, Vint n1 :: nil => - if Int.ltu n Int.iwordsize then Some (Vint (Int.shr n1 n)) else None - | Oshrximm n, Vint n1 :: nil => - if Int.ltu n Int.iwordsize then Some (Vint (Int.shrx n1 n)) else None - | Oshru, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shru n1 n2)) else None - | Orolm amount mask, Vint n1 :: nil => - Some (Vint (Int.rolm n1 amount mask)) - | Oroli amount mask, Vint n1 :: Vint n2 :: nil => - Some (Vint (Int.or (Int.and n1 (Int.not mask)) (Int.rolm n2 amount mask))) - | Onegf, Vfloat f1 :: nil => Some (Vfloat (Float.neg f1)) - | Oabsf, Vfloat f1 :: nil => Some (Vfloat (Float.abs f1)) - | Oaddf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.add f1 f2)) - | Osubf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.sub f1 f2)) - | Omulf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.mul f1 f2)) - | Odivf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.div f1 f2)) - | Omuladdf, Vfloat f1 :: Vfloat f2 :: Vfloat f3 :: nil => - Some (Vfloat (Float.add (Float.mul f1 f2) f3)) - | Omulsubf, Vfloat f1 :: Vfloat f2 :: Vfloat f3 :: nil => - Some (Vfloat (Float.sub (Float.mul f1 f2) f3)) - | Osingleoffloat, v1 :: nil => - Some (Val.singleoffloat v1) - | Ointoffloat, Vfloat f1 :: nil => - option_map Vint (Float.intoffloat f1) - | Ofloatofwords, Vint i1 :: Vint i2 :: nil => - Some (Vfloat (Float.from_words i1 i2)) - | Ocmp c, _ => - match eval_condition c vl m with - | None => None - | Some false => Some Vfalse - | Some true => Some Vtrue - end + | Oaddrsymbol s ofs, nil => Some (symbol_address genv s ofs) + | Oaddrstack ofs, nil => Some (Val.add sp (Vint ofs)) + | Ocast8signed, v1::nil => Some (Val.sign_ext 8 v1) + | Ocast16signed, v1::nil => Some (Val.sign_ext 16 v1) + | Oadd, v1::v2::nil => Some (Val.add v1 v2) + | Oaddimm n, v1::nil => Some (Val.add v1 (Vint n)) + | Osub, v1::v2::nil => Some (Val.sub v1 v2) + | Osubimm n, v1::nil => Some (Val.sub (Vint n) v1) + | Omul, v1::v2::nil => Some (Val.mul v1 v2) + | Omulimm n, v1::nil => Some (Val.mul v1 (Vint n)) + | Odiv, v1::v2::nil => Val.divs v1 v2 + | Odivu, v1::v2::nil => Val.divu v1 v2 + | Oand, v1::v2::nil => Some(Val.and v1 v2) + | Oandimm n, v1::nil => Some (Val.and v1 (Vint n)) + | Oor, v1::v2::nil => Some(Val.or v1 v2) + | Oorimm n, v1::nil => Some (Val.or v1 (Vint n)) + | Oxor, v1::v2::nil => Some(Val.xor v1 v2) + | Oxorimm n, v1::nil => Some (Val.xor v1 (Vint n)) + | Onand, v1::v2::nil => Some (Val.notint (Val.and v1 v2)) + | Onor, v1::v2::nil => Some (Val.notint (Val.or v1 v2)) + | Onxor, v1::v2::nil => Some (Val.notint (Val.xor v1 v2)) + | Oshl, v1::v2::nil => Some (Val.shl v1 v2) + | Oshr, v1::v2::nil => Some (Val.shr v1 v2) + | Oshrimm n, v1::nil => Some (Val.shr v1 (Vint n)) + | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Oshru, v1::v2::nil => Some (Val.shru v1 v2) + | Orolm amount mask, v1::nil => Some (Val.rolm v1 amount mask) + | Oroli amount mask, v1::v2::nil => + Some(Val.or (Val.and v1 (Vint (Int.not mask))) (Val.rolm v2 amount mask)) + | Onegf, v1::nil => Some(Val.negf v1) + | Oabsf, v1::nil => Some(Val.absf v1) + | Oaddf, v1::v2::nil => Some(Val.addf v1 v2) + | Osubf, v1::v2::nil => Some(Val.subf v1 v2) + | Omulf, v1::v2::nil => Some(Val.mulf v1 v2) + | Odivf, v1::v2::nil => Some(Val.divf v1 v2) + | Omuladdf, v1::v2::v3::nil => Some(Val.addf (Val.mulf v1 v2) v3) + | Omulsubf, v1::v2::v3::nil => Some(Val.subf (Val.mulf v1 v2) v3) + | Osingleoffloat, v1::nil => Some(Val.singleoffloat v1) + | Ointoffloat, v1::nil => Val.intoffloat v1 + | Ofloatofwords, v1::v2::nil => Some(Val.floatofwords v1 v2) + | Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m)) | _, _ => None end. @@ -270,39 +210,14 @@ Definition eval_addressing (F V: Type) (genv: Genv.t F V) (sp: val) (addr: addressing) (vl: list val) : option val := match addr, vl with - | Aindexed n, Vptr b1 n1 :: nil => - Some (Vptr b1 (Int.add n1 n)) - | Aindexed2, Vptr b1 n1 :: Vint n2 :: nil => - Some (Vptr b1 (Int.add n1 n2)) - | Aindexed2, Vint n1 :: Vptr b2 n2 :: nil => - Some (Vptr b2 (Int.add n2 n1)) - | Aglobal s ofs, nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b ofs) - end - | Abased s ofs, Vint n1 :: nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b (Int.add ofs n1)) - end - | Ainstack ofs, nil => - offset_sp sp ofs + | Aindexed n, v1::nil => Some (Val.add v1 (Vint n)) + | Aindexed2, v1::v2::nil => Some (Val.add v1 v2) + | Aglobal s ofs, nil => Some (symbol_address genv s ofs) + | Abased s ofs, v1::nil => Some (Val.add (symbol_address genv s ofs) v1) + | Ainstack ofs, nil => Some(Val.add sp (Vint ofs)) | _, _ => None end. -Definition negate_condition (cond: condition): condition := - match cond with - | Ccomp c => Ccomp(negate_comparison c) - | Ccompu c => Ccompu(negate_comparison c) - | Ccompimm c n => Ccompimm (negate_comparison c) n - | Ccompuimm c n => Ccompuimm (negate_comparison c) n - | Ccompf c => Cnotcompf c - | Cnotcompf c => Ccompf c - | Cmaskzero n => Cmasknotzero n - | Cmasknotzero n => Cmaskzero n - end. - Ltac FuncInv := match goal with | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => @@ -315,103 +230,7 @@ Ltac FuncInv := idtac end. -Remark eval_negate_compare_mismatch: - forall c b, - eval_compare_mismatch c = Some b -> - eval_compare_mismatch (negate_comparison c) = Some (negb b). -Proof. - intros until b. unfold eval_compare_mismatch. - destruct c; intro EQ; inv EQ; auto. -Qed. - -Remark eval_negate_compare_null: - forall c i b, - eval_compare_null c i = Some b -> - eval_compare_null (negate_comparison c) i = Some (negb b). -Proof. - unfold eval_compare_null; intros. - destruct (Int.eq i Int.zero). apply eval_negate_compare_mismatch; auto. congruence. -Qed. - -Lemma eval_negate_condition: - 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 (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_cmp. auto. - rewrite Int.negate_cmpu. auto. - apply eval_negate_compare_null; auto. - auto. - rewrite negb_elim. auto. - auto. - rewrite negb_elim. auto. -Qed. - -(** [eval_operation] and [eval_addressing] depend on a global environment - for resolving references to global symbols. We show that they give - the same results if a global environment is replaced by another that - assigns the same addresses to the same symbols. *) - -Section GENV_TRANSF. - -Variable F1 F2 V1 V2: Type. -Variable ge1: Genv.t F1 V1. -Variable ge2: Genv.t F2 V2. -Hypothesis agree_on_symbols: - forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. - -Lemma eval_operation_preserved: - forall sp op vl m, - eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. -Proof. - intros. - unfold eval_operation; destruct op; try rewrite agree_on_symbols; - reflexivity. -Qed. - -Lemma eval_addressing_preserved: - forall sp addr vl, - eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. -Proof. - intros. - unfold eval_addressing; destruct addr; try rewrite agree_on_symbols; - reflexivity. -Qed. - -End GENV_TRANSF. - -(** Recognition of move operations. *) - -Definition is_move_operation - (A: Type) (op: operation) (args: list A) : option A := - match op, args with - | Omove, arg :: nil => Some arg - | _, _ => None - end. - -Lemma is_move_operation_correct: - forall (A: Type) (op: operation) (args: list A) (a: A), - is_move_operation op args = Some a -> - op = Omove /\ args = a :: nil. -Proof. - intros until a. unfold is_move_operation; destruct op; - try (intros; discriminate). - destruct args. intros; discriminate. - destruct args. intros. intuition congruence. - intros; discriminate. -Qed. - -(** Static typing of conditions, operators and addressing modes. *) +(** * Static typing of conditions, operators and addressing modes. *) Definition type_of_condition (c: condition) : list typ := match c with @@ -433,9 +252,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oaddrsymbol _ _ => (nil, Tint) | Oaddrstack _ => (nil, Tint) | Ocast8signed => (Tint :: nil, Tint) - | Ocast8unsigned => (Tint :: nil, Tint) | Ocast16signed => (Tint :: nil, Tint) - | Ocast16unsigned => (Tint :: nil, Tint) | Oadd => (Tint :: Tint :: nil, Tint) | Oaddimm _ => (Tint :: nil, Tint) | Osub => (Tint :: Tint :: nil, Tint) @@ -497,38 +314,52 @@ Lemma type_of_operation_sound: op <> Omove -> eval_operation genv sp op vl m = Some v -> Val.has_type v (snd (type_of_operation op)). -Proof. +Proof with (try exact I). intros. - destruct op; simpl in H0; FuncInv; try subst v; try exact I. + destruct op; simpl in H0; FuncInv; subst; simpl. congruence. - destruct (Genv.find_symbol genv i); simplify_eq H0; intro; subst v; exact I. - simpl. unfold offset_sp in H0. destruct sp; try discriminate. - inversion H0. exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct (eq_block b b0). injection H0; intro; subst v; exact I. - discriminate. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct v0; exact I. - destruct (Float.intoffloat f); simpl in H0; inv H0. exact I. - destruct (eval_condition c vl). - destruct b; injection H0; intro; subst v; exact I. - discriminate. + exact I. + exact I. + unfold symbol_address. destruct (Genv.find_symbol genv i)... + destruct sp... + destruct v0... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... simpl. destruct (zeq b b0)... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... + destruct v0; simpl in *; inv H0. destruct (Int.ltu i (Int.repr 31)); inv H2... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1; destruct v2... + destruct v0; destruct v1; destruct v2... + destruct v0... + destruct v0; simpl in H0; inv H0. destruct (Float.intoffloat f); inv H2... + destruct v0; destruct v1... + destruct (eval_condition c vl m); simpl... destruct b... Qed. Lemma type_of_chunk_correct: @@ -546,243 +377,436 @@ Qed. End SOUNDNESS. -(** Alternate definition of [eval_condition], [eval_op], [eval_addressing] - as total functions that return [Vundef] when not applicable - (instead of [None]). Used in the proof of [PPCgen]. *) - -Section EVAL_OP_TOTAL. +(** * Manipulating and transforming operations *) -Variable F V: Type. -Variable genv: Genv.t F V. +(** Recognition of move operations. *) -Definition find_symbol_offset (id: ident) (ofs: int) : val := - match Genv.find_symbol genv id with - | Some b => Vptr b ofs - | None => Vundef +Definition is_move_operation + (A: Type) (op: operation) (args: list A) : option A := + match op, args with + | Omove, arg :: nil => Some arg + | _, _ => None end. -Definition eval_condition_total (cond: condition) (vl: list val) : val := - match cond, vl with - | Ccomp c, v1::v2::nil => Val.cmp c v1 v2 - | Ccompu c, v1::v2::nil => Val.cmpu c v1 v2 - | Ccompimm c n, v1::nil => Val.cmp c v1 (Vint n) - | Ccompuimm c n, v1::nil => Val.cmpu c v1 (Vint n) - | Ccompf c, v1::v2::nil => Val.cmpf c v1 v2 - | Cnotcompf c, v1::v2::nil => Val.notbool(Val.cmpf c v1 v2) - | Cmaskzero n, v1::nil => Val.notbool (Val.and v1 (Vint n)) - | Cmasknotzero n, v1::nil => Val.notbool(Val.notbool (Val.and v1 (Vint n))) - | _, _ => Vundef +Lemma is_move_operation_correct: + forall (A: Type) (op: operation) (args: list A) (a: A), + is_move_operation op args = Some a -> + op = Omove /\ args = a :: nil. +Proof. + intros until a. unfold is_move_operation; destruct op; + try (intros; discriminate). + destruct args. intros; discriminate. + destruct args. intros. intuition congruence. + intros; discriminate. +Qed. + +(** [negate_condition cond] returns a condition that is logically + equivalent to the negation of [cond]. *) + +Definition negate_condition (cond: condition): condition := + match cond with + | Ccomp c => Ccomp(negate_comparison c) + | Ccompu c => Ccompu(negate_comparison c) + | Ccompimm c n => Ccompimm (negate_comparison c) n + | Ccompuimm c n => Ccompuimm (negate_comparison c) n + | Ccompf c => Cnotcompf c + | Cnotcompf c => Ccompf c + | Cmaskzero n => Cmasknotzero n + | Cmasknotzero n => Cmaskzero n end. -Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val := - match op, vl with - | Omove, v1::nil => v1 - | Ointconst n, nil => Vint n - | Ofloatconst n, nil => Vfloat n - | Oaddrsymbol s ofs, nil => find_symbol_offset s ofs - | Oaddrstack ofs, nil => Val.add sp (Vint ofs) - | Ocast8signed, v1::nil => Val.sign_ext 8 v1 - | Ocast8unsigned, v1::nil => Val.zero_ext 8 v1 - | Ocast16signed, v1::nil => Val.sign_ext 16 v1 - | Ocast16unsigned, v1::nil => Val.zero_ext 16 v1 - | Oadd, v1::v2::nil => Val.add v1 v2 - | Oaddimm n, v1::nil => Val.add v1 (Vint n) - | Osub, v1::v2::nil => Val.sub v1 v2 - | Osubimm n, v1::nil => Val.sub (Vint n) v1 - | Omul, v1::v2::nil => Val.mul v1 v2 - | Omulimm n, v1::nil => Val.mul v1 (Vint n) - | Odiv, v1::v2::nil => Val.divs v1 v2 - | Odivu, v1::v2::nil => Val.divu v1 v2 - | Oand, v1::v2::nil => Val.and v1 v2 - | Oandimm n, v1::nil => Val.and v1 (Vint n) - | Oor, v1::v2::nil => Val.or v1 v2 - | Oorimm n, v1::nil => Val.or v1 (Vint n) - | Oxor, v1::v2::nil => Val.xor v1 v2 - | Oxorimm n, v1::nil => Val.xor v1 (Vint n) - | Onand, v1::v2::nil => Val.notint(Val.and v1 v2) - | Onor, v1::v2::nil => Val.notint(Val.or v1 v2) - | Onxor, v1::v2::nil => Val.notint(Val.xor v1 v2) - | Oshl, v1::v2::nil => Val.shl v1 v2 - | Oshr, v1::v2::nil => Val.shr v1 v2 - | Oshrimm n, v1::nil => Val.shr v1 (Vint n) - | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) - | Oshru, v1::v2::nil => Val.shru v1 v2 - | Orolm amount mask, v1::nil => Val.rolm v1 amount mask - | Oroli amount mask, v1::v2::nil => - Val.or (Val.and v1 (Vint (Int.not mask))) (Val.rolm v2 amount mask) - | Onegf, v1::nil => Val.negf v1 - | Oabsf, v1::nil => Val.absf v1 - | Oaddf, v1::v2::nil => Val.addf v1 v2 - | Osubf, v1::v2::nil => Val.subf v1 v2 - | Omulf, v1::v2::nil => Val.mulf v1 v2 - | Odivf, v1::v2::nil => Val.divf v1 v2 - | Omuladdf, v1::v2::v3::nil => Val.addf (Val.mulf v1 v2) v3 - | Omulsubf, v1::v2::v3::nil => Val.subf (Val.mulf v1 v2) v3 - | Osingleoffloat, v1::nil => Val.singleoffloat v1 - | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ofloatofwords, v1::v2::nil => Val.floatofwords v1 v2 - | Ocmp c, _ => eval_condition_total c vl - | _, _ => Vundef +Lemma eval_negate_condition: + 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; simpl. + rewrite Val.negate_cmp_bool; rewrite H; auto. + rewrite Val.negate_cmpu_bool; rewrite H; auto. + rewrite Val.negate_cmp_bool; rewrite H; auto. + rewrite Val.negate_cmpu_bool; rewrite H; auto. + rewrite H; auto. + destruct (Val.cmpf_bool c v v0); simpl in H; inv H. rewrite negb_elim; auto. + rewrite H0; auto. + rewrite <- H0. rewrite negb_elim; auto. +Qed. + +(** Shifting stack-relative references. This is used in [Stacking]. *) + +Definition shift_stack_addressing (delta: int) (addr: addressing) := + match addr with + | Ainstack ofs => Ainstack (Int.add delta ofs) + | _ => addr end. -Definition eval_addressing_total - (sp: val) (addr: addressing) (vl: list val) : val := - match addr, vl with - | Aindexed n, v1::nil => Val.add v1 (Vint n) - | Aindexed2, v1::v2::nil => Val.add v1 v2 - | Aglobal s ofs, nil => find_symbol_offset s ofs - | Abased s ofs, v1::nil => Val.add (find_symbol_offset s ofs) v1 - | Ainstack ofs, nil => Val.add sp (Vint ofs) - | _, _ => Vundef +Definition shift_stack_operation (delta: int) (op: operation) := + match op with + | Oaddrstack ofs => Oaddrstack (Int.add delta ofs) + | _ => op end. -Lemma eval_compare_mismatch_weaken: - forall c b, - eval_compare_mismatch c = Some b -> - Val.cmp_mismatch c = Val.of_bool b. +Lemma type_shift_stack_addressing: + forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. Proof. - unfold eval_compare_mismatch. intros. destruct c; inv H; auto. + intros. destruct addr; auto. Qed. -Lemma eval_compare_null_weaken: - forall n c b, - eval_compare_null c n = Some b -> - (if Int.eq n Int.zero then Val.cmp_mismatch c else Vundef) = Val.of_bool b. +Lemma type_shift_stack_operation: + forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. Proof. - unfold eval_compare_null. - intros. destruct (Int.eq n Int.zero). apply eval_compare_mismatch_weaken. auto. - discriminate. + intros. destruct op; auto. Qed. -Lemma eval_condition_weaken: - forall c vl b m, - eval_condition c vl m = Some b -> - eval_condition_total c vl = Val.of_bool b. +Lemma eval_shift_stack_addressing: + forall F V (ge: Genv.t F V) sp addr vl delta, + eval_addressing ge sp (shift_stack_addressing delta addr) vl = + eval_addressing ge (Val.add sp (Vint delta)) addr vl. Proof. - intros. - 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. - symmetry. apply Val.notbool_negb_1. - symmetry. apply Val.notbool_negb_1. + intros. destruct addr; simpl; auto. + rewrite Val.add_assoc. simpl. auto. Qed. -Lemma eval_operation_weaken: - forall sp op vl v m, - eval_operation genv sp op vl m = Some v -> - eval_operation_total sp op vl = v. +Lemma eval_shift_stack_operation: + forall F V (ge: Genv.t F V) sp op vl m delta, + eval_operation ge sp (shift_stack_operation delta op) vl m = + eval_operation ge (Val.add sp (Vint delta)) op vl m. Proof. - intros. - unfold eval_operation in H; destruct op; FuncInv; - try subst v; try reflexivity; simpl. - unfold find_symbol_offset. - destruct (Genv.find_symbol genv i); try discriminate. - congruence. - unfold offset_sp in H. - destruct sp; try discriminate. simpl. congruence. - unfold eq_block in H. destruct (zeq b b0); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.ltu i0 Int.iwordsize); congruence. - destruct (Int.ltu i0 Int.iwordsize); congruence. - destruct (Int.ltu i Int.iwordsize); congruence. - 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 m); intros; rewrite H0 in H. - replace v with (Val.of_bool b). - eapply eval_condition_weaken; eauto. - destruct b; simpl; congruence. - discriminate. + intros. destruct op; simpl; auto. + rewrite Val.add_assoc. simpl. auto. Qed. -Lemma eval_addressing_weaken: - forall sp addr vl v, - eval_addressing genv sp addr vl = Some v -> - eval_addressing_total sp addr vl = v. +(** Transformation of addressing modes with two operands or more + into an equivalent arithmetic operation. This is used in the [Reload] + pass when a store instruction cannot be reloaded directly because + it runs out of temporary registers. *) + +(** For the PowerPC, there is only one binary addressing mode: [Aindexed2]. + The corresponding operation is [Oadd]. *) + +Definition op_for_binary_addressing (addr: addressing) : operation := Oadd. + +Lemma eval_op_for_binary_addressing: + forall (F V: Type) (ge: Genv.t F V) sp addr args v m, + (length args >= 2)%nat -> + eval_addressing ge sp addr args = Some v -> + eval_operation ge sp (op_for_binary_addressing addr) args m = Some v. Proof. intros. - unfold eval_addressing in H; destruct addr; FuncInv; - try subst v; simpl; try reflexivity. - unfold find_symbol_offset. - destruct (Genv.find_symbol genv i); congruence. - unfold find_symbol_offset. - destruct (Genv.find_symbol genv i); try congruence. - inversion H. reflexivity. - unfold offset_sp in H. destruct sp; simpl; congruence. + destruct addr; simpl in H0; FuncInv; simpl in H; try omegaContradiction. + simpl; congruence. Qed. -Lemma eval_condition_total_is_bool: - forall cond vl, Val.is_bool (eval_condition_total cond vl). +Lemma type_op_for_binary_addressing: + forall addr, + (length (type_of_addressing addr) >= 2)%nat -> + type_of_operation (op_for_binary_addressing addr) = (type_of_addressing addr, Tint). Proof. - intros; destruct cond; - destruct vl; try apply Val.undef_is_bool; - destruct vl; try apply Val.undef_is_bool; - try (destruct vl; try apply Val.undef_is_bool); simpl. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmpf_is_bool. - apply Val.notbool_is_bool. - apply Val.notbool_is_bool. - apply Val.notbool_is_bool. + intros. destruct addr; simpl in H; reflexivity || omegaContradiction. Qed. -End EVAL_OP_TOTAL. +(** Two-address operations. There is only one: rotate-mask-insert. *) -(** Compatibility of the evaluation functions with the - ``is less defined'' relation over values. *) +Definition two_address_op (op: operation) : bool := + match op with + | Oroli _ _ => true + | _ => false + end. -Section EVAL_LESSDEF. +(** Operations that are so cheap to recompute that CSE should not factor them out. *) + +Definition is_trivial_op (op: operation) : bool := + match op with + | Omove => true + | Ointconst _ => true + | Oaddrsymbol _ _ => true + | Oaddrstack _ => true + | _ => false + end. + +(** Operations that depend on the memory state. *) + +Definition op_depends_on_memory (op: operation) : bool := + match op with + | Ocmp (Ccompu _) => true + | _ => false + end. + +Lemma op_depends_on_memory_correct: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + op_depends_on_memory op = false -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. +Proof. + intros until m2. destruct op; simpl; try congruence. + destruct c; simpl; auto; discriminate. +Qed. + +(** * Invariance and compatibility properties. *) + +(** [eval_operation] and [eval_addressing] depend on a global environment + for resolving references to global symbols. We show that they give + the same results if a global environment is replaced by another that + assigns the same addresses to the same symbols. *) + +Section GENV_TRANSF. + +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. +Hypothesis agree_on_symbols: + forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. + +Lemma eval_operation_preserved: + forall sp op vl m, + eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. +Proof. + intros. destruct op; simpl; auto. + destruct vl; auto. decEq. unfold symbol_address. rewrite agree_on_symbols. auto. +Qed. + +Lemma eval_addressing_preserved: + forall sp addr vl, + eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. +Proof. + intros. destruct addr; simpl; auto; unfold symbol_address; rewrite agree_on_symbols; auto. +Qed. + +End GENV_TRANSF. + +(** Compatibility of the evaluation functions with value injections. *) + +Section EVAL_COMPAT. Variable F V: Type. Variable genv: Genv.t F V. +Variable f: meminj. -Ltac InvLessdef := +Hypothesis symbol_address_inj: + forall id ofs, + val_inject f (symbol_address genv id ofs) (symbol_address genv id ofs). + +Variable m1: mem. +Variable m2: mem. + +Hypothesis valid_pointer_inj: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + +Hypothesis valid_pointer_no_overflow: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + +Hypothesis valid_different_pointers_inj: + forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)). + +Ltac InvInject := match goal with - | [ H: Val.lessdef (Vint _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef (Vfloat _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef (Vptr _ _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef_list nil _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef_list (_ :: _) _ |- _ ] => - inv H; InvLessdef + | [ 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_lessdef: - forall cond vl1 vl2 b m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> +Remark val_add_inj: + forall v1 v1' v2 v2', + val_inject f v1 v1' -> val_inject f v2 v2' -> val_inject f (Val.add v1 v2) (Val.add v1' v2'). +Proof. + intros. inv H; inv H0; simpl; econstructor; eauto. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. +Qed. + +Lemma eval_condition_inj: + forall cond vl1 vl2 b, + val_list_inject f vl1 vl2 -> eval_condition cond vl1 m1 = Some b -> eval_condition cond vl2 m2 = Some b. Proof. - intros. destruct cond; simpl in *; FuncInv; InvLessdef; auto. - 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. +Opaque Int.add. + assert (CMPU: + forall c v1 v2 v1' v2' b, + val_inject f v1 v1' -> + val_inject f v2 v2' -> + Val.cmpu_bool (Mem.valid_pointer m1) c v1 v2 = Some b -> + Val.cmpu_bool (Mem.valid_pointer m2) c v1' v2' = Some b). + intros. inv H; simpl in H1; try discriminate; inv H0; simpl in H1; try discriminate; simpl; auto. + destruct (Mem.valid_pointer m1 b1 (Int.unsigned ofs1)) as []_eqn; try discriminate. + destruct (Mem.valid_pointer m1 b0 (Int.unsigned ofs0)) as []_eqn; try discriminate. + rewrite (valid_pointer_inj _ H2 Heqb4). + rewrite (valid_pointer_inj _ H Heqb0). simpl. + destruct (zeq b1 b0); simpl in H1. + inv H1. rewrite H in H2; inv H2. rewrite zeq_true. + decEq. apply Int.translate_cmpu. + eapply valid_pointer_no_overflow; eauto. + eapply valid_pointer_no_overflow; eauto. + exploit valid_different_pointers_inj; eauto. intros P. + destruct (zeq b2 b3); auto. + destruct P. congruence. + destruct c; simpl in H1; inv H1. + simpl; decEq. rewrite Int.eq_false; auto. congruence. + simpl; decEq. rewrite Int.eq_false; auto. congruence. + + intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. + inv H3; inv H2; simpl in H0; inv H0; auto. + eauto. + inv H3; simpl in H0; inv H0; auto. + eauto. + inv H3; inv H2; simpl in H0; inv H0; auto. + inv H3; inv H2; simpl in H0; inv H0; auto. Qed. Ltac TrivialExists := match goal with - | [ |- exists v2, Some ?v1 = Some v2 /\ Val.lessdef ?v1 v2 ] => - exists v1; split; [auto | constructor] + | [ |- exists v2, Some ?v1 = Some v2 /\ val_inject _ _ v2 ] => + exists v1; split; auto | _ => idtac end. +Lemma eval_operation_inj: + forall op sp1 vl1 sp2 vl2 v1, + val_inject f sp1 sp2 -> + val_list_inject f vl1 vl2 -> + eval_operation genv sp1 op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp2 op vl2 m2 = Some v2 /\ val_inject f v1 v2. +Proof. + intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + inv H; simpl; econstructor; eauto. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + inv H4; simpl; auto. + inv H4; simpl; auto. + apply val_add_inj; auto. + apply val_add_inj; auto. + inv H4; inv H2; simpl; auto. econstructor; eauto. + rewrite Int.sub_add_l. auto. + destruct (zeq b1 b0); auto. subst. rewrite H1 in H0. inv H0. rewrite zeq_true. + rewrite Int.sub_shifted. auto. + inv H4; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. + inv H4; simpl in *; inv H1. destruct (Int.ltu i (Int.repr 31)); inv H2. econstructor; eauto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto; inv H2; simpl; auto; inv H3; simpl; auto. + inv H4; simpl; auto; inv H2; simpl; auto; inv H3; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl in H1; inv H1. simpl. destruct (Float.intoffloat f0); simpl in H2; inv H2. + exists (Vint i); auto. + inv H4; inv H2; simpl; auto. + subst v1. destruct (eval_condition c vl1 m1) as []_eqn. + exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. + destruct b; simpl; constructor. + simpl; constructor. +Qed. + +Lemma eval_addressing_inj: + forall addr sp1 vl1 sp2 vl2 v1, + val_inject f sp1 sp2 -> + val_list_inject f vl1 vl2 -> + eval_addressing genv sp1 addr vl1 = Some v1 -> + exists v2, eval_addressing genv sp2 addr vl2 = Some v2 /\ val_inject f v1 v2. +Proof. + intros. destruct addr; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + apply val_add_inj; auto. + apply val_add_inj; auto. + apply val_add_inj; auto. + apply val_add_inj; auto. +Qed. + +End EVAL_COMPAT. + +(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) + +Section EVAL_LESSDEF. + +Variable F V: Type. +Variable genv: Genv.t F V. + +Remark valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. +Proof. + intros. inv H0. rewrite Int.add_zero. eapply Mem.valid_pointer_extends; eauto. +Qed. + +Remark valid_pointer_no_overflow_extends: + forall m1 b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. +Proof. + intros. inv H. rewrite Zplus_0_r. apply Int.unsigned_range_2. +Qed. + +Remark valid_different_pointers_extends: + forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + Some(b1, 0) = Some (b1', delta1) -> + Some(b2, 0) = Some (b2', delta2) -> + b1' <> b2' \/ + Int.unsigned(Int.add ofs1 (Int.repr delta1)) <> Int.unsigned(Int.add ofs2 (Int.repr delta2)). +Proof. + intros. inv H2; inv H3. auto. +Qed. + +Lemma eval_condition_lessdef: + forall cond vl1 vl2 b m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1). + apply valid_pointer_extends; auto. + apply valid_pointer_no_overflow_extends; auto. + apply valid_different_pointers_extends; auto. + rewrite <- val_list_inject_lessdef. eauto. auto. +Qed. + Lemma eval_operation_lessdef: forall sp op vl1 vl2 v1 m1 m2, Val.lessdef_list vl1 vl2 -> @@ -790,28 +814,18 @@ Lemma eval_operation_lessdef: 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 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 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 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. + intros. rewrite val_list_inject_lessdef in H. + assert (exists v2 : val, + eval_operation genv sp op vl2 m2 = Some v2 + /\ val_inject (fun b => Some(b, 0)) v1 v2). + eapply eval_operation_inj with (m1 := m1) (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + apply valid_pointer_extends; auto. + apply valid_pointer_no_overflow_extends; auto. + apply valid_different_pointers_extends; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. Qed. Lemma eval_addressing_lessdef: @@ -820,40 +834,19 @@ Lemma eval_addressing_lessdef: eval_addressing genv sp addr vl1 = Some v1 -> exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. Proof. - intros. destruct addr; simpl in *; FuncInv; InvLessdef; TrivialExists. - destruct (Genv.find_symbol genv i); inv H0. TrivialExists. - destruct (Genv.find_symbol genv i); inv H0. TrivialExists. - exists v1; auto. + intros. rewrite val_list_inject_lessdef in H. + assert (exists v2 : val, + eval_addressing genv sp addr vl2 = Some v2 + /\ val_inject (fun b => Some(b, 0)) v1 v2). + eapply eval_addressing_inj with (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. Qed. End EVAL_LESSDEF. -(** 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. @@ -867,20 +860,13 @@ 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. +Remark symbol_address_inject: + forall id ofs, val_inject f (symbol_address genv id ofs) (symbol_address genv id ofs). +Proof. + intros. unfold symbol_address. destruct (Genv.find_symbol genv id) as []_eqn; auto. + exploit (proj1 globals); eauto. intros. + econstructor; eauto. rewrite Int.add_zero; auto. +Qed. Lemma eval_condition_inject: forall cond vl1 vl2 b m1 m2, @@ -889,35 +875,12 @@ Lemma eval_condition_inject: 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. + intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. 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 -> @@ -926,15 +889,10 @@ Lemma eval_addressing_inject: 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. + intros. + rewrite eval_shift_stack_addressing. simpl. + eapply eval_addressing_inj with (sp1 := Vptr sp1 Int.zero); eauto. + exact symbol_address_inject. Qed. Lemma eval_operation_inject: @@ -946,102 +904,89 @@ Lemma eval_operation_inject: 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. + intros. + rewrite eval_shift_stack_operation. simpl. + eapply eval_operation_inj with (sp1 := Vptr sp1 Int.zero) (m1 := m1); eauto. + exact symbol_address_inject. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. 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 - it runs out of temporary registers. *) - -(** For the PowerPC, there is only one binary addressing mode: [Aindexed2]. - The corresponding operation is [Oadd]. *) - -Definition op_for_binary_addressing (addr: addressing) : operation := Oadd. - -Lemma eval_op_for_binary_addressing: - forall (F V: Type) (ge: Genv.t F V) sp addr args v m, - (length args >= 2)%nat -> - eval_addressing ge sp addr args = Some v -> - eval_operation ge sp (op_for_binary_addressing addr) args m = Some v. -Proof. - intros. - unfold eval_addressing in H0; destruct addr; FuncInv; simpl in H; try omegaContradiction; - simpl; congruence. -Qed. - -Lemma type_op_for_binary_addressing: - forall addr, - (length (type_of_addressing addr) >= 2)%nat -> - type_of_operation (op_for_binary_addressing addr) = (type_of_addressing addr, Tint). -Proof. - intros. destruct addr; simpl in H; reflexivity || omegaContradiction. -Qed. - -(** Two-address operations. There is only one: rotate-mask-insert. *) +(** * Masks for rotate and mask instructions *) + +(** Recognition of integers that are acceptable as immediate operands + to the [rlwim] PowerPC instruction. These integers are of the form + [000011110000] or [111100001111], that is, a run of one bits + surrounded by zero bits, or conversely. We recognize these integers by + running the following automaton on the bits. The accepting states are + 2, 3, 4, 5, and 6. +<< + 0 1 0 + / \ / \ / \ + \ / \ / \ / + -0--> [1] --1--> [2] --0--> [3] + / + [0] + \ + -1--> [4] --0--> [5] --1--> [6] + / \ / \ / \ + \ / \ / \ / + 1 0 1 +>> +*) -Definition two_address_op (op: operation) : bool := - match op with - | Oroli _ _ => true - | _ => false +Inductive rlw_state: Type := + | RLW_S0 : rlw_state + | RLW_S1 : rlw_state + | RLW_S2 : rlw_state + | RLW_S3 : rlw_state + | RLW_S4 : rlw_state + | RLW_S5 : rlw_state + | RLW_S6 : rlw_state + | RLW_Sbad : rlw_state. + +Definition rlw_transition (s: rlw_state) (b: bool) : rlw_state := + match s, b with + | RLW_S0, false => RLW_S1 + | RLW_S0, true => RLW_S4 + | RLW_S1, false => RLW_S1 + | RLW_S1, true => RLW_S2 + | RLW_S2, false => RLW_S3 + | RLW_S2, true => RLW_S2 + | RLW_S3, false => RLW_S3 + | RLW_S3, true => RLW_Sbad + | RLW_S4, false => RLW_S5 + | RLW_S4, true => RLW_S4 + | RLW_S5, false => RLW_S5 + | RLW_S5, true => RLW_S6 + | RLW_S6, false => RLW_Sbad + | RLW_S6, true => RLW_S6 + | RLW_Sbad, _ => RLW_Sbad end. -(** Operations that are so cheap to recompute that CSE should not factor them out. *) - -Definition is_trivial_op (op: operation) : bool := - match op with - | Omove => true - | Ointconst _ => true - | Oaddrsymbol _ _ => true - | Oaddrstack _ => true - | _ => false +Definition rlw_accepting (s: rlw_state) : bool := + match s with + | RLW_S0 => false + | RLW_S1 => false + | RLW_S2 => true + | RLW_S3 => true + | RLW_S4 => true + | RLW_S5 => true + | RLW_S6 => true + | RLW_Sbad => false end. -(** Operations that depend on the memory state. *) - -Definition op_depends_on_memory (op: operation) : bool := - match op with - | Ocmp (Ccompu _) => true - | _ => false +Fixpoint is_rlw_mask_rec (n: nat) (s: rlw_state) (x: Z) {struct n} : bool := + match n with + | O => + rlw_accepting s + | S m => + let (b, y) := Int.Z_bin_decomp x in + is_rlw_mask_rec m (rlw_transition s b) y end. -Lemma op_depends_on_memory_correct: - forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, - op_depends_on_memory op = false -> - eval_operation ge sp op args m1 = eval_operation ge sp op args m2. -Proof. - intros until m2. destruct op; simpl; try congruence. - destruct c; simpl; congruence. -Qed. +Definition is_rlw_mask (x: int) : bool := + is_rlw_mask_rec Int.wordsize RLW_S0 (Int.unsigned x). diff --git a/powerpc/PrintOp.ml b/powerpc/PrintOp.ml index bfac9a9..3b5e98d 100644 --- a/powerpc/PrintOp.ml +++ b/powerpc/PrintOp.ml @@ -54,9 +54,7 @@ let print_operation reg pp = function | Oaddrstack ofs, [] -> fprintf pp "stack(%ld)" (camlint_of_coqint ofs) | Ocast8signed, [r1] -> fprintf pp "int8signed(%a)" reg r1 - | Ocast8unsigned, [r1] -> fprintf pp "int8unsigned(%a)" reg r1 | Ocast16signed, [r1] -> fprintf pp "int16signed(%a)" reg r1 - | Ocast16unsigned, [r1] -> fprintf pp "int16unsigned(%a)" reg r1 | Oadd, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 | Oaddimm n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2 diff --git a/powerpc/SelectOp.v b/powerpc/SelectOp.v deleted file mode 100644 index b188993..0000000 --- a/powerpc/SelectOp.v +++ /dev/null @@ -1,1018 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Instruction selection for operators *) - -(** The instruction selection pass recognizes opportunities for using - combined arithmetic and logical operations and addressing modes - offered by the target processor. For instance, the expression [x + 1] - can take advantage of the "immediate add" instruction of the processor, - and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned - into a "rotate and mask" instruction. - - This file defines functions for building CminorSel expressions and - statements, especially expressions consisting of operator - applications. These functions examine their arguments to choose - cheaper forms of operators whenever possible. - - For instance, [add e1 e2] will return a CminorSel expression semantically - equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a - [Oaddimm] operator if one of the arguments is an integer constant, - or suppress the addition altogether if one of the arguments is the - null integer. In passing, we perform operator reassociation - ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount - of constant propagation. - - On top of the "smart constructor" functions defined below, - module [Selection] implements the actual instruction selection pass. -*) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Cminor. -Require Import Op. -Require Import CminorSel. - -Open Local Scope cminorsel_scope. - -(** ** Constants **) - -Definition addrsymbol (id: ident) (ofs: int) := - Eop (Oaddrsymbol id ofs) Enil. - -Definition addrstack (ofs: int) := - Eop (Oaddrstack ofs) Enil. - -(** ** Integer logical negation *) - -(** The natural way to write smart constructors is by pattern-matching - on their arguments, recognizing cases where cheaper operators - or combined operators are applicable. For instance, integer logical - negation has three special cases (not-and, not-or and not-xor), - along with a default case that uses not-or over its arguments and itself. - This is written naively as follows: -<< -Definition notint (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ointconst (Int.not n)) Enil - | Eop Oand (t1:::t2:::Enil) => Eop Onand (t1:::t2:::Enil) - | Eop Oor (t1:::t2:::Enil) => Eop Onor (t1:::t2:::Enil) - | Eop Oxor (t1:::t2:::Enil) => Eop Onxor (t1:::t2:::Enil) - | _ => Elet e (Eop Onor (Eletvar O ::: Eletvar O ::: Enil)) - end. ->> - However, Coq expands complex pattern-matchings like the above into - elementary matchings over all constructors of an inductive type, - resulting in much duplication of the final catch-all case. - Such duplications generate huge executable code and duplicate - cases in the correctness proofs. - - To limit this duplication, we use the following trick due to - Yves Bertot. We first define a dependent inductive type that - characterizes the expressions that match each of the 4 cases of interest. -*) - -Inductive notint_cases: forall (e: expr), Type := - | notint_case1: - forall n, - notint_cases (Eop (Ointconst n) Enil) - | notint_case2: - forall t1 t2, - notint_cases (Eop Oand (t1:::t2:::Enil)) - | notint_case3: - forall t1 t2, - notint_cases (Eop Oor (t1:::t2:::Enil)) - | notint_case4: - forall t1 t2, - notint_cases (Eop Oxor (t1:::t2:::Enil)) - | notint_default: - forall (e: expr), - notint_cases e. - -(** We then define a classification function that takes an expression - and return the case in which it falls. Note that the catch-all case - [notint_default] does not state that it is mutually exclusive with - the first three, more specific cases. The classification function - nonetheless chooses the specific cases in preference to the catch-all - case. *) - -Definition notint_match (e: expr) := - match e as z1 return notint_cases z1 with - | Eop (Ointconst n) Enil => - notint_case1 n - | Eop Oand (t1:::t2:::Enil) => - notint_case2 t1 t2 - | Eop Oor (t1:::t2:::Enil) => - notint_case3 t1 t2 - | Eop Oxor (t1:::t2:::Enil) => - notint_case4 t1 t2 - | e => - notint_default e - end. - -(** Finally, the [notint] function we need is defined by a 4-case match - over the result of the classification function. Thus, no duplication - of the right-hand sides of this match occur, and the proof has only - 4 cases to consider (it proceeds by case over [notint_match e]). - Since the default case is not obviously exclusive with the three - specific cases, it is important that its right-hand side is - semantically correct for all possible values of [e], which is the - case here and for all other smart constructors. *) - -Definition notint (e: expr) := - match notint_match e with - | notint_case1 n => - Eop (Ointconst (Int.not n)) Enil - | notint_case2 t1 t2 => - Eop Onand (t1:::t2:::Enil) - | notint_case3 t1 t2 => - Eop Onor (t1:::t2:::Enil) - | notint_case4 t1 t2 => - Eop Onxor (t1:::t2:::Enil) - | notint_default e => - Elet e (Eop Onor (Eletvar O ::: Eletvar O ::: Enil)) - end. - -(** This programming pattern will be applied systematically for the - other smart constructors in this file. *) - -(** ** Boolean negation *) - -Definition notbool_base (e: expr) := - Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil). - -Fixpoint notbool (e: expr) {struct e} : expr := - match e with - | Eop (Ointconst n) Enil => - Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil - | Eop (Ocmp cond) args => - Eop (Ocmp (negate_condition cond)) args - | Econdition e1 e2 e3 => - Econdition e1 (notbool e2) (notbool e3) - | _ => - notbool_base e - end. - -(** ** Integer addition and pointer addition *) - -(* -Definition addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match e with - | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil - | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Int.add n m)) Enil - | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Int.add n m)) Enil - | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) - | _ => Eop (Oaddimm n) (e ::: Enil) - end. -*) - -(** Addition of an integer constant. *) - -Inductive addimm_cases: forall (e: expr), Type := - | addimm_case1: - forall (m: int), - addimm_cases (Eop (Ointconst m) Enil) - | addimm_case2: - forall (s: ident) (m: int), - addimm_cases (Eop (Oaddrsymbol s m) Enil) - | addimm_case3: - forall (m: int), - addimm_cases (Eop (Oaddrstack m) Enil) - | addimm_case4: - forall (m: int) (t: expr), - addimm_cases (Eop (Oaddimm m) (t ::: Enil)) - | addimm_default: - forall (e: expr), - addimm_cases e. - -Definition addimm_match (e: expr) := - match e as z1 return addimm_cases z1 with - | Eop (Ointconst m) Enil => - addimm_case1 m - | Eop (Oaddrsymbol s m) Enil => - addimm_case2 s m - | Eop (Oaddrstack m) Enil => - addimm_case3 m - | Eop (Oaddimm m) (t ::: Enil) => - addimm_case4 m t - | e => - addimm_default e - end. - -Definition addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match addimm_match e with - | addimm_case1 m => - Eop (Ointconst(Int.add n m)) Enil - | addimm_case2 s m => - Eop (Oaddrsymbol s (Int.add n m)) Enil - | addimm_case3 m => - Eop (Oaddrstack (Int.add n m)) Enil - | addimm_case4 m t => - Eop (Oaddimm(Int.add n m)) (t ::: Enil) - | addimm_default e => - Eop (Oaddimm n) (e ::: Enil) - end. - -(** Addition of two integer or pointer expressions. *) - -(* -Definition add (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) - | Eop(Oaddimm n1) (t1:::Enil)), t2 => addimm n1 (Eop Oadd (t1:::t2:::Enil)) - | t1, Eop (Ointconst n2) Enil => addimm n2 t1 - | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm n2 (Eop Oadd (t1:::t2:::Enil)) - | Eop (Oaddrsymbol s n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => Eop Oadd (Eop (Oaddrsymbol s (Int.add n1 n2)) Enil ::: t2 ::: Enil) - | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => Eop Oadd (Eop (Oaddstack (Int.add n1 n2)) Enil ::: t2 ::: Enil) - | _, _ => Eop Oadd (e1:::e2:::Enil) - end. -*) - -Inductive add_cases: forall (e1: expr) (e2: expr), Type := - | add_case1: - forall (n1: int) (t2: expr), - add_cases (Eop (Ointconst n1) Enil) (t2) - | add_case2: - forall (n1: int) (t1: expr) (n2: int) (t2: expr), - add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) - | add_case3: - forall (n1: int) (t1: expr) (t2: expr), - add_cases (Eop(Oaddimm n1) (t1:::Enil)) (t2) - | add_case4: - forall (t1: expr) (n2: int), - add_cases (t1) (Eop (Ointconst n2) Enil) - | add_case5: - forall (t1: expr) (n2: int) (t2: expr), - add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) - | add_case6: - forall s n1 n2 t2, - add_cases (Eop (Oaddrsymbol s n1) Enil) (Eop (Oaddimm n2) (t2:::Enil)) - | add_case7: - forall n1 n2 t2, - add_cases (Eop (Oaddrstack n1) Enil) (Eop (Oaddimm n2) (t2:::Enil)) - | add_default: - forall (e1: expr) (e2: expr), - add_cases e1 e2. - -Definition add_match_aux (e1: expr) (e2: expr) := - match e2 as z2 return add_cases e1 z2 with - | Eop (Ointconst n2) Enil => - add_case4 e1 n2 - | Eop (Oaddimm n2) (t2:::Enil) => - add_case5 e1 n2 t2 - | e2 => - add_default e1 e2 - end. - -Definition add_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return add_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - add_case1 n1 t2 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => - add_case2 n1 t1 n2 t2 - | Eop(Oaddimm n1) (t1:::Enil), t2 => - add_case3 n1 t1 t2 - | Eop (Oaddrsymbol s n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => - add_case6 s n1 n2 t2 - | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => - add_case7 n1 n2 t2 - | e1, e2 => - add_match_aux e1 e2 - end. - -Definition add (e1: expr) (e2: expr) := - match add_match e1 e2 with - | add_case1 n1 t2 => - addimm n1 t2 - | add_case2 n1 t1 n2 t2 => - addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) - | add_case3 n1 t1 t2 => - addimm n1 (Eop Oadd (t1:::t2:::Enil)) - | add_case4 t1 n2 => - addimm n2 t1 - | add_case5 t1 n2 t2 => - addimm n2 (Eop Oadd (t1:::t2:::Enil)) - | add_case6 s n1 n2 t2 => - Eop Oadd (Eop (Oaddrsymbol s (Int.add n1 n2)) Enil ::: t2 ::: Enil) - | add_case7 n1 n2 t2 => - Eop Oadd (Eop (Oaddrstack (Int.add n1 n2)) Enil ::: t2 ::: Enil) - | add_default e1 e2 => - Eop Oadd (e1:::e2:::Enil) - end. - -(** ** Integer and pointer subtraction *) - -(* -Definition sub (e1: expr) (e2: expr) := - match e1, e2 with - | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => addimm -(intsub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | Eop (Oaddimm n1) (t1:::Enil), t2 => addimm n1 (Eop Osub (t1:::t2:::Rni -l)) - | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1::: -:t2:::Enil)) - | _, _ => Eop Osub (e1:::e2:::Enil) - end. -*) - -Inductive sub_cases: forall (e1: expr) (e2: expr), Type := - | sub_case1: - forall (t1: expr) (n2: int), - sub_cases (t1) (Eop (Ointconst n2) Enil) - | sub_case2: - forall (n1: int) (t1: expr) (n2: int) (t2: expr), - sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) - | sub_case3: - forall (n1: int) (t1: expr) (t2: expr), - sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) - | sub_case4: - forall (t1: expr) (n2: int) (t2: expr), - sub_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) - | sub_default: - forall (e1: expr) (e2: expr), - sub_cases e1 e2. - -Definition sub_match_aux (e1: expr) (e2: expr) := - match e1 as z1 return sub_cases z1 e2 with - | Eop (Oaddimm n1) (t1:::Enil) => - sub_case3 n1 t1 e2 - | e1 => - sub_default e1 e2 - end. - -Definition sub_match (e1: expr) (e2: expr) := - match e2 as z2, e1 as z1 return sub_cases z1 z2 with - | Eop (Ointconst n2) Enil, t1 => - sub_case1 t1 n2 - | Eop (Oaddimm n2) (t2:::Enil), Eop (Oaddimm n1) (t1:::Enil) => - sub_case2 n1 t1 n2 t2 - | Eop (Oaddimm n2) (t2:::Enil), t1 => - sub_case4 t1 n2 t2 - | e2, e1 => - sub_match_aux e1 e2 - end. - -Definition sub (e1: expr) (e2: expr) := - match sub_match e1 e2 with - | sub_case1 t1 n2 => - addimm (Int.neg n2) t1 - | sub_case2 n1 t1 n2 t2 => - addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | sub_case3 n1 t1 t2 => - addimm n1 (Eop Osub (t1:::t2:::Enil)) - | sub_case4 t1 n2 t2 => - addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) - | sub_default e1 e2 => - Eop Osub (e1:::e2:::Enil) - end. - -(** ** Rotates and immediate shifts *) - -(** Recognition of integers that are acceptable as immediate operands - to the [rlwim] PowerPC instruction. These integers are of the form - [000011110000] or [111100001111], that is, a run of one bits - surrounded by zero bits, or conversely. We recognize these integers by - running the following automaton on the bits. The accepting states are - 2, 3, 4, 5, and 6. -<< - 0 1 0 - / \ / \ / \ - \ / \ / \ / - -0--> [1] --1--> [2] --0--> [3] - / - [0] - \ - -1--> [4] --0--> [5] --1--> [6] - / \ / \ / \ - \ / \ / \ / - 1 0 1 ->> -*) - -Inductive rlw_state: Type := - | RLW_S0 : rlw_state - | RLW_S1 : rlw_state - | RLW_S2 : rlw_state - | RLW_S3 : rlw_state - | RLW_S4 : rlw_state - | RLW_S5 : rlw_state - | RLW_S6 : rlw_state - | RLW_Sbad : rlw_state. - -Definition rlw_transition (s: rlw_state) (b: bool) : rlw_state := - match s, b with - | RLW_S0, false => RLW_S1 - | RLW_S0, true => RLW_S4 - | RLW_S1, false => RLW_S1 - | RLW_S1, true => RLW_S2 - | RLW_S2, false => RLW_S3 - | RLW_S2, true => RLW_S2 - | RLW_S3, false => RLW_S3 - | RLW_S3, true => RLW_Sbad - | RLW_S4, false => RLW_S5 - | RLW_S4, true => RLW_S4 - | RLW_S5, false => RLW_S5 - | RLW_S5, true => RLW_S6 - | RLW_S6, false => RLW_Sbad - | RLW_S6, true => RLW_S6 - | RLW_Sbad, _ => RLW_Sbad - end. - -Definition rlw_accepting (s: rlw_state) : bool := - match s with - | RLW_S0 => false - | RLW_S1 => false - | RLW_S2 => true - | RLW_S3 => true - | RLW_S4 => true - | RLW_S5 => true - | RLW_S6 => true - | RLW_Sbad => false - end. - -Fixpoint is_rlw_mask_rec (n: nat) (s: rlw_state) (x: Z) {struct n} : bool := - match n with - | O => - rlw_accepting s - | S m => - let (b, y) := Int.Z_bin_decomp x in - is_rlw_mask_rec m (rlw_transition s b) y - end. - -Definition is_rlw_mask (x: int) : bool := - is_rlw_mask_rec Int.wordsize RLW_S0 (Int.unsigned x). - -(* -Definition rolm (e1: expr) := - match e1 with - | Eop (Ointconst n1) Enil => - Eop (Ointconst(Int.and (Int.rol n1 amount2) mask2)) Enil - | Eop (Orolm amount1 mask1) (t1:::Enil) => - let amount := Int.and (Int.add amount1 amount2) Ox1Fl in - let mask := Int.and (Int.rol mask1 amount2) mask2 in - if Int.is_rlw_mask mask - then Eop (Orolm amount mask) (t1:::Enil) - else Eop (Orolm amount2 mask2) (e1:::Enil) - | _ => Eop (Orolm amount2 mask2) (e1:::Enil) - end -*) - -Inductive rolm_cases: forall (e1: expr), Type := - | rolm_case1: - forall (n1: int), - rolm_cases (Eop (Ointconst n1) Enil) - | rolm_case2: - forall (amount1: int) (mask1: int) (t1: expr), - rolm_cases (Eop (Orolm amount1 mask1) (t1:::Enil)) - | rolm_default: - forall (e1: expr), - rolm_cases e1. - -Definition rolm_match (e1: expr) := - match e1 as z1 return rolm_cases z1 with - | Eop (Ointconst n1) Enil => - rolm_case1 n1 - | Eop (Orolm amount1 mask1) (t1:::Enil) => - rolm_case2 amount1 mask1 t1 - | e1 => - rolm_default e1 - end. - -Definition rolm (e1: expr) (amount2 mask2: int) := - match rolm_match e1 with - | rolm_case1 n1 => - Eop (Ointconst(Int.and (Int.rol n1 amount2) mask2)) Enil - | rolm_case2 amount1 mask1 t1 => - let amount := Int.modu (Int.add amount1 amount2) Int.iwordsize in - let mask := Int.and (Int.rol mask1 amount2) mask2 in - if is_rlw_mask mask - then Eop (Orolm amount mask) (t1:::Enil) - else Eop (Orolm amount2 mask2) (e1:::Enil) - | rolm_default e1 => - Eop (Orolm amount2 mask2) (e1:::Enil) - end. - -Definition shlimm (e1: expr) (n2: int) := - if Int.eq n2 Int.zero then - e1 - else if Int.ltu n2 Int.iwordsize then - rolm e1 n2 (Int.shl Int.mone n2) - else - Eop Oshl (e1:::Eop (Ointconst n2) Enil:::Enil). - -Definition shruimm (e1: expr) (n2: int) := - if Int.eq n2 Int.zero then - e1 - else if Int.ltu n2 Int.iwordsize then - rolm e1 (Int.sub Int.iwordsize n2) (Int.shru Int.mone n2) - else - Eop Oshru (e1:::Eop (Ointconst n2) Enil:::Enil). - -(** ** Integer multiply *) - -Definition mulimm_base (n1: int) (e2: expr) := - match Int.one_bits n1 with - | i :: nil => - shlimm e2 i - | i :: j :: nil => - Elet e2 - (Eop Oadd (shlimm (Eletvar 0) i ::: - shlimm (Eletvar 0) j ::: Enil)) - | _ => - Eop (Omulimm n1) (e2:::Enil) - end. - -(* -Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then - Elet e2 (Eop (Ointconst Int.zero) Enil) - else if Int.eq n1 Int.one then - e2 - else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil - | Eop (Oaddimm n2) (t2:::Enil) => addimm (intmul n1 n2) (mulimm_base n1 t2) - | _ => mulimm_base n1 e2 - end. -*) - -Inductive mulimm_cases: forall (e2: expr), Type := - | mulimm_case1: - forall (n2: int), - mulimm_cases (Eop (Ointconst n2) Enil) - | mulimm_case2: - forall (n2: int) (t2: expr), - mulimm_cases (Eop (Oaddimm n2) (t2:::Enil)) - | mulimm_default: - forall (e2: expr), - mulimm_cases e2. - -Definition mulimm_match (e2: expr) := - match e2 as z1 return mulimm_cases z1 with - | Eop (Ointconst n2) Enil => - mulimm_case1 n2 - | Eop (Oaddimm n2) (t2:::Enil) => - mulimm_case2 n2 t2 - | e2 => - mulimm_default e2 - end. - -Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then - Elet e2 (Eop (Ointconst Int.zero) Enil) - else if Int.eq n1 Int.one then - e2 - else match mulimm_match e2 with - | mulimm_case1 n2 => - Eop (Ointconst(Int.mul n1 n2)) Enil - | mulimm_case2 n2 t2 => - addimm (Int.mul n1 n2) (mulimm_base n1 t2) - | mulimm_default e2 => - mulimm_base n1 e2 - end. - -(* -Definition mul (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 - | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 - | _, _ => Eop Omul (e1:::e2:::Enil) - end. -*) - -Inductive mul_cases: forall (e1: expr) (e2: expr), Type := - | mul_case1: - forall (n1: int) (t2: expr), - mul_cases (Eop (Ointconst n1) Enil) (t2) - | mul_case2: - forall (t1: expr) (n2: int), - mul_cases (t1) (Eop (Ointconst n2) Enil) - | mul_default: - forall (e1: expr) (e2: expr), - mul_cases e1 e2. - -Definition mul_match_aux (e1: expr) (e2: expr) := - match e2 as z2 return mul_cases e1 z2 with - | Eop (Ointconst n2) Enil => - mul_case2 e1 n2 - | e2 => - mul_default e1 e2 - end. - -Definition mul_match (e1: expr) (e2: expr) := - match e1 as z1 return mul_cases z1 e2 with - | Eop (Ointconst n1) Enil => - mul_case1 n1 e2 - | e1 => - mul_match_aux e1 e2 - end. - -Definition mul (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => - mulimm n1 t2 - | mul_case2 t1 n2 => - mulimm n2 t1 - | mul_default e1 e2 => - Eop Omul (e1:::e2:::Enil) - end. - -(** ** Bitwise and, or, xor *) - -Definition andimm (n1: int) (e2: expr) := - if is_rlw_mask n1 - then rolm e2 Int.zero n1 - else Eop (Oandimm n1) (e2:::Enil). - -Definition and (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => - andimm n1 t2 - | mul_case2 t1 n2 => - andimm n2 t1 - | mul_default e1 e2 => - Eop Oand (e1:::e2:::Enil) - end. - -Definition same_expr_pure (e1 e2: expr) := - match e1, e2 with - | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false - | _, _ => false - end. - -Inductive or_cases: forall (e1: expr) (e2: expr), Type := - | or_case1: - forall (amount1: int) (mask1: int) (t1: expr) - (amount2: int) (mask2: int) (t2: expr), - or_cases (Eop (Orolm amount1 mask1) (t1:::Enil)) - (Eop (Orolm amount2 mask2) (t2:::Enil)) - | or_default: - forall (e1: expr) (e2: expr), - or_cases e1 e2. - -Definition or_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return or_cases z1 z2 with - | Eop (Orolm amount1 mask1) (t1:::Enil), - Eop (Orolm amount2 mask2) (t2:::Enil) => - or_case1 amount1 mask1 t1 amount2 mask2 t2 - | e1, e2 => - or_default e1 e2 - end. - -Definition or (e1: expr) (e2: expr) := - match or_match e1 e2 with - | or_case1 amount1 mask1 t1 amount2 mask2 t2 => - if Int.eq amount1 amount2 - && is_rlw_mask (Int.or mask1 mask2) - && same_expr_pure t1 t2 then - Eop (Orolm amount1 (Int.or mask1 mask2)) (t1:::Enil) - else if Int.eq amount1 Int.zero - && Int.eq mask1 (Int.not mask2) then - Eop (Oroli amount2 mask2) (t1:::t2:::Enil) - else if Int.eq amount2 Int.zero - && Int.eq mask2 (Int.not mask1) then - Eop (Oroli amount1 mask1) (t2:::t1:::Enil) - else - Eop Oor (e1:::e2:::Enil) - | or_default e1 e2 => - Eop Oor (e1:::e2:::Enil) - end. - -(** ** Integer division and modulus *) - -Definition divs (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). - -Definition mod_aux (divop: operation) (e1 e2: expr) := - Elet e1 - (Elet (lift e2) - (Eop Osub (Eletvar 1 ::: - Eop Omul (Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) ::: - Eletvar 0 ::: - Enil) ::: - Enil))). - -Definition mods := mod_aux Odiv. - -Inductive divu_cases: forall (e2: expr), Type := - | divu_case1: - forall (n2: int), - divu_cases (Eop (Ointconst n2) Enil) - | divu_default: - forall (e2: expr), - divu_cases e2. - -Definition divu_match (e2: expr) := - match e2 as z1 return divu_cases z1 with - | Eop (Ointconst n2) Enil => - divu_case1 n2 - | e2 => - divu_default e2 - end. - -Definition divu (e1: expr) (e2: expr) := - match divu_match e2 with - | divu_case1 n2 => - match Int.is_power2 n2 with - | Some l2 => shruimm e1 l2 - | None => Eop Odivu (e1:::e2:::Enil) - end - | divu_default e2 => - Eop Odivu (e1:::e2:::Enil) - end. - -Definition modu (e1: expr) (e2: expr) := - match divu_match e2 with - | divu_case1 n2 => - match Int.is_power2 n2 with - | Some l2 => andimm (Int.sub n2 Int.one) e1 - | None => mod_aux Odivu e1 e2 - end - | divu_default e2 => - mod_aux Odivu e1 e2 - end. - -(** ** General shifts *) - -Inductive shift_cases: forall (e1: expr), Type := - | shift_case1: - forall (n2: int), - shift_cases (Eop (Ointconst n2) Enil) - | shift_default: - forall (e1: expr), - shift_cases e1. - -Definition shift_match (e1: expr) := - match e1 as z1 return shift_cases z1 with - | Eop (Ointconst n2) Enil => - shift_case1 n2 - | e1 => - shift_default e1 - end. - -Definition shl (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shlimm e1 n2 - | shift_default e2 => - Eop Oshl (e1:::e2:::Enil) - end. - -Definition shru (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shruimm e1 n2 - | shift_default e2 => - Eop Oshru (e1:::e2:::Enil) - end. - -(** ** Floating-point arithmetic *) - -Parameter use_fused_mul : unit -> bool. - -(* -Definition addf (e1: expr) (e2: expr) := - match e1, e2 with - | Eop Omulf (t1:::t2:::Enil), t3 => Eop Omuladdf (t1:::t2:::t3:::Enil) - | t1, Eop Omulf (t2:::t3:::Enil) => Elet t1 (Eop Omuladdf (t2:::t3:::Rvar 0:::Enil)) - | _, _ => Eop Oaddf (e1:::e2:::Enil) - end. -*) - -Inductive addf_cases: forall (e1: expr) (e2: expr), Type := - | addf_case1: - forall (t1: expr) (t2: expr) (t3: expr), - addf_cases (Eop Omulf (t1:::t2:::Enil)) (t3) - | addf_case2: - forall (t1: expr) (t2: expr) (t3: expr), - addf_cases (t1) (Eop Omulf (t2:::t3:::Enil)) - | addf_default: - forall (e1: expr) (e2: expr), - addf_cases e1 e2. - -Definition addf_match_aux (e1: expr) (e2: expr) := - match e2 as z2 return addf_cases e1 z2 with - | Eop Omulf (t2:::t3:::Enil) => - addf_case2 e1 t2 t3 - | e2 => - addf_default e1 e2 - end. - -Definition addf_match (e1: expr) (e2: expr) := - match e1 as z1 return addf_cases z1 e2 with - | Eop Omulf (t1:::t2:::Enil) => - addf_case1 t1 t2 e2 - | e1 => - addf_match_aux e1 e2 - end. - -Definition addf (e1: expr) (e2: expr) := - if use_fused_mul tt then - match addf_match e1 e2 with - | addf_case1 t1 t2 t3 => - Eop Omuladdf (t1:::t2:::t3:::Enil) - | addf_case2 t1 t2 t3 => - Eop Omuladdf (t2:::t3:::t1:::Enil) - | addf_default e1 e2 => - Eop Oaddf (e1:::e2:::Enil) - end - else Eop Oaddf (e1:::e2:::Enil). - -(* -Definition subf (e1: expr) (e2: expr) := - match e1, e2 with - | Eop Omulfloat (t1:::t2:::Enil), t3 => Eop Omulsubf (t1:::t2:::t3:::Enil) - | _, _ => Eop Osubf (e1:::e2:::Enil) - end. -*) - -Inductive subf_cases: forall (e1: expr) (e2: expr), Type := - | subf_case1: - forall (t1: expr) (t2: expr) (t3: expr), - subf_cases (Eop Omulf (t1:::t2:::Enil)) (t3) - | subf_default: - forall (e1: expr) (e2: expr), - subf_cases e1 e2. - -Definition subf_match (e1: expr) (e2: expr) := - match e1 as z1 return subf_cases z1 e2 with - | Eop Omulf (t1:::t2:::Enil) => - subf_case1 t1 t2 e2 - | e1 => - subf_default e1 e2 - end. - -Definition subf (e1: expr) (e2: expr) := - if use_fused_mul tt then - match subf_match e1 e2 with - | subf_case1 t1 t2 t3 => - Eop Omulsubf (t1:::t2:::t3:::Enil) - | subf_default e1 e2 => - Eop Osubf (e1:::e2:::Enil) - end - else Eop Osubf (e1:::e2:::Enil). - -(** ** Comparisons *) - -Inductive comp_cases: forall (e1: expr) (e2: expr), Type := - | comp_case1: - forall n1 t2, - comp_cases (Eop (Ointconst n1) Enil) (t2) - | comp_case2: - forall t1 n2, - comp_cases (t1) (Eop (Ointconst n2) Enil) - | comp_default: - forall (e1: expr) (e2: expr), - comp_cases e1 e2. - -Definition comp_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return comp_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - comp_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => - comp_case2 t1 n2 - | e1, e2 => - comp_default e1 e2 - end. - -Definition comp (c: comparison) (e1: expr) (e2: expr) := - match comp_match e1 e2 with - | comp_case1 n1 t2 => - Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2 ::: Enil) - | comp_case2 t1 n2 => - Eop (Ocmp (Ccompimm c n2)) (t1 ::: Enil) - | comp_default e1 e2 => - Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) - end. - -Definition compu (c: comparison) (e1: expr) (e2: expr) := - match comp_match e1 e2 with - | comp_case1 n1 t2 => - Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2 ::: Enil) - | comp_case2 t1 n2 => - Eop (Ocmp (Ccompuimm c n2)) (t1 ::: Enil) - | comp_default e1 e2 => - Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) - end. - -Definition compf (c: comparison) (e1: expr) (e2: expr) := - Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). - -(** ** Floating-point conversions *) - -Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). - -Definition intuoffloat (e: expr) := - let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in - Elet e - (Econdition (CEcond (Ccompf Clt) (Eletvar O ::: f ::: Enil)) - (intoffloat (Eletvar O)) - (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar O) f)))). - -Definition floatofintu (e: expr) := - subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: e ::: Enil)) - (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Int.zero)) Enil). - -Definition floatofint (e: expr) := - subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil - ::: addimm Float.ox8000_0000 e ::: Enil)) - (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Float.ox8000_0000)) Enil). - -(** ** Other operators, not optimized. *) - -Definition cast8unsigned (e: expr) := Eop Ocast8unsigned (e ::: Enil). -Definition cast8signed (e: expr) := Eop Ocast8signed (e ::: Enil). -Definition cast16unsigned (e: expr) := Eop Ocast16unsigned (e ::: Enil). -Definition cast16signed (e: expr) := Eop Ocast16signed (e ::: Enil). -Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). -Definition negint (e: expr) := Eop (Osubimm Int.zero) (e ::: Enil). -Definition negf (e: expr) := Eop Onegf (e ::: Enil). -Definition absf (e: expr) := Eop Oabsf (e ::: Enil). -Definition xor (e1 e2: expr) := Eop Oxor (e1 ::: e2 ::: Enil). -Definition shr (e1 e2: expr) := Eop Oshr (e1 ::: e2 ::: Enil). -Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). -Definition divf (e1 e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil). - -(** ** Recognition of addressing modes for load and store operations *) - -(* -Definition addressing (e: expr) := - match e with - | Eop (Oaddrsymbol s n) Enil => (Aglobal s n, Enil) - | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) - | Eop Oadd (Eop (Oaddrsymbol s n) Enil) e2 => (Abased(s, n), e2:::Enil) - | Eop (Oaddimm n) (e1:::Enil) => (Aindexed n, e1:::Enil) - | Eop Oadd (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) - | _ => (Aindexed Int.zero, e:::Enil) - end. -*) - -Inductive addressing_cases: forall (e: expr), Type := - | addressing_case1: - forall (s: ident) (n: int), - addressing_cases (Eop (Oaddrsymbol s n) Enil) - | addressing_case2: - forall (n: int), - addressing_cases (Eop (Oaddrstack n) Enil) - | addressing_case3: - forall (s: ident) (n: int) (e2: expr), - addressing_cases - (Eop Oadd (Eop (Oaddrsymbol s n) Enil:::e2:::Enil)) - | addressing_case4: - forall (n: int) (e1: expr), - addressing_cases (Eop (Oaddimm n) (e1:::Enil)) - | addressing_case5: - forall (e1: expr) (e2: expr), - addressing_cases (Eop Oadd (e1:::e2:::Enil)) - | addressing_default: - forall (e: expr), - addressing_cases e. - -Definition addressing_match (e: expr) := - match e as z1 return addressing_cases z1 with - | Eop (Oaddrsymbol s n) Enil => - addressing_case1 s n - | Eop (Oaddrstack n) Enil => - addressing_case2 n - | Eop Oadd (Eop (Oaddrsymbol s n) Enil:::e2:::Enil) => - addressing_case3 s n e2 - | Eop (Oaddimm n) (e1:::Enil) => - addressing_case4 n e1 - | Eop Oadd (e1:::e2:::Enil) => - addressing_case5 e1 e2 - | e => - addressing_default e - end. - -Definition addressing (chunk: memory_chunk) (e: expr) := - match addressing_match e with - | addressing_case1 s n => - (Aglobal s n, Enil) - | addressing_case2 n => - (Ainstack n, Enil) - | addressing_case3 s n e2 => - (Abased s n, e2:::Enil) - | addressing_case4 n e1 => - (Aindexed n, e1:::Enil) - | addressing_case5 e1 e2 => - (Aindexed2, e1:::e2:::Enil) - | addressing_default e => - (Aindexed Int.zero, e:::Enil) - end. diff --git a/powerpc/SelectOp.vp b/powerpc/SelectOp.vp new file mode 100644 index 0000000..40c9011 --- /dev/null +++ b/powerpc/SelectOp.vp @@ -0,0 +1,432 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for operators *) + +(** The instruction selection pass recognizes opportunities for using + combined arithmetic and logical operations and addressing modes + offered by the target processor. For instance, the expression [x + 1] + can take advantage of the "immediate add" instruction of the processor, + and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned + into a "rotate and mask" instruction. + + This file defines functions for building CminorSel expressions and + statements, especially expressions consisting of operator + applications. These functions examine their arguments to choose + cheaper forms of operators whenever possible. + + For instance, [add e1 e2] will return a CminorSel expression semantically + equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a + [Oaddimm] operator if one of the arguments is an integer constant, + or suppress the addition altogether if one of the arguments is the + null integer. In passing, we perform operator reassociation + ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount + of constant propagation. + + On top of the "smart constructor" functions defined below, + module [Selection] implements the actual instruction selection pass. +*) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Cminor. +Require Import Op. +Require Import CminorSel. + +Open Local Scope cminorsel_scope. + +(** ** Constants **) + +Definition addrsymbol (id: ident) (ofs: int) := + Eop (Oaddrsymbol id ofs) Enil. + +Definition addrstack (ofs: int) := + Eop (Oaddrstack ofs) Enil. + +(** ** Integer logical negation *) + +Nondetfunction notint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.not n)) Enil + | Eop Oand (t1:::t2:::Enil) => Eop Onand (t1:::t2:::Enil) + | Eop Oor (t1:::t2:::Enil) => Eop Onor (t1:::t2:::Enil) + | Eop Oxor (t1:::t2:::Enil) => Eop Onxor (t1:::t2:::Enil) + | _ => Elet e (Eop Onor (Eletvar O ::: Eletvar O ::: Enil)) + end. + +(** ** Boolean negation *) + +Fixpoint notbool (e: expr) {struct e} : expr := + let default := Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil) in + match e with + | Eop (Ointconst n) Enil => + Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil + | Eop (Ocmp cond) args => + Eop (Ocmp (negate_condition cond)) args + | Econdition e1 e2 e3 => + Econdition e1 (notbool e2) (notbool e3) + | _ => + default + end. + +(** ** Integer addition and pointer addition *) + +Nondetfunction addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else + match e with + | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil + | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Int.add n m)) Enil + | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Int.add n m)) Enil + | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) + | _ => Eop (Oaddimm n) (e ::: Enil) + end. + +Nondetfunction add (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + addimm n1 t2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | Eop (Oaddrsymbol s n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => + Eop Oadd (Eop (Oaddrsymbol s (Int.add n1 n2)) Enil ::: t2 ::: Enil) + | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => + Eop Oadd (Eop (Oaddrstack (Int.add n1 n2)) Enil ::: t2 ::: Enil) + | t1, Eop (Ointconst n2) Enil => + addimm n2 t1 + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | _, _ => + Eop Oadd (e1:::e2:::Enil) + end. + +(** ** Integer and pointer subtraction *) + +Nondetfunction sub (e1: expr) (e2: expr) := + match e1, e2 with + | t1, Eop (Ointconst n2) Enil => + addimm (Int.neg n2) t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | _, _ => + Eop Osub (e1:::e2:::Enil) + end. + +Definition negint (e: expr) := Eop (Osubimm Int.zero) (e ::: Enil). + +(** ** Rotates and immediate shifts *) + +Nondetfunction rolm (e1: expr) (amount2: int) (mask2: int) := + match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst(Int.and (Int.rol n1 amount2) mask2)) Enil + | Eop (Orolm amount1 mask1) (t1:::Enil) => + Eop (Orolm (Int.modu (Int.add amount1 amount2) Int.iwordsize) + (Int.and (Int.rol mask1 amount2) mask2)) + (t1:::Enil) + | Eop (Oandimm mask1) (t1:::Enil) => + Eop (Orolm (Int.modu amount2 Int.iwordsize) + (Int.and (Int.rol mask1 amount2) mask2)) + (t1:::Enil) + | _ => + Eop (Orolm amount2 mask2) (e1:::Enil) + end. + +Definition shlimm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then + e1 + else if Int.ltu n2 Int.iwordsize then + rolm e1 n2 (Int.shl Int.mone n2) + else + Eop Oshl (e1:::Eop (Ointconst n2) Enil:::Enil). + +Definition shrimm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then + e1 + else + Eop (Oshrimm n2) (e1:::Enil). + +Definition shruimm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then + e1 + else if Int.ltu n2 Int.iwordsize then + rolm e1 (Int.sub Int.iwordsize n2) (Int.shru Int.mone n2) + else + Eop Oshru (e1:::Eop (Ointconst n2) Enil:::Enil). + +(** ** Integer multiply *) + +Definition mulimm_base (n1: int) (e2: expr) := + match Int.one_bits n1 with + | i :: nil => + shlimm e2 i + | i :: j :: nil => + Elet e2 + (Eop Oadd (shlimm (Eletvar 0) i ::: + shlimm (Eletvar 0) j ::: Enil)) + | _ => + Eop (Omulimm n1) (e2:::Enil) + end. + +Nondetfunction mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.one then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst(Int.mul n1 n2)) Enil + | Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | _ => mulimm_base n1 e2 + end. + +Nondetfunction mul (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 + | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 + | _, _ => Eop Omul (e1:::e2:::Enil) + end. + +(** ** Bitwise and, or, xor *) + +Nondetfunction andimm (n1: int) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => + Eop (Ointconst (Int.and n1 n2)) Enil + | Eop (Oandimm n2) (t2:::Enil) => + Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | Eop (Orolm amount2 mask2) (t2:::Enil) => + Eop (Orolm amount2 (Int.and n1 mask2)) (t2:::Enil) + | Eop (Oshrimm amount) (t2:::Enil) => + if Int.eq (Int.shru (Int.shl n1 amount) amount) n1 + && Int.ltu amount Int.iwordsize + then rolm t2 (Int.sub Int.iwordsize amount) + (Int.and (Int.shru Int.mone amount) n1) + else Eop (Oandimm n1) (e2:::Enil) + | _ => + Eop (Oandimm n1) (e2:::Enil) + end. + +Nondetfunction and (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 + | t1, Eop (Ointconst n2) Enil => andimm n2 t1 + | _, _ => Eop Oand (e1:::e2:::Enil) + end. + +Definition same_expr_pure (e1 e2: expr) := + match e1, e2 with + | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false + | _, _ => false + end. + +Nondetfunction orimm (n1: int) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil + | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorimm n1) (e2:::Enil) + end. + +Nondetfunction or (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Orolm amount1 mask1) (t1:::Enil), Eop (Orolm amount2 mask2) (t2:::Enil) => + if Int.eq amount1 amount2 && same_expr_pure t1 t2 + then Eop (Orolm amount1 (Int.or mask1 mask2)) (t1:::Enil) + else Eop Oor (e1:::e2:::Enil) + | Eop (Oandimm mask1) (t1:::Enil), Eop (Orolm amount2 mask2) (t2:::Enil) => + if Int.eq mask1 (Int.not mask2) && is_rlw_mask mask2 + then Eop (Oroli amount2 mask2) (t1:::t2:::Enil) + else Eop Oor (e1:::e2:::Enil) + | Eop (Orolm amount1 mask1) (t1:::Enil), Eop (Oandimm mask2) (t2:::Enil) => + if Int.eq mask2 (Int.not mask1) && is_rlw_mask mask1 + then Eop (Oroli amount1 mask1) (t2:::t1:::Enil) + else Eop Oor (e1:::e2:::Enil) + | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 + | t1, Eop (Ointconst n2) Enil => orimm n2 t1 + | _, _ => Eop Oor (e1:::e2:::Enil) + end. + +Nondetfunction xorimm (n1: int) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.xor n1 n2)) Enil + | Eop (Oxorimm n2) (t2:::Enil) => Eop (Oxorimm (Int.xor n1 n2)) (t2:::Enil) + | _ => Eop (Oxorimm n1) (e2:::Enil) + end. + +Nondetfunction xor (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2 + | t1, Eop (Ointconst n2) Enil => xorimm n2 t1 + | _, _ => Eop Oxor (e1:::e2:::Enil) + end. + +(** ** Integer division and modulus *) + +Definition divs (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). + +Definition mod_aux (divop: operation) (e1 e2: expr) := + Elet e1 + (Elet (lift e2) + (Eop Osub (Eletvar 1 ::: + Eop Omul (Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) ::: + Eletvar 0 ::: + Enil) ::: + Enil))). + +Definition mods := mod_aux Odiv. + +Definition divuimm (e: expr) (n: int) := + match Int.is_power2 n with + | Some l => shruimm e l + | None => Eop Odivu (e ::: Eop (Ointconst n) Enil ::: Enil) + end. + +Nondetfunction divu (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => divuimm e1 n2 + | _ => Eop Odivu (e1:::e2:::Enil) + end. + +Definition moduimm (e: expr) (n: int) := + match Int.is_power2 n with + | Some l => andimm (Int.sub n Int.one) e + | None => mod_aux Odivu e (Eop (Ointconst n) Enil) + end. + +Nondetfunction modu (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => moduimm e1 n2 + | _ => mod_aux Odivu e1 e2 + end. + +(** ** General shifts *) + +Nondetfunction shl (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shlimm e1 n2 + | _ => Eop Oshl (e1:::e2:::Enil) + end. + +Nondetfunction shr (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shrimm e1 n2 + | _ => Eop Oshr (e1:::e2:::Enil) + end. + +Nondetfunction shru (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shruimm e1 n2 + | _ => Eop Oshru (e1:::e2:::Enil) + end. + +(** ** Floating-point arithmetic *) + +Definition negf (e: expr) := Eop Onegf (e ::: Enil). +Definition absf (e: expr) := Eop Oabsf (e ::: Enil). + +Parameter use_fused_mul : unit -> bool. + +Nondetfunction addf (e1: expr) (e2: expr) := + if negb(use_fused_mul tt) then Eop Oaddf (e1:::e2:::Enil) else + match e1, e2 with + | Eop Omulf (t1:::t2:::Enil), t3 => Eop Omuladdf (t1:::t2:::t3:::Enil) + | t1, Eop Omulf (t2:::t3:::Enil) => Eop Omuladdf (t2:::t3:::t1:::Enil) + | _, _ => Eop Oaddf (e1:::e2:::Enil) + end. + +Nondetfunction subf (e1: expr) (e2: expr) := + if negb(use_fused_mul tt) then Eop Osubf (e1:::e2:::Enil) else + match e1 with + | Eop Omulf (t1:::t2:::Enil) => Eop Omulsubf (t1:::t2:::e2:::Enil) + | _ => Eop Osubf (e1:::e2:::Enil) + end. + +Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). +Definition divf (e1 e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil). + +(** ** Comparisons *) + +Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2 ::: Enil) + | t1, Eop (Ointconst n2) Enil => + Eop (Ocmp (Ccompimm c n2)) (t1 ::: Enil) + | _, _ => + Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) + end. + +Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2 ::: Enil) + | t1, Eop (Ointconst n2) Enil => + Eop (Ocmp (Ccompuimm c n2)) (t1 ::: Enil) + | _, _ => + Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) + end. + +Definition compf (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). + +(** ** Integer conversions *) + +Definition cast8unsigned (e: expr) := andimm (Int.repr 255) e. + +Definition cast8signed (e: expr) := Eop Ocast8signed (e ::: Enil). + +Definition cast16unsigned (e: expr) := andimm (Int.repr 65535) e. + +Definition cast16signed (e: expr) := Eop Ocast16signed (e ::: Enil). + +(** ** Floating-point conversions *) + +Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). + +Definition intuoffloat (e: expr) := + let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in + Elet e + (Econdition (CEcond (Ccompf Clt) (Eletvar O ::: f ::: Enil)) + (intoffloat (Eletvar O)) + (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar O) f)))). + +Definition floatofintu (e: expr) := + subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: e ::: Enil)) + (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Int.zero)) Enil). + +Definition floatofint (e: expr) := + subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil + ::: addimm Float.ox8000_0000 e ::: Enil)) + (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Float.ox8000_0000)) Enil). + +Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). + +(** ** Recognition of addressing modes for load and store operations *) + +Nondetfunction addressing (chunk: memory_chunk) (e: expr) := + match e with + | Eop (Oaddrsymbol s n) Enil => (Aglobal s n, Enil) + | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) + | Eop Oadd (Eop (Oaddrsymbol s n) Enil ::: e2 ::: Enil) => (Abased s n, e2:::Enil) + | Eop (Oaddimm n) (e1:::Enil) => (Aindexed n, e1:::Enil) + | Eop Oadd (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) + | _ => (Aindexed Int.zero, e:::Enil) + end. + diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v index b23e5a5..8ad9807 100644 --- a/powerpc/SelectOpproof.v +++ b/powerpc/SelectOpproof.v @@ -44,8 +44,6 @@ Variable m: mem. Ltac EvalOp := eapply eval_Eop; eauto with evalexpr. -Ltac TrivialOp cstr := unfold cstr; intros; EvalOp. - Ltac InvEval1 := match goal with | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => @@ -78,14 +76,19 @@ Ltac InvEval2 := Ltac InvEval := InvEval1; InvEval2; InvEval2. +Ltac TrivialExists := + match goal with + | [ |- exists v, _ /\ Val.lessdef ?a v ] => exists a; split; [EvalOp | auto] + end. + (** * Correctness of the smart constructors *) (** We now show that the code generated by "smart constructor" functions such as [SelectOp.notint] behaves as expected. Continuing the [notint] example, we show that if the expression [e] - evaluates to some integer value [Vint n], then [SelectOp.notint e] - evaluates to a value [Vint (Int.not n)] which is indeed the integer - negation of the value of [e]. + evaluates to some value [v], then [SelectOp.notint e] + evaluates to a value [v'] which is either [Val.notint v] or more defined + than [Val.notint v]. All proofs follow a common pattern: - Reasoning by case over the result of the classification functions @@ -95,405 +98,286 @@ Ltac InvEval := InvEval1; InvEval2; InvEval2. - Inversion of the evaluations of the arguments, exploiting the additional information thus gathered. - Equational reasoning over the arithmetic operations performed, - using the lemmas from the [Int] and [Float] modules. + using the lemmas from the [Int], [Float] and [Value] modules. - Construction of an evaluation derivation for the expression returned by the smart constructor. *) +Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. + +Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := + forall le a x b y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. + Theorem eval_addrsymbol: - forall le id ofs b, - Genv.find_symbol ge id = Some b -> - eval_expr ge sp e m le (addrsymbol id ofs) (Vptr b ofs). + forall le id ofs, + exists v, eval_expr ge sp e m le (addrsymbol id ofs) v /\ Val.lessdef (symbol_address ge id ofs) v. Proof. - intros. unfold addrsymbol. econstructor. constructor. - simpl. rewrite H. auto. + intros. unfold addrsymbol. econstructor; split. + EvalOp. simpl; eauto. + auto. Qed. Theorem eval_addrstack: - forall le ofs b n, - sp = Vptr b n -> - eval_expr ge sp e m le (addrstack ofs) (Vptr b (Int.add n ofs)). + forall le ofs, + exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.add sp (Vint ofs)) v. Proof. - intros. unfold addrstack. econstructor. constructor. - simpl. unfold offset_sp. rewrite H. auto. + intros. unfold addrstack. econstructor; split. + EvalOp. simpl; eauto. + auto. Qed. -Theorem eval_notint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (notint a) (Vint (Int.not x)). -Proof. - unfold notint; intros until x; case (notint_match a); intros; InvEval. - EvalOp. - EvalOp. simpl. congruence. - EvalOp. simpl. congruence. - EvalOp. simpl. congruence. +Theorem eval_notint: unary_constructor_sound notint Val.notint. +Proof. + unfold notint; red; intros until x; case (notint_match a); intros; InvEval. + TrivialExists. + subst. TrivialExists. + subst. TrivialExists. + subst. TrivialExists. + econstructor; split; eauto. eapply eval_Elet. eexact H. eapply eval_Eop. eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity. eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity. apply eval_Enil. - simpl. rewrite Int.or_idem. auto. -Qed. - -Lemma eval_notbool_base: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_expr ge sp e m le (notbool_base a) (Val.of_bool (negb b)). -Proof. - TrivialOp notbool_base. simpl. - inv H0. - rewrite Int.eq_false; auto. - rewrite Int.eq_true; auto. - reflexivity. -Qed. - -Hint Resolve Val.bool_of_true_val Val.bool_of_false_val - Val.bool_of_true_val_inv Val.bool_of_false_val_inv: valboolof. - -Theorem eval_notbool: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_expr ge sp e m le (notbool a) (Val.of_bool (negb b)). -Proof. - induction a; simpl; intros; try (eapply eval_notbool_base; eauto). - destruct o; try (eapply eval_notbool_base; eauto). - - destruct e0. InvEval. - inv H0. rewrite Int.eq_false; auto. - simpl; eauto with evalexpr. - rewrite Int.eq_true; simpl; eauto with evalexpr. - eapply eval_notbool_base; eauto. - - inv H. eapply eval_Eop; eauto. - simpl. assert (eval_condition c vl m = Some b). - generalize H6. simpl. - case (eval_condition c vl m); intros. - destruct b0; inv H1; inversion H0; auto; congruence. - congruence. - rewrite (Op.eval_negate_condition _ _ _ H). - destruct b; reflexivity. - - inv H. eapply eval_Econdition; eauto. - destruct v1; eauto. + simpl. destruct x; simpl; auto. rewrite Int.or_idem. auto. +Qed. + +Theorem eval_notbool: unary_constructor_sound notbool Val.notbool. +Proof. + assert (DFL: + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (Eop (Ocmp (Ccompuimm Ceq Int.zero)) (a ::: Enil)) v + /\ Val.lessdef (Val.notbool x) v). + intros. TrivialExists. simpl. destruct x; simpl; auto. + + red. induction a; simpl; intros; eauto. destruct o; eauto. +(* intconst *) + destruct e0; eauto. InvEval. TrivialExists. simpl. destruct (Int.eq i Int.zero); auto. +(* cmp *) + inv H. simpl in H5. + destruct (eval_condition c vl m) as []_eqn. + TrivialExists. simpl. rewrite (eval_negate_condition _ _ _ Heqo). destruct b; inv H5; auto. + inv H5. simpl. + destruct (eval_condition (negate_condition c) vl m) as []_eqn. + destruct b; [exists Vtrue | exists Vfalse]; split; auto; EvalOp; simpl. rewrite Heqo0; auto. rewrite Heqo0; auto. + exists Vundef; split; auto; EvalOp; simpl. rewrite Heqo0; auto. +(* condition *) + inv H. destruct v1. + exploit IHa1; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. + exploit IHa2; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. Qed. Theorem eval_addimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (addimm n a) (Vint (Int.add x n)). -Proof. - unfold addimm; intros until x. - generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. - subst n. rewrite Int.add_zero. auto. - case (addimm_match a); intros; InvEval; EvalOp; simpl. + forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)). +Proof. + red; unfold addimm; intros until x. + predSpec Int.eq Int.eq_spec n Int.zero. + subst n. intros. exists x; split; auto. + destruct x; simpl; auto. rewrite Int.add_zero. auto. rewrite Int.add_zero. auto. + case (addimm_match a); intros; InvEval; simpl; TrivialExists; simpl. rewrite Int.add_commut. auto. - destruct (Genv.find_symbol ge s); discriminate. - destruct sp; simpl in H1; discriminate. - subst x. rewrite Int.add_assoc. decEq; decEq; decEq. apply Int.add_commut. + unfold symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. rewrite Int.add_commut; auto. + rewrite Val.add_assoc. rewrite Int.add_commut. auto. + subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. Qed. -Theorem eval_addimm_ptr: - forall le n a b ofs, - eval_expr ge sp e m le a (Vptr b ofs) -> - eval_expr ge sp e m le (addimm n a) (Vptr b (Int.add ofs n)). -Proof. - unfold addimm; intros until ofs. - generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. - subst n. rewrite Int.add_zero. auto. - case (addimm_match a); intros; InvEval; EvalOp; simpl. - destruct (Genv.find_symbol ge s). - rewrite Int.add_commut. congruence. - discriminate. - destruct sp; simpl in H1; try discriminate. - inv H1. simpl. decEq. decEq. - rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. rewrite (Int.add_commut n m0). rewrite Int.add_assoc. auto. -Qed. - -Theorem eval_add: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (add a b) (Vint (Int.add x y)). +Theorem eval_add: binary_constructor_sound add Val.add. Proof. - intros until y. + red; intros until y. unfold add; case (add_match a b); intros; InvEval. - rewrite Int.add_commut. apply eval_addimm. auto. - replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)). - apply eval_addimm. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - replace (Int.add x y) with (Int.add (Int.add i y) n1). - apply eval_addimm. EvalOp. - subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - apply eval_addimm. auto. - replace (Int.add x y) with (Int.add (Int.add x i) n2). - apply eval_addimm. EvalOp. - subst y. rewrite Int.add_assoc. auto. - destruct (Genv.find_symbol ge s); inv H0. - destruct sp; simpl in H0; inv H0. - EvalOp. -Qed. - -Theorem eval_add_ptr: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (add a b) (Vptr p (Int.add x y)). -Proof. - intros until y. unfold add; case (add_match a b); intros; InvEval. - replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)). - apply eval_addimm_ptr. subst b0. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - replace (Int.add x y) with (Int.add (Int.add i y) n1). - apply eval_addimm_ptr. subst b0. EvalOp. - subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - apply eval_addimm_ptr. auto. - replace (Int.add x y) with (Int.add (Int.add x i) n2). - apply eval_addimm_ptr. EvalOp. - subst y. rewrite Int.add_assoc. auto. - revert H0. case_eq (Genv.find_symbol ge s); intros; inv H1. - EvalOp. constructor. EvalOp. simpl. rewrite H0; eauto. - constructor. eauto. constructor. - simpl. decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut. - destruct sp; simpl in H0; inv H0. - EvalOp. constructor. EvalOp. simpl. eauto. constructor. eauto. constructor. - simpl. decEq. decEq. repeat rewrite Int.add_assoc. - decEq. decEq. apply Int.add_commut. - EvalOp. -Qed. - -Theorem eval_add_ptr_2: - forall le a b x p y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vptr p y) -> - eval_expr ge sp e m le (add a b) (Vptr p (Int.add y x)). -Proof. - intros until y. unfold add; case (add_match a b); intros; InvEval. - apply eval_addimm_ptr. auto. - replace (Int.add y x) with (Int.add (Int.add i i0) (Int.add n1 n2)). - apply eval_addimm_ptr. subst b0. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. - rewrite (Int.add_commut n1 n2). apply Int.add_permut. - replace (Int.add y x) with (Int.add (Int.add y i) n1). - apply eval_addimm_ptr. EvalOp. - subst x. repeat rewrite Int.add_assoc. auto. - replace (Int.add y x) with (Int.add (Int.add i x) n2). - apply eval_addimm_ptr. EvalOp. subst b0; reflexivity. - subst y. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - destruct (Genv.find_symbol ge s); inv H0. - destruct sp; simpl in H0; inv H0. - EvalOp. -Qed. - -Theorem eval_sub: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). -Proof. - intros until y. + rewrite Val.add_commut. apply eval_addimm; auto. + subst. + replace (Val.add (Val.add v1 (Vint n1)) (Val.add v0 (Vint n2))) + with (Val.add (Val.add v1 v0) (Val.add (Vint n1) (Vint n2))). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. decEq. apply Val.add_permut. + subst. + replace (Val.add (Val.add v1 (Vint n1)) y) + with (Val.add (Val.add v1 y) (Vint n1)). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. decEq. apply Val.add_commut. + subst. TrivialExists. + econstructor. EvalOp. simpl. reflexivity. econstructor. eauto. constructor. + simpl. rewrite (Val.add_commut v1). rewrite <- Val.add_assoc. decEq; decEq. + unfold symbol_address. destruct (Genv.find_symbol ge s); auto. + subst. TrivialExists. + econstructor. EvalOp. simpl. reflexivity. econstructor. eauto. constructor. + simpl. repeat rewrite Val.add_assoc. decEq; decEq. + rewrite Val.add_commut. rewrite Val.add_permut. auto. + apply eval_addimm; auto. + subst. rewrite <- Val.add_assoc. apply eval_addimm. EvalOp. + TrivialExists. +Qed. + +Theorem eval_sub: binary_constructor_sound sub Val.sub. +Proof. + red; intros until y. unfold sub; case (sub_match a b); intros; InvEval. - rewrite Int.sub_add_opp. - apply eval_addimm. assumption. - replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm. EvalOp. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm. EvalOp. - subst x. rewrite Int.sub_add_l. auto. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm. EvalOp. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. + rewrite Val.sub_add_opp. apply eval_addimm; auto. + subst. rewrite Val.sub_add_l. rewrite Val.sub_add_r. + rewrite Val.add_assoc. simpl. rewrite Int.add_commut. rewrite <- Int.sub_add_opp. + apply eval_addimm; EvalOp. + subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp. + subst. rewrite Val.sub_add_r. apply eval_addimm; EvalOp. + TrivialExists. Qed. -Theorem eval_sub_ptr_int: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (sub a b) (Vptr p (Int.sub x y)). +Theorem eval_negint: unary_constructor_sound negint (fun v => Val.sub Vzero v). Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - rewrite Int.sub_add_opp. - apply eval_addimm_ptr. assumption. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm_ptr. EvalOp. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm_ptr. EvalOp. - subst x. rewrite Int.sub_add_l. auto. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm_ptr. EvalOp. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. + red; intros. unfold negint. TrivialExists. Qed. -Theorem eval_sub_ptr_ptr: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vptr p y) -> - eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). +Lemma eval_rolm: + forall amount mask, + unary_constructor_sound (fun a => rolm a amount mask) + (fun x => Val.rolm x amount mask). Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm. EvalOp. - simpl; unfold eq_block. subst b0; subst b1; rewrite zeq_true. auto. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm. EvalOp. - simpl. unfold eq_block. rewrite zeq_true. auto. - subst x. rewrite Int.sub_add_l. auto. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm. EvalOp. - simpl. unfold eq_block. rewrite zeq_true. auto. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. simpl. unfold eq_block. rewrite zeq_true. auto. + red; intros until x. unfold rolm; case (rolm_match a); intros; InvEval. + TrivialExists. + subst. rewrite Val.rolm_rolm. TrivialExists. + subst. rewrite <- Val.rolm_zero. rewrite Val.rolm_rolm. + rewrite (Int.add_commut Int.zero). rewrite Int.add_zero. TrivialExists. + TrivialExists. Qed. -Lemma eval_rolm: - forall le a amount mask x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (rolm a amount mask) (Vint (Int.rolm x amount mask)). -Proof. - intros until x. unfold rolm; case (rolm_match a); intros; InvEval. - eauto with evalexpr. - case (is_rlw_mask (Int.and (Int.rol mask1 amount) mask)). - EvalOp. simpl. subst x. - decEq. decEq. - symmetry. apply Int.rolm_rolm. apply int_wordsize_divides_modulus. - EvalOp. econstructor. EvalOp. simpl. rewrite H. reflexivity. constructor. auto. - EvalOp. +Theorem eval_shlimm: + forall n, unary_constructor_sound (fun a => shlimm a n) + (fun x => Val.shl x (Vint n)). +Proof. + red; intros. unfold shlimm. + predSpec Int.eq Int.eq_spec n Int.zero. + subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shl_zero; auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn. + rewrite Val.shl_rolm; auto. apply eval_rolm; auto. + TrivialExists. econstructor. eauto. econstructor. EvalOp. simpl; eauto. constructor. auto. Qed. -Theorem eval_shlimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n Int.iwordsize = true -> - eval_expr ge sp e m le (shlimm a n) (Vint (Int.shl x n)). +Theorem eval_shrimm: + forall n, unary_constructor_sound (fun a => shrimm a n) + (fun x => Val.shr x (Vint n)). Proof. - intros. unfold shlimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.shl_zero. auto. - rewrite H0. - replace (Int.shl x n) with (Int.rolm x n (Int.shl Int.mone n)). - apply eval_rolm. auto. symmetry. apply Int.shl_rolm. exact H0. + red; intros. unfold shrimm. + predSpec Int.eq Int.eq_spec n Int.zero. + subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto. + TrivialExists. Qed. Theorem eval_shruimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n Int.iwordsize = true -> - eval_expr ge sp e m le (shruimm a n) (Vint (Int.shru x n)). + forall n, unary_constructor_sound (fun a => shruimm a n) + (fun x => Val.shru x (Vint n)). Proof. - intros. unfold shruimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.shru_zero. auto. - rewrite H0. - replace (Int.shru x n) with (Int.rolm x (Int.sub Int.iwordsize n) (Int.shru Int.mone n)). - apply eval_rolm. auto. symmetry. apply Int.shru_rolm. exact H0. + red; intros. unfold shruimm. + predSpec Int.eq Int.eq_spec n Int.zero. + subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn. + rewrite Val.shru_rolm; auto. apply eval_rolm; auto. + TrivialExists. econstructor. eauto. econstructor. EvalOp. simpl; eauto. constructor. auto. Qed. Lemma eval_mulimm_base: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (mulimm_base n a) (Vint (Int.mul x n)). + forall n, unary_constructor_sound (mulimm_base n) (fun x => Val.mul x (Vint n)). Proof. - intros; unfold mulimm_base. + intros; red; intros; unfold mulimm_base. generalize (Int.one_bits_decomp n). generalize (Int.one_bits_range n). - change (Z_of_nat Int.wordsize) with 32. destruct (Int.one_bits n). - intros. EvalOp. + intros. TrivialExists. destruct l. intros. rewrite H1. simpl. - rewrite Int.add_zero. rewrite <- Int.shl_mul. - apply eval_shlimm. auto. auto with coqlib. + rewrite Int.add_zero. + replace (Vint (Int.shl Int.one i)) with (Val.shl Vone (Vint i)). rewrite Val.shl_mul. + apply eval_shlimm. auto. simpl. rewrite H0; auto with coqlib. destruct l. - intros. apply eval_Elet with (Vint x). auto. - rewrite H1. simpl. rewrite Int.add_zero. - rewrite Int.mul_add_distr_r. - rewrite <- Int.shl_mul. - rewrite <- Int.shl_mul. - EvalOp. eapply eval_Econs. - apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. - auto with coqlib. - eapply eval_Econs. - apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. - auto with coqlib. - auto with evalexpr. - reflexivity. - intros. EvalOp. + intros. rewrite H1. simpl. + exploit (eval_shlimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]]. + exploit (eval_shlimm i0 (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]]. + exists (Val.add v1 v2); split. + econstructor. eauto. EvalOp. + rewrite Int.add_zero. + replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one i0))) + with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint i0))). + rewrite Val.mul_add_distr_r. + repeat rewrite Val.shl_mul. apply Val.add_lessdef; auto. + simpl. repeat rewrite H0; auto with coqlib. + intros. TrivialExists. Qed. Theorem eval_mulimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (mulimm n a) (Vint (Int.mul x n)). -Proof. - intros until x; unfold mulimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.mul_zero. - intro. eapply eval_Elet; eauto with evalexpr. - generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intro. - subst n. rewrite Int.mul_one. auto. + forall n, unary_constructor_sound (mulimm n) (fun x => Val.mul x (Vint n)). +Proof. + intros; red; intros until x; unfold mulimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.mul_zero. auto. + predSpec Int.eq Int.eq_spec n Int.one. + intros. exists x; split; auto. + destruct x; simpl; auto. subst n. rewrite Int.mul_one. auto. case (mulimm_match a); intros; InvEval. - EvalOp. rewrite Int.mul_commut. reflexivity. - replace (Int.mul x n) with (Int.add (Int.mul i n) (Int.mul n n2)). - apply eval_addimm. apply eval_mulimm_base. auto. - subst x. rewrite Int.mul_add_distr_l. decEq. apply Int.mul_commut. - apply eval_mulimm_base. assumption. + TrivialExists. simpl. rewrite Int.mul_commut; auto. + subst. rewrite Val.mul_add_distr_l. + exploit eval_mulimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]]. + exploit (eval_addimm (Int.mul n n2) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]]. + exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.add_lessdef; eauto. + rewrite Val.mul_commut; auto. + apply eval_mulimm_base; auto. Qed. -Theorem eval_mul: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (mul a b) (Vint (Int.mul x y)). +Theorem eval_mul: binary_constructor_sound mul Val.mul. Proof. - intros until y. + red; intros until y. unfold mul; case (mul_match a b); intros; InvEval. - rewrite Int.mul_commut. apply eval_mulimm. auto. + rewrite Val.mul_commut. apply eval_mulimm. auto. apply eval_mulimm. auto. - EvalOp. + TrivialExists. Qed. Theorem eval_andimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (andimm n a) (Vint (Int.and x n)). -Proof. - intros. unfold andimm. case (is_rlw_mask n). - rewrite <- Int.rolm_zero. apply eval_rolm; auto. - EvalOp. + forall n, unary_constructor_sound (andimm n) (fun x => Val.and x (Vint n)). +Proof. + intros; red; intros until x. unfold andimm. case (andimm_match a); intros. + InvEval. TrivialExists. simpl. rewrite Int.and_commut; auto. + InvEval. subst. rewrite Val.and_assoc. simpl. rewrite Int.and_commut. TrivialExists. + InvEval. subst. TrivialExists. simpl. + destruct v1; auto. simpl. unfold Int.rolm. rewrite Int.and_assoc. + decEq. decEq. decEq. apply Int.and_commut. + destruct (Int.eq (Int.shru (Int.shl n amount) amount) n && + Int.ltu amount Int.iwordsize) as []_eqn. + InvEval. destruct (andb_prop _ _ Heqb). + generalize (Int.eq_spec (Int.shru (Int.shl n amount) amount) n). rewrite H0; intros. + replace (Val.and x (Vint n)) + with (Val.rolm v1 (Int.sub Int.iwordsize amount) (Int.and (Int.shru Int.mone amount) n)). + apply eval_rolm; auto. + subst x. destruct v1; simpl; auto. rewrite H1; simpl. decEq. + transitivity (Int.and (Int.shru i amount) n). + rewrite (Int.shru_rolm i); auto. unfold Int.rolm. rewrite Int.and_assoc; auto. + symmetry. apply Int.shr_and_shru_and. auto. + TrivialExists. + TrivialExists. +Qed. + +Theorem eval_and: binary_constructor_sound and Val.and. +Proof. + red; intros until y; unfold and; case (and_match a b); intros; InvEval. + rewrite Val.and_commut. apply eval_andimm; auto. + apply eval_andimm; auto. + TrivialExists. Qed. -Theorem eval_and: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (and a b) (Vint (Int.and x y)). +Theorem eval_orimm: + forall n, unary_constructor_sound (orimm n) (fun x => Val.or x (Vint n)). Proof. - intros until y; unfold and; case (mul_match a b); intros; InvEval. - rewrite Int.and_commut. apply eval_andimm; auto. - apply eval_andimm; auto. - EvalOp. + intros; red; intros until x. + unfold orimm. destruct (orimm_match a); intros; InvEval. + TrivialExists. simpl. rewrite Int.or_commut; auto. + subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists. + TrivialExists. Qed. Remark eval_same_expr: @@ -511,59 +395,71 @@ Proof. discriminate. Qed. -Lemma eval_or: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (or a b) (Vint (Int.or x y)). -Proof. - intros until y; unfold or; case (or_match a b); intros; InvEval. - caseEq (Int.eq amount1 amount2 - && is_rlw_mask (Int.or mask1 mask2) - && same_expr_pure t1 t2); intro. - destruct (andb_prop _ _ H1). destruct (andb_prop _ _ H4). - generalize (Int.eq_spec amount1 amount2). rewrite H6. intro. subst amount2. - exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. - simpl. EvalOp. simpl. rewrite Int.or_rolm. auto. - caseEq (Int.eq amount1 Int.zero && Int.eq mask1 (Int.not mask2)); intro. - destruct (andb_prop _ _ H4). - generalize (Int.eq_spec amount1 Int.zero). rewrite H5. intro. - generalize (Int.eq_spec mask1 (Int.not mask2)). rewrite H6. intro. - subst. rewrite Int.rolm_zero. EvalOp. - caseEq (Int.eq amount2 Int.zero && Int.eq mask2 (Int.not mask1)); intro. - destruct (andb_prop _ _ H5). - generalize (Int.eq_spec amount2 Int.zero). rewrite H6. intro. - generalize (Int.eq_spec mask2 (Int.not mask1)). rewrite H7. intro. - subst. rewrite Int.rolm_zero. rewrite Int.or_commut. EvalOp. - simpl. apply eval_Eop with (Vint x :: Vint y :: nil). - econstructor. EvalOp. simpl. congruence. - econstructor. EvalOp. simpl. congruence. constructor. auto. - EvalOp. +Theorem eval_or: binary_constructor_sound or Val.or. +Proof. + red; intros until y; unfold or; case (or_match a b); intros. +(* rolm - rolm *) + destruct (Int.eq amount1 amount2 && same_expr_pure t1 t2) as []_eqn. + destruct (andb_prop _ _ Heqb0). + generalize (Int.eq_spec amount1 amount2). rewrite H1. intro. subst amount2. + InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]. subst. + rewrite Val.or_rolm. TrivialExists. + TrivialExists. +(* andimm - rolm *) + destruct (Int.eq mask1 (Int.not mask2) && is_rlw_mask mask2) as []_eqn. + destruct (andb_prop _ _ Heqb0). + generalize (Int.eq_spec mask1 (Int.not mask2)); rewrite H1; intros. + InvEval. subst. TrivialExists. + TrivialExists. +(* rolm - andimm *) + destruct (Int.eq mask2 (Int.not mask1) && is_rlw_mask mask1) as []_eqn. + destruct (andb_prop _ _ Heqb0). + generalize (Int.eq_spec mask2 (Int.not mask1)); rewrite H1; intros. + InvEval. subst. rewrite Val.or_commut. TrivialExists. + TrivialExists. +(* intconst *) + InvEval. rewrite Val.or_commut. apply eval_orimm; auto. + InvEval. apply eval_orimm; auto. +(* default *) + TrivialExists. +Qed. + +Theorem eval_xorimm: + forall n, unary_constructor_sound (xorimm n) (fun x => Val.xor x (Vint n)). +Proof. + intros; red; intros until x. + unfold xorimm. destruct (xorimm_match a); intros; InvEval. + TrivialExists. simpl. rewrite Int.xor_commut; auto. + subst. rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. TrivialExists. + TrivialExists. +Qed. + +Theorem eval_xor: binary_constructor_sound xor Val.xor. +Proof. + red; intros until y; unfold xor; case (xor_match a b); intros; InvEval. + rewrite Val.xor_commut. apply eval_xorimm; auto. + apply eval_xorimm; auto. + TrivialExists. Qed. Theorem eval_divs: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (divs a b) (Vint (Int.divs x y)). + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divs x y = Some z -> + exists v, eval_expr ge sp e m le (divs a b) v /\ Val.lessdef z v. Proof. - TrivialOp divs. simpl. - predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. + intros. unfold divs. exists z; split. EvalOp. auto. Qed. Lemma eval_mod_aux: forall divop semdivop, - (forall sp x y m, - y <> Int.zero -> - eval_operation ge sp divop (Vint x :: Vint y :: nil) m = - Some (Vint (semdivop x y))) -> - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (mod_aux divop a b) - (Vint (Int.sub x (Int.mul (semdivop x y) y))). + (forall sp x y m, eval_operation ge sp divop (x :: y :: nil) m = semdivop x y) -> + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + semdivop x y = Some z -> + eval_expr ge sp e m le (mod_aux divop a b) (Val.sub x (Val.mul z y)). Proof. intros; unfold mod_aux. eapply eval_Elet. eexact H0. eapply eval_Elet. @@ -575,7 +471,7 @@ Proof. eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. apply eval_Enil. - apply H. assumption. + rewrite H. eauto. eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. apply eval_Enil. simpl; reflexivity. apply eval_Enil. @@ -583,374 +479,273 @@ Proof. Qed. Theorem eval_mods: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (mods a b) (Vint (Int.mods x y)). + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.mods x y = Some z -> + exists v, eval_expr ge sp e m le (mods a b) v /\ Val.lessdef z v. Proof. intros; unfold mods. - rewrite Int.mods_divs. - eapply eval_mod_aux; eauto. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. + exploit Val.mods_divs; eauto. intros [v [A B]]. + subst. econstructor; split; eauto. + apply eval_mod_aux with (semdivop := Val.divs); auto. Qed. -Lemma eval_divu_base: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (Eop Odivu (a ::: b ::: Enil)) (Vint (Int.divu x y)). +Theorem eval_divuimm: + forall le n a x z, + eval_expr ge sp e m le a x -> + Val.divu x (Vint n) = Some z -> + exists v, eval_expr ge sp e m le (divuimm a n) v /\ Val.lessdef z v. Proof. - intros. EvalOp. simpl. - predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. + intros; unfold divuimm. + destruct (Int.is_power2 n) as []_eqn. + replace z with (Val.shru x (Vint i)). apply eval_shruimm; auto. + eapply Val.divu_pow2; eauto. + TrivialExists. + econstructor. eauto. econstructor. EvalOp. simpl; eauto. constructor. auto. Qed. Theorem eval_divu: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (divu a b) (Vint (Int.divu x y)). -Proof. - intros until y. - unfold divu; case (divu_match b); intros; InvEval. - caseEq (Int.is_power2 y). - intros. rewrite (Int.divu_pow2 x y i H0). - apply eval_shruimm. auto. - apply Int.is_power2_range with y. auto. - intros. apply eval_divu_base. auto. EvalOp. auto. - eapply eval_divu_base; eauto. + forall le a x b y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divu x y = Some z -> + exists v, eval_expr ge sp e m le (divu a b) v /\ Val.lessdef z v. +Proof. + intros until z. unfold divu; destruct (divu_match b); intros; InvEval. + eapply eval_divuimm; eauto. + TrivialExists. +Qed. + +Theorem eval_moduimm: + forall le n a x z, + eval_expr ge sp e m le a x -> + Val.modu x (Vint n) = Some z -> + exists v, eval_expr ge sp e m le (moduimm a n) v /\ Val.lessdef z v. +Proof. + intros; unfold moduimm. + destruct (Int.is_power2 n) as []_eqn. + replace z with (Val.and x (Vint (Int.sub n Int.one))). apply eval_andimm; auto. + eapply Val.modu_pow2; eauto. + exploit Val.modu_divu; eauto. intros [v [A B]]. + subst. econstructor; split; eauto. + apply eval_mod_aux with (semdivop := Val.divu); auto. + EvalOp. Qed. Theorem eval_modu: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (modu a b) (Vint (Int.modu x y)). + forall le a x b y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.modu x y = Some z -> + exists v, eval_expr ge sp e m le (modu a b) v /\ Val.lessdef z v. Proof. - intros until y; unfold modu; case (divu_match b); intros; InvEval. - caseEq (Int.is_power2 y). - intros. rewrite (Int.modu_and x y i H0). apply eval_andimm. auto. - intro. rewrite Int.modu_divu. eapply eval_mod_aux. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. - auto. EvalOp. auto. auto. - rewrite Int.modu_divu. eapply eval_mod_aux. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. auto. auto. auto. auto. + intros until y; unfold modu; case (modu_match b); intros; InvEval. + eapply eval_moduimm; eauto. + exploit Val.modu_divu; eauto. intros [v [A B]]. + subst. econstructor; split; eauto. + apply eval_mod_aux with (semdivop := Val.divu); auto. Qed. - -Theorem eval_shl: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y Int.iwordsize = true -> - eval_expr ge sp e m le (shl a b) (Vint (Int.shl x y)). +Theorem eval_shl: binary_constructor_sound shl Val.shl. Proof. - intros until y; unfold shl; case (shift_match b); intros. + red; intros until y; unfold shl; case (shl_match b); intros. InvEval. apply eval_shlimm; auto. - EvalOp. simpl. rewrite H1. auto. + TrivialExists. Qed. -Theorem eval_shru: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y Int.iwordsize = true -> - eval_expr ge sp e m le (shru a b) (Vint (Int.shru x y)). +Theorem eval_shr: binary_constructor_sound shr Val.shr. +Proof. + red; intros until y; unfold shr; case (shr_match b); intros. + InvEval. apply eval_shrimm; auto. + TrivialExists. +Qed. + +Theorem eval_shru: binary_constructor_sound shru Val.shru. Proof. - intros until y; unfold shru; case (shift_match b); intros. + red; intros until y; unfold shru; case (shru_match b); intros. InvEval. apply eval_shruimm; auto. - EvalOp. simpl. rewrite H1. auto. + TrivialExists. Qed. -Theorem eval_addf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (addf a b) (Vfloat (Float.add x y)). +Theorem eval_negf: unary_constructor_sound negf Val.negf. Proof. - intros until y; unfold addf. - destruct (use_fused_mul tt). + red; intros. TrivialExists. +Qed. + +Theorem eval_absf: unary_constructor_sound absf Val.absf. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_addf: binary_constructor_sound addf Val.addf. +Proof. + red; intros until y; unfold addf. + destruct (use_fused_mul tt); simpl. case (addf_match a b); intros; InvEval. - EvalOp. simpl. congruence. - EvalOp. simpl. rewrite Float.addf_commut. congruence. - EvalOp. - intros. EvalOp. + TrivialExists. simpl. congruence. + TrivialExists. simpl. rewrite Val.addf_commut. congruence. + intros. TrivialExists. + intros. TrivialExists. Qed. -Theorem eval_subf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (subf a b) (Vfloat (Float.sub x y)). -Proof. - intros until y; unfold subf. - destruct (use_fused_mul tt). - case (subf_match a b); intros. - InvEval. EvalOp. simpl. congruence. - EvalOp. - intros. EvalOp. +Theorem eval_subf: binary_constructor_sound subf Val.subf. +Proof. + red; intros until y; unfold subf. + destruct (use_fused_mul tt); simpl. + case (subf_match a); intros; InvEval. + TrivialExists. simpl. congruence. + TrivialExists. + intros. TrivialExists. Qed. -Theorem eval_cast8signed: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v). -Proof. TrivialOp cast8signed. Qed. +Theorem eval_mulf: binary_constructor_sound mulf Val.mulf. +Proof. + red; intros; TrivialExists. +Qed. -Theorem eval_cast8unsigned: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v). -Proof. TrivialOp cast8unsigned. Qed. +Theorem eval_divf: binary_constructor_sound divf Val.divf. +Proof. + red; intros; TrivialExists. +Qed. -Theorem eval_cast16signed: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v). -Proof. TrivialOp cast16signed. Qed. +Theorem eval_comp: + forall c, binary_constructor_sound (comp c) (Val.cmp c). +Proof. + intros; red; intros until y. unfold comp; case (comp_match a b); intros; InvEval. + TrivialExists. simpl. rewrite Val.swap_cmp_bool. auto. + TrivialExists. + TrivialExists. +Qed. -Theorem eval_cast16unsigned: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v). -Proof. TrivialOp cast16unsigned. Qed. +Theorem eval_compu: + forall c, binary_constructor_sound (compu c) (Val.cmpu (Mem.valid_pointer m) c). +Proof. + intros; red; intros until y. unfold compu; case (compu_match a b); intros; InvEval. + TrivialExists. simpl. rewrite Val.swap_cmpu_bool. auto. + TrivialExists. + TrivialExists. +Qed. -Theorem eval_singleoffloat: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v). -Proof. TrivialOp singleoffloat. Qed. +Theorem eval_compf: + forall c, binary_constructor_sound (compf c) (Val.cmpf c). +Proof. + intros; red; intros. unfold compf. TrivialExists. +Qed. -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) -> - eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x y)). -Proof. - intros until y. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. -Qed. - -Theorem eval_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 -> - match eval_compare_null c x with - | Some true => Some Vtrue - | Some false => Some Vfalse - | None => None (A:=val) - end = Some v. -Proof. - unfold Cminor.eval_compare_null, eval_compare_null; intros. - destruct (Int.eq x Int.zero); try discriminate. - destruct c; try discriminate; auto. -Qed. - -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 (compu c a b) v. -Proof. - intros until v. - 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. - -Remark eval_compare_null_swap: - forall c x, - Cminor.eval_compare_null (swap_comparison c) x = - Cminor.eval_compare_null c x. -Proof. - intros. unfold Cminor.eval_compare_null. - destruct (Int.eq x Int.zero). destruct c; auto. auto. -Qed. - -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 (compu c a b) v. -Proof. - intros until v. - 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_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 (compu c a b) (Val.of_bool(Int.cmpu c x2 y2)). -Proof. - intros until y2. - 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_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 (compu c a b) v. -Proof. - intros until y2. - unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto. - destruct c; simpl in H3; inv H3; auto. + +Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8). +Proof. + red; intros. unfold cast8signed. TrivialExists. Qed. -Theorem eval_compf: - forall le c a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (compf c a b) (Val.of_bool(Float.cmp c x y)). +Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). Proof. - intros. unfold compf. EvalOp. simpl. - destruct (Float.cmp c x y); reflexivity. + red; intros. unfold cast8unsigned. + rewrite Val.zero_ext_and. apply eval_andimm; auto. compute; auto. Qed. -Theorem eval_negint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (negint a) (Vint (Int.neg x)). -Proof. intros; unfold negint; EvalOp. Qed. +Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). +Proof. + red; intros. unfold cast16signed. TrivialExists. +Qed. -Theorem eval_negf: - forall le a x, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le (negf a) (Vfloat (Float.neg x)). -Proof. intros; unfold negf; EvalOp. Qed. +Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). +Proof. + red; intros. unfold cast16unsigned. + rewrite Val.zero_ext_and. apply eval_andimm; auto. compute; auto. +Qed. -Theorem eval_absf: - forall le a x, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le (absf a) (Vfloat (Float.abs x)). -Proof. intros; unfold absf; EvalOp. Qed. +Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. +Proof. + red; intros. unfold singleoffloat. TrivialExists. +Qed. Theorem eval_intoffloat: - forall le a x n, - eval_expr ge sp e m le a (Vfloat x) -> - Float.intoffloat x = Some n -> - eval_expr ge sp e m le (intoffloat a) (Vint n). + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v. Proof. - intros; unfold intoffloat; EvalOp. simpl. rewrite H0; auto. + intros; unfold intoffloat. TrivialExists. Qed. Theorem eval_intuoffloat: - forall le a x n, - eval_expr ge sp e m le a (Vfloat x) -> - Float.intuoffloat x = Some n -> - eval_expr ge sp e m le (intuoffloat a) (Vint n). -Proof. - intros. unfold intuoffloat. - econstructor. eauto. + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intuoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. +Proof. + intros. destruct x; simpl in H0; try discriminate. + destruct (Float.intuoffloat f) as [n|]_eqn; simpl in H0; inv H0. + exists (Vint n); split; auto. unfold intuoffloat. set (im := Int.repr Int.half_modulus). set (fm := Float.floatofintu im). - assert (eval_expr ge sp e m (Vfloat x :: le) (Eletvar O) (Vfloat x)). + assert (eval_expr ge sp e m (Vfloat f :: le) (Eletvar O) (Vfloat f)). constructor. auto. - apply eval_Econdition with (v1 := Float.cmp Clt x fm). + econstructor. eauto. + apply eval_Econdition with (v1 := Float.cmp Clt f fm). econstructor. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. simpl. auto. - caseEq (Float.cmp Clt x fm); intros. + destruct (Float.cmp Clt f fm) as []_eqn. exploit Float.intuoffloat_intoffloat_1; eauto. intro EQ. EvalOp. simpl. rewrite EQ; auto. exploit Float.intuoffloat_intoffloat_2; eauto. intro EQ. - replace n with (Int.add (Int.sub n Float.ox8000_0000) Float.ox8000_0000). - apply eval_addimm. eapply eval_intoffloat; eauto. - apply eval_subf; auto. EvalOp. - rewrite Int.sub_add_opp. rewrite Int.add_assoc. apply Int.add_zero. + set (t1 := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil). + set (t2 := subf (Eletvar 0) t1). + set (t3 := intoffloat t2). + exploit (eval_subf (Vfloat f :: le) (Eletvar 0) (Vfloat f) t1). + auto. unfold t1; EvalOp. simpl; eauto. + fold t2. intros [v2 [A2 B2]]. simpl in B2. inv B2. + exploit (eval_addimm Float.ox8000_0000 (Vfloat f :: le) t3). + unfold t3. unfold intoffloat. EvalOp. simpl. rewrite EQ. simpl. eauto. + intros [v4 [A4 B4]]. simpl in B4. inv B4. + rewrite Int.sub_add_opp in A4. rewrite Int.add_assoc in A4. + rewrite (Int.add_commut (Int.neg Float.ox8000_0000)) in A4. + rewrite Int.add_neg_zero in A4. + rewrite Int.add_zero in A4. + auto. Qed. Theorem eval_floatofint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (floatofint a) (Vfloat (Float.floatofint x)). -Proof. - intros. unfold floatofint. rewrite Float.floatofint_from_words. - apply eval_subf. - EvalOp. constructor. EvalOp. simpl; eauto. - constructor. apply eval_addimm. eauto. constructor. - simpl. auto. - EvalOp. + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofint x = Some y -> + exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v. +Proof. + intros. destruct x; simpl in H0; inv H0. + exists (Vfloat (Float.floatofint i)); split; auto. + unfold floatofint. + set (t1 := addimm Float.ox8000_0000 a). + set (t2 := Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: t1 ::: Enil)). + set (t3 := Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Float.ox8000_0000)) Enil). + exploit (eval_addimm Float.ox8000_0000 le a). eauto. fold t1. + intros [v1 [A1 B1]]. simpl in B1. inv B1. + exploit (eval_subf le t2). + unfold t2. EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. + unfold eval_operation. eauto. + instantiate (2 := t3). unfold t3. EvalOp. simpl; eauto. + intros [v2 [A2 B2]]. simpl in B2. inv B2. rewrite Float.floatofint_from_words. auto. Qed. Theorem eval_floatofintu: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (floatofintu a) (Vfloat (Float.floatofintu x)). -Proof. - intros. unfold floatofintu. rewrite Float.floatofintu_from_words. - apply eval_subf. - EvalOp. constructor. EvalOp. simpl; eauto. - constructor. eauto. constructor. - simpl. auto. - EvalOp. + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofintu x = Some y -> + exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v. +Proof. + intros. destruct x; simpl in H0; inv H0. + exists (Vfloat (Float.floatofintu i)); split; auto. + unfold floatofintu. + set (t2 := Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: a ::: Enil)). + set (t3 := Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Int.zero)) Enil). + exploit (eval_subf le t2). + unfold t2. EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. + unfold eval_operation. eauto. + instantiate (2 := t3). unfold t3. EvalOp. simpl; eauto. + intros [v2 [A2 B2]]. simpl in B2. inv B2. rewrite Float.floatofintu_from_words. auto. Qed. -Theorem eval_xor: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (xor a b) (Vint (Int.xor x y)). -Proof. intros; unfold xor; EvalOp. Qed. - -Theorem eval_shr: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y Int.iwordsize = true -> - eval_expr ge sp e m le (shr a b) (Vint (Int.shr x y)). -Proof. intros; unfold shr; EvalOp. simpl. rewrite H1. auto. Qed. - -Theorem eval_mulf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (mulf a b) (Vfloat (Float.mul x y)). -Proof. intros; unfold mulf; EvalOp. Qed. - -Theorem eval_divf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (divf a b) (Vfloat (Float.div x y)). -Proof. intros; unfold divf; EvalOp. Qed. - Theorem eval_addressing: forall le chunk a v b ofs, eval_expr ge sp e m le a v -> @@ -964,18 +759,11 @@ Proof. intros until v. unfold addressing; case (addressing_match a); intros; InvEval. exists (@nil val). split. eauto with evalexpr. simpl. auto. exists (@nil val). split. eauto with evalexpr. simpl. auto. - destruct (Genv.find_symbol ge s); congruence. - exists (Vint i0 :: nil). split. eauto with evalexpr. - simpl. destruct (Genv.find_symbol ge s). congruence. discriminate. - exists (Vptr b0 i :: nil). split. eauto with evalexpr. - simpl. congruence. - exists (Vint i :: Vptr b0 i0 :: nil). - split. eauto with evalexpr. simpl. - congruence. - exists (Vptr b0 i :: Vint i0 :: nil). - split. eauto with evalexpr. simpl. congruence. - exists (v :: nil). split. eauto with evalexpr. - subst v. simpl. rewrite Int.add_zero. auto. + exists (v0 :: nil). split. eauto with evalexpr. simpl. congruence. + exists (v1 :: nil). split. eauto with evalexpr. simpl. congruence. + exists (v1 :: v0 :: nil). split. eauto with evalexpr. simpl. congruence. + exists (v :: nil). split. eauto with evalexpr. subst v. simpl. + rewrite Int.add_zero. auto. Qed. End CMCONSTR. diff --git a/test/regression/Makefile b/test/regression/Makefile index 044e593..f3dcf4d 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -11,7 +11,8 @@ TESTS=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \ bitfields5 bitfields6 bitfields7 \ expr1 expr6 initializers volatile1 volatile2 volatile3 \ funct3 expr5 struct7 struct8 struct11 casts1 casts2 char1 \ - sizeof1 sizeof2 packedstruct1 packedstruct2 + sizeof1 sizeof2 packedstruct1 packedstruct2 \ + instrsel # Other tests: should compile to .s without errors (but expect warnings) EXTRAS=annot1 commaprec expr2 expr3 expr4 extern1 funct2 funptr1 init1 \ diff --git a/test/regression/Results/instrsel b/test/regression/Results/instrsel new file mode 100644 index 0000000..97d1a9d --- /dev/null +++ b/test/regression/Results/instrsel @@ -0,0 +1,6 @@ +bres = 135 214 210 255 135 135 135 135 135 135 +sbres = 12 -4 -46 -1 -121 -121 -121 -121 -121 0 +sres = 12 65532 1234 65279 54919 135 65415 54919 54919 135 +ssres = 12 -4 1234 -257 -10617 135 -121 -10617 -10617 0 +res = 135 -121 135 -121 54919 -10617 54919 -10617 135 135 -121 -121 135 135 -121 65415 12 12 12 -4 -4 1234 -257 0 135 12 12 12 12 12 243 0 44478 173 214 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +fres = 2.5 -3.14159 -3.14159 0 0 0 0 0 0 0 diff --git a/test/regression/instrsel.c b/test/regression/instrsel.c new file mode 100644 index 0000000..0dbe5e3 --- /dev/null +++ b/test/regression/instrsel.c @@ -0,0 +1,140 @@ +/* Testing instruction selection and cast optimizations */ + +typedef unsigned char U8; +typedef signed char S8; +typedef unsigned short U16; +typedef signed short S16; + +U8 b, bres[10]; +S8 sb, sbres[10]; +U16 s, sres[10]; +S16 ss, ssres[10]; +int i, res[50]; +unsigned int ui; +float f, fres[10]; +double d, dres[10]; + +#ifdef __COMPCERT__ +#define TEST(x) __builtin_annot(#x); x +#else +#define TEST(x) x +#endif + +void test(void) +{ + /* Telescoping casts */ + TEST(res[0] = (U8) (U8) i); + TEST(res[1] = (S8) (U8) i); + TEST(res[2] = (U8) (S8) i); + TEST(res[3] = (S8) (S8) i); + TEST(res[4] = (U16) (U16) i); + TEST(res[5] = (S16) (U16) i); + TEST(res[6] = (U16) (S16) i); + TEST(res[7] = (S16) (S16) i); + TEST(res[8] = (U16) (U8) i); + TEST(res[9] = (U8) (U16) i); + TEST(res[10] = (S16) (S8) i); + TEST(res[11] = (S8) (S16) i); + TEST(res[12] = (S16) (U8) i); + TEST(res[13] = (U8) (S16) i); + TEST(res[14] = (S8) (U16) i); + TEST(res[15] = (U16) (S8) i); + TEST(dres[0] = (float) (float) d); + /* Redundant casts after a load */ + TEST(res[16] = (U8) b); + TEST(res[17] = (U16) b); + TEST(res[18] = (S16) b); + TEST(res[19] = (S8) sb); + TEST(res[20] = (S16) sb); + TEST(res[21] = (U16) s); + TEST(res[22] = (S16) ss); + TEST(dres[1] = (float) f); + /* Redundant casts before a store */ + TEST(bres[0] = b); + TEST(bres[1] = sb); + TEST(bres[2] = s); + TEST(bres[3] = ss); + TEST(bres[4] = i); + TEST(bres[5] = (U8) i); + TEST(bres[6] = (S8) i); + TEST(bres[7] = (U16) i); + TEST(bres[8] = (S16) i); + TEST(bres[9] = i & 0xFF); + TEST(sbres[0] = b); + TEST(sbres[1] = sb); + TEST(sbres[2] = s); + TEST(sbres[3] = ss); + TEST(sbres[4] = i); + TEST(sbres[5] = (U8) i); + TEST(sbres[6] = (S8) i); + TEST(sbres[7] = (U16) i); + TEST(sbres[8] = (S16) i); + TEST(sres[0] = b); + TEST(sres[1] = sb); + TEST(sres[2] = s); + TEST(sres[3] = ss); + TEST(sres[4] = i); + TEST(sres[5] = (U8) i); + TEST(sres[6] = (S8) i); + TEST(sres[7] = (U16) i); + TEST(sres[8] = (S16) i); + TEST(sres[9] = i & 0xFF); + TEST(sres[10] = i & 0xFFFF); + TEST(ssres[0] = b); + TEST(ssres[1] = sb); + TEST(ssres[2] = s); + TEST(ssres[3] = ss); + TEST(ssres[4] = i); + TEST(ssres[5] = (U8) i); + TEST(ssres[6] = (S8) i); + TEST(ssres[7] = (U16) i); + TEST(ssres[8] = (S16) i); + TEST(fres[0] = f); + TEST(fres[1] = d); + TEST(fres[2] = (float) d); + /* Bitwise operations */ + TEST(res[23] = (U8) (b & 1)); + TEST(res[24] = (U8) (i & 0xFF)); + TEST(res[25] = (U8) (b & 0xFFFF)); + TEST(res[26] = (U8) (b & b)); + TEST(res[27] = (U8) (b | b)); + TEST(res[28] = (U8) (b | 0x8)); + TEST(res[29] = (U8) (b & b)); + TEST(res[30] = (U8) (b ^ 0xFF)); + TEST(res[31] = (U8) (b ^ b)); + /* Combining unsigned shifts */ + TEST(res[32] = (ui << 8) >> 16); + TEST(res[33] = (ui >> 16) & 0xFF); + /* Combining signed shifts */ + TEST(res[34] = (U8) ((i >> 8) & 0xFF)); + TEST(res[35] = (U8) (i >> 24)); +} + +#include <stdio.h> + +int main() +{ + int n; + b = 12; sb = -4; s = 1234; ss = -257; i = 1234567; ui = 0xDEADBEEF; + f = 2.5; d = -3.14159; + test(); + printf("bres = "); + for (n = 0; n < 10; n++) printf("%d ", bres[n]); + printf("\n"); + printf("sbres = "); + for (n = 0; n < 10; n++) printf("%d ", sbres[n]); + printf("\n"); + printf("sres = "); + for (n = 0; n < 10; n++) printf("%d ", sres[n]); + printf("\n"); + printf("ssres = "); + for (n = 0; n < 10; n++) printf("%d ", ssres[n]); + printf("\n"); + printf("res = "); + for (n = 0; n < 50; n++) printf("%d ", res[n]); + printf("\n"); + printf("fres = "); + for (n = 0; n < 10; n++) printf("%g ", fres[n]); + printf("\n"); + return 0; +} diff --git a/tools/ndfun.ml b/tools/ndfun.ml new file mode 100644 index 0000000..78fb03d --- /dev/null +++ b/tools/ndfun.ml @@ -0,0 +1,231 @@ +open Printf + +(* Error reporting *) + +let error file line msg = + eprintf "%s:%d: Error: %s\n" file line msg; + exit 2 + +(* Replace newlines with spaces *) + +let oneline s = + let t = String.create (String.length s) in + for i = 0 to String.length s - 1 do + t.[i] <- (match s.[i] with '\n' -> ' ' | c -> c) + done; + t + +(* Trim leading and terminating spaces, and compress multiple spaces *) + +let re_trim_1 = Str.regexp "^[ \t]+\\|[ \t]+$" +let re_trim_2 = Str.regexp " +" + +let trim s = + Str.global_replace re_trim_2 " " (Str.global_replace re_trim_1 "" s) + +(* A nicer interface to Str.match_string, with automatic trimming *) + +let str_match n re s = + if not (Str.string_match re s 0) then [||] else begin + let res = Array.make (n+1) "" in + for i = 1 to n do res.(i) <- Str.matched_group i s done; + for i = 1 to n do res.(i) <- trim res.(i) done; + res + end + +(* List all occurrences of the given regexp in the given string *) + +let str_grep re s = + let rec occs pos = + try + let pos1 = Str.search_forward re s pos in + let pos2 = Str.match_end() in + String.sub s pos1 (pos2 - pos1) :: occs pos2 + with Not_found -> + [] + in occs 0 + +(* Auxiliary transformations *) + +let re_comma = Str.regexp ", *" + +let remove_commas args = Str.global_replace re_comma " " args + +(* "x, y, z" -> "x as zz1, y as zz2, z as zz3" *) + +let re_arg = Str.regexp "\\([a-z][a-z0-9_]*\\)" + +let match_args args = + let n = ref 0 in + let subst s = + incr n; sprintf "%s as zz%d" (Str.matched_group 1 s) !n in + Str.global_substitute re_arg subst args + +(* "x, y, z" -> "zz1 zz2 zz3" *) + +let match_temps args = + let n = ref 0 in + let subst s = + incr n; sprintf "zz%d" !n in + Str.global_substitute re_arg subst (remove_commas args) + +(* "foo, bar, gee" -> "(foo) (bar) (gee)" *) + +let parenpats p = + "(" ^ Str.global_replace re_comma ") (" p ^ ")" + +(* Extract the bound variables in a pattern. Heuristic: any identifier + that starts with a lowercase letter and is not "nil". *) + +let re_ident = Str.regexp "\\([A-Za-z][A-Za-z0-9_]*\\)" + +let boundvarspat p = + String.concat " " + (List.filter + (fun id -> id <> "nil" && Str.string_match re_arg id 0) + (str_grep re_ident p)) + +(* Given a match argument "id1, id2, id3" + and a parameter list "(id0: ty0) (id1: ty1) (id2: ty2) (id3: ty3)" + produce "(id1: ty1) (id2: ty2) (id3: ty3)". *) + +let re_param = Str.regexp "(\\([A-Za-z][A-Za-z0-9_]*\\):[^)]*) *" + +let matched_params params args = + let arglist = Str.split re_comma args in + let filter_param s = + if List.mem (Str.matched_group 1 s) arglist + then Str.matched_string s + else "" in + Str.global_substitute re_param filter_param params + +(* Translation of a "Nondetfunction" *) + +let re_nd = Str.regexp( + "Nondetfunction +\\([a-z][a-z0-9_]*\\) +\\(.+\\):=" (* name, params *) +^ "\\(.*\\)" (* prefix code *) +^ "\\bmatch\\b\\(.*\\)\\bwith\\b" (* match arguments *) +^ "\\(.*\\)\\bend\\." (* match cases *) +) + +let re_split_cases = Str.regexp "|" + +let re_case = Str.regexp "\\(.*\\)=>\\(.*\\)" + +let re_default_pat = Str.regexp "[ _,]*$" + +let transl_ndfun filename lineno s = + (* Decompose as follows: + Nondetfunction <name> <parenthesized parameters> := + <prefix> + match <args> with + <cases> + end. *) + let res = str_match 5 re_nd (oneline s) in + if Array.length res = 0 then + error filename lineno "ill-formed 'Nondetfunction'"; + let name = res.(1) + and params = res.(2) + and prefix = res.(3) + and args = res.(4) + and cases = res.(5) in + let mparams = matched_params params args in +(*** + printf "name = '%s'\n" name; + printf "params = '%s'\n" params; + printf "prefix = '%s'\n" prefix; + printf "args = '%s'\n" args; + printf "cases = '%s'\n" cases; +***) + let a = Buffer.create 2048 (* inductive declaration *) + and b = Buffer.create 2048 (* matching function *) + and c = Buffer.create 2048 in (* computational function *) + + (* Beginning of code *) + bprintf a "Inductive %s_cases: forall %s, Type :=\n" name mparams; + bprintf b "Definition %s_match %s :=\n" name mparams; + bprintf b " match %s return %s_cases %s with\n" + (match_args args) name (match_temps args); + bprintf c "Definition %s %s :=\n" name params; + bprintf c " %s match %s_match %s with\n" prefix name (remove_commas args); + + (* Adding each case *) + let numcase = ref 0 in + let transl_case s = + let res = str_match 2 re_case s in + if Array.length res = 0 then + error filename lineno ("ill-formed case: " ^ s); + let patlist = res.(1) and rhs = res.(2) in + let bv = boundvarspat patlist in + if not (Str.string_match re_default_pat patlist 0) then begin + incr numcase; + bprintf a " | %s_case%d: forall %s, %s_cases %s\n" + name !numcase bv name (parenpats patlist); + bprintf b " | %s => %s_case%d %s\n" patlist name !numcase bv; + bprintf c " | %s_case%d %s => (* %s *) \n" name !numcase bv patlist; + bprintf c " %s\n" rhs + end else begin + let bv = remove_commas args in + bprintf a " | %s_default: forall %s, %s_cases %s.\n\n" + name mparams name bv; + bprintf b " | %s => %s_default %s\n" args name bv; + bprintf b " end.\n\n"; + bprintf c " | %s_default %s =>\n" name bv; + bprintf c " %s\n" rhs; + bprintf c " end.\n\n" + end + in List.iter transl_case (Str.split re_split_cases cases); + + (* Generate the output *) + printf "(** Original definition:\n<<\n%s>>\n*)\n\n" s; + Buffer.output_buffer stdout a; + Buffer.output_buffer stdout b; + Buffer.output_buffer stdout c + +(* Main loop: translate "Nondetfunction ... end." fragments in the given + file. Copy the rest to standard output. *) + +let re_begin_nd_fun = Str.regexp "Nondetfunction\\b" +let re_end_nd_fun = Str.regexp ".*\\bend\\." + +let transl_file f = + let ic = open_in f in + let b = Buffer.create 2048 in + let in_nd = ref false in + let line_no = ref 0 in + let line_start = ref 0 in + try + while true do + incr line_no; + let l = input_line ic in + if !in_nd then begin + Buffer.add_string b l; + Buffer.add_char b '\n'; + if Str.string_match re_end_nd_fun l 0 then begin + transl_ndfun f !line_start (Buffer.contents b); + Buffer.clear b; + in_nd := false + end + end else begin + if Str.string_match re_begin_nd_fun l 0 then begin + Buffer.clear b; + Buffer.add_string b l; + Buffer.add_char b '\n'; + in_nd := true; + line_start := !line_no + end else begin + output_string stdout l; + output_char stdout '\n' + end + end + done + with End_of_file -> + close_in ic; + if !in_nd then error f !line_start "unterminated 'Nondetfunction'" + +(* Entry point *) + +let _ = + for i = 1 to Array.length Sys.argv - 1 do + transl_file Sys.argv.(i) + done |