summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.depend27
-rw-r--r--Makefile6
-rw-r--r--backend/Allocation.v2
-rw-r--r--backend/Allocproof.v2
-rw-r--r--backend/CSE.v428
-rw-r--r--backend/CSEdomain.v147
-rw-r--r--backend/CSEproof.v1608
-rw-r--r--backend/Constprop.v447
-rw-r--r--backend/Constpropproof.v782
-rw-r--r--backend/Deadcode.v192
-rw-r--r--backend/Deadcodeproof.v1014
-rw-r--r--backend/Kildall.v1167
-rw-r--r--backend/Linearize.v2
-rw-r--r--backend/Linearizeproof.v4
-rw-r--r--backend/Liveness.v3
-rw-r--r--backend/NeedDomain.v1515
-rw-r--r--backend/PrintRTL.ml3
-rw-r--r--backend/Regalloc.ml2
-rw-r--r--backend/Splitting.ml2
-rw-r--r--backend/ValueAnalysis.v1812
-rw-r--r--backend/ValueDomain.v3692
-rw-r--r--cfrontend/Cexec.v2
-rw-r--r--cfrontend/Cminorgen.v228
-rw-r--r--cfrontend/Cminorgenproof.v658
-rw-r--r--common/Events.v84
-rw-r--r--common/Memory.v135
-rw-r--r--common/Values.v6
-rw-r--r--driver/Clflags.ml1
-rw-r--r--driver/Compiler.v9
-rw-r--r--driver/Driver.ml3
-rw-r--r--extraction/extraction.v16
-rw-r--r--ia32/CombineOp.v23
-rw-r--r--ia32/CombineOpproof.v59
-rw-r--r--ia32/ConstpropOp.vp203
-rw-r--r--ia32/ConstpropOpproof.v517
-rw-r--r--ia32/NeedOp.v169
-rw-r--r--ia32/Op.v59
-rw-r--r--ia32/SelectOp.vp18
-rw-r--r--ia32/SelectOpproof.v18
-rw-r--r--ia32/ValueAOp.v158
-rw-r--r--lib/Camlcoq.ml10
-rw-r--r--lib/Integers.v13
-rw-r--r--lib/IntvSets.v410
-rw-r--r--lib/Lattice.v235
-rw-r--r--powerpc/CombineOp.v8
-rw-r--r--powerpc/CombineOpproof.v80
-rw-r--r--powerpc/ConstpropOp.vp186
-rw-r--r--powerpc/ConstpropOpproof.v422
-rw-r--r--powerpc/NeedOp.v160
-rw-r--r--powerpc/Op.v10
-rw-r--r--powerpc/ValueAOp.v160
51 files changed, 12730 insertions, 4187 deletions
diff --git a/.depend b/.depend
index 24941d8..d79e968 100644
--- a/.depend
+++ b/.depend
@@ -14,6 +14,7 @@ lib/UnionFind.vo lib/UnionFind.glob lib/UnionFind.v.beautified: lib/UnionFind.v
lib/Wfsimpl.vo lib/Wfsimpl.glob lib/Wfsimpl.v.beautified: lib/Wfsimpl.v lib/Axioms.vo
lib/Postorder.vo lib/Postorder.glob lib/Postorder.v.beautified: lib/Postorder.v lib/Coqlib.vo lib/Maps.vo lib/Iteration.vo
lib/FSetAVLplus.vo lib/FSetAVLplus.glob lib/FSetAVLplus.v.beautified: lib/FSetAVLplus.v lib/Coqlib.vo
+lib/IntvSets.vo lib/IntvSets.glob lib/IntvSets.v.beautified: lib/IntvSets.v lib/Coqlib.vo
common/Errors.vo common/Errors.glob common/Errors.v.beautified: common/Errors.v lib/Coqlib.vo
common/AST.vo common/AST.glob common/AST.v.beautified: common/AST.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo
common/Events.vo common/Events.glob common/Events.v.beautified: common/Events.v lib/Coqlib.vo lib/Intv.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Errors.vo
@@ -53,14 +54,22 @@ backend/Renumberproof.vo backend/Renumberproof.glob backend/Renumberproof.v.beau
backend/RTLtyping.vo backend/RTLtyping.glob backend/RTLtyping.v.beautified: backend/RTLtyping.v lib/Coqlib.vo common/Errors.vo common/Subtyping.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo common/Globalenvs.vo common/Values.vo lib/Integers.vo common/Memory.vo common/Events.vo backend/RTL.vo backend/Conventions.vo
backend/Kildall.vo backend/Kildall.glob backend/Kildall.v.beautified: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo lib/Heaps.vo
backend/Liveness.vo backend/Liveness.glob backend/Liveness.v.beautified: backend/Liveness.v lib/Coqlib.vo lib/Maps.vo lib/Lattice.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo
-$(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOp.glob $(ARCH)/ConstpropOp.v.beautified: $(ARCH)/ConstpropOp.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/Registers.vo
-backend/Constprop.vo backend/Constprop.glob backend/Constprop.v.beautified: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/Liveness.vo $(ARCH)/ConstpropOp.vo
-$(ARCH)/ConstpropOpproof.vo $(ARCH)/ConstpropOpproof.glob $(ARCH)/ConstpropOpproof.v.beautified: $(ARCH)/ConstpropOpproof.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo $(ARCH)/ConstpropOp.vo backend/Constprop.vo
-backend/Constpropproof.vo backend/Constpropproof.glob backend/Constpropproof.v.beautified: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/Liveness.vo $(ARCH)/ConstpropOp.vo backend/Constprop.vo $(ARCH)/ConstpropOpproof.vo
-$(ARCH)/CombineOp.vo $(ARCH)/CombineOp.glob $(ARCH)/CombineOp.v.beautified: $(ARCH)/CombineOp.v lib/Coqlib.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo $(ARCH)/SelectOp.vo
-backend/CSE.vo backend/CSE.glob backend/CSE.v.beautified: backend/CSE.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 $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Kildall.vo $(ARCH)/CombineOp.vo
-$(ARCH)/CombineOpproof.vo $(ARCH)/CombineOpproof.glob $(ARCH)/CombineOpproof.v.beautified: $(ARCH)/CombineOpproof.v lib/Coqlib.vo lib/Integers.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo backend/RTL.vo $(ARCH)/CombineOp.vo backend/CSE.vo
-backend/CSEproof.vo backend/CSEproof.glob backend/CSEproof.v.beautified: backend/CSEproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Kildall.vo $(ARCH)/CombineOp.vo $(ARCH)/CombineOpproof.vo backend/CSE.vo
+backend/ValueDomain.vo backend/ValueDomain.glob backend/ValueDomain.v.beautified: backend/ValueDomain.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 common/Events.vo lib/Lattice.vo backend/Kildall.vo backend/Registers.vo backend/RTL.vo
+$(ARCH)/ValueAOp.vo $(ARCH)/ValueAOp.glob $(ARCH)/ValueAOp.v.beautified: $(ARCH)/ValueAOp.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/ValueDomain.vo backend/RTL.vo
+backend/ValueAnalysis.vo backend/ValueAnalysis.glob backend/ValueAnalysis.v.beautified: backend/ValueAnalysis.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 common/Events.vo lib/Lattice.vo backend/Kildall.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/Liveness.vo lib/Axioms.vo
+$(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOp.glob $(ARCH)/ConstpropOp.v.beautified: $(ARCH)/ConstpropOp.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/Registers.vo backend/ValueDomain.vo
+backend/Constprop.vo backend/Constprop.glob backend/Constprop.v.beautified: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/Liveness.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo $(ARCH)/ConstpropOp.vo
+$(ARCH)/ConstpropOpproof.vo $(ARCH)/ConstpropOpproof.glob $(ARCH)/ConstpropOpproof.v.beautified: $(ARCH)/ConstpropOpproof.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/ValueDomain.vo $(ARCH)/ConstpropOp.vo
+backend/Constpropproof.vo backend/Constpropproof.glob backend/Constpropproof.v.beautified: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo $(ARCH)/ConstpropOp.vo backend/Constprop.vo $(ARCH)/ConstpropOpproof.vo
+backend/CSEdomain.vo backend/CSEdomain.glob backend/CSEdomain.v.beautified: backend/CSEdomain.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo
+$(ARCH)/CombineOp.vo $(ARCH)/CombineOp.glob $(ARCH)/CombineOp.v.beautified: $(ARCH)/CombineOp.v lib/Coqlib.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/CSEdomain.vo
+backend/CSE.vo backend/CSE.glob backend/CSE.v.beautified: backend/CSE.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 $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/CSEdomain.vo backend/Kildall.vo $(ARCH)/CombineOp.vo
+$(ARCH)/CombineOpproof.vo $(ARCH)/CombineOpproof.glob $(ARCH)/CombineOpproof.v.beautified: $(ARCH)/CombineOpproof.v lib/Coqlib.vo lib/Integers.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo backend/RTL.vo backend/CSEdomain.vo $(ARCH)/CombineOp.vo
+backend/CSEproof.vo backend/CSEproof.glob backend/CSEproof.v.beautified: backend/CSEproof.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/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo backend/CSEdomain.vo $(ARCH)/CombineOp.vo $(ARCH)/CombineOpproof.vo backend/CSE.vo
+backend/NeedDomain.vo backend/NeedDomain.glob backend/NeedDomain.v.beautified: backend/NeedDomain.v lib/Coqlib.vo lib/Maps.vo lib/IntvSets.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo lib/Lattice.vo backend/Registers.vo backend/ValueDomain.vo $(ARCH)/Op.vo backend/RTL.vo
+$(ARCH)/NeedOp.vo $(ARCH)/NeedOp.glob $(ARCH)/NeedOp.v.beautified: $(ARCH)/NeedOp.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/NeedDomain.vo backend/RTL.vo
+backend/Deadcode.vo backend/Deadcode.glob backend/Deadcode.v.beautified: backend/Deadcode.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Memory.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/NeedDomain.vo $(ARCH)/NeedOp.vo
+backend/Deadcodeproof.vo backend/Deadcodeproof.glob backend/Deadcodeproof.v.beautified: backend/Deadcodeproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/IntvSets.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/NeedDomain.vo $(ARCH)/NeedOp.vo backend/Deadcode.vo
$(ARCH)/Machregs.vo $(ARCH)/Machregs.glob $(ARCH)/Machregs.v.beautified: $(ARCH)/Machregs.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo
backend/Locations.vo backend/Locations.glob backend/Locations.v.beautified: backend/Locations.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/AST.vo common/Values.vo $(ARCH)/Machregs.vo
$(ARCH)/$(VARIANT)/Conventions1.vo $(ARCH)/$(VARIANT)/Conventions1.glob $(ARCH)/$(VARIANT)/Conventions1.v.beautified: $(ARCH)/$(VARIANT)/Conventions1.v lib/Coqlib.vo common/AST.vo backend/Locations.vo
@@ -106,7 +115,7 @@ cfrontend/Cshmgenproof.vo cfrontend/Cshmgenproof.glob cfrontend/Cshmgenproof.v.b
cfrontend/Csharpminor.vo cfrontend/Csharpminor.glob cfrontend/Csharpminor.v.beautified: cfrontend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo backend/Cminor.vo common/Smallstep.vo
cfrontend/Cminorgen.vo cfrontend/Cminorgen.glob cfrontend/Cminorgen.v.beautified: cfrontend/Cminorgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo lib/Floats.vo cfrontend/Csharpminor.vo backend/Cminor.vo
cfrontend/Cminorgenproof.vo cfrontend/Cminorgenproof.glob cfrontend/Cminorgenproof.v.beautified: 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/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.beautified: driver/Compiler.v lib/Coqlib.vo common/Errors.vo common/AST.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/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/SimplLocals.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/Inlining.vo backend/Renumber.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Stacking.vo $(ARCH)/Asmgen.vo cfrontend/SimplExprproof.vo cfrontend/SimplLocalsproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/Inliningproof.vo backend/Renumberproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Tunnelingproof.vo backend/Linearizeproof.vo backend/CleanupLabelsproof.vo backend/Stackingproof.vo $(ARCH)/Asmgenproof.vo
+driver/Compiler.vo driver/Compiler.glob driver/Compiler.v.beautified: driver/Compiler.v lib/Coqlib.vo common/Errors.vo common/AST.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/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/SimplLocals.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/Inlining.vo backend/Renumber.vo backend/Constprop.vo backend/CSE.vo backend/Deadcode.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Stacking.vo $(ARCH)/Asmgen.vo cfrontend/SimplExprproof.vo cfrontend/SimplLocalsproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/Inliningproof.vo backend/Renumberproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Deadcodeproof.vo backend/Allocproof.vo backend/Tunnelingproof.vo backend/Linearizeproof.vo backend/CleanupLabelsproof.vo backend/Stackingproof.vo $(ARCH)/Asmgenproof.vo
driver/Complements.vo driver/Complements.glob driver/Complements.v.beautified: driver/Complements.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Behaviors.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo backend/Cminor.vo backend/RTL.vo $(ARCH)/Asm.vo driver/Compiler.vo common/Errors.vo
flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_Raux.glob flocq/Core/Fcore_Raux.v.beautified: flocq/Core/Fcore_Raux.v flocq/Core/Fcore_Zaux.vo
flocq/Core/Fcore_Zaux.vo flocq/Core/Fcore_Zaux.glob flocq/Core/Fcore_Zaux.v.beautified: flocq/Core/Fcore_Zaux.v
diff --git a/Makefile b/Makefile
index a4d2036..28e945f 100644
--- a/Makefile
+++ b/Makefile
@@ -66,7 +66,7 @@ FLOCQ=\
LIB=Axioms.v Coqlib.v Intv.v Maps.v Heaps.v Lattice.v Ordered.v \
Iteration.v Integers.v Floats.v Nan.v Parmov.v UnionFind.v Wfsimpl.v \
- Postorder.v FSetAVLplus.v
+ Postorder.v FSetAVLplus.v IntvSets.v
# Parts common to the front-ends and the back-end (in common/)
@@ -86,8 +86,10 @@ BACKEND=\
Renumber.v Renumberproof.v \
RTLtyping.v \
Kildall.v Liveness.v \
+ ValueDomain.v ValueAOp.v ValueAnalysis.v \
ConstpropOp.v Constprop.v ConstpropOpproof.v Constpropproof.v \
- CombineOp.v CSE.v CombineOpproof.v CSEproof.v \
+ CSEdomain.v CombineOp.v CSE.v CombineOpproof.v CSEproof.v \
+ NeedDomain.v NeedOp.v Deadcode.v Deadcodeproof.v \
Machregs.v Locations.v Conventions1.v Conventions.v LTL.v \
Allocation.v Allocproof.v \
Tunneling.v Tunnelingproof.v \
diff --git a/backend/Allocation.v b/backend/Allocation.v
index e53c5aa..0851b77 100644
--- a/backend/Allocation.v
+++ b/backend/Allocation.v
@@ -1104,7 +1104,7 @@ Definition successors_block_shape (bsh: block_shape) : list node :=
end.
Definition analyze (f: RTL.function) (env: regenv) (bsh: PTree.t block_shape) :=
- DS.fixpoint bsh successors_block_shape (transfer f env bsh) nil.
+ DS.fixpoint_allnodes bsh successors_block_shape (transfer f env bsh).
(** * Validating and translating functions and programs *)
diff --git a/backend/Allocproof.v b/backend/Allocproof.v
index e91be74..1e637f9 100644
--- a/backend/Allocproof.v
+++ b/backend/Allocproof.v
@@ -1342,7 +1342,7 @@ Lemma analyze_successors:
an!!pc = OK e ->
exists e', transfer f env bsh s an!!s = OK e' /\ EqSet.Subset e' e.
Proof.
- unfold analyze; intros. exploit DS.fixpoint_solution; eauto.
+ unfold analyze; intros. exploit DS.fixpoint_allnodes_solution; eauto.
rewrite H2. unfold DS.L.ge. destruct (transfer f env bsh s an#s); intros.
exists e0; auto.
contradiction.
diff --git a/backend/CSE.v b/backend/CSE.v
index 205d446..373acce 100644
--- a/backend/CSE.v
+++ b/backend/CSE.v
@@ -24,12 +24,12 @@ Require Import Memory.
Require Import Op.
Require Import Registers.
Require Import RTL.
-Require Import RTLtyping.
+Require Import ValueDomain.
+Require Import ValueAnalysis.
+Require Import CSEdomain.
Require Import Kildall.
Require Import CombineOp.
-(** * Value numbering *)
-
(** The idea behind value numbering algorithms is to associate
abstract identifiers (``value numbers'') to the contents of registers
at various program points, and record equations between these
@@ -45,49 +45,10 @@ Require Import CombineOp.
[r1 = add(r2, r3)] by a move instruction [r1 = r4], therefore eliminating
a common subexpression and reusing the result of an earlier addition.
- Abstract identifiers / value numbers are represented by positive integers.
- Equations are of the form [valnum = rhs], where the right-hand sides
- [rhs] are either arithmetic operations or memory loads. *)
-
-(*
-Definition valnum := positive.
+ The representation of value numbers and equations is described in
+ module [CSEdomain]. *)
-Inductive rhs : Type :=
- | Op: operation -> list valnum -> rhs
- | Load: memory_chunk -> addressing -> list valnum -> rhs.
-*)
-
-Definition eq_valnum: forall (x y: valnum), {x=y}+{x<>y} := peq.
-
-Definition eq_list_valnum (x y: list valnum) : {x=y}+{x<>y}.
-Proof. decide equality. apply eq_valnum. Defined.
-
-Definition eq_rhs (x y: rhs) : {x=y}+{x<>y}.
-Proof.
- generalize Int.eq_dec; intro.
- generalize Float.eq_dec; intro.
- generalize eq_operation; intro.
- generalize eq_addressing; intro.
- assert (forall (x y: memory_chunk), {x=y}+{x<>y}). decide equality.
- generalize eq_valnum; intro.
- generalize eq_list_valnum; intro.
- decide equality.
-Defined.
-
-(** A value numbering is a collection of equations between value numbers
- plus a partial map from registers to value numbers. Additionally,
- we maintain the next unused value number, so as to easily generate
- fresh value numbers. *)
-
-Record numbering : Type := mknumbering {
- num_next: valnum; (**r first unused value number *)
- num_eqs: list (valnum * rhs); (**r valid equations *)
- num_reg: PTree.t valnum; (**r mapping register to valnum *)
- num_val: PMap.t (list reg) (**r reverse mapping valnum to regs containing it *)
-}.
-
-Definition empty_numbering :=
- mknumbering 1%positive nil (PTree.empty valnum) (PMap.init nil).
+(** * Operations on value numberings *)
(** [valnum_reg n r] returns the value number for the contents of
register [r]. If none exists, a fresh value number is returned
@@ -100,10 +61,10 @@ Definition valnum_reg (n: numbering) (r: reg) : numbering * valnum :=
| Some v => (n, v)
| None =>
let v := n.(num_next) in
- (mknumbering (Psucc v)
- n.(num_eqs)
- (PTree.set r v n.(num_reg))
- (PMap.set v (r :: nil) n.(num_val)),
+ ( {| num_next := Psucc v;
+ num_eqs := n.(num_eqs);
+ num_reg := PTree.set r v n.(num_reg);
+ num_val := PMap.set v (r :: nil) n.(num_val) |},
v)
end.
@@ -122,24 +83,67 @@ Fixpoint valnum_regs (n: numbering) (rl: list reg)
for an equation of the form [vn = rhs] for some value number [vn].
If found, [Some vn] is returned, otherwise [None] is returned. *)
-Fixpoint find_valnum_rhs (r: rhs) (eqs: list (valnum * rhs))
+Fixpoint find_valnum_rhs (r: rhs) (eqs: list equation)
{struct eqs} : option valnum :=
match eqs with
| nil => None
- | (v, r') :: eqs1 =>
- if eq_rhs r r' then Some v else find_valnum_rhs r eqs1
+ | Eq v str r' :: eqs1 =>
+ if str && eq_rhs r r' then Some v else find_valnum_rhs r eqs1
+ end.
+
+(** [find_valnum_rhs' rhs eqs] is similar, but also accepts equations
+ of the form [vn >= rhs]. *)
+
+Fixpoint find_valnum_rhs' (r: rhs) (eqs: list equation)
+ {struct eqs} : option valnum :=
+ match eqs with
+ | nil => None
+ | Eq v str r' :: eqs1 =>
+ if eq_rhs r r' then Some v else find_valnum_rhs' r eqs1
end.
(** [find_valnum_num vn eqs] searches the list of equations [eqs]
for an equation of the form [vn = rhs] for some equation [rhs].
If found, [Some rhs] is returned, otherwise [None] is returned. *)
-Fixpoint find_valnum_num (v: valnum) (eqs: list (valnum * rhs))
+Fixpoint find_valnum_num (v: valnum) (eqs: list equation)
{struct eqs} : option rhs :=
match eqs with
| nil => None
- | (v', r') :: eqs1 =>
- if peq v v' then Some r' else find_valnum_num v eqs1
+ | Eq v' str r' :: eqs1 =>
+ if str && peq v v' then Some r' else find_valnum_num v eqs1
+ end.
+
+(** [reg_valnum n vn] returns a register that is mapped to value number
+ [vn], or [None] if no such register exists. *)
+
+Definition reg_valnum (n: numbering) (vn: valnum) : option reg :=
+ match PMap.get vn n.(num_val) with
+ | nil => None
+ | r :: rs => Some r
+ end.
+
+(** [regs_valnums] is similar, for a list of value numbers. *)
+
+Fixpoint regs_valnums (n: numbering) (vl: list valnum) : option (list reg) :=
+ match vl with
+ | nil => Some nil
+ | v1 :: vs =>
+ match reg_valnum n v1, regs_valnums n vs with
+ | Some r1, Some rs => Some (r1 :: rs)
+ | _, _ => None
+ end
+ end.
+
+(** [find_rhs] return a register that already holds the result of the
+ given arithmetic operation or memory load, or a value more defined
+ than this result, according to the given
+ numbering. [None] is returned if no such register exists. *)
+
+Definition find_rhs (n: numbering) (rh: rhs) : option reg :=
+ match find_valnum_rhs' rh n.(num_eqs) with
+ | None => None
+ | Some vres => reg_valnum n vres
end.
(** Update the [num_val] mapping prior to a redefinition of register [r]. *)
@@ -163,14 +167,15 @@ Definition update_reg (n: numbering) (rd: reg) (vn: valnum) : PMap.t (list reg)
Definition add_rhs (n: numbering) (rd: reg) (rh: rhs) : numbering :=
match find_valnum_rhs rh n.(num_eqs) with
| Some vres =>
- mknumbering n.(num_next) n.(num_eqs)
- (PTree.set rd vres n.(num_reg))
- (update_reg n rd vres)
+ {| num_next := n.(num_next);
+ num_eqs := n.(num_eqs);
+ num_reg := PTree.set rd vres n.(num_reg);
+ num_val := update_reg n rd vres |}
| None =>
- mknumbering (Psucc n.(num_next))
- ((n.(num_next), rh) :: n.(num_eqs))
- (PTree.set rd n.(num_next) n.(num_reg))
- (update_reg n rd n.(num_next))
+ {| num_next := Psucc n.(num_next);
+ num_eqs := Eq n.(num_next) true rh :: n.(num_eqs);
+ num_reg := PTree.set rd n.(num_next) n.(num_reg);
+ num_val := update_reg n rd n.(num_next) |}
end.
(** [add_op n rd op rs] specializes [add_rhs] for the case of an
@@ -193,8 +198,10 @@ Definition add_op (n: numbering) (rd: reg) (op: operation) (rs: list reg) :=
match is_move_operation op rs with
| Some r =>
let (n1, v) := valnum_reg n r in
- mknumbering n1.(num_next) n1.(num_eqs)
- (PTree.set rd v n1.(num_reg)) (update_reg n1 rd v)
+ {| num_next := n1.(num_next);
+ num_eqs := n1.(num_eqs);
+ num_reg := PTree.set rd v n1.(num_reg);
+ num_val := update_reg n1 rd v |}
| None =>
let (n1, vs) := valnum_regs n rs in
add_rhs n1 rd (Op op vs)
@@ -211,30 +218,32 @@ Definition add_load (n: numbering) (rd: reg)
let (n1, vs) := valnum_regs n rs in
add_rhs n1 rd (Load chunk addr vs).
-(** [add_unknown n rd] returns a numbering where [rd] is mapped to a
- fresh value number, and no equations are added. This is useful
- to model instructions with unpredictable results such as [Ibuiltin]. *)
+(** [set_unknown n rd] returns a numbering where [rd] is mapped to
+ no value number, and no equations are added. This is useful
+ to model instructions with unpredictable results such as [Ibuiltin]. *)
-Definition add_unknown (n: numbering) (rd: reg) :=
- mknumbering (Psucc n.(num_next))
- n.(num_eqs)
- (PTree.set rd n.(num_next) n.(num_reg))
- (forget_reg n rd).
+Definition set_unknown (n: numbering) (rd: reg) :=
+ {| num_next := n.(num_next);
+ num_eqs := n.(num_eqs);
+ num_reg := PTree.remove rd n.(num_reg);
+ num_val := forget_reg n rd |}.
(** [kill_equations pred n] remove all equations satisfying predicate [pred]. *)
-Fixpoint kill_eqs (pred: rhs -> bool) (eqs: list (valnum * rhs)) : list (valnum * rhs) :=
+Fixpoint kill_eqs (pred: rhs -> bool) (eqs: list equation) : list equation :=
match eqs with
| nil => nil
- | eq :: rem => if pred (snd eq) then kill_eqs pred rem else eq :: kill_eqs pred rem
+ | (Eq l strict r) as eq :: rem =>
+ if pred r then kill_eqs pred rem else eq :: kill_eqs pred rem
end.
Definition kill_equations (pred: rhs -> bool) (n: numbering) : numbering :=
- mknumbering n.(num_next)
- (kill_eqs pred n.(num_eqs))
- n.(num_reg) n.(num_val).
+ {| num_next := n.(num_next);
+ num_eqs := kill_eqs pred n.(num_eqs);
+ num_reg := n.(num_reg);
+ num_val := n.(num_val) |}.
-(** [kill_loads n] removes all equations involving memory loads,
+(** [kill_all_loads n] removes all equations involving memory loads,
as well as those involving memory-dependent operators.
It is used to reflect the effect of a builtin operation, which can
change memory in unpredictable ways and potentially invalidate all such equations. *)
@@ -245,63 +254,121 @@ Definition filter_loads (r: rhs) : bool :=
| Load _ _ _ => true
end.
-Definition kill_loads (n: numbering) : numbering :=
+Definition kill_all_loads (n: numbering) : numbering :=
kill_equations filter_loads n.
-(** [add_store n chunk addr rargs rsrc] updates the numbering [n] to reflect
- the effect of a store instruction [Istore chunk addr rargs rsrc].
- Equations involving the memory state are removed from [n], unless we
- can prove that the store does not invalidate them.
- Then, an equations [rsrc = Load chunk addr rargs] is added to reflect
- the known content of the stored memory area, but only if [chunk] is
- a "full-size" quantity ([Mint32] or [Mfloat64] or [Mint64]). *)
+(** [kill_loads_after_store app n chunk addr args] removes all equations
+ involving loads that could be invalidated by a store of quantity [chunk]
+ at address determined by [addr] and [args]. Loads that are disjoint
+ from this store are preserved. Equations involving memory-dependent
+ operators are also removed. *)
-Definition filter_after_store (chunk: memory_chunk) (addr: addressing) (vl: list valnum) (r: rhs) : bool :=
+Definition filter_after_store (app: VA.t) (n: numbering) (p: aptr) (sz: Z) (r: rhs) :=
match r with
- | Op op vl' => op_depends_on_memory op
- | Load chunk' addr' vl' =>
- negb(eq_list_valnum vl vl' && addressing_separated chunk addr chunk' addr')
+ | Op op vl =>
+ op_depends_on_memory op
+ | Load chunk addr vl =>
+ match regs_valnums n vl with
+ | None => true
+ | Some rl =>
+ negb (pdisjoint (aaddressing app addr rl) (size_chunk chunk) p sz)
+ end
end.
-Definition add_store (n: numbering) (chunk: memory_chunk) (addr: addressing)
- (rargs: list reg) (rsrc: reg) : numbering :=
- let (n1, vargs) := valnum_regs n rargs in
- let n2 := kill_equations (filter_after_store chunk addr vargs) n1 in
+Definition kill_loads_after_store
+ (app: VA.t) (n: numbering)
+ (chunk: memory_chunk) (addr: addressing) (args: list reg) :=
+ let p := aaddressing app addr args in
+ kill_equations (filter_after_store app n p (size_chunk chunk)) n.
+
+(** [add_store_result n chunk addr rargs rsrc] updates the numbering [n]
+ to reflect the knowledge gained after executing an instruction
+ [Istore chunk addr rargs rsrc]. An equation [vsrc >= Load chunk addr vargs]
+ is added, but only if the value of [rsrc] is known to be normalized
+ with respect to [chunk]. *)
+
+Definition store_normalized_range (chunk: memory_chunk) : aval :=
match chunk with
- | Mint32 | Mint64 | Mfloat64 | Mfloat64al32 => add_rhs n2 rsrc (Load chunk addr vargs)
- | _ => n2
+ | Mint8signed => Sgn 8
+ | Mint8unsigned => Uns 8
+ | Mint16signed => Sgn 16
+ | Mint16unsigned => Uns 16
+ | Mfloat32 => Fsingle
+ | _ => Vtop
end.
-(** [reg_valnum n vn] returns a register that is mapped to value number
- [vn], or [None] if no such register exists. *)
-
-Definition reg_valnum (n: numbering) (vn: valnum) : option reg :=
- match PMap.get vn n.(num_val) with
- | nil => None
- | r :: rs => Some r
+Definition add_store_result (app: VA.t) (n: numbering) (chunk: memory_chunk) (addr: addressing)
+ (rargs: list reg) (rsrc: reg) :=
+ if vincl (avalue app rsrc) (store_normalized_range chunk) then
+ let (n1, vsrc) := valnum_reg n rsrc in
+ let (n2, vargs) := valnum_regs n1 rargs in
+ {| num_next := n2.(num_next);
+ num_eqs := Eq vsrc false (Load chunk addr vargs) :: n2.(num_eqs);
+ num_reg := n2.(num_reg);
+ num_val := n2.(num_val) |}
+ else n.
+
+(** [kill_loads_after_storebyte app n dst sz] removes all equations
+ involving loads that could be invalidated by a store of [sz] bytes
+ starting at address [dst]. Loads that are disjoint from this
+ store-bytes are preserved. Equations involving memory-dependent
+ operators are also removed. *)
+
+Definition kill_loads_after_storebytes
+ (app: VA.t) (n: numbering) (dst: reg) (sz: Z) :=
+ let p := aaddr app dst in
+ kill_equations (filter_after_store app n p sz) n.
+
+(** [add_memcpy app n1 n2 rsrc rdst sz] adds equations to [n2] that
+ represent the effect of a [memcpy] block copy operation of [sz] bytes
+ from the address denoted by [rsrc] to the address denoted by [rdst].
+ [n2] is the numbering returned by [kill_loads_after_storebytes]
+ and [n1] is the original numbering before the [memcpy] operation.
+ Valid equations (found in [n1]) involving loads within the source
+ area of the [memcpy] are translated as equations involving loads
+ within the destination area, and added to numbering [n2].
+ Currently, we only track [memcpy] operations between stack
+ locations, as often occur when compiling assignments between local C
+ variables of struct type. *)
+
+Definition shift_memcpy_eq (src sz delta: Z) (e: equation) :=
+ match e with
+ | Eq l strict (Load chunk (Ainstack i) _) =>
+ let i := Int.unsigned i in
+ let j := i + delta in
+ if zle src i
+ && zle (i + size_chunk chunk) (src + sz)
+ && zeq (Zmod delta (align_chunk chunk)) 0
+ && zle 0 j
+ && zle j Int.max_unsigned
+ then Some(Eq l strict (Load chunk (Ainstack (Int.repr j)) nil))
+ else None
+ | _ => None
end.
-Fixpoint regs_valnums (n: numbering) (vl: list valnum) : option (list reg) :=
- match vl with
- | nil => Some nil
- | v1 :: vs =>
- match reg_valnum n v1, regs_valnums n vs with
- | Some r1, Some rs => Some (r1 :: rs)
- | _, _ => None
+Fixpoint add_memcpy_eqs (src sz delta: Z) (eqs1 eqs2: list equation) :=
+ match eqs1 with
+ | nil => eqs2
+ | e :: eqs =>
+ match shift_memcpy_eq src sz delta e with
+ | None => add_memcpy_eqs src sz delta eqs eqs2
+ | Some e' => e' :: add_memcpy_eqs src sz delta eqs eqs2
end
end.
-(** [find_rhs] return a register that already holds the result of the given arithmetic
- operation or memory load, according to the given numbering.
- [None] is returned if no such register exists. *)
-
-Definition find_rhs (n: numbering) (rh: rhs) : option reg :=
- match find_valnum_rhs rh n.(num_eqs) with
- | None => None
- | Some vres => reg_valnum n vres
+Definition add_memcpy (app: VA.t) (n1 n2: numbering) (rsrc rdst: reg) (sz: Z) :=
+ match aaddr app rsrc, aaddr app rdst with
+ | Stk src, Stk dst =>
+ {| num_next := n2.(num_next);
+ num_eqs := add_memcpy_eqs (Int.unsigned src) sz
+ (Int.unsigned dst - Int.unsigned src)
+ n1.(num_eqs) n2.(num_eqs);
+ num_reg := n2.(num_reg);
+ num_val := n2.(num_val) |}
+ | _, _ => n2
end.
-(** Experimental: take advantage of known equations to select more efficient
+(** Take advantage of known equations to select more efficient
forms of operations, addressing modes, and conditions. *)
Section REDUCE.
@@ -336,52 +403,6 @@ End REDUCE.
(** * The static analysis *)
-(** We now define a notion of satisfiability of a numbering. This semantic
- notion plays a central role in the correctness proof (see [CSEproof]),
- but is defined here because we need it to define the ordering over
- numberings used in the static analysis.
-
- A numbering is satisfiable in a given register environment and memory
- state if there exists a valuation, mapping value numbers to actual values,
- that validates both the equations and the association of registers
- to value numbers. *)
-
-Definition equation_holds
- (valuation: valnum -> val)
- (ge: genv) (sp: val) (m: mem)
- (vres: valnum) (rh: rhs) : Prop :=
- match rh with
- | Op op vl =>
- eval_operation ge sp op (List.map valuation vl) m =
- Some (valuation vres)
- | Load chunk addr vl =>
- exists a,
- eval_addressing ge sp addr (List.map valuation vl) = Some a /\
- Mem.loadv chunk m a = Some (valuation vres)
- end.
-
-Definition numbering_holds
- (valuation: valnum -> val)
- (ge: genv) (sp: val) (rs: regset) (m: mem) (n: numbering) : Prop :=
- (forall vn rh,
- In (vn, rh) n.(num_eqs) ->
- equation_holds valuation ge sp m vn rh)
- /\ (forall r vn,
- PTree.get r n.(num_reg) = Some vn -> rs#r = valuation vn).
-
-Definition numbering_satisfiable
- (ge: genv) (sp: val) (rs: regset) (m: mem) (n: numbering) : Prop :=
- exists valuation, numbering_holds valuation ge sp rs m n.
-
-Lemma empty_numbering_satisfiable:
- forall ge sp rs m, numbering_satisfiable ge sp rs m empty_numbering.
-Proof.
- intros; red.
- exists (fun (vn: valnum) => Vundef). split; simpl; intros.
- elim H.
- rewrite PTree.gempty in H. discriminate.
-Qed.
-
(** We now equip the type [numbering] with a partial order and a greatest
element. The partial order is based on entailment: [n1] is greater
than [n2] if [n1] is satisfiable whenever [n2] is. The greatest element
@@ -390,13 +411,13 @@ Qed.
Module Numbering.
Definition t := numbering.
Definition ge (n1 n2: numbering) : Prop :=
- forall ge sp rs m,
- numbering_satisfiable ge sp rs m n2 ->
- numbering_satisfiable ge sp rs m n1.
+ forall valu ge sp rs m,
+ numbering_holds valu ge sp rs m n2 ->
+ numbering_holds valu ge sp rs m n1.
Definition top := empty_numbering.
Lemma top_ge: forall x, ge top x.
Proof.
- intros; red; intros. unfold top. apply empty_numbering_satisfiable.
+ intros; red; intros. unfold top. apply empty_numbering_holds.
Qed.
Lemma refl_ge: forall x, ge x x.
Proof.
@@ -414,8 +435,9 @@ Module Solver := BBlock_solver(Numbering).
numbering ``before''. For [Iop] and [Iload] instructions, we add
equations or reuse existing value numbers as described for
[add_op] and [add_load]. For [Istore] instructions, we forget
- all equations involving memory loads. For [Icall] instructions,
- we could simply associate a fresh, unconstrained by equations value number
+ equations involving memory loads at possibly overlapping locations,
+ then add an equation for loads from the same location stored to.
+ For [Icall] instructions, we could simply associate a fresh, unconstrained by equations value number
to the result register. However, it is often undesirable to eliminate
common subexpressions across a function call (there is a risk of
increasing too much the register pressure across the call), so we
@@ -428,13 +450,13 @@ Module Solver := BBlock_solver(Numbering).
turned into function calls ([EF_external], [EF_malloc], [EF_free]).
- Forget equations involving loads but keep equations over registers.
This is appropriate for builtins that can modify memory,
- e.g. volatile stores, or [EF_memcpy], or [EF_builtin]
+ e.g. volatile stores, or [EF_builtin]
- Keep all equations, taking advantage of the fact that neither memory
nor registers are modified. This is appropriate for annotations
and for volatile loads.
*)
-Definition transfer (f: function) (pc: node) (before: numbering) :=
+Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numbering) :=
match f.(fn_code)!pc with
| None => before
| Some i =>
@@ -446,7 +468,9 @@ Definition transfer (f: function) (pc: node) (before: numbering) :=
| Iload chunk addr args dst s =>
add_load before dst chunk addr args
| Istore chunk addr args src s =>
- add_store before chunk addr args src
+ let app := approx!!pc in
+ let n := kill_loads_after_store app before chunk addr args in
+ add_store_result app n chunk addr args src
| Icall sig ros args res s =>
empty_numbering
| Itailcall sig ros args =>
@@ -455,12 +479,19 @@ Definition transfer (f: function) (pc: node) (before: numbering) :=
match ef with
| EF_external _ _ | EF_malloc | EF_free | EF_inline_asm _ =>
empty_numbering
- | EF_vstore _ | EF_vstore_global _ _ _
- | EF_builtin _ _ | EF_memcpy _ _ =>
- add_unknown (kill_loads before) res
- | EF_vload _ | EF_vload_global _ _ _
- | EF_annot _ _ | EF_annot_val _ _ =>
- add_unknown before res
+ | EF_builtin _ _ | EF_vstore _ | EF_vstore_global _ _ _ =>
+ set_unknown (kill_all_loads before) res
+ | EF_memcpy sz al =>
+ match args with
+ | rdst :: rsrc :: nil =>
+ let app := approx!!pc in
+ let n := kill_loads_after_storebytes app before rdst sz in
+ set_unknown (add_memcpy app before n rsrc rdst sz) res
+ | _ =>
+ empty_numbering
+ end
+ | EF_vload _ | EF_vload_global _ _ _ | EF_annot _ _ | EF_annot_val _ _ =>
+ set_unknown before res
end
| Icond cond args ifso ifnot =>
before
@@ -476,8 +507,8 @@ Definition transfer (f: function) (pc: node) (before: numbering) :=
which produces sub-optimal solutions quickly. The result is
a mapping from program points to numberings. *)
-Definition analyze (f: RTL.function): option (PMap.t numbering) :=
- Solver.fixpoint (fn_code f) successors_instr (transfer f) f.(fn_entrypoint).
+Definition analyze (f: RTL.function) (approx: PMap.t VA.t): option (PMap.t numbering) :=
+ Solver.fixpoint (fn_code f) successors_instr (transfer f approx) f.(fn_entrypoint).
(** * Code transformation *)
@@ -526,25 +557,24 @@ Definition transf_instr (n: numbering) (instr: instruction) :=
Definition transf_code (approxs: PMap.t numbering) (instrs: code) : code :=
PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs.
-Definition transf_function (f: function) : res function :=
- match type_function f with
- | Error msg => Error msg
- | OK tyenv =>
- match analyze f with
- | None => Error (msg "CSE failure")
- | Some approxs =>
- OK(mkfunction
- f.(fn_sig)
- f.(fn_params)
- f.(fn_stacksize)
- (transf_code approxs f.(fn_code))
- f.(fn_entrypoint))
- end
+Definition vanalyze := ValueAnalysis.analyze.
+
+Definition transf_function (rm: romem) (f: function) : res function :=
+ let approx := vanalyze rm f in
+ match analyze f approx with
+ | None => Error (msg "CSE failure")
+ | Some approxs =>
+ OK(mkfunction
+ f.(fn_sig)
+ f.(fn_params)
+ f.(fn_stacksize)
+ (transf_code approxs f.(fn_code))
+ f.(fn_entrypoint))
end.
-Definition transf_fundef (f: fundef) : res fundef :=
- AST.transf_partial_fundef transf_function f.
+Definition transf_fundef (rm: romem) (f: fundef) : res fundef :=
+ AST.transf_partial_fundef (transf_function rm) f.
Definition transf_program (p: program) : res program :=
- transform_partial_program transf_fundef p.
+ transform_partial_program (transf_fundef (romem_for_program p)) p.
diff --git a/backend/CSEdomain.v b/backend/CSEdomain.v
new file mode 100644
index 0000000..6a75d51
--- /dev/null
+++ b/backend/CSEdomain.v
@@ -0,0 +1,147 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** The abstract domain for value numbering, used in common
+ subexpression elimination. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Values.
+Require Import Memory.
+Require Import Op.
+Require Import Registers.
+Require Import RTL.
+
+(** Value numbers are represented by positive integers. Equations are
+ of the form [valnum = rhs] or [valnum >= rhs], where the right-hand
+ sides [rhs] are either arithmetic operations or memory loads, [=] is
+ strict equality of values, and [>=] is the "more defined than" relation
+ over values. *)
+
+Definition valnum := positive.
+
+Inductive rhs : Type :=
+ | Op: operation -> list valnum -> rhs
+ | Load: memory_chunk -> addressing -> list valnum -> rhs.
+
+Inductive equation : Type :=
+ | Eq (v: valnum) (strict: bool) (r: rhs).
+
+Definition eq_valnum: forall (x y: valnum), {x=y}+{x<>y} := peq.
+
+Definition eq_list_valnum: forall (x y: list valnum), {x=y}+{x<>y} := list_eq_dec peq.
+
+Definition eq_rhs (x y: rhs) : {x=y}+{x<>y}.
+Proof.
+ generalize chunk_eq eq_operation eq_addressing eq_valnum eq_list_valnum.
+ decide equality.
+Defined.
+
+(** A value numbering is a collection of equations between value numbers
+ plus a partial map from registers to value numbers. Additionally,
+ we maintain the next unused value number, so as to easily generate
+ fresh value numbers. We also maintain a reverse mapping from value
+ numbers to registers, redundant with the mapping from registers to
+ value numbers, in order to speed up some operations. *)
+
+Record numbering : Type := mknumbering {
+ num_next: valnum; (**r first unused value number *)
+ num_eqs: list equation; (**r valid equations *)
+ num_reg: PTree.t valnum; (**r mapping register to valnum *)
+ num_val: PMap.t (list reg) (**r reverse mapping valnum to regs containing it *)
+}.
+
+Definition empty_numbering :=
+ {| num_next := 1%positive;
+ num_eqs := nil;
+ num_reg := PTree.empty _;
+ num_val := PMap.init nil |}.
+
+(** A numbering is well formed if all value numbers mentioned are below
+ [num_next]. Moreover, the [num_val] reverse mapping must be consistent
+ with the [num_reg] direct mapping. *)
+
+Definition valnums_rhs (r: rhs): list valnum :=
+ match r with
+ | Op op vl => vl
+ | Load chunk addr vl => vl
+ end.
+
+Definition wf_rhs (next: valnum) (r: rhs) : Prop :=
+forall v, In v (valnums_rhs r) -> Plt v next.
+
+Definition wf_equation (next: valnum) (e: equation) : Prop :=
+ match e with Eq l str r => Plt l next /\ wf_rhs next r end.
+
+Record wf_numbering (n: numbering) : Prop := {
+ wf_num_eqs: forall e,
+ In e n.(num_eqs) -> wf_equation n.(num_next) e;
+ wf_num_reg: forall r v,
+ PTree.get r n.(num_reg) = Some v -> Plt v n.(num_next);
+ wf_num_val: forall r v,
+ In r (PMap.get v n.(num_val)) -> PTree.get r n.(num_reg) = Some v
+}.
+
+Hint Resolve wf_num_eqs wf_num_reg wf_num_val: cse.
+
+(** Satisfiability of numberings. A numbering holds in a concrete
+ execution state if there exists a valuation assigning values to
+ value numbers that satisfies the equations and register mapping
+ of the numbering. *)
+
+Definition valuation := valnum -> val.
+
+Inductive rhs_eval_to (valu: valuation) (ge: genv) (sp: val) (m: mem):
+ rhs -> val -> Prop :=
+ | op_eval_to: forall op vl v,
+ eval_operation ge sp op (map valu vl) m = Some v ->
+ rhs_eval_to valu ge sp m (Op op vl) v
+ | load_eval_to: forall chunk addr vl a v,
+ eval_addressing ge sp addr (map valu vl) = Some a ->
+ Mem.loadv chunk m a = Some v ->
+ rhs_eval_to valu ge sp m (Load chunk addr vl) v.
+
+Inductive equation_holds (valu: valuation) (ge: genv) (sp: val) (m: mem):
+ equation -> Prop :=
+ | eq_holds_strict: forall l r,
+ rhs_eval_to valu ge sp m r (valu l) ->
+ equation_holds valu ge sp m (Eq l true r)
+ | eq_holds_lessdef: forall l r v,
+ rhs_eval_to valu ge sp m r v -> Val.lessdef v (valu l) ->
+ equation_holds valu ge sp m (Eq l false r).
+
+Record numbering_holds (valu: valuation) (ge: genv) (sp: val)
+ (rs: regset) (m: mem) (n: numbering) : Prop := {
+ num_holds_wf:
+ wf_numbering n;
+ num_holds_eq: forall eq,
+ In eq n.(num_eqs) -> equation_holds valu ge sp m eq;
+ num_holds_reg: forall r v,
+ n.(num_reg)!r = Some v -> rs#r = valu v
+}.
+
+Hint Resolve num_holds_wf num_holds_eq num_holds_reg: cse.
+
+Lemma empty_numbering_holds:
+ forall valu ge sp rs m,
+ numbering_holds valu ge sp rs m empty_numbering.
+Proof.
+ intros; split; simpl; intros.
+- split; simpl; intros.
+ + contradiction.
+ + rewrite PTree.gempty in H; discriminate.
+ + rewrite PMap.gi in H; contradiction.
+- contradiction.
+- rewrite PTree.gempty in H; discriminate.
+Qed.
+
diff --git a/backend/CSEproof.v b/backend/CSEproof.v
index 478b6f0..6c9331a 100644
--- a/backend/CSEproof.v
+++ b/backend/CSEproof.v
@@ -16,6 +16,8 @@ Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Errors.
+Require Import Integers.
+Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Events.
@@ -24,713 +26,692 @@ Require Import Smallstep.
Require Import Op.
Require Import Registers.
Require Import RTL.
-Require Import RTLtyping.
Require Import Kildall.
+Require Import ValueDomain.
+Require Import ValueAOp.
+Require Import ValueAnalysis.
+Require Import CSEdomain.
Require Import CombineOp.
Require Import CombineOpproof.
Require Import CSE.
-(** * Semantic properties of value numberings *)
+(** * Soundness of operations over value numberings *)
-(** ** Well-formedness of numberings *)
+Remark wf_equation_incr:
+ forall next1 next2 e,
+ wf_equation next1 e -> Ple next1 next2 -> wf_equation next2 e.
+Proof.
+ unfold wf_equation; intros; destruct e. destruct H. split.
+ apply Plt_le_trans with next1; auto.
+ red; intros. apply Plt_le_trans with next1; auto. apply H1; auto.
+Qed.
-(** A numbering is well-formed if all registers mentioned in equations
- are less than the ``next'' register number given in the numbering.
- This guarantees that the next register is fresh with respect to
- the equations. *)
+(** Extensionality with respect to valuations. *)
-Definition wf_rhs (next: valnum) (rh: rhs) : Prop :=
- match rh with
- | Op op vl => forall v, In v vl -> Plt v next
- | Load chunk addr vl => forall v, In v vl -> Plt v next
- end.
+Definition valu_agree (valu1 valu2: valuation) (upto: valnum) :=
+ forall v, Plt v upto -> valu2 v = valu1 v.
-Definition wf_equation (next: valnum) (vr: valnum) (rh: rhs) : Prop :=
- Plt vr next /\ wf_rhs next rh.
+Section EXTEN.
-Inductive wf_numbering (n: numbering) : Prop :=
- wf_numbering_intro
- (EQS: forall v rh,
- In (v, rh) n.(num_eqs) -> wf_equation n.(num_next) v rh)
- (REG: forall r v,
- PTree.get r n.(num_reg) = Some v -> Plt v n.(num_next))
- (VAL: forall r v,
- In r (PMap.get v n.(num_val)) -> PTree.get r n.(num_reg) = Some v).
+Variable valu1: valuation.
+Variable upto: valnum.
+Variable valu2: valuation.
+Hypothesis AGREE: valu_agree valu1 valu2 upto.
+Variable ge: genv.
+Variable sp: val.
+Variable rs: regset.
+Variable m: mem.
-Lemma wf_empty_numbering:
- wf_numbering empty_numbering.
+Lemma valnums_val_exten:
+ forall vl,
+ (forall v, In v vl -> Plt v upto) ->
+ map valu2 vl = map valu1 vl.
Proof.
- unfold empty_numbering; split; simpl; intros.
- contradiction.
- rewrite PTree.gempty in H. congruence.
- rewrite PMap.gi in H. contradiction.
+ intros. apply list_map_exten. intros. symmetry. auto.
Qed.
-Lemma wf_rhs_increasing:
- forall next1 next2 rh,
- Ple next1 next2 ->
- wf_rhs next1 rh -> wf_rhs next2 rh.
+Lemma rhs_eval_to_exten:
+ forall r v,
+ rhs_eval_to valu1 ge sp m r v ->
+ (forall v, In v (valnums_rhs r) -> Plt v upto) ->
+ rhs_eval_to valu2 ge sp m r v.
Proof.
- intros; destruct rh; simpl; intros; apply Plt_Ple_trans with next1; auto.
+ intros. inv H; simpl in *.
+- constructor. rewrite valnums_val_exten by assumption. auto.
+- econstructor; eauto. rewrite valnums_val_exten by assumption. auto.
Qed.
-Lemma wf_equation_increasing:
- forall next1 next2 vr rh,
- Ple next1 next2 ->
- wf_equation next1 vr rh -> wf_equation next2 vr rh.
+Lemma equation_holds_exten:
+ forall e,
+ equation_holds valu1 ge sp m e ->
+ wf_equation upto e ->
+ equation_holds valu2 ge sp m e.
Proof.
- intros. destruct H0. split.
- apply Plt_Ple_trans with next1; auto.
- apply wf_rhs_increasing with next1; auto.
+ intros. destruct e. destruct H0. inv H.
+- constructor. rewrite AGREE by auto. apply rhs_eval_to_exten; auto.
+- econstructor. apply rhs_eval_to_exten; eauto. rewrite AGREE by auto. auto.
Qed.
-(** We now show that all operations over numberings
- preserve well-formedness. *)
-
-Lemma wf_valnum_reg:
- forall n r n' v,
- wf_numbering n ->
- valnum_reg n r = (n', v) ->
- wf_numbering n' /\ Plt v n'.(num_next) /\ Ple n.(num_next) n'.(num_next).
+Lemma numbering_holds_exten:
+ forall n,
+ numbering_holds valu1 ge sp rs m n ->
+ Ple n.(num_next) upto ->
+ numbering_holds valu2 ge sp rs m n.
Proof.
- intros until v. unfold valnum_reg. intros WF VREG. inversion WF.
- destruct ((num_reg n)!r) as [v'|] eqn:?.
-(* found *)
- inv VREG. split. auto. split. eauto. apply Ple_refl.
-(* not found *)
- inv VREG. split.
- split; simpl; intros.
- apply wf_equation_increasing with (num_next n). apply Ple_succ. auto.
- rewrite PTree.gsspec in H. destruct (peq r0 r).
- inv H. apply Plt_succ.
- apply Plt_trans_succ; eauto.
- rewrite PMap.gsspec in H. destruct (peq v (num_next n)).
- subst v. simpl in H. destruct H. subst r0. apply PTree.gss. contradiction.
- rewrite PTree.gso. eauto. exploit VAL; eauto. congruence.
- simpl. split. apply Plt_succ. apply Ple_succ.
+ intros. destruct H. constructor; intros.
+- auto.
+- apply equation_holds_exten. auto.
+ eapply wf_equation_incr; eauto with cse.
+- rewrite AGREE. eauto. eapply Plt_le_trans; eauto. eapply wf_num_reg; eauto.
Qed.
-Lemma wf_valnum_regs:
- forall rl n n' vl,
- wf_numbering n ->
- valnum_regs n rl = (n', vl) ->
- wf_numbering n' /\
- (forall v, In v vl -> Plt v n'.(num_next)) /\
- Ple n.(num_next) n'.(num_next).
-Proof.
- induction rl; intros.
- simpl in H0. inversion H0. subst n'; subst vl.
- simpl. intuition.
- simpl in H0.
- caseEq (valnum_reg n a). intros n1 v1 EQ1.
- caseEq (valnum_regs n1 rl). intros ns vs EQS.
- rewrite EQ1 in H0; rewrite EQS in H0; simpl in H0.
- inversion H0. subst n'; subst vl.
- generalize (wf_valnum_reg _ _ _ _ H EQ1); intros [A1 [B1 C1]].
- generalize (IHrl _ _ _ A1 EQS); intros [As [Bs Cs]].
- split. auto.
- split. simpl; intros. elim H1; intro.
- subst v. eapply Plt_Ple_trans; eauto.
- auto.
- eapply Ple_trans; eauto.
-Qed.
+End EXTEN.
-Lemma find_valnum_rhs_correct:
- forall rh vn eqs,
- find_valnum_rhs rh eqs = Some vn -> In (vn, rh) eqs.
-Proof.
- induction eqs; simpl.
- congruence.
- case a; intros v r'. case (eq_rhs rh r'); intro.
- intro. left. congruence.
- intro. right. auto.
-Qed.
+Ltac splitall := repeat (match goal with |- _ /\ _ => split end).
-Lemma find_valnum_num_correct:
- forall rh vn eqs,
- find_valnum_num vn eqs = Some rh -> In (vn, rh) eqs.
+Lemma valnum_reg_holds:
+ forall valu1 ge sp rs m n r n' v,
+ numbering_holds valu1 ge sp rs m n ->
+ valnum_reg n r = (n', v) ->
+ exists valu2,
+ numbering_holds valu2 ge sp rs m n'
+ /\ rs#r = valu2 v
+ /\ valu_agree valu1 valu2 n.(num_next)
+ /\ Plt v n'.(num_next)
+ /\ Ple n.(num_next) n'.(num_next).
Proof.
- induction eqs; simpl.
- congruence.
- destruct a as [v' r']. destruct (peq vn v'); intros.
- left. congruence.
- right. auto.
+ unfold valnum_reg; intros.
+ destruct (num_reg n)!r as [v'|] eqn:NR.
+- inv H0. exists valu1; splitall.
+ + auto.
+ + eauto with cse.
+ + red; auto.
+ + eauto with cse.
+ + apply Ple_refl.
+- inv H0; simpl.
+ set (valu2 := fun vn => if peq vn n.(num_next) then rs#r else valu1 vn).
+ assert (AG: valu_agree valu1 valu2 n.(num_next)).
+ { red; intros. unfold valu2. apply peq_false. apply Plt_ne; auto. }
+ exists valu2; splitall.
++ constructor; simpl; intros.
+* constructor; simpl; intros.
+ apply wf_equation_incr with (num_next n). eauto with cse. xomega.
+ rewrite PTree.gsspec in H0. destruct (peq r0 r).
+ inv H0; xomega.
+ apply Plt_trans_succ; eauto with cse.
+ rewrite PMap.gsspec in H0. destruct (peq v (num_next n)).
+ replace r0 with r by (simpl in H0; intuition). rewrite PTree.gss. subst; auto.
+ exploit wf_num_val; eauto with cse. intro.
+ rewrite PTree.gso by congruence. auto.
+* eapply equation_holds_exten; eauto with cse.
+* unfold valu2. rewrite PTree.gsspec in H0. destruct (peq r0 r).
+ inv H0. rewrite peq_true; auto.
+ rewrite peq_false. eauto with cse. apply Plt_ne; eauto with cse.
++ unfold valu2. rewrite peq_true; auto.
++ auto.
++ xomega.
++ xomega.
Qed.
-Remark in_remove:
- forall (A: Type) (eq: forall (x y: A), {x=y}+{x<>y}) x y l,
- In y (List.remove eq x l) <-> x <> y /\ In y l.
+Lemma valnum_regs_holds:
+ forall rl valu1 ge sp rs m n n' vl,
+ numbering_holds valu1 ge sp rs m n ->
+ valnum_regs n rl = (n', vl) ->
+ exists valu2,
+ numbering_holds valu2 ge sp rs m n'
+ /\ rs##rl = map valu2 vl
+ /\ valu_agree valu1 valu2 n.(num_next)
+ /\ (forall v, In v vl -> Plt v n'.(num_next))
+ /\ Ple n.(num_next) n'.(num_next).
Proof.
- induction l; simpl.
- tauto.
- destruct (eq x a).
- subst a. rewrite IHl. tauto.
- simpl. rewrite IHl. intuition congruence.
+ induction rl; simpl; intros.
+- inv H0. exists valu1; splitall; auto. red; auto. simpl; tauto. xomega.
+- destruct (valnum_reg n a) as [n1 v1] eqn:V1.
+ destruct (valnum_regs n1 rl) as [n2 vs] eqn:V2.
+ inv H0.
+ exploit valnum_reg_holds; eauto.
+ intros (valu2 & A & B & C & D & E).
+ exploit (IHrl valu2); eauto.
+ intros (valu3 & P & Q & R & S & T).
+ exists valu3; splitall.
+ + auto.
+ + simpl; f_equal; auto. rewrite R; auto.
+ + red; intros. transitivity (valu2 v); auto. apply R. xomega.
+ + simpl; intros. destruct H0; auto. subst v1; xomega.
+ + xomega.
Qed.
-Lemma wf_forget_reg:
- forall n rd r v,
- wf_numbering n ->
- In r (PMap.get v (forget_reg n rd)) -> r <> rd /\ PTree.get r n.(num_reg) = Some v.
+Lemma find_valnum_rhs_charact:
+ forall rh v eqs,
+ find_valnum_rhs rh eqs = Some v -> In (Eq v true rh) eqs.
Proof.
- unfold forget_reg; intros. inversion H.
- destruct ((num_reg n)!rd) as [vd|] eqn:?.
- rewrite PMap.gsspec in H0. destruct (peq v vd).
- subst vd. rewrite in_remove in H0. destruct H0. split. auto. eauto.
- split; eauto. exploit VAL; eauto. congruence.
- split; eauto. exploit VAL; eauto. congruence.
+ induction eqs; simpl; intros.
+- inv H.
+- destruct a. destruct (strict && eq_rhs rh r) eqn:T.
+ + InvBooleans. inv H. left; auto.
+ + right; eauto.
Qed.
-Lemma wf_update_reg:
- forall n rd vd r v,
- wf_numbering n ->
- In r (PMap.get v (update_reg n rd vd)) -> PTree.get r (PTree.set rd vd n.(num_reg)) = Some v.
+Lemma find_valnum_rhs'_charact:
+ forall rh v eqs,
+ find_valnum_rhs' rh eqs = Some v -> exists strict, In (Eq v strict rh) eqs.
Proof.
- unfold update_reg; intros. inversion H. rewrite PMap.gsspec in H0.
- destruct (peq v vd).
- subst v; simpl in H0. destruct H0.
- subst r. apply PTree.gss.
- exploit wf_forget_reg; eauto. intros [A B]. rewrite PTree.gso; eauto.
- exploit wf_forget_reg; eauto. intros [A B]. rewrite PTree.gso; eauto.
+ induction eqs; simpl; intros.
+- inv H.
+- destruct a. destruct (eq_rhs rh r) eqn:T.
+ + inv H. exists strict; auto.
+ + exploit IHeqs; eauto. intros [s IN]. exists s; auto.
Qed.
-Lemma wf_add_rhs:
- forall n rd rh,
- wf_numbering n ->
- wf_rhs n.(num_next) rh ->
- wf_numbering (add_rhs n rd rh).
+Lemma find_valnum_num_charact:
+ forall v r eqs, find_valnum_num v eqs = Some r -> In (Eq v true r) eqs.
Proof.
- intros. inversion H. unfold add_rhs.
- destruct (find_valnum_rhs rh n.(num_eqs)) as [vres|] eqn:?.
-(* found *)
- exploit find_valnum_rhs_correct; eauto. intros IN.
- split; simpl; intros.
- auto.
- rewrite PTree.gsspec in H1. destruct (peq r rd).
- inv H1. exploit EQS; eauto. intros [A B]. auto.
- eauto.
- eapply wf_update_reg; eauto.
-(* not found *)
- split; simpl; intros.
- destruct H1.
- inv H1. split. apply Plt_succ. apply wf_rhs_increasing with n.(num_next). apply Ple_succ. auto.
- apply wf_equation_increasing with n.(num_next). apply Ple_succ. auto.
- rewrite PTree.gsspec in H1. destruct (peq r rd).
- inv H1. apply Plt_succ.
- apply Plt_trans_succ. eauto.
- eapply wf_update_reg; eauto.
+ induction eqs; simpl; intros.
+- inv H.
+- destruct a. destruct (strict && peq v v0) eqn:T.
+ + InvBooleans. inv H. auto.
+ + eauto.
Qed.
-Lemma wf_add_op:
- forall n rd op rs,
- wf_numbering n ->
- wf_numbering (add_op n rd op rs).
+Lemma reg_valnum_sound:
+ forall n v r valu ge sp rs m,
+ reg_valnum n v = Some r ->
+ numbering_holds valu ge sp rs m n ->
+ rs#r = valu v.
Proof.
- intros. unfold add_op. destruct (is_move_operation op rs) as [r|] eqn:?.
-(* move *)
- destruct (valnum_reg n r) as [n' v] eqn:?.
- exploit wf_valnum_reg; eauto. intros [A [B C]]. inversion A.
- constructor; simpl; intros.
- eauto.
- rewrite PTree.gsspec in H0. destruct (peq r0 rd). inv H0. auto. eauto.
- eapply wf_update_reg; eauto.
-(* not a move *)
- destruct (valnum_regs n rs) as [n' vs] eqn:?.
- exploit wf_valnum_regs; eauto. intros [A [B C]].
- eapply wf_add_rhs; eauto.
+ unfold reg_valnum; intros. destruct (num_val n)#v as [ | r1 rl] eqn:E; inv H.
+ eapply num_holds_reg; eauto. eapply wf_num_val; eauto with cse.
+ rewrite E; auto with coqlib.
Qed.
-Lemma wf_add_load:
- forall n rd chunk addr rs,
- wf_numbering n ->
- wf_numbering (add_load n rd chunk addr rs).
+Lemma regs_valnums_sound:
+ forall n valu ge sp rs m,
+ numbering_holds valu ge sp rs m n ->
+ forall vl rl,
+ regs_valnums n vl = Some rl ->
+ rs##rl = map valu vl.
Proof.
- intros. unfold add_load.
- caseEq (valnum_regs n rs). intros n' vl EQ.
- generalize (wf_valnum_regs _ _ _ _ H EQ). intros [A [B C]].
- apply wf_add_rhs; auto.
+ induction vl; simpl; intros.
+- inv H0; auto.
+- destruct (reg_valnum n a) as [r1|] eqn:RV1; try discriminate.
+ destruct (regs_valnums n vl) as [rl1|] eqn:RVL; inv H0.
+ simpl; f_equal. eapply reg_valnum_sound; eauto. eauto.
Qed.
-Lemma wf_add_unknown:
- forall n rd,
- wf_numbering n ->
- wf_numbering (add_unknown n rd).
+Lemma find_rhs_sound:
+ forall n rh r valu ge sp rs m,
+ find_rhs n rh = Some r ->
+ numbering_holds valu ge sp rs m n ->
+ exists v, rhs_eval_to valu ge sp m rh v /\ Val.lessdef v rs#r.
Proof.
- intros. inversion H. unfold add_unknown. constructor; simpl; intros.
- eapply wf_equation_increasing; eauto. auto with coqlib.
- rewrite PTree.gsspec in H0. destruct (peq r rd).
- inv H0. auto with coqlib.
- apply Plt_trans_succ; eauto.
- exploit wf_forget_reg; eauto. intros [A B]. rewrite PTree.gso; eauto.
+ unfold find_rhs; intros. destruct (find_valnum_rhs' rh (num_eqs n)) as [vres|] eqn:E; try discriminate.
+ exploit find_valnum_rhs'_charact; eauto. intros [strict IN].
+ erewrite reg_valnum_sound by eauto.
+ exploit num_holds_eq; eauto. intros EH. inv EH.
+- exists (valu vres); auto.
+- exists v; auto.
Qed.
-Remark kill_eqs_in:
- forall pred v rhs eqs,
- In (v, rhs) (kill_eqs pred eqs) -> In (v, rhs) eqs /\ pred rhs = false.
+Remark in_remove:
+ forall (A: Type) (eq: forall (x y: A), {x=y}+{x<>y}) x y l,
+ In y (List.remove eq x l) <-> x <> y /\ In y l.
Proof.
- induction eqs; simpl; intros.
+ induction l; simpl.
tauto.
- destruct (pred (snd a)) eqn:?.
- exploit IHeqs; eauto. tauto.
- simpl in H; destruct H. subst a. auto. exploit IHeqs; eauto. tauto.
-Qed.
-
-Lemma wf_kill_equations:
- forall pred n, wf_numbering n -> wf_numbering (kill_equations pred n).
-Proof.
- intros. inversion H. unfold kill_equations; split; simpl; intros.
- exploit kill_eqs_in; eauto. intros [A B]. auto.
- eauto.
- eauto.
-Qed.
-
-Lemma wf_add_store:
- forall n chunk addr rargs rsrc,
- wf_numbering n -> wf_numbering (add_store n chunk addr rargs rsrc).
-Proof.
- intros. unfold add_store.
- destruct (valnum_regs n rargs) as [n1 vargs] eqn:?.
- exploit wf_valnum_regs; eauto. intros [A [B C]].
- assert (wf_numbering (kill_equations (filter_after_store chunk addr vargs) n1)).
- apply wf_kill_equations. auto.
- destruct chunk; auto; apply wf_add_rhs; auto.
+ destruct (eq x a).
+ subst a. rewrite IHl. tauto.
+ simpl. rewrite IHl. intuition congruence.
Qed.
-Lemma wf_transfer:
- forall f pc n, wf_numbering n -> wf_numbering (transfer f pc n).
+Lemma forget_reg_charact:
+ forall n rd r v,
+ wf_numbering n ->
+ In r (PMap.get v (forget_reg n rd)) -> r <> rd /\ In r (PMap.get v n.(num_val)).
Proof.
- intros. unfold transfer.
- destruct (f.(fn_code)!pc); auto.
- destruct i; auto.
- apply wf_add_op; auto.
- apply wf_add_load; auto.
- apply wf_add_store; auto.
- apply wf_empty_numbering.
- apply wf_empty_numbering.
- destruct e; (apply wf_empty_numbering ||
- apply wf_add_unknown; auto; apply wf_kill_equations; auto).
-Qed.
-
-(** As a consequence, the numberings computed by the static analysis
- are well formed. *)
-
-Theorem wf_analyze:
- forall f approx pc, analyze f = Some approx -> wf_numbering approx!!pc.
+ unfold forget_reg; intros.
+ destruct (PTree.get rd n.(num_reg)) as [vd|] eqn:GET.
+- rewrite PMap.gsspec in H0. destruct (peq v vd).
+ + subst v. rewrite in_remove in H0. intuition.
+ + split; auto. exploit wf_num_val; eauto. congruence.
+- split; auto. exploit wf_num_val; eauto. congruence.
+Qed.
+
+Lemma update_reg_charact:
+ forall n rd vd r v,
+ wf_numbering n ->
+ In r (PMap.get v (update_reg n rd vd)) ->
+ PTree.get r (PTree.set rd vd n.(num_reg)) = Some v.
Proof.
- unfold analyze; intros.
- eapply Solver.fixpoint_invariant with (P := wf_numbering); eauto.
- exact wf_empty_numbering.
- intros. eapply wf_transfer; eauto.
+ unfold update_reg; intros.
+ rewrite PMap.gsspec in H0.
+ destruct (peq v vd).
+- subst v. destruct H0.
++ subst r. apply PTree.gss.
++ exploit forget_reg_charact; eauto. intros [A B].
+ rewrite PTree.gso by auto. eapply wf_num_val; eauto.
+- exploit forget_reg_charact; eauto. intros [A B].
+ rewrite PTree.gso by auto. eapply wf_num_val; eauto.
Qed.
-(** ** Properties of satisfiability of numberings *)
-
-Module ValnumEq.
- Definition t := valnum.
- Definition eq := peq.
-End ValnumEq.
-
-Module VMap := EMap(ValnumEq).
-
-Section SATISFIABILITY.
-
-Variable ge: genv.
-Variable sp: val.
-
-(** Agremment between two mappings from value numbers to values
- up to a given value number. *)
-
-Definition valu_agree (valu1 valu2: valnum -> val) (upto: valnum) : Prop :=
- forall v, Plt v upto -> valu2 v = valu1 v.
-
-Lemma valu_agree_refl:
- forall valu upto, valu_agree valu valu upto.
+Lemma rhs_eval_to_inj:
+ forall valu ge sp m rh v1 v2,
+ rhs_eval_to valu ge sp m rh v1 -> rhs_eval_to valu ge sp m rh v2 -> v1 = v2.
Proof.
- intros; red; auto.
+ intros. inv H; inv H0; congruence.
Qed.
-Lemma valu_agree_trans:
- forall valu1 valu2 valu3 upto12 upto23,
- valu_agree valu1 valu2 upto12 ->
- valu_agree valu2 valu3 upto23 ->
- Ple upto12 upto23 ->
- valu_agree valu1 valu3 upto12.
+Lemma add_rhs_holds:
+ forall valu1 ge sp rs m n rd rh rs',
+ numbering_holds valu1 ge sp rs m n ->
+ rhs_eval_to valu1 ge sp m rh (rs'#rd) ->
+ wf_rhs n.(num_next) rh ->
+ (forall r, r <> rd -> rs'#r = rs#r) ->
+ exists valu2, numbering_holds valu2 ge sp rs' m (add_rhs n rd rh).
Proof.
- intros; red; intros. transitivity (valu2 v).
- apply H0. apply Plt_Ple_trans with upto12; auto.
- apply H; auto.
-Qed.
+ unfold add_rhs; intros.
+ destruct (find_valnum_rhs rh n.(num_eqs)) as [vres|] eqn:FIND.
+
+- (* A value number exists already *)
+ exploit find_valnum_rhs_charact; eauto. intros IN.
+ exploit wf_num_eqs; eauto with cse. intros [A B].
+ exploit num_holds_eq; eauto. intros EH. inv EH.
+ assert (rs'#rd = valu1 vres) by (eapply rhs_eval_to_inj; eauto).
+ exists valu1; constructor; simpl; intros.
++ constructor; simpl; intros.
+ * eauto with cse.
+ * rewrite PTree.gsspec in H5. destruct (peq r rd).
+ inv H5. auto.
+ eauto with cse.
+ * eapply update_reg_charact; eauto with cse.
++ eauto with cse.
++ rewrite PTree.gsspec in H5. destruct (peq r rd).
+ congruence.
+ rewrite H2 by auto. eauto with cse.
-Lemma valu_agree_list:
- forall valu1 valu2 upto vl,
- valu_agree valu1 valu2 upto ->
- (forall v, In v vl -> Plt v upto) ->
- map valu2 vl = map valu1 vl.
-Proof.
- intros. apply list_map_exten. intros. symmetry. apply H. auto.
+- (* Assigning a new value number *)
+ set (valu2 := fun v => if peq v n.(num_next) then rs'#rd else valu1 v).
+ assert (AG: valu_agree valu1 valu2 n.(num_next)).
+ { red; intros. unfold valu2. apply peq_false. apply Plt_ne; auto. }
+ exists valu2; constructor; simpl; intros.
++ constructor; simpl; intros.
+ * destruct H3. inv H3. simpl; split. xomega.
+ red; intros. apply Plt_trans_succ; eauto.
+ apply wf_equation_incr with (num_next n). eauto with cse. xomega.
+ * rewrite PTree.gsspec in H3. destruct (peq r rd).
+ inv H3. xomega.
+ apply Plt_trans_succ; eauto with cse.
+ * apply update_reg_charact; eauto with cse.
++ destruct H3. inv H3.
+ constructor. unfold valu2 at 2; rewrite peq_true.
+ eapply rhs_eval_to_exten; eauto.
+ eapply equation_holds_exten; eauto with cse.
++ rewrite PTree.gsspec in H3. unfold valu2. destruct (peq r rd).
+ inv H3. rewrite peq_true; auto.
+ rewrite peq_false. rewrite H2 by auto. eauto with cse.
+ apply Plt_ne; eauto with cse.
Qed.
-(** The [numbering_holds] predicate (defined in file [CSE]) is
- extensional with respect to [valu_agree]. *)
-
-Lemma numbering_holds_exten:
- forall valu1 valu2 n rs m,
- valu_agree valu1 valu2 n.(num_next) ->
- wf_numbering n ->
+Lemma add_op_holds:
+ forall valu1 ge sp rs m n op (args: list reg) v dst,
numbering_holds valu1 ge sp rs m n ->
- numbering_holds valu2 ge sp rs m n.
+ eval_operation ge sp op rs##args m = Some v ->
+ exists valu2, numbering_holds valu2 ge sp (rs#dst <- v) m (add_op n dst op args).
Proof.
- intros. inversion H0. inversion H1. split; intros.
- exploit EQS; eauto. intros [A B]. red in B.
- generalize (H2 _ _ H4).
- unfold equation_holds; destruct rh.
- rewrite (valu_agree_list valu1 valu2 n.(num_next)).
- rewrite H. auto. auto. auto. auto.
- rewrite (valu_agree_list valu1 valu2 n.(num_next)).
- rewrite H. auto. auto. auto. auto.
- rewrite H. auto. eauto.
+ unfold add_op; intros.
+ destruct (is_move_operation op args) as [src|] eqn:ISMOVE.
+- (* special case for moves *)
+ exploit is_move_operation_correct; eauto. intros [A B]; subst op args.
+ simpl in H0. inv H0.
+ destruct (valnum_reg n src) as [n1 vsrc] eqn:VN.
+ exploit valnum_reg_holds; eauto.
+ intros (valu2 & A & B & C & D & E).
+ exists valu2; constructor; simpl; intros.
++ constructor; simpl; intros; eauto with cse.
+ * rewrite PTree.gsspec in H0. destruct (peq r dst).
+ inv H0. auto.
+ eauto with cse.
+ * eapply update_reg_charact; eauto with cse.
++ eauto with cse.
++ rewrite PTree.gsspec in H0. rewrite Regmap.gsspec.
+ destruct (peq r dst). congruence. eauto with cse.
+
+- (* general case *)
+ destruct (valnum_regs n args) as [n1 vl] eqn:VN.
+ exploit valnum_regs_holds; eauto.
+ intros (valu2 & A & B & C & D & E).
+ eapply add_rhs_holds; eauto.
++ constructor. rewrite Regmap.gss. congruence.
++ intros. apply Regmap.gso; auto.
Qed.
-(** [valnum_reg] and [valnum_regs] preserve the [numbering_holds] predicate.
- Moreover, it is always the case that the returned value number has
- the value of the given register in the final assignment of values to
- value numbers. *)
-
-Lemma valnum_reg_holds:
- forall valu1 rs n r n' v m,
- wf_numbering n ->
+Lemma add_load_holds:
+ forall valu1 ge sp rs m n addr (args: list reg) a chunk v dst,
numbering_holds valu1 ge sp rs m n ->
- valnum_reg n r = (n', v) ->
- exists valu2,
- numbering_holds valu2 ge sp rs m n' /\
- valu2 v = rs#r /\
- valu_agree valu1 valu2 n.(num_next).
+ eval_addressing ge sp addr rs##args = Some a ->
+ Mem.loadv chunk m a = Some v ->
+ exists valu2, numbering_holds valu2 ge sp (rs#dst <- v) m (add_load n dst chunk addr args).
Proof.
- intros until v. unfold valnum_reg.
- caseEq (n.(num_reg)!r).
- (* Register already has a value number *)
- intros. inversion H2. subst n'; subst v0.
- inversion H1.
- exists valu1. split. auto.
- split. symmetry. auto.
- apply valu_agree_refl.
- (* Register gets a fresh value number *)
- intros. inversion H2. subst n'. subst v. inversion H1.
- set (valu2 := VMap.set n.(num_next) rs#r valu1).
- assert (AG: valu_agree valu1 valu2 n.(num_next)).
- red; intros. unfold valu2. apply VMap.gso.
- auto with coqlib.
- destruct (numbering_holds_exten _ _ _ _ _ AG H0 H1) as [A B].
- exists valu2.
- split. split; simpl; intros. auto.
- unfold valu2, VMap.set, ValnumEq.eq.
- rewrite PTree.gsspec in H5. destruct (peq r0 r).
- inv H5. rewrite peq_true. auto.
- rewrite peq_false. auto.
- assert (Plt vn (num_next n)). inv H0. eauto.
- red; intros; subst; eapply Plt_strict; eauto.
- split. unfold valu2. rewrite VMap.gss. auto.
- auto.
+ unfold add_load; intros.
+ destruct (valnum_regs n args) as [n1 vl] eqn:VN.
+ exploit valnum_regs_holds; eauto.
+ intros (valu2 & A & B & C & D & E).
+ eapply add_rhs_holds; eauto.
++ econstructor. rewrite <- B; eauto. rewrite Regmap.gss; auto.
++ intros. apply Regmap.gso; auto.
Qed.
-Lemma valnum_regs_holds:
- forall rs rl valu1 n n' vl m,
- wf_numbering n ->
- numbering_holds valu1 ge sp rs m n ->
- valnum_regs n rl = (n', vl) ->
- exists valu2,
- numbering_holds valu2 ge sp rs m n' /\
- List.map valu2 vl = rs##rl /\
- valu_agree valu1 valu2 n.(num_next).
+Lemma set_unknown_holds:
+ forall valu ge sp rs m n r v,
+ numbering_holds valu ge sp rs m n ->
+ numbering_holds valu ge sp (rs#r <- v) m (set_unknown n r).
Proof.
- induction rl; simpl; intros.
- (* base case *)
- inversion H1; subst n'; subst vl.
- exists valu1. split. auto. split. auto. apply valu_agree_refl.
- (* inductive case *)
- caseEq (valnum_reg n a); intros n1 v1 EQ1.
- caseEq (valnum_regs n1 rl); intros ns vs EQs.
- rewrite EQ1 in H1; rewrite EQs in H1. inversion H1. subst vl; subst n'.
- generalize (valnum_reg_holds _ _ _ _ _ _ _ H H0 EQ1).
- intros [valu2 [A [B C]]].
- generalize (wf_valnum_reg _ _ _ _ H EQ1). intros [D [E F]].
- generalize (IHrl _ _ _ _ _ D A EQs).
- intros [valu3 [P [Q R]]].
- exists valu3.
- split. auto.
- split. simpl. rewrite R. congruence. auto.
- eapply valu_agree_trans; eauto.
+ intros; constructor; simpl; intros.
+- constructor; simpl; intros.
+ + eauto with cse.
+ + rewrite PTree.grspec in H0. destruct (PTree.elt_eq r0 r).
+ discriminate.
+ eauto with cse.
+ + exploit forget_reg_charact; eauto with cse. intros [A B].
+ rewrite PTree.gro; eauto with cse.
+- eauto with cse.
+- rewrite PTree.grspec in H0. destruct (PTree.elt_eq r0 r).
+ discriminate.
+ rewrite Regmap.gso; eauto with cse.
Qed.
-(** A reformulation of the [equation_holds] predicate in terms
- of the value to which a right-hand side of an equation evaluates. *)
-
-Definition rhs_evals_to
- (valu: valnum -> val) (rh: rhs) (m: mem) (v: val) : Prop :=
- match rh with
- | Op op vl =>
- eval_operation ge sp op (List.map valu vl) m = Some v
- | Load chunk addr vl =>
- exists a,
- eval_addressing ge sp addr (List.map valu vl) = Some a /\
- Mem.loadv chunk m a = Some v
- end.
-
-Lemma equation_evals_to_holds_1:
- forall valu rh v vres m,
- rhs_evals_to valu rh m v ->
- equation_holds valu ge sp m vres rh ->
- valu vres = v.
+Lemma kill_eqs_charact:
+ forall pred l strict r eqs,
+ In (Eq l strict r) (kill_eqs pred eqs) ->
+ pred r = false /\ In (Eq l strict r) eqs.
Proof.
- intros until m. unfold rhs_evals_to, equation_holds.
- destruct rh. congruence.
- intros [a1 [A1 B1]] [a2 [A2 B2]]. congruence.
+ induction eqs; simpl; intros.
+- tauto.
+- destruct a. destruct (pred r0) eqn:PRED.
+ tauto.
+ inv H. inv H0. auto. tauto.
Qed.
-Lemma equation_evals_to_holds_2:
- forall valu rh v vres m,
- wf_rhs vres rh ->
- rhs_evals_to valu rh m v ->
- equation_holds (VMap.set vres v valu) ge sp m vres rh.
+Lemma kill_equations_hold:
+ forall valu ge sp rs m n pred m',
+ numbering_holds valu ge sp rs m n ->
+ (forall r v,
+ pred r = false ->
+ rhs_eval_to valu ge sp m r v ->
+ rhs_eval_to valu ge sp m' r v) ->
+ numbering_holds valu ge sp rs m' (kill_equations pred n).
Proof.
- intros until m. unfold wf_rhs, rhs_evals_to, equation_holds.
- rewrite VMap.gss.
- assert (forall vl: list valnum,
- (forall v, In v vl -> Plt v vres) ->
- map (VMap.set vres v valu) vl = map valu vl).
- intros. apply list_map_exten. intros.
- symmetry. apply VMap.gso. apply Plt_ne. auto.
- destruct rh; intros; rewrite H; auto.
+ intros; constructor; simpl; intros.
+- constructor; simpl; intros; eauto with cse.
+ destruct e. exploit kill_eqs_charact; eauto. intros [A B]. eauto with cse.
+- destruct eq. exploit kill_eqs_charact; eauto. intros [A B].
+ exploit num_holds_eq; eauto. intro EH; inv EH; econstructor; eauto.
+- eauto with cse.
Qed.
-(** The numbering obtained by adding an equation [rd = rhs] is satisfiable
- in a concrete register set where [rd] is set to the value of [rhs]. *)
-
-Lemma add_rhs_satisfiable_gen:
- forall n rh valu1 rs rd rs' m,
- wf_numbering n ->
- wf_rhs n.(num_next) rh ->
- numbering_holds valu1 ge sp rs m n ->
- rhs_evals_to valu1 rh m (rs'#rd) ->
- (forall r, r <> rd -> rs'#r = rs#r) ->
- numbering_satisfiable ge sp rs' m (add_rhs n rd rh).
+Lemma kill_all_loads_hold:
+ forall valu ge sp rs m n m',
+ numbering_holds valu ge sp rs m n ->
+ numbering_holds valu ge sp rs m' (kill_all_loads n).
Proof.
- intros. unfold add_rhs.
- caseEq (find_valnum_rhs rh n.(num_eqs)).
- (* RHS found *)
- intros vres FINDVN. inversion H1.
- exists valu1. split; simpl; intros.
- auto.
- rewrite PTree.gsspec in H6.
- destruct (peq r rd).
- inv H6.
- symmetry. eapply equation_evals_to_holds_1; eauto.
- apply H4. apply find_valnum_rhs_correct. congruence.
- rewrite H3; auto.
- (* RHS not found *)
- intro FINDVN.
- set (valu2 := VMap.set n.(num_next) (rs'#rd) valu1).
- assert (AG: valu_agree valu1 valu2 n.(num_next)).
- red; intros. unfold valu2. apply VMap.gso.
- auto with coqlib.
- elim (numbering_holds_exten _ _ _ _ _ AG H H1); intros.
- exists valu2. split; simpl; intros.
- destruct H6.
- inv H6. unfold valu2. eapply equation_evals_to_holds_2; eauto. auto.
- rewrite PTree.gsspec in H6. destruct (peq r rd).
- unfold valu2. inv H6. rewrite VMap.gss. auto.
- rewrite H3; auto.
+ intros. eapply kill_equations_hold; eauto.
+ unfold filter_loads; intros. inv H1.
+ constructor. rewrite <- H2. apply op_depends_on_memory_correct; auto.
+ discriminate.
Qed.
-Lemma add_rhs_satisfiable:
- forall n rh valu1 rs rd v m,
- wf_numbering n ->
- wf_rhs n.(num_next) rh ->
- numbering_holds valu1 ge sp rs m n ->
- rhs_evals_to valu1 rh m v ->
- numbering_satisfiable ge sp (rs#rd <- v) m (add_rhs n rd rh).
+Lemma kill_loads_after_store_holds:
+ forall valu ge sp rs m n addr args a chunk v m' bc approx ae am,
+ numbering_holds valu ge (Vptr sp Int.zero) rs m n ->
+ eval_addressing ge (Vptr sp Int.zero) addr rs##args = Some a ->
+ Mem.storev chunk m a v = Some m' ->
+ genv_match bc ge ->
+ bc sp = BCstack ->
+ ematch bc rs ae ->
+ approx = VA.State ae am ->
+ numbering_holds valu ge (Vptr sp Int.zero) rs m'
+ (kill_loads_after_store approx n chunk addr args).
Proof.
- intros. eapply add_rhs_satisfiable_gen; eauto.
- rewrite Regmap.gss; auto.
- intros. apply Regmap.gso; auto.
+ intros. apply kill_equations_hold with m; auto.
+ intros. unfold filter_after_store in H6; inv H7.
+- constructor. rewrite <- H8. apply op_depends_on_memory_correct; auto.
+- destruct (regs_valnums n vl) as [rl|] eqn:RV; try discriminate.
+ econstructor; eauto. rewrite <- H9.
+ destruct a; simpl in H1; try discriminate.
+ destruct a0; simpl in H9; try discriminate.
+ simpl.
+ rewrite negb_false_iff in H6. unfold aaddressing in H6.
+ eapply Mem.load_store_other. eauto.
+ eapply pdisjoint_sound. eauto.
+ apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto.
+ erewrite <- regs_valnums_sound by eauto. eauto with va.
+ apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto with va.
Qed.
-(** [add_op] returns a numbering that is satisfiable in the register
- set after execution of the corresponding [Iop] instruction. *)
-
-Lemma add_op_satisfiable:
- forall n rs op args dst v m,
- wf_numbering n ->
- numbering_satisfiable ge sp rs m n ->
- eval_operation ge sp op rs##args m = Some v ->
- numbering_satisfiable ge sp (rs#dst <- v) m (add_op n dst op args).
+Lemma store_normalized_range_sound:
+ forall bc chunk v,
+ vmatch bc v (store_normalized_range chunk) ->
+ Val.lessdef (Val.load_result chunk v) v.
Proof.
- intros. inversion H0.
- unfold add_op.
- caseEq (@is_move_operation reg op args).
- intros arg EQ.
- destruct (is_move_operation_correct _ _ EQ) as [A B]. subst op args.
- caseEq (valnum_reg n arg). intros n1 v1 VL.
- generalize (valnum_reg_holds _ _ _ _ _ _ _ H H2 VL). intros [valu2 [A [B C]]].
- generalize (wf_valnum_reg _ _ _ _ H VL). intros [D [E F]].
- elim A; intros. exists valu2; split; simpl; intros.
- auto. rewrite Regmap.gsspec. rewrite PTree.gsspec in H5.
- destruct (peq r dst). simpl in H1. congruence. auto.
- intro NEQ. caseEq (valnum_regs n args). intros n1 vl VRL.
- generalize (valnum_regs_holds _ _ _ _ _ _ _ H H2 VRL). intros [valu2 [A [B C]]].
- generalize (wf_valnum_regs _ _ _ _ H VRL). intros [D [E F]].
- apply add_rhs_satisfiable with valu2; auto.
- simpl. congruence.
+ intros. destruct chunk; simpl in *; destruct v; auto.
+- inv H. rewrite is_sgn_sign_ext in H3 by omega. rewrite H3; auto.
+- inv H. rewrite is_uns_zero_ext in H3 by omega. rewrite H3; auto.
+- inv H. rewrite is_sgn_sign_ext in H3 by omega. rewrite H3; auto.
+- inv H. rewrite is_uns_zero_ext in H3 by omega. rewrite H3; auto.
+- inv H. rewrite Float.singleoffloat_of_single by auto. auto.
Qed.
-(** [add_load] returns a numbering that is satisfiable in the register
- set after execution of the corresponding [Iload] instruction. *)
-
-Lemma add_load_satisfiable:
- forall n rs chunk addr args dst a v m,
- wf_numbering n ->
- numbering_satisfiable ge sp rs m n ->
+Lemma add_store_result_hold:
+ forall valu1 ge sp rs m' n addr args a chunk m src bc ae approx am,
+ numbering_holds valu1 ge sp rs m' n ->
eval_addressing ge sp addr rs##args = Some a ->
- Mem.loadv chunk m a = Some v ->
- numbering_satisfiable ge sp (rs#dst <- v) m (add_load n dst chunk addr args).
+ Mem.storev chunk m a rs#src = Some m' ->
+ ematch bc rs ae ->
+ approx = VA.State ae am ->
+ exists valu2, numbering_holds valu2 ge sp rs m' (add_store_result approx n chunk addr args src).
Proof.
- intros. inversion H0.
- unfold add_load.
- caseEq (valnum_regs n args). intros n1 vl VRL.
- generalize (valnum_regs_holds _ _ _ _ _ _ _ H H3 VRL). intros [valu2 [A [B C]]].
- generalize (wf_valnum_regs _ _ _ _ H VRL). intros [D [E F]].
- apply add_rhs_satisfiable with valu2; auto.
- simpl. exists a; split; congruence.
+ unfold add_store_result; intros.
+ unfold avalue; rewrite H3.
+ destruct (vincl (AE.get src ae) (store_normalized_range chunk)) eqn:INCL.
+- destruct (valnum_reg n src) as [n1 vsrc] eqn:VR1.
+ destruct (valnum_regs n1 args) as [n2 vargs] eqn:VR2.
+ exploit valnum_reg_holds; eauto. intros (valu2 & A & B & C & D & E).
+ exploit valnum_regs_holds; eauto. intros (valu3 & P & Q & R & S & T).
+ exists valu3. constructor; simpl; intros.
++ constructor; simpl; intros; eauto with cse.
+ destruct H4; eauto with cse. subst e. split.
+ eapply Plt_le_trans; eauto.
+ red; simpl; intros. auto.
++ destruct H4; eauto with cse. subst eq. apply eq_holds_lessdef with (Val.load_result chunk rs#src).
+ apply load_eval_to with a. rewrite <- Q; auto.
+ destruct a; try discriminate. simpl. eapply Mem.load_store_same; eauto.
+ rewrite B. rewrite R by auto. apply store_normalized_range_sound with bc.
+ rewrite <- B. eapply vmatch_ge. apply vincl_ge; eauto. apply H2.
++ eauto with cse.
+
+- exists valu1; auto.
Qed.
-(** [add_unknown] returns a numbering that is satisfiable in the
- register set after setting the target register to any value. *)
-
-Lemma add_unknown_satisfiable:
- forall n rs dst v m,
- wf_numbering n ->
- numbering_satisfiable ge sp rs m n ->
- numbering_satisfiable ge sp (rs#dst <- v) m (add_unknown n dst).
+Lemma kill_loads_after_storebytes_holds:
+ forall valu ge sp rs m n dst b ofs bytes m' bc approx ae am sz,
+ numbering_holds valu ge (Vptr sp Int.zero) rs m n ->
+ rs#dst = Vptr b ofs ->
+ Mem.storebytes m b (Int.unsigned ofs) bytes = Some m' ->
+ genv_match bc ge ->
+ bc sp = BCstack ->
+ ematch bc rs ae ->
+ approx = VA.State ae am ->
+ length bytes = nat_of_Z sz -> sz >= 0 ->
+ numbering_holds valu ge (Vptr sp Int.zero) rs m'
+ (kill_loads_after_storebytes approx n dst sz).
Proof.
- intros. destruct H0 as [valu A].
- set (valu' := VMap.set n.(num_next) v valu).
- assert (numbering_holds valu' ge sp rs m n).
- eapply numbering_holds_exten; eauto.
- unfold valu'; red; intros. apply VMap.gso. auto with coqlib.
- destruct H0 as [B C].
- exists valu'; split; simpl; intros.
- eauto.
- rewrite PTree.gsspec in H0. rewrite Regmap.gsspec.
- destruct (peq r dst). inversion H0. unfold valu'. rewrite VMap.gss; auto.
- eauto.
+ intros. apply kill_equations_hold with m; auto.
+ intros. unfold filter_after_store in H8; inv H9.
+- constructor. rewrite <- H10. apply op_depends_on_memory_correct; auto.
+- destruct (regs_valnums n vl) as [rl|] eqn:RV; try discriminate.
+ econstructor; eauto. rewrite <- H11.
+ destruct a; simpl in H10; try discriminate.
+ simpl.
+ rewrite negb_false_iff in H8.
+ eapply Mem.load_storebytes_other. eauto.
+ rewrite H6. rewrite nat_of_Z_eq by auto.
+ eapply pdisjoint_sound. eauto.
+ unfold aaddressing. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto.
+ erewrite <- regs_valnums_sound by eauto. eauto with va.
+ unfold aaddr. apply match_aptr_of_aval. rewrite <- H0. apply H4.
Qed.
-(** Satisfiability of [kill_equations]. *)
-
-Lemma kill_equations_holds:
- forall pred valu n rs m m',
- (forall v r,
- equation_holds valu ge sp m v r -> pred r = false -> equation_holds valu ge sp m' v r) ->
- numbering_holds valu ge sp rs m n ->
- numbering_holds valu ge sp rs m' (kill_equations pred n).
+Lemma load_memcpy:
+ forall m b1 ofs1 sz bytes b2 ofs2 m' chunk i v,
+ Mem.loadbytes m b1 ofs1 sz = Some bytes ->
+ Mem.storebytes m b2 ofs2 bytes = Some m' ->
+ Mem.load chunk m b1 i = Some v ->
+ ofs1 <= i -> i + size_chunk chunk <= ofs1 + sz ->
+ (align_chunk chunk | ofs2 - ofs1) ->
+ Mem.load chunk m' b2 (i + (ofs2 - ofs1)) = Some v.
Proof.
- intros. destruct H0 as [A B]. red; simpl. split; intros.
- exploit kill_eqs_in; eauto. intros [C D]. eauto.
- auto.
+ intros.
+ generalize (size_chunk_pos chunk); intros SPOS.
+ set (n1 := i - ofs1).
+ set (n2 := size_chunk chunk).
+ set (n3 := sz - (n1 + n2)).
+ replace sz with (n1 + (n2 + n3)) in H by (unfold n3, n2, n1; omega).
+ exploit Mem.loadbytes_split; eauto.
+ unfold n1; omega.
+ unfold n3, n2, n1; omega.
+ intros (bytes1 & bytes23 & LB1 & LB23 & EQ).
+ clear H.
+ exploit Mem.loadbytes_split; eauto.
+ unfold n2; omega.
+ unfold n3, n2, n1; omega.
+ intros (bytes2 & bytes3 & LB2 & LB3 & EQ').
+ subst bytes23; subst bytes.
+ exploit Mem.load_loadbytes; eauto. intros (bytes2' & A & B).
+ assert (bytes2' = bytes2).
+ { replace (ofs1 + n1) with i in LB2 by (unfold n1; omega). unfold n2 in LB2. congruence. }
+ subst bytes2'.
+ exploit Mem.storebytes_split; eauto. intros (m1 & SB1 & SB23).
+ clear H0.
+ exploit Mem.storebytes_split; eauto. intros (m2 & SB2 & SB3).
+ clear SB23.
+ assert (L1: Z.of_nat (length bytes1) = n1).
+ { erewrite Mem.loadbytes_length by eauto. apply nat_of_Z_eq. unfold n1; omega. }
+ assert (L2: Z.of_nat (length bytes2) = n2).
+ { erewrite Mem.loadbytes_length by eauto. apply nat_of_Z_eq. unfold n2; omega. }
+ rewrite L1 in *. rewrite L2 in *.
+ assert (LB': Mem.loadbytes m2 b2 (ofs2 + n1) n2 = Some bytes2).
+ { rewrite <- L2. eapply Mem.loadbytes_storebytes_same; eauto. }
+ assert (LB'': Mem.loadbytes m' b2 (ofs2 + n1) n2 = Some bytes2).
+ { rewrite <- LB'. eapply Mem.loadbytes_storebytes_other; eauto.
+ unfold n2; omega.
+ right; left; omega. }
+ exploit Mem.load_valid_access; eauto. intros [P Q].
+ rewrite B. apply Mem.loadbytes_load.
+ replace (i + (ofs2 - ofs1)) with (ofs2 + n1) by (unfold n1; omega).
+ exact LB''.
+ apply Z.divide_add_r; auto.
Qed.
-(** [kill_loads] preserves satisfiability. Moreover, the resulting numbering
- is satisfiable in any concrete memory state. *)
-
-Lemma kill_loads_satisfiable:
- forall n rs m m',
- numbering_satisfiable ge sp rs m n ->
- numbering_satisfiable ge sp rs m' (kill_loads n).
-Proof.
- intros. destruct H as [valu A]. exists valu. eapply kill_equations_holds with (m := m); eauto.
- intros. destruct r; simpl in *. rewrite <- H. apply op_depends_on_memory_correct; auto.
- congruence.
+Lemma shift_memcpy_eq_wf:
+ forall src sz delta e e' next,
+ shift_memcpy_eq src sz delta e = Some e' ->
+ wf_equation next e ->
+ wf_equation next e'.
+Proof with (try discriminate).
+ unfold shift_memcpy_eq; intros.
+ destruct e. destruct r... destruct a...
+ destruct (zle src (Int.unsigned i) &&
+ zle (Int.unsigned i + size_chunk m) (src + sz) &&
+ zeq (delta mod align_chunk m) 0 && zle 0 (Int.unsigned i + delta) &&
+ zle (Int.unsigned i + delta) Int.max_unsigned)...
+ inv H. destruct H0. split. auto. red; simpl; tauto.
Qed.
-(** [add_store] returns a numbering that is satisfiable in the memory state
- after execution of the corresponding [Istore] instruction. *)
-
-Lemma add_store_satisfiable:
- forall n rs chunk addr args src a m m',
- wf_numbering n ->
- numbering_satisfiable ge sp rs m n ->
- eval_addressing ge sp addr rs##args = Some a ->
- Mem.storev chunk m a (rs#src) = Some m' ->
- Val.has_type (rs#src) (type_of_chunk_use chunk) ->
- numbering_satisfiable ge sp rs m' (add_store n chunk addr args src).
-Proof.
- intros. unfold add_store. destruct H0 as [valu A].
- destruct (valnum_regs n args) as [n1 vargs] eqn:?.
- exploit valnum_regs_holds; eauto. intros [valu' [B [C D]]].
- exploit wf_valnum_regs; eauto. intros [U [V W]].
- set (n2 := kill_equations (filter_after_store chunk addr vargs) n1).
- assert (numbering_holds valu' ge sp rs m' n2).
- apply kill_equations_holds with (m := m); auto.
- intros. destruct r; simpl in *.
- rewrite <- H0. apply op_depends_on_memory_correct; auto.
- destruct H0 as [a' [P Q]].
- destruct (eq_list_valnum vargs l); simpl in H4; try congruence. subst l.
- rewrite negb_false_iff in H4.
- exists a'; split; auto.
- destruct a; simpl in H2; try congruence.
- destruct a'; simpl in Q; try congruence.
- simpl. rewrite <- Q.
- rewrite C in P. eapply Mem.load_store_other; eauto.
- exploit addressing_separated_sound; eauto. intuition congruence.
- assert (N2: numbering_satisfiable ge sp rs m' n2).
- exists valu'; auto.
- set (n3 := add_rhs n2 src (Load chunk addr vargs)).
- assert (N3: Val.load_result chunk (rs#src) = rs#src -> numbering_satisfiable ge sp rs m' n3).
- intro EQ. unfold n3. apply add_rhs_satisfiable_gen with valu' rs.
- apply wf_kill_equations; auto.
- red. auto. auto.
- red. exists a; split. congruence.
- rewrite <- EQ. destruct a; simpl in H2; try discriminate. simpl.
- eapply Mem.load_store_same; eauto.
- auto.
- destruct chunk; auto; apply N3.
- simpl in H3. destruct (rs#src); auto || contradiction.
- simpl in H3. destruct (rs#src); auto || contradiction.
- simpl in H3. destruct (rs#src); auto || contradiction.
- simpl in H3. destruct (rs#src); auto || contradiction.
+Lemma shift_memcpy_eq_holds:
+ forall src dst sz e e' m sp bytes m' valu ge,
+ shift_memcpy_eq src sz (dst - src) e = Some e' ->
+ Mem.loadbytes m sp src sz = Some bytes ->
+ Mem.storebytes m sp dst bytes = Some m' ->
+ equation_holds valu ge (Vptr sp Int.zero) m e ->
+ equation_holds valu ge (Vptr sp Int.zero) m' e'.
+Proof with (try discriminate).
+ intros. set (delta := dst - src) in *. unfold shift_memcpy_eq in H.
+ destruct e as [l strict rhs] eqn:E.
+ destruct rhs as [op vl | chunk addr vl]...
+ destruct addr...
+ set (i1 := Int.unsigned i) in *. set (j := i1 + delta) in *.
+ destruct (zle src i1)...
+ destruct (zle (i1 + size_chunk chunk) (src + sz))...
+ destruct (zeq (delta mod align_chunk chunk) 0)...
+ destruct (zle 0 j)...
+ destruct (zle j Int.max_unsigned)...
+ simpl in H; inv H.
+ assert (LD: forall v,
+ Mem.loadv chunk m (Vptr sp i) = Some v ->
+ Mem.loadv chunk m' (Vptr sp (Int.repr j)) = Some v).
+ {
+ simpl; intros. rewrite Int.unsigned_repr by omega.
+ unfold j, delta. eapply load_memcpy; eauto.
+ apply Zmod_divide; auto. generalize (align_chunk_pos chunk); omega.
+ }
+ inv H2.
++ inv H3. destruct vl... simpl in H6. rewrite Int.add_zero_l in H6. inv H6.
+ apply eq_holds_strict. econstructor. simpl. rewrite Int.add_zero_l. eauto.
+ apply LD; auto.
++ inv H4. destruct vl... simpl in H7. rewrite Int.add_zero_l in H7. inv H7.
+ apply eq_holds_lessdef with v; auto.
+ econstructor. simpl. rewrite Int.add_zero_l. eauto. apply LD; auto.
Qed.
-(** Correctness of [reg_valnum]: if it returns a register [r],
- that register correctly maps back to the given value number. *)
-
-Lemma reg_valnum_correct:
- forall n v r, wf_numbering n -> reg_valnum n v = Some r -> n.(num_reg)!r = Some v.
+Lemma add_memcpy_eqs_charact:
+ forall e' src sz delta eqs2 eqs1,
+ In e' (add_memcpy_eqs src sz delta eqs1 eqs2) ->
+ In e' eqs2 \/ exists e, In e eqs1 /\ shift_memcpy_eq src sz delta e = Some e'.
Proof.
- unfold reg_valnum; intros. inv H.
- destruct ((num_val n)#v) as [| r1 rl] eqn:?; inv H0.
- eapply VAL. rewrite Heql. auto with coqlib.
+ induction eqs1; simpl; intros.
+- auto.
+- destruct (shift_memcpy_eq src sz delta a) as [e''|] eqn:SHIFT.
+ + destruct H. subst e''. right; exists a; auto.
+ destruct IHeqs1 as [A | [e [A B]]]; auto. right; exists e; auto.
+ + destruct IHeqs1 as [A | [e [A B]]]; auto. right; exists e; auto.
Qed.
-(** Correctness of [find_rhs]: if successful and in a
- satisfiable numbering, the returned register does contain the
- result value of the operation or memory load. *)
-
-Lemma find_rhs_correct:
- forall valu rs m n rh r,
- wf_numbering n ->
- numbering_holds valu ge sp rs m n ->
- find_rhs n rh = Some r ->
- rhs_evals_to valu rh m rs#r.
+Lemma add_memcpy_holds:
+ forall m bsrc osrc sz bytes bdst odst m' valu ge sp rs n1 n2 bc approx ae am rsrc rdst,
+ Mem.loadbytes m bsrc (Int.unsigned osrc) sz = Some bytes ->
+ Mem.storebytes m bdst (Int.unsigned odst) bytes = Some m' ->
+ numbering_holds valu ge (Vptr sp Int.zero) rs m n1 ->
+ numbering_holds valu ge (Vptr sp Int.zero) rs m' n2 ->
+ genv_match bc ge ->
+ bc sp = BCstack ->
+ ematch bc rs ae ->
+ approx = VA.State ae am ->
+ rs#rsrc = Vptr bsrc osrc ->
+ rs#rdst = Vptr bdst odst ->
+ Ple (num_next n1) (num_next n2) ->
+ numbering_holds valu ge (Vptr sp Int.zero) rs m' (add_memcpy approx n1 n2 rsrc rdst sz).
Proof.
- intros until r. intros WF NH.
- unfold find_rhs.
- caseEq (find_valnum_rhs rh n.(num_eqs)); intros.
- exploit find_valnum_rhs_correct; eauto. intros.
- exploit reg_valnum_correct; eauto. intros.
- inversion NH.
- generalize (H3 _ _ H1). rewrite (H4 _ _ H2).
- destruct rh; simpl; auto.
- discriminate.
+ intros. unfold add_memcpy.
+ destruct (aaddr approx rsrc) eqn:ASRC; auto.
+ destruct (aaddr approx rdst) eqn:ADST; auto.
+ assert (A: forall r b o i,
+ rs#r = Vptr b o -> aaddr approx r = Stk i -> b = sp /\ i = o).
+ {
+ intros until i. unfold aaddr; subst approx. intros.
+ specialize (H5 r). rewrite H6 in H5. rewrite match_aptr_of_aval in H5.
+ rewrite H10 in H5. inv H5. split; auto. eapply bc_stack; eauto.
+ }
+ exploit (A rsrc); eauto. intros [P Q].
+ exploit (A rdst); eauto. intros [U V].
+ subst bsrc ofs bdst ofs0.
+ constructor; simpl; intros; eauto with cse.
+- constructor; simpl; eauto with cse.
+ intros. exploit add_memcpy_eqs_charact; eauto. intros [X | (e0 & X & Y)].
+ eauto with cse.
+ apply wf_equation_incr with (num_next n1); auto.
+ eapply shift_memcpy_eq_wf; eauto with cse.
+- exploit add_memcpy_eqs_charact; eauto. intros [X | (e0 & X & Y)].
+ eauto with cse.
+ eapply shift_memcpy_eq_holds; eauto with cse.
Qed.
(** Correctness of operator reduction *)
@@ -740,29 +721,19 @@ Section REDUCE.
Variable A: Type.
Variable f: (valnum -> option rhs) -> A -> list valnum -> option (A * list valnum).
Variable V: Type.
+Variable ge: genv.
+Variable sp: val.
Variable rs: regset.
Variable m: mem.
Variable sem: A -> list val -> option V.
Hypothesis f_sound:
forall eqs valu op args op' args',
- (forall v rhs, eqs v = Some rhs -> equation_holds valu ge sp m v rhs) ->
+ (forall v rhs, eqs v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v)) ->
f eqs op args = Some(op', args') ->
sem op' (map valu args') = sem op (map valu args).
Variable n: numbering.
Variable valu: valnum -> val.
Hypothesis n_holds: numbering_holds valu ge sp rs m n.
-Hypothesis n_wf: wf_numbering n.
-
-Lemma regs_valnums_correct:
- forall vl rl, regs_valnums n vl = Some rl -> rs##rl = map valu vl.
-Proof.
- induction vl; simpl; intros.
- inv H. auto.
- destruct (reg_valnum n a) as [r1|] eqn:?; try discriminate.
- destruct (regs_valnums n vl) as [rx|] eqn:?; try discriminate.
- inv H. simpl; decEq; auto.
- eapply (proj2 n_holds); eauto. eapply reg_valnum_correct; eauto.
-Qed.
Lemma reduce_rec_sound:
forall niter op args op' rl' res,
@@ -776,11 +747,14 @@ Proof.
as [[op1 args1] | ] eqn:?.
assert (sem op1 (map valu args1) = Some res).
rewrite <- H0. eapply f_sound; eauto.
- simpl; intros. apply (proj1 n_holds). eapply find_valnum_num_correct; eauto.
+ simpl; intros.
+ exploit num_holds_eq; eauto.
+ eapply find_valnum_num_charact; eauto with cse.
+ intros EH; inv EH; auto.
destruct (reduce_rec A f n niter op1 args1) as [[op2 rl2] | ] eqn:?.
inv H. eapply IHniter; eauto.
destruct (regs_valnums n args1) as [rl|] eqn:?.
- inv H. erewrite regs_valnums_correct; eauto.
+ inv H. erewrite regs_valnums_sound; eauto.
discriminate.
discriminate.
Qed.
@@ -800,8 +774,6 @@ Qed.
End REDUCE.
-End SATISFIABILITY.
-
(** The numberings associated to each instruction by the static analysis
are inductively satisfiable, in the following sense: the numbering
at the function entry point is satisfiable, and for any RTL execution
@@ -809,26 +781,26 @@ End SATISFIABILITY.
satisfiability at [pc']. *)
Theorem analysis_correct_1:
- forall ge sp rs m f approx pc pc' i,
- analyze f = Some approx ->
+ forall ge sp rs m f vapprox approx pc pc' i,
+ analyze f vapprox = Some approx ->
f.(fn_code)!pc = Some i -> In pc' (successors_instr i) ->
- numbering_satisfiable ge sp rs m (transfer f pc approx!!pc) ->
- numbering_satisfiable ge sp rs m approx!!pc'.
+ (exists valu, numbering_holds valu ge sp rs m (transfer f vapprox pc approx!!pc)) ->
+ (exists valu, numbering_holds valu ge sp rs m approx!!pc').
Proof.
intros.
- assert (Numbering.ge approx!!pc' (transfer f pc approx!!pc)).
+ assert (Numbering.ge approx!!pc' (transfer f vapprox pc approx!!pc)).
eapply Solver.fixpoint_solution; eauto.
- apply H3. auto.
+ destruct H2 as [valu NH]. exists valu; apply H3. auto.
Qed.
Theorem analysis_correct_entry:
- forall ge sp rs m f approx,
- analyze f = Some approx ->
- numbering_satisfiable ge sp rs m approx!!(f.(fn_entrypoint)).
+ forall ge sp rs m f vapprox approx,
+ analyze f vapprox = Some approx ->
+ exists valu, numbering_holds valu ge sp rs m approx!!(f.(fn_entrypoint)).
Proof.
intros.
replace (approx!!(f.(fn_entrypoint))) with Solver.L.top.
- apply empty_numbering_satisfiable.
+ exists (fun v => Vundef). apply empty_numbering_holds.
symmetry. eapply Solver.fixpoint_entry; eauto.
Qed.
@@ -841,45 +813,34 @@ Variable tprog : program.
Hypothesis TRANSF: transf_program prog = OK tprog.
Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.
+Let rm := romem_for_program prog.
Lemma symbols_preserved:
forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
-Proof (Genv.find_symbol_transf_partial transf_fundef prog TRANSF).
+Proof (Genv.find_symbol_transf_partial (transf_fundef rm) prog TRANSF).
Lemma varinfo_preserved:
forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
-Proof (Genv.find_var_info_transf_partial transf_fundef prog TRANSF).
+Proof (Genv.find_var_info_transf_partial (transf_fundef rm) prog TRANSF).
Lemma functions_translated:
forall (v: val) (f: RTL.fundef),
Genv.find_funct ge v = Some f ->
- exists tf, Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf.
-Proof (Genv.find_funct_transf_partial transf_fundef prog TRANSF).
+ exists tf, Genv.find_funct tge v = Some tf /\ transf_fundef rm f = OK tf.
+Proof (Genv.find_funct_transf_partial (transf_fundef rm) prog TRANSF).
Lemma funct_ptr_translated:
forall (b: block) (f: RTL.fundef),
Genv.find_funct_ptr ge b = Some f ->
- exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf.
-Proof (Genv.find_funct_ptr_transf_partial transf_fundef prog TRANSF).
+ exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef rm f = OK tf.
+Proof (Genv.find_funct_ptr_transf_partial (transf_fundef rm) prog TRANSF).
Lemma sig_preserved:
- forall f tf, transf_fundef f = OK tf -> funsig tf = funsig f.
+ forall f tf, transf_fundef rm f = OK tf -> funsig tf = funsig f.
Proof.
unfold transf_fundef; intros. destruct f; monadInv H; auto.
- unfold transf_function in EQ. destruct (type_function f); try discriminate.
- destruct (analyze f); try discriminate. inv EQ; auto.
-Qed.
-
-Lemma find_function_translated:
- forall ros rs f,
- find_function ge ros rs = Some f ->
- exists tf, find_function tge ros rs = Some tf /\ transf_fundef f = OK tf.
-Proof.
- intros until f; destruct ros; simpl.
- intro. apply functions_translated; auto.
- rewrite symbols_preserved. destruct (Genv.find_symbol ge i); intro.
- apply funct_ptr_translated; auto.
- discriminate.
+ unfold transf_function in EQ.
+ destruct (analyze f (vanalyze rm f)); try discriminate. inv EQ; auto.
Qed.
Definition transf_function' (f: function) (approxs: PMap.t numbering) : function :=
@@ -890,6 +851,50 @@ Definition transf_function' (f: function) (approxs: PMap.t numbering) : function
(transf_code approxs f.(fn_code))
f.(fn_entrypoint).
+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 find_function_translated:
+ forall ros rs fd rs',
+ find_function ge ros rs = Some fd ->
+ regs_lessdef rs rs' ->
+ exists tfd, find_function tge ros rs' = Some tfd /\ transf_fundef rm fd = OK tfd.
+Proof.
+ unfold find_function; intros; destruct ros.
+- specialize (H0 r). inv H0.
+ apply functions_translated; auto.
+ rewrite <- H2 in H; discriminate.
+- rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
+ apply funct_ptr_translated; auto.
+ discriminate.
+Qed.
+
(** The proof of semantic preservation is a simulation argument using
diagrams of the following form:
<<
@@ -906,45 +911,44 @@ Definition transf_function' (f: function) (approxs: PMap.t numbering) : function
the numbering at [pc] (returned by the static analysis) is satisfiable.
*)
-Inductive match_stackframes: list stackframe -> list stackframe -> typ -> Prop :=
+Inductive match_stackframes: list stackframe -> list stackframe -> Prop :=
| match_stackframes_nil:
- match_stackframes nil nil Tint
+ match_stackframes nil nil
| match_stackframes_cons:
- forall res sp pc rs f approx tyenv s s' ty
- (ANALYZE: analyze f = Some approx)
- (WTF: wt_function f tyenv)
- (WTREGS: wt_regset tyenv rs)
- (TYRES: subtype ty (tyenv res) = true)
- (SAT: forall v m, numbering_satisfiable ge sp (rs#res <- v) m approx!!pc)
- (STACKS: match_stackframes s s' (proj_sig_res (fn_sig f))),
+ forall res sp pc rs f approx s rs' s'
+ (ANALYZE: analyze f (vanalyze rm f) = Some approx)
+ (SAT: forall v m, exists valu, numbering_holds valu ge sp (rs#res <- v) m approx!!pc)
+ (RLD: regs_lessdef rs rs')
+ (STACKS: match_stackframes s s'),
match_stackframes
(Stackframe res f sp pc rs :: s)
- (Stackframe res (transf_function' f approx) sp pc rs :: s')
- ty.
+ (Stackframe res (transf_function' f approx) sp pc rs' :: s').
Inductive match_states: state -> state -> Prop :=
| match_states_intro:
- forall s sp pc rs m s' f approx tyenv
- (ANALYZE: analyze f = Some approx)
- (WTF: wt_function f tyenv)
- (WTREGS: wt_regset tyenv rs)
- (SAT: numbering_satisfiable ge sp rs m approx!!pc)
- (STACKS: match_stackframes s s' (proj_sig_res (fn_sig f))),
+ forall s sp pc rs m s' rs' m' f approx
+ (ANALYZE: analyze f (vanalyze rm f) = Some approx)
+ (SAT: exists valu, numbering_holds valu ge sp rs m approx!!pc)
+ (RLD: regs_lessdef rs rs')
+ (MEXT: Mem.extends m m')
+ (STACKS: match_stackframes s s'),
match_states (State s f sp pc rs m)
- (State s' (transf_function' f approx) sp pc rs m)
+ (State s' (transf_function' f approx) sp pc rs' m')
| match_states_call:
- forall s f tf args m s',
- match_stackframes s s' (proj_sig_res (funsig f)) ->
- Val.has_type_list args (sig_args (funsig f)) ->
- transf_fundef f = OK tf ->
+ forall s f tf args m s' args' m',
+ match_stackframes s s' ->
+ transf_fundef rm f = OK tf ->
+ Val.lessdef_list args args' ->
+ Mem.extends m m' ->
match_states (Callstate s f args m)
- (Callstate s' tf args m)
+ (Callstate s' tf args' m')
| match_states_return:
- forall s s' ty v m,
- match_stackframes s s' ty ->
- Val.has_type v ty ->
+ forall s s' v v' m m',
+ match_stackframes s s' ->
+ Val.lessdef v v' ->
+ Mem.extends m m' ->
match_states (Returnstate s v m)
- (Returnstate s' v m).
+ (Returnstate s' v' m').
Ltac TransfInstr :=
match goal with
@@ -960,196 +964,241 @@ Ltac TransfInstr :=
Lemma transf_step_correct:
forall s1 t s2, step ge s1 t s2 ->
- forall s1' (MS: match_states s1 s1'),
+ forall s1' (MS: match_states s1 s1') (SOUND: sound_state prog s1),
exists s2', step tge s1' t s2' /\ match_states s2 s2'.
Proof.
induction 1; intros; inv MS; try (TransfInstr; intro C).
(* Inop *)
- exists (State s' (transf_function' f approx) sp pc' rs m); split.
- apply exec_Inop; auto.
+- econstructor; split.
+ eapply exec_Inop; eauto.
econstructor; eauto.
eapply analysis_correct_1; eauto. simpl; auto.
unfold transfer; rewrite H; auto.
(* Iop *)
- exists (State s' (transf_function' f approx) sp pc' (rs#res <- v) m); split.
- destruct (is_trivial_op op) eqn:?.
- eapply exec_Iop'; eauto.
- rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved.
+- destruct (is_trivial_op op) eqn:TRIV.
++ (* unchanged *)
+ exploit eval_operation_lessdef. eapply regs_lessdef_regs; eauto. eauto. eauto.
+ intros [v' [A B]].
+ econstructor; split.
+ eapply exec_Iop with (v := v'); eauto.
+ rewrite <- A. apply eval_operation_preserved. exact symbols_preserved.
+ econstructor; eauto.
+ eapply analysis_correct_1; eauto. simpl; auto.
+ unfold transfer; rewrite H.
+ destruct SAT as [valu NH]. eapply add_op_holds; eauto.
+ apply set_reg_lessdef; auto.
++ (* possibly optimized *)
destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?.
- assert (wf_numbering approx!!pc). eapply wf_analyze; eauto.
destruct SAT as [valu1 NH1].
- exploit valnum_regs_holds; eauto. intros [valu2 [NH2 [EQ AG]]].
- assert (wf_numbering n1). eapply wf_valnum_regs; eauto.
+ exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q).
destruct (find_rhs n1 (Op op vl)) as [r|] eqn:?.
- (* replaced by move *)
- assert (EV: rhs_evals_to ge sp valu2 (Op op vl) m rs#r). eapply find_rhs_correct; eauto.
- assert (RES: rs#r = v). red in EV. congruence.
- eapply exec_Iop'; eauto. simpl. congruence.
- (* possibly simplified *)
+* (* replaced by move *)
+ exploit find_rhs_sound; eauto. intros (v' & EV & LD).
+ assert (v' = v) by (inv EV; congruence). subst v'.
+ econstructor; split.
+ eapply exec_Iop; eauto. simpl; eauto.
+ econstructor; eauto.
+ eapply analysis_correct_1; eauto. simpl; auto.
+ unfold transfer; rewrite H.
+ eapply add_op_holds; eauto.
+ apply set_reg_lessdef; auto.
+ eapply Val.lessdef_trans; eauto.
+* (* possibly simplified *)
destruct (reduce operation combine_op n1 op args vl) as [op' args'] eqn:?.
assert (RES: eval_operation ge sp op' rs##args' m = Some v).
eapply reduce_sound with (sem := fun op vl => eval_operation ge sp op vl m); eauto.
intros; eapply combine_op_sound; eauto.
- eapply exec_Iop'; eauto.
- rewrite <- RES. apply eval_operation_preserved. exact symbols_preserved.
- (* state matching *)
+ exploit eval_operation_lessdef. eapply regs_lessdef_regs; eauto. eauto. eauto.
+ intros [v' [A B]].
+ econstructor; split.
+ eapply exec_Iop with (v := v'); eauto.
+ rewrite <- A. apply eval_operation_preserved. exact symbols_preserved.
econstructor; eauto.
- eapply wt_exec_Iop; eauto. eapply wt_instr_at; eauto.
eapply analysis_correct_1; eauto. simpl; auto.
unfold transfer; rewrite H.
- eapply add_op_satisfiable; eauto. eapply wf_analyze; eauto.
+ eapply add_op_holds; eauto.
+ apply set_reg_lessdef; auto.
- (* Iload *)
- exists (State s' (transf_function' f approx) sp pc' (rs#dst <- v) m); split.
+- (* Iload *)
destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?.
- assert (wf_numbering approx!!pc). eapply wf_analyze; eauto.
destruct SAT as [valu1 NH1].
- exploit valnum_regs_holds; eauto. intros [valu2 [NH2 [EQ AG]]].
- assert (wf_numbering n1). eapply wf_valnum_regs; eauto.
+ exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q).
destruct (find_rhs n1 (Load chunk addr vl)) as [r|] eqn:?.
- (* replaced by move *)
- assert (EV: rhs_evals_to ge sp valu2 (Load chunk addr vl) m rs#r). eapply find_rhs_correct; eauto.
- assert (RES: rs#r = v). red in EV. destruct EV as [a' [EQ1 EQ2]]. congruence.
- eapply exec_Iop'; eauto. simpl. congruence.
- (* possibly simplified *)
++ (* replaced by move *)
+ exploit find_rhs_sound; eauto. intros (v' & EV & LD).
+ assert (v' = v) by (inv EV; congruence). subst v'.
+ econstructor; split.
+ eapply exec_Iop; eauto. simpl; eauto.
+ econstructor; eauto.
+ eapply analysis_correct_1; eauto. simpl; auto.
+ unfold transfer; rewrite H.
+ eapply add_load_holds; eauto.
+ apply set_reg_lessdef; auto. eapply Val.lessdef_trans; eauto.
++ (* load is preserved, but addressing is possibly simplified *)
destruct (reduce addressing combine_addr n1 addr args vl) as [addr' args'] eqn:?.
assert (ADDR: eval_addressing ge sp addr' rs##args' = Some a).
- eapply reduce_sound with (sem := fun addr vl => eval_addressing ge sp addr vl); eauto.
- intros; eapply combine_addr_sound; eauto.
- assert (ADDR': eval_addressing tge sp addr' rs##args' = Some a).
- rewrite <- ADDR. apply eval_addressing_preserved. exact symbols_preserved.
+ { eapply reduce_sound with (sem := fun addr vl => eval_addressing ge sp addr vl); eauto.
+ intros; eapply combine_addr_sound; eauto. }
+ exploit eval_addressing_lessdef. apply regs_lessdef_regs; eauto. eexact ADDR.
+ intros [a' [A B]].
+ assert (ADDR': 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' [X Y]].
+ econstructor; split.
eapply exec_Iload; eauto.
- (* state matching *)
econstructor; eauto.
- eapply wt_exec_Iload; eauto. eapply wt_instr_at; eauto.
eapply analysis_correct_1; eauto. simpl; auto.
unfold transfer; rewrite H.
- eapply add_load_satisfiable; eauto. eapply wf_analyze; eauto.
+ eapply add_load_holds; eauto.
+ apply set_reg_lessdef; auto.
- (* Istore *)
- exists (State s' (transf_function' f approx) sp pc' rs m'); split.
+- (* Istore *)
destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?.
- assert (wf_numbering approx!!pc). eapply wf_analyze; eauto.
destruct SAT as [valu1 NH1].
- exploit valnum_regs_holds; eauto. intros [valu2 [NH2 [EQ AG]]].
- assert (wf_numbering n1). eapply wf_valnum_regs; eauto.
+ exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q).
destruct (reduce addressing combine_addr n1 addr args vl) as [addr' args'] eqn:?.
assert (ADDR: eval_addressing ge sp addr' rs##args' = Some a).
- eapply reduce_sound with (sem := fun addr vl => eval_addressing ge sp addr vl); eauto.
- intros; eapply combine_addr_sound; eauto.
- assert (ADDR': eval_addressing tge sp addr' rs##args' = Some a).
- rewrite <- ADDR. apply eval_addressing_preserved. exact symbols_preserved.
+ { eapply reduce_sound with (sem := fun addr vl => eval_addressing ge sp addr vl); eauto.
+ intros; eapply combine_addr_sound; eauto. }
+ exploit eval_addressing_lessdef. apply regs_lessdef_regs; eauto. eexact ADDR.
+ intros [a' [A B]].
+ assert (ADDR': eval_addressing tge sp addr' rs'##args' = Some a').
+ { rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. }
+ exploit Mem.storev_extends; eauto. intros [m'' [X Y]].
+ econstructor; split.
eapply exec_Istore; eauto.
econstructor; eauto.
eapply analysis_correct_1; eauto. simpl; auto.
unfold transfer; rewrite H.
- eapply add_store_satisfiable; eauto. eapply wf_analyze; eauto.
- exploit wt_instr_at; eauto. intros WTI; inv WTI.
- eapply Val.has_subtype; eauto.
+ inv SOUND.
+ eapply add_store_result_hold; eauto.
+ eapply kill_loads_after_store_holds; eauto.
- (* Icall *)
+- (* Icall *)
exploit find_function_translated; eauto. intros [tf [FIND' TRANSF']].
econstructor; split.
eapply exec_Icall; eauto.
apply sig_preserved; auto.
- exploit wt_instr_at; eauto. intros WTI; inv WTI.
econstructor; eauto.
econstructor; eauto.
intros. eapply analysis_correct_1; eauto. simpl; auto.
unfold transfer; rewrite H.
- apply empty_numbering_satisfiable.
- eapply Val.has_subtype_list; eauto. apply wt_regset_list; auto.
+ exists (fun _ => Vundef); apply empty_numbering_holds.
+ apply regs_lessdef_regs; auto.
- (* Itailcall *)
+- (* Itailcall *)
exploit find_function_translated; eauto. intros [tf [FIND' TRANSF']].
+ exploit Mem.free_parallel_extends; eauto. intros [m'' [A B]].
econstructor; split.
eapply exec_Itailcall; eauto.
apply sig_preserved; auto.
- exploit wt_instr_at; eauto. intros WTI; inv WTI.
econstructor; eauto.
- replace (proj_sig_res (funsig fd)) with (proj_sig_res (fn_sig f)). auto.
- unfold proj_sig_res. rewrite H6; auto.
- eapply Val.has_subtype_list; eauto. apply wt_regset_list; auto.
+ apply regs_lessdef_regs; auto.
- (* Ibuiltin *)
+- (* Ibuiltin *)
+ exploit external_call_mem_extends; eauto.
+ instantiate (1 := rs'##args). apply regs_lessdef_regs; auto.
+ intros (v' & m1' & P & Q & R & S).
econstructor; split.
eapply exec_Ibuiltin; eauto.
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
econstructor; eauto.
- eapply wt_exec_Ibuiltin; eauto. eapply wt_instr_at; eauto.
eapply analysis_correct_1; eauto. simpl; auto.
- unfold transfer; rewrite H.
- assert (CASE1: numbering_satisfiable ge sp (rs#res <- v) m' empty_numbering).
- { apply empty_numbering_satisfiable. }
- assert (CASE2: m' = m -> numbering_satisfiable ge sp (rs#res <- v) m' (add_unknown approx#pc res)).
- { intros. rewrite H1. apply add_unknown_satisfiable.
- eapply wf_analyze; eauto. auto. }
- assert (CASE3: numbering_satisfiable ge sp (rs#res <- v) m'
- (add_unknown (kill_loads approx#pc) res)).
- { apply add_unknown_satisfiable. apply wf_kill_equations. eapply wf_analyze; eauto.
- eapply kill_loads_satisfiable; eauto. }
- destruct ef; auto; apply CASE2; inv H0; auto.
-
- (* Icond *)
+* unfold transfer; rewrite H.
+ destruct SAT as [valu NH].
+ assert (CASE1: exists valu, numbering_holds valu ge sp (rs#res <- v) m' empty_numbering).
+ { exists valu; apply empty_numbering_holds. }
+ assert (CASE2: m' = m -> exists valu, numbering_holds valu ge sp (rs#res <- v) m' (set_unknown approx#pc res)).
+ { intros. rewrite H1. exists valu. apply set_unknown_holds; auto. }
+ assert (CASE3: exists valu, numbering_holds valu ge sp (rs#res <- v) m'
+ (set_unknown (kill_all_loads approx#pc) res)).
+ { exists valu. apply set_unknown_holds. eapply kill_all_loads_hold; eauto. }
+ destruct ef.
+ + apply CASE1.
+ + apply CASE3.
+ + apply CASE2; inv H0; auto.
+ + apply CASE3.
+ + apply CASE2; inv H0; auto.
+ + apply CASE3; auto.
+ + apply CASE1.
+ + apply CASE1.
+ + destruct args as [ | rdst args]; auto.
+ destruct args as [ | rsrc args]; auto.
+ destruct args; auto.
+ simpl in H0. inv H0.
+ exists valu.
+ apply set_unknown_holds.
+ inv SOUND. eapply add_memcpy_holds; eauto.
+ eapply kill_loads_after_storebytes_holds; eauto.
+ eapply Mem.loadbytes_length; eauto.
+ omega.
+ simpl. apply Ple_refl.
+ + apply CASE2; inv H0; auto.
+ + apply CASE2; inv H0; auto.
+ + apply CASE1.
+* apply set_reg_lessdef; auto.
+
+- (* Icond *)
destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?.
- assert (wf_numbering approx!!pc). eapply wf_analyze; eauto.
elim SAT; intros valu1 NH1.
- exploit valnum_regs_holds; eauto. intros [valu2 [NH2 [EQ AG]]].
- assert (wf_numbering n1). eapply wf_valnum_regs; eauto.
+ exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q).
destruct (reduce condition combine_cond n1 cond args vl) as [cond' args'] eqn:?.
assert (RES: eval_condition cond' rs##args' m = Some b).
- eapply reduce_sound with (sem := fun cond vl => eval_condition cond vl m); eauto.
- intros; eapply combine_cond_sound; eauto.
+ { eapply reduce_sound with (sem := fun cond vl => eval_condition cond vl m); eauto.
+ intros; eapply combine_cond_sound; eauto. }
econstructor; split.
eapply exec_Icond; eauto.
+ eapply eval_condition_lessdef; eauto. apply regs_lessdef_regs; auto.
econstructor; eauto.
destruct b; eapply analysis_correct_1; eauto; simpl; auto;
unfold transfer; rewrite H; auto.
- (* Ijumptable *)
+- (* Ijumptable *)
+ generalize (RLD arg); rewrite H0; intro LD; inv LD.
econstructor; split.
eapply exec_Ijumptable; eauto.
econstructor; eauto.
eapply analysis_correct_1; eauto. simpl. eapply list_nth_z_in; eauto.
unfold transfer; rewrite H; auto.
- (* Ireturn *)
+- (* Ireturn *)
+ exploit Mem.free_parallel_extends; eauto. intros [m'' [A B]].
econstructor; split.
eapply exec_Ireturn; eauto.
econstructor; eauto.
- exploit wt_instr_at; eauto. intros WTI; inv WTI; simpl.
- auto.
- unfold proj_sig_res; rewrite H2. eapply Val.has_subtype; eauto.
+ destruct or; simpl; auto.
- (* internal function *)
- monadInv H7. unfold transf_function in EQ.
- destruct (type_function f) as [tyenv|] eqn:?; try discriminate.
- destruct (analyze f) as [approx|] eqn:?; inv EQ.
- assert (WTF: wt_function f tyenv). apply type_function_correct; auto.
+- (* internal function *)
+ monadInv H6. unfold transf_function in EQ.
+ destruct (analyze f (vanalyze rm f)) as [approx|] eqn:?; inv EQ.
+ exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl.
+ intros (m'' & A & B).
econstructor; split.
- eapply exec_function_internal; eauto.
+ eapply exec_function_internal; simpl; eauto.
simpl. econstructor; eauto.
- apply wt_init_regs. inv WTF. eapply Val.has_subtype_list; eauto.
- apply analysis_correct_entry; auto.
+ eapply analysis_correct_entry; eauto.
+ apply init_regs_lessdef; auto.
- (* external function *)
- monadInv H7.
+- (* external function *)
+ monadInv H6.
+ exploit external_call_mem_extends; eauto.
+ intros (v' & m1' & P & Q & R & S).
econstructor; split.
eapply exec_function_external; eauto.
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
econstructor; eauto.
- simpl. eapply external_call_well_typed; eauto.
- (* return *)
- inv H3.
+- (* return *)
+ inv H2.
econstructor; split.
eapply exec_return; eauto.
econstructor; eauto.
- apply wt_regset_assign; auto. eapply Val.has_subtype; eauto.
+ apply set_reg_lessdef; auto.
Qed.
Lemma transf_initial_states:
@@ -1165,24 +1214,27 @@ Proof.
rewrite symbols_preserved. eauto.
symmetry. eapply transform_partial_program_main; eauto.
rewrite <- H3. apply sig_preserved; auto.
- constructor. rewrite H3. constructor. rewrite H3. constructor. auto.
+ constructor. constructor. auto. auto. 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 H5. inv H3. constructor.
Qed.
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.
+ eapply forward_simulation_step with
+ (match_states := fun s1 s2 => sound_state prog s1 /\ match_states s1 s2).
+- eexact symbols_preserved.
+- intros. exploit transf_initial_states; eauto. intros [s2 [A B]].
+ exists s2. split. auto. split. apply sound_initial; auto. auto.
+- intros. destruct H. eapply transf_final_states; eauto.
+- intros. destruct H0. exploit transf_step_correct; eauto.
+ intros [s2' [A B]]. exists s2'; split. auto. split. eapply sound_step; eauto. auto.
Qed.
End PRESERVATION.
diff --git a/backend/Constprop.v b/backend/Constprop.v
index e5ea64d..76d8e6c 100644
--- a/backend/Constprop.v
+++ b/backend/Constprop.v
@@ -25,242 +25,30 @@ Require Import RTL.
Require Import Lattice.
Require Import Kildall.
Require Import Liveness.
+Require Import ValueDomain.
+Require Import ValueAOp.
+Require Import ValueAnalysis.
Require Import ConstpropOp.
-(** * Static analysis *)
-
-(** The type [approx] of compile-time approximations of values is
- defined in the machine-dependent part [ConstpropOp]. *)
-
-(** 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.
- apply Int.eq_dec.
- apply Float.eq_dec.
- apply Int64.eq_dec.
- apply Int.eq_dec.
- apply ident_eq.
- apply Int.eq_dec.
- Defined.
- Definition beq (x y: t) := if eq_dec x y then true else false.
- Lemma beq_correct: forall x y, beq x y = true -> x = y.
- Proof.
- unfold beq; intros. destruct (eq_dec x y). auto. congruence.
- Qed.
-
- Definition ge (x y: t) : Prop := x = Unknown \/ y = Novalue \/ x = y.
-
- Lemma ge_refl: forall x y, eq x y -> ge x y.
- Proof.
- unfold eq, ge; tauto.
- Qed.
- Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
- Proof.
- unfold ge; intuition congruence.
- Qed.
- Lemma ge_compat: forall x x' y y', eq x x' -> eq y y' -> ge x y -> ge x' y'.
- Proof.
- unfold eq, ge; intros; congruence.
- Qed.
- Definition bot := Novalue.
- Definition top := Unknown.
- Lemma ge_bot: forall x, ge x bot.
- Proof.
- unfold ge, bot; tauto.
- Qed.
- Lemma ge_top: forall x, ge top x.
- Proof.
- unfold ge, bot; tauto.
- Qed.
- Definition lub (x y: t) : t :=
- if eq_dec x y then x else
- match x, y with
- | Novalue, _ => y
- | _, Novalue => x
- | _, _ => Unknown
- end.
- Lemma ge_lub_left: forall x y, ge (lub x y) x.
- Proof.
- unfold lub; intros.
- case (eq_dec x y); intro.
- apply ge_refl. apply eq_refl.
- destruct x; destruct y; unfold ge; tauto.
- Qed.
- Lemma ge_lub_right: forall x y, ge (lub x y) y.
- Proof.
- unfold lub; intros.
- case (eq_dec x y); intro.
- apply ge_refl. subst. apply eq_refl.
- destruct x; destruct y; unfold ge; tauto.
- Qed.
-End Approx.
-
-Module D := LPMap Approx.
-
-(** We keep track of read-only global variables (i.e. "const" global
- variables in C) as a map from their names to their initialization
- data. *)
-
-Definition global_approx : Type := PTree.t (list init_data).
-
-(** Given some initialization data and a byte offset, compute a static
- approximation of the result of a memory load from a memory block
- initialized with this data. *)
-
-Fixpoint eval_load_init (chunk: memory_chunk) (pos: Z) (il: list init_data): approx :=
- match il with
- | nil => Unknown
- | Init_int8 n :: il' =>
- if zeq pos 0 then
- match chunk with
- | Mint8unsigned => I (Int.zero_ext 8 n)
- | Mint8signed => I (Int.sign_ext 8 n)
- | _ => Unknown
- end
- else eval_load_init chunk (pos - 1) il'
- | Init_int16 n :: il' =>
- if zeq pos 0 then
- match chunk with
- | Mint16unsigned => I (Int.zero_ext 16 n)
- | Mint16signed => I (Int.sign_ext 16 n)
- | _ => Unknown
- end
- else eval_load_init chunk (pos - 2) il'
- | Init_int32 n :: il' =>
- if zeq pos 0
- then match chunk with Mint32 => I n | _ => Unknown end
- else eval_load_init chunk (pos - 4) il'
- | Init_int64 n :: il' =>
- if zeq pos 0
- then match chunk with Mint64 => L n | _ => Unknown end
- else eval_load_init chunk (pos - 8) il'
- | Init_float32 n :: il' =>
- if zeq pos 0
- then match chunk with
- | Mfloat32 => if propagate_float_constants tt then F (Float.singleoffloat n) else Unknown
- | _ => Unknown
- end
- else eval_load_init chunk (pos - 4) il'
- | Init_float64 n :: il' =>
- if zeq pos 0
- then match chunk with
- | Mfloat64 => if propagate_float_constants tt then F n else Unknown
- | _ => Unknown
- end
- else eval_load_init chunk (pos - 8) il'
- | Init_addrof symb ofs :: il' =>
- if zeq pos 0
- then match chunk with Mint32 => G symb ofs | _ => Unknown end
- else eval_load_init chunk (pos - 4) il'
- | Init_space n :: il' =>
- eval_load_init chunk (pos - Zmax n 0) il'
- end.
-
-(** Compute a static approximation for the result of a load at an address whose
- approximation is known. If the approximation points to a global variable,
- and this global variable is read-only, we use its initialization data
- to determine a static approximation. Otherwise, [Unknown] is returned. *)
-
-Definition eval_static_load (gapp: global_approx) (chunk: memory_chunk) (addr: approx) : approx :=
- match addr with
- | G symb ofs =>
- match gapp!symb with
- | None => Unknown
- | Some il => eval_load_init chunk (Int.unsigned ofs) il
- end
- | _ => Unknown
- end.
-
-(** The transfer function for the dataflow analysis is straightforward.
- For [Iop] instructions, we set the approximation of the destination
- register to the result of executing abstractly the operation.
- For [Iload] instructions, we set the approximation of the destination
- register to the result of [eval_static_load].
- For [Icall] and [Ibuiltin], the destination register becomes [Unknown].
- Other instructions keep the approximations unchanged, as they preserve
- the values of all registers. *)
-
-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 (gapp: global_approx) (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 := eval_static_operation op (approx_regs before args) in
- D.set res a before
- | Iload chunk addr args dst s =>
- let a := eval_static_load gapp chunk
- (eval_static_addressing addr (approx_regs before args)) in
- D.set dst a 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.
-
-(** To reduce the size of approximations, we preventively set to [Top]
- the approximations of registers used for the last time in the
- current instruction. *)
-
-Definition transfer' (gapp: global_approx) (f: function) (lastuses: PTree.t (list reg))
- (pc: node) (before: D.t) :=
- let after := transfer gapp f pc before in
- match lastuses!pc with
- | None => after
- | Some regs => List.fold_left (fun a r => D.set r Unknown a) regs after
- end.
-
-(** The static analysis itself is then an instantiation of Kildall's
- generic solver for forward dataflow inequations. [analyze f]
- returns a mapping from program points to mappings of pseudo-registers
- to approximations. It can fail to reach a fixpoint in a reasonable
- number of iterations, in which case we use the trivial mapping
- (program point -> [D.top]) instead. *)
-
-Module DS := Dataflow_Solver(D)(NodeSetForward).
-
-Definition analyze (gapp: global_approx) (f: RTL.function): PMap.t D.t :=
- let lu := Liveness.last_uses f in
- match DS.fixpoint f.(fn_code) successors_instr (transfer' gapp f lu)
- ((f.(fn_entrypoint), D.top) :: nil) with
- | None => PMap.init D.top
- | Some res => res
- end.
-
-(** * Code transformation *)
-
-(** The code transformation proceeds instruction by instruction.
- Operators whose arguments are all statically known are turned
- into ``load integer constant'', ``load float constant'' or
- ``load symbol address'' operations. Likewise for loads whose
- result can be statically predicted. Operators for which some
- but not all arguments are known are subject to strength reduction,
- and similarly for the addressing modes of load and store instructions.
- Conditional branches and multi-way branches are statically resolved
- into [Inop] instructions if possible. Other instructions are unchanged.
-
- In addition, we try to jump over conditionals whose condition can
- be statically resolved based on the abstract state "after" the
- instruction that branches to the conditional. A typical example is:
+(** The code transformation builds on the results of the static analysis
+ of values from module [ValueAnalysis]. It proceeds instruction by
+ instruction.
+- Operators whose arguments are all statically known are turned into
+ ``load integer constant'', ``load float constant'' or ``load
+ symbol address'' operations. Likewise for loads whose result can
+ be statically predicted.
+- Operators for which some but not all arguments are known are subject
+ to strength reduction (replacement by cheaper operators) and
+ similarly for the addressing modes of load and store instructions.
+- Cast operators that have no effect (because their arguments are
+ already normalized to the destination type) are removed.
+- Conditional branches and multi-way branches are statically resolved
+ into [Inop] instructions when possible.
+- Other instructions are unchanged.
+
+ In addition, we try to jump over conditionals whose condition can
+ be statically resolved based on the abstract state "after" the
+ instruction that branches to the conditional. A typical example is:
<<
1: x := 0 and goto 2
2: if (x == 0) goto 3 else goto 4
@@ -273,37 +61,35 @@ Definition analyze (gapp: global_approx) (f: RTL.function): PMap.t D.t :=
>>
*)
-Definition transf_ros (app: D.t) (ros: reg + ident) : reg + ident :=
+Definition transf_ros (ae: AE.t) (ros: reg + ident) : reg + ident :=
match ros with
| inl r =>
- match D.get r app with
- | G symb ofs => if Int.eq ofs Int.zero then inr _ symb else ros
+ match areg ae r with
+ | Ptr(Gl symb ofs) => if Int.eq ofs Int.zero then inr _ symb else ros
| _ => ros
end
| inr s => ros
end.
-Parameter generate_float_constants : unit -> bool.
-
-Definition const_for_result (a: approx) : option operation :=
+Definition const_for_result (a: aval) : option operation :=
match a with
| I n => Some(Ointconst n)
| F n => if generate_float_constants tt then Some(Ofloatconst n) else None
- | G symb ofs => Some(Oaddrsymbol symb ofs)
- | S ofs => Some(Oaddrstack ofs)
+ | Ptr(Gl symb ofs) => Some(Oaddrsymbol symb ofs)
+ | Ptr(Stk ofs) => Some(Oaddrstack ofs)
| _ => None
end.
-Fixpoint successor_rec (n: nat) (f: function) (app: D.t) (pc: node) : node :=
+Fixpoint successor_rec (n: nat) (f: function) (ae: AE.t) (pc: node) : node :=
match n with
| O => pc
- | Datatypes.S n' =>
+ | S n' =>
match f.(fn_code)!pc with
| Some (Inop s) =>
- successor_rec n' f app s
+ successor_rec n' f ae s
| Some (Icond cond args s1 s2) =>
- match eval_static_condition cond (approx_regs app args) with
- | Some b => if b then s1 else s2
+ match resolve_branch (eval_static_condition cond (aregs ae args)) with
+ | Some b => successor_rec n' f ae (if b then s1 else s2)
| None => pc
end
| _ => pc
@@ -312,15 +98,15 @@ Fixpoint successor_rec (n: nat) (f: function) (app: D.t) (pc: node) : node :=
Definition num_iter := 10%nat.
-Definition successor (f: function) (app: D.t) (pc: node) : node :=
- successor_rec num_iter f app pc.
+Definition successor (f: function) (ae: AE.t) (pc: node) : node :=
+ successor_rec num_iter f ae pc.
-Function annot_strength_reduction
- (app: D.t) (targs: list annot_arg) (args: list reg) :=
+Fixpoint annot_strength_reduction
+ (ae: AE.t) (targs: list annot_arg) (args: list reg) :=
match targs, args with
| AA_arg ty :: targs', arg :: args' =>
- let (targs'', args'') := annot_strength_reduction app targs' args' in
- match ty, approx_reg app arg with
+ let (targs'', args'') := annot_strength_reduction ae targs' args' in
+ match ty, areg ae arg with
| Tint, I n => (AA_int n :: targs'', args'')
| Tfloat, F n => if generate_float_constants tt
then (AA_float n :: targs'', args'')
@@ -328,117 +114,106 @@ Function annot_strength_reduction
| _, _ => (AA_arg ty :: targs'', arg :: args'')
end
| targ :: targs', _ =>
- let (targs'', args'') := annot_strength_reduction app targs' args in
+ let (targs'', args'') := annot_strength_reduction ae targs' args in
(targ :: targs'', args'')
| _, _ =>
(targs, args)
end.
Function builtin_strength_reduction
- (app: D.t) (ef: external_function) (args: list reg) :=
+ (ae: AE.t) (ef: external_function) (args: list reg) :=
match ef, args with
| EF_vload chunk, r1 :: nil =>
- match approx_reg app r1 with
- | G symb n1 => (EF_vload_global chunk symb n1, nil)
+ match areg ae r1 with
+ | Ptr(Gl symb n1) => (EF_vload_global chunk symb n1, nil)
| _ => (ef, args)
end
| EF_vstore chunk, r1 :: r2 :: nil =>
- match approx_reg app r1 with
- | G symb n1 => (EF_vstore_global chunk symb n1, r2 :: nil)
+ match areg ae r1 with
+ | Ptr(Gl symb n1) => (EF_vstore_global chunk symb n1, r2 :: nil)
| _ => (ef, args)
end
| EF_annot text targs, args =>
- let (targs', args') := annot_strength_reduction app targs args in
+ let (targs', args') := annot_strength_reduction ae targs args in
(EF_annot text targs', args')
| _, _ =>
(ef, args)
end.
-Definition transf_instr (gapp: global_approx) (f: function) (apps: PMap.t D.t)
- (pc: node) (instr: instruction) :=
- let app := apps!!pc in
- match instr with
- | Iop op args res s =>
- let a := eval_static_operation op (approx_regs app args) in
- let s' := successor f (D.set res a app) s in
- match const_for_result a with
- | Some cop =>
- Iop cop nil res s'
- | None =>
- 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 a := eval_static_load gapp chunk
- (eval_static_addressing addr (approx_regs app args)) in
- match const_for_result a with
- | Some cop =>
- Iop cop nil dst s
- | None =>
- let (addr', args') := addr_strength_reduction addr args (approx_regs app args) in
- Iload chunk addr' args' dst s
- end
- | Istore chunk addr args src s =>
- 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
- | Itailcall sig ros args =>
- Itailcall sig (transf_ros app ros) args
- | Ibuiltin ef args res s =>
- let (ef', args') := builtin_strength_reduction app ef args in
- Ibuiltin ef' args' res s
- | Icond cond args s1 s2 =>
- match eval_static_condition cond (approx_regs app args) with
- | Some b =>
- if b then Inop s1 else Inop s2
- | None =>
- let (cond', args') := cond_strength_reduction cond args (approx_regs app args) in
- Icond cond' args' s1 s2
- end
- | Ijumptable arg tbl =>
- match approx_reg app arg with
- | I n =>
- match list_nth_z tbl (Int.unsigned n) with
- | Some s => Inop s
- | None => instr
+Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem)
+ (pc: node) (instr: instruction) :=
+ match an!!pc with
+ | VA.Bot =>
+ instr
+ | VA.State ae am =>
+ match instr with
+ | Iop op args res s =>
+ let aargs := aregs ae args in
+ let a := eval_static_operation op aargs in
+ let s' := successor f (AE.set res a ae) s in
+ match const_for_result a with
+ | Some cop =>
+ Iop cop nil res s'
+ | None =>
+ let (op', args') := op_strength_reduction op args aargs in
+ Iop op' args' res s'
+ end
+ | Iload chunk addr args dst s =>
+ let aargs := aregs ae args in
+ let a := ValueDomain.loadv chunk rm am (eval_static_addressing addr aargs) in
+ match const_for_result a with
+ | Some cop =>
+ Iop cop nil dst s
+ | None =>
+ let (addr', args') := addr_strength_reduction addr args aargs in
+ Iload chunk addr' args' dst s
+ end
+ | Istore chunk addr args src s =>
+ let aargs := aregs ae args in
+ let (addr', args') := addr_strength_reduction addr args aargs in
+ Istore chunk addr' args' src s
+ | Icall sig ros args res s =>
+ Icall sig (transf_ros ae ros) args res s
+ | Itailcall sig ros args =>
+ Itailcall sig (transf_ros ae ros) args
+ | Ibuiltin ef args res s =>
+ let (ef', args') := builtin_strength_reduction ae ef args in
+ Ibuiltin ef' args' res s
+ | Icond cond args s1 s2 =>
+ let aargs := aregs ae args in
+ match resolve_branch (eval_static_condition cond aargs) with
+ | Some b =>
+ if b then Inop s1 else Inop s2
+ | None =>
+ let (cond', args') := cond_strength_reduction cond args aargs in
+ Icond cond' args' s1 s2
end
- | _ => instr
+ | Ijumptable arg tbl =>
+ match areg ae arg with
+ | I n =>
+ match list_nth_z tbl (Int.unsigned n) with
+ | Some s => Inop s
+ | None => instr
+ end
+ | _ => instr
+ end
+ | _ =>
+ instr
end
- | _ =>
- instr
end.
-Definition transf_code (gapp: global_approx) (f: function) (app: PMap.t D.t) (instrs: code) : code :=
- PTree.map (transf_instr gapp f app) instrs.
-
-Definition transf_function (gapp: global_approx) (f: function) : function :=
- let approxs := analyze gapp f in
+Definition transf_function (rm: romem) (f: function) : function :=
+ let an := ValueAnalysis.analyze rm f in
mkfunction
f.(fn_sig)
f.(fn_params)
f.(fn_stacksize)
- (transf_code gapp f approxs f.(fn_code))
+ (PTree.map (transf_instr f an rm) f.(fn_code))
f.(fn_entrypoint).
-Definition transf_fundef (gapp: global_approx) (fd: fundef) : fundef :=
- AST.transf_fundef (transf_function gapp) fd.
-
-Fixpoint make_global_approx (gapp: global_approx) (gdl: list (ident * globdef fundef unit)): global_approx :=
- match gdl with
- | nil => gapp
- | (id, gl) :: gdl' =>
- let gapp1 :=
- match gl with
- | Gfun f => PTree.remove id gapp
- | Gvar gv =>
- if gv.(gvar_readonly) && negb gv.(gvar_volatile)
- then PTree.set id gv.(gvar_init) gapp
- else PTree.remove id gapp
- end in
- make_global_approx gapp1 gdl'
- end.
+Definition transf_fundef (rm: romem) (fd: fundef) : fundef :=
+ AST.transf_fundef (transf_function rm) fd.
Definition transf_program (p: program) : program :=
- let gapp := make_global_approx (PTree.empty _) p.(prog_defs) in
- transform_program (transf_fundef gapp) p.
+ let rm := romem_for_program p in
+ transform_program (transf_fundef rm) p.
diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v
index 898c4df..41afe8c 100644
--- a/backend/Constpropproof.v
+++ b/backend/Constpropproof.v
@@ -26,7 +26,9 @@ Require Import Registers.
Require Import RTL.
Require Import Lattice.
Require Import Kildall.
-Require Import Liveness.
+Require Import ValueDomain.
+Require Import ValueAOp.
+Require Import ValueAnalysis.
Require Import ConstpropOp.
Require Import Constprop.
Require Import ConstpropOpproof.
@@ -37,316 +39,7 @@ Variable prog: program.
Let tprog := transf_program prog.
Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.
-Let gapp := make_global_approx (PTree.empty _) prog.(prog_defs).
-
-(** * Correctness of the static analysis *)
-
-Section ANALYSIS.
-
-Variable sp: val.
-
-Definition regs_match_approx (a: D.t) (rs: regset) : Prop :=
- 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.
-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 ge sp a2 v -> val_match_approx ge sp a1 v.
-Proof.
- intros until v.
- intros [A|[B|C]].
- subst a1. simpl. auto.
- subst a2. simpl. tauto.
- subst a2. auto.
-Qed.
-
-Lemma regs_match_approx_increasing:
- forall a1 a2 rs,
- D.ge a1 a2 -> regs_match_approx a2 rs -> regs_match_approx a1 rs.
-Proof.
- unfold D.ge, regs_match_approx. intros.
- apply val_match_approx_increasing with (D.get r a2); auto.
-Qed.
-
-Lemma regs_match_approx_update:
- forall ra rs a v r,
- val_match_approx ge sp a v ->
- regs_match_approx ra rs ->
- regs_match_approx (D.set r a ra) (rs#r <- v).
-Proof.
- intros; red; intros.
- rewrite D.gsspec. rewrite Regmap.gsspec. destruct (peq r0 r); auto.
- red; intros; subst ra. specialize (H0 xH). rewrite D.get_bot in H0. inv H0.
- unfold Approx.eq. red; intros; subst a. inv H.
-Qed.
-
-Lemma approx_regs_val_list:
- forall ra rs rl,
- regs_match_approx ra rs ->
- val_list_match_approx ge sp (approx_regs ra rl) rs##rl.
-Proof.
- induction rl; simpl; intros.
- constructor.
- constructor. apply H. auto.
-Qed.
-
-Lemma regs_match_approx_forget:
- forall rs rl ra,
- regs_match_approx ra rs ->
- regs_match_approx (List.fold_left (fun a r => D.set r Unknown a) rl ra) rs.
-Proof.
- induction rl; simpl; intros.
- auto.
- apply IHrl.
- red; intros. rewrite D.gsspec. destruct (peq r a). constructor. auto.
- red; intros; subst ra. specialize (H xH). inv H.
- unfold Approx.eq, Approx.bot. congruence.
-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. *)
-
-Lemma analyze_correct_1:
- forall f pc rs pc' i,
- f.(fn_code)!pc = Some i ->
- In pc' (successors_instr i) ->
- regs_match_approx (transfer gapp f pc (analyze gapp f)!!pc) rs ->
- regs_match_approx (analyze gapp f)!!pc' rs.
-Proof.
- unfold analyze; intros.
- set (lu := last_uses f) in *.
- destruct (DS.fixpoint (fn_code f) successors_instr (transfer' gapp f lu)
- ((fn_entrypoint f, D.top) :: nil)) as [approxs|] eqn:FIX.
- apply regs_match_approx_increasing with (transfer' gapp f lu pc approxs!!pc).
- eapply DS.fixpoint_solution; eauto.
- unfold transfer'. destruct (lu!pc) as [regs|].
- apply regs_match_approx_forget; auto.
- auto.
- intros. rewrite PMap.gi. apply regs_match_approx_top.
-Qed.
-
-Lemma analyze_correct_3:
- forall f rs,
- regs_match_approx (analyze gapp f)!!(f.(fn_entrypoint)) rs.
-Proof.
- intros. unfold analyze.
- set (lu := last_uses f) in *.
- destruct (DS.fixpoint (fn_code f) successors_instr (transfer' gapp f lu)
- ((fn_entrypoint f, D.top) :: nil)) as [approxs|] eqn:FIX.
- 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.
-
-(** eval_static_load *)
-
-Definition mem_match_approx (m: mem) : Prop :=
- forall id il b,
- gapp!id = Some il -> Genv.find_symbol ge id = Some b ->
- Genv.load_store_init_data ge m b 0 il /\
- Mem.valid_block m b /\
- (forall ofs, ~Mem.perm m b ofs Max Writable).
-
-Lemma eval_load_init_sound:
- forall chunk m b il base ofs pos v,
- Genv.load_store_init_data ge m b base il ->
- Mem.load chunk m b ofs = Some v ->
- ofs = base + pos ->
- val_match_approx ge sp (eval_load_init chunk pos il) v.
-Proof.
- induction il; simpl; intros.
-(* base case il = nil *)
- auto.
-(* inductive case *)
- destruct a.
- (* Init_int8 *)
- destruct H. destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0.
- destruct chunk; simpl; auto.
- rewrite Mem.load_int8_signed_unsigned in H0. rewrite H in H0. simpl in H0.
- inv H0. decEq. apply Int.sign_ext_zero_ext. compute; auto.
- congruence.
- eapply IHil; eauto. omega.
- (* Init_int16 *)
- destruct H. destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0.
- destruct chunk; simpl; auto.
- rewrite Mem.load_int16_signed_unsigned in H0. rewrite H in H0. simpl in H0.
- inv H0. decEq. apply Int.sign_ext_zero_ext. compute; auto.
- congruence.
- eapply IHil; eauto. omega.
- (* Init_int32 *)
- destruct H. destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0.
- destruct chunk; simpl; auto.
- congruence.
- eapply IHil; eauto. omega.
- (* Init_int64 *)
- destruct H. destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0.
- destruct chunk; simpl; auto.
- congruence.
- eapply IHil; eauto. omega.
- (* Init_float32 *)
- destruct H. destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0.
- destruct chunk; simpl; auto. destruct (propagate_float_constants tt); simpl; auto.
- congruence.
- eapply IHil; eauto. omega.
- (* Init_float64 *)
- destruct H. destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0.
- destruct chunk; simpl; auto. destruct (propagate_float_constants tt); simpl; auto.
- congruence.
- eapply IHil; eauto. omega.
- (* Init_space *)
- eapply IHil; eauto. omega.
- (* Init_symbol *)
- destruct H as [[b' [A B]] C].
- destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0.
- destruct chunk; simpl; auto.
- unfold symbol_address. rewrite A. congruence.
- eapply IHil; eauto. omega.
-Qed.
-
-Lemma eval_static_load_sound:
- forall chunk m addr vaddr v,
- Mem.loadv chunk m vaddr = Some v ->
- mem_match_approx m ->
- val_match_approx ge sp addr vaddr ->
- val_match_approx ge sp (eval_static_load gapp chunk addr) v.
-Proof.
- intros. unfold eval_static_load. destruct addr; simpl; auto.
- destruct (gapp!i) as [il|] eqn:?; auto.
- red in H1. subst vaddr. unfold symbol_address in H.
- destruct (Genv.find_symbol ge i) as [b'|] eqn:?; simpl in H; try discriminate.
- exploit H0; eauto. intros [A [B C]].
- eapply eval_load_init_sound; eauto.
- red; auto.
-Qed.
-
-Lemma mem_match_approx_store:
- forall chunk m addr v m',
- mem_match_approx m ->
- Mem.storev chunk m addr v = Some m' ->
- mem_match_approx m'.
-Proof.
- intros; red; intros. exploit H; eauto. intros [A [B C]].
- destruct addr; simpl in H0; try discriminate.
- exploit Mem.store_valid_access_3; eauto. intros [P Q].
- split. apply Genv.load_store_init_data_invariant with m; auto.
- intros. eapply Mem.load_store_other; eauto. left; red; intro; subst b0.
- eapply C. apply Mem.perm_cur_max. eapply P. instantiate (1 := Int.unsigned i).
- generalize (size_chunk_pos chunk). omega.
- split. eauto with mem.
- intros; red; intros. eapply C. eapply Mem.perm_store_2; eauto.
-Qed.
-
-Lemma mem_match_approx_alloc:
- forall m lo hi b m',
- mem_match_approx m ->
- Mem.alloc m lo hi = (m', b) ->
- mem_match_approx m'.
-Proof.
- intros; red; intros. exploit H; eauto. intros [A [B C]].
- split. apply Genv.load_store_init_data_invariant with m; auto.
- intros. eapply Mem.load_alloc_unchanged; eauto.
- split. eauto with mem.
- intros; red; intros. exploit Mem.perm_alloc_inv; eauto.
- rewrite dec_eq_false. apply C. eapply Mem.valid_not_valid_diff; eauto with mem.
-Qed.
-
-Lemma mem_match_approx_free:
- forall m lo hi b m',
- mem_match_approx m ->
- Mem.free m b lo hi = Some m' ->
- mem_match_approx m'.
-Proof.
- intros; red; intros. exploit H; eauto. intros [A [B C]].
- split. apply Genv.load_store_init_data_invariant with m; auto.
- intros. eapply Mem.load_free; eauto.
- destruct (eq_block b0 b); auto. subst b0.
- right. destruct (zlt lo hi); auto.
- elim (C lo). apply Mem.perm_cur_max.
- exploit Mem.free_range_perm; eauto. instantiate (1 := lo); omega.
- intros; eapply Mem.perm_implies; eauto with mem.
- split. eauto with mem.
- intros; red; intros. eapply C. eauto with mem.
-Qed.
-
-Lemma mem_match_approx_extcall:
- forall ef vargs m t vres m',
- mem_match_approx m ->
- external_call ef ge vargs m t vres m' ->
- mem_match_approx m'.
-Proof.
- intros; red; intros. exploit H; eauto. intros [A [B C]].
- split. apply Genv.load_store_init_data_invariant with m; auto.
- intros. eapply external_call_readonly; eauto.
- split. eapply external_call_valid_block; eauto.
- intros; red; intros. elim (C ofs). eapply external_call_max_perm; eauto.
-Qed.
-
-(* Show that mem_match_approx holds initially *)
-
-Definition global_approx_charact (g: genv) (ga: global_approx) : Prop :=
- forall id il b,
- ga!id = Some il ->
- Genv.find_symbol g id = Some b ->
- Genv.find_var_info g b = Some (mkglobvar tt il true false).
-
-Lemma make_global_approx_correct:
- forall gdl g ga,
- global_approx_charact g ga ->
- global_approx_charact (Genv.add_globals g gdl) (make_global_approx ga gdl).
-Proof.
- induction gdl; simpl; intros.
- auto.
- destruct a as [id gd]. apply IHgdl.
- red; intros.
- assert (EITHER: id0 = id /\ gd = Gvar(mkglobvar tt il true false)
- \/ id0 <> id /\ ga!id0 = Some il).
- destruct gd.
- rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id); [discriminate|auto].
- destruct (gvar_readonly v && negb (gvar_volatile v)) eqn:?.
- rewrite PTree.gsspec in H0. destruct (peq id0 id).
- inv H0. left. split; auto.
- destruct v; simpl in *.
- destruct gvar_readonly; try discriminate.
- destruct gvar_volatile; try discriminate.
- destruct gvar_info. auto.
- auto.
- rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id); [discriminate|auto].
-
- unfold Genv.add_global, Genv.find_symbol, Genv.find_var_info in *;
- simpl in *.
- destruct EITHER as [[A B] | [A B]].
- subst id0. rewrite PTree.gss in H1. inv H1. rewrite PTree.gss. auto.
- rewrite PTree.gso in H1; auto. destruct gd. eapply H; eauto.
- rewrite PTree.gso. eapply H; eauto.
- red; intros; subst b. eelim Plt_strict; eapply Genv.genv_symb_range; eauto.
-Qed.
-
-Theorem mem_match_approx_init:
- forall m, Genv.init_mem prog = Some m -> mem_match_approx m.
-Proof.
- intros.
- assert (global_approx_charact ge gapp).
- unfold ge, gapp. unfold Genv.globalenv.
- apply make_global_approx_correct.
- red; intros. rewrite PTree.gempty in H0; discriminate.
- red; intros.
- exploit Genv.init_mem_characterization.
- unfold ge in H0. eapply H0; eauto. eauto.
- unfold Genv.perm_globvar; simpl.
- intros [A [B C]].
- split. auto. split. eapply Genv.find_symbol_not_fresh; eauto.
- intros; red; intros. exploit B; eauto. intros [P Q]. inv Q.
-Qed.
-
-End ANALYSIS.
+Let rm := romem_for_program prog.
(** * Correctness of the code transformation *)
@@ -370,24 +63,24 @@ Qed.
Lemma functions_translated:
forall (v: val) (f: fundef),
Genv.find_funct ge v = Some f ->
- Genv.find_funct tge v = Some (transf_fundef gapp f).
+ Genv.find_funct tge v = Some (transf_fundef rm f).
Proof.
intros.
- exact (Genv.find_funct_transf (transf_fundef gapp) _ _ H).
+ exact (Genv.find_funct_transf (transf_fundef rm) _ _ 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 gapp f).
+ Genv.find_funct_ptr tge b = Some (transf_fundef rm f).
Proof.
intros.
- exact (Genv.find_funct_ptr_transf (transf_fundef gapp) _ _ H).
+ exact (Genv.find_funct_ptr_transf (transf_fundef rm) _ _ H).
Qed.
Lemma sig_function_translated:
forall f,
- funsig (transf_fundef gapp f) = funsig f.
+ funsig (transf_fundef rm f) = funsig f.
Proof.
intros. destruct f; reflexivity.
Qed.
@@ -422,82 +115,103 @@ Proof.
Qed.
Lemma transf_ros_correct:
- forall sp ros rs rs' f approx,
- regs_match_approx sp approx rs ->
+ forall bc rs ae ros f rs',
+ genv_match bc ge ->
+ ematch bc rs ae ->
find_function ge ros rs = Some f ->
regs_lessdef rs rs' ->
- find_function tge (transf_ros approx ros) rs' = Some (transf_fundef gapp f).
-Proof.
- 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 gapp 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.
+ find_function tge (transf_ros ae ros) rs' = Some (transf_fundef rm f).
+Proof.
+ intros until rs'; intros GE EM FF RLD. destruct ros; simpl in *.
+- (* function pointer *)
+ generalize (EM r); fold (areg ae r); intro VM. generalize (RLD r); intro LD.
+ assert (DEFAULT: find_function tge (inl _ r) rs' = Some (transf_fundef rm f)).
+ {
+ simpl. inv LD. apply functions_translated; auto. rewrite <- H0 in FF; discriminate.
+ }
+ destruct (areg ae r); auto. destruct p; auto.
+ predSpec Int.eq Int.eq_spec ofs Int.zero; intros; auto.
+ subst ofs. exploit vmatch_ptr_gl; eauto. intros LD'. inv LD'; try discriminate.
+ rewrite H1 in FF. unfold symbol_address in FF.
+ simpl. rewrite symbols_preserved.
+ destruct (Genv.find_symbol ge id) as [b|]; try discriminate.
+ simpl in FF. rewrite dec_eq_true in FF.
+ apply function_ptr_translated; auto.
+ rewrite <- H0 in FF; discriminate.
+- (* function symbol *)
+ rewrite symbols_preserved.
+ destruct (Genv.find_symbol ge i) as [b|]; try discriminate.
apply function_ptr_translated; auto.
Qed.
Lemma const_for_result_correct:
- forall a op sp v m,
+ forall a op bc v sp m,
const_for_result a = Some op ->
- val_match_approx ge sp a v ->
- eval_operation tge sp op nil m = Some v.
-Proof.
- unfold const_for_result; intros.
- destruct a; inv H; simpl in H0.
- simpl. congruence.
- destruct (generate_float_constants tt); inv H2. simpl. congruence.
- simpl. subst v. unfold symbol_address. rewrite symbols_preserved. auto.
- simpl. congruence.
-Qed.
-
-Inductive match_pc (f: function) (app: D.t): nat -> node -> node -> Prop :=
+ vmatch bc v a ->
+ bc sp = BCstack ->
+ genv_match bc ge ->
+ exists v', eval_operation tge (Vptr sp Int.zero) op nil m = Some v' /\ Val.lessdef v v'.
+Proof.
+ unfold const_for_result; intros.
+ destruct a; try discriminate.
+- (* integer *)
+ inv H. inv H0. exists (Vint n); auto.
+- (* float *)
+ destruct (generate_float_constants tt); inv H. inv H0. exists (Vfloat f); auto.
+- (* pointer *)
+ destruct p; try discriminate.
+ + (* global *)
+ inv H. exists (symbol_address ge id ofs); split.
+ unfold symbol_address. rewrite <- symbols_preserved. reflexivity.
+ eapply vmatch_ptr_gl; eauto.
+ + (* stack *)
+ inv H. exists (Vptr sp ofs); split.
+ simpl; rewrite Int.add_zero_l; auto.
+ eapply vmatch_ptr_stk; eauto.
+Qed.
+
+Inductive match_pc (f: function) (ae: AE.t): nat -> node -> node -> Prop :=
| match_pc_base: forall n pc,
- match_pc f app n pc pc
+ match_pc f ae n pc pc
| match_pc_nop: forall n pc s pcx,
f.(fn_code)!pc = Some (Inop s) ->
- match_pc f app n s pcx ->
- match_pc f app (Datatypes.S n) pc pcx
- | match_pc_cond: forall n pc cond args s1 s2 b,
+ match_pc f ae n s pcx ->
+ match_pc f ae (S n) pc pcx
+ | match_pc_cond: forall n pc cond args s1 s2 b pcx,
f.(fn_code)!pc = Some (Icond cond args s1 s2) ->
- eval_static_condition cond (approx_regs app args) = Some b ->
- match_pc f app (Datatypes.S n) pc (if b then s1 else s2).
+ resolve_branch (eval_static_condition cond (aregs ae args)) = Some b ->
+ match_pc f ae n (if b then s1 else s2) pcx ->
+ match_pc f ae (S n) pc pcx.
Lemma match_successor_rec:
- forall f app n pc, match_pc f app n pc (successor_rec n f app pc).
+ forall f ae n pc, match_pc f ae n pc (successor_rec n f ae pc).
Proof.
induction n; simpl; intros.
- apply match_pc_base.
- destruct (fn_code f)!pc as [i|] eqn:?; try apply match_pc_base.
- destruct i; try apply match_pc_base.
- eapply match_pc_nop; eauto.
- destruct (eval_static_condition c (approx_regs app l)) as [b|] eqn:?.
+- apply match_pc_base.
+- destruct (fn_code f)!pc as [[]|] eqn:INSTR; try apply match_pc_base.
+ eapply match_pc_nop; eauto.
+ destruct (resolve_branch (eval_static_condition c (aregs ae l))) as [b|] eqn:COND.
eapply match_pc_cond; eauto.
apply match_pc_base.
Qed.
Lemma match_successor:
- forall f app pc, match_pc f app num_iter pc (successor f app pc).
+ forall f ae pc, match_pc f ae num_iter pc (successor f ae pc).
Proof.
unfold successor; intros. apply match_successor_rec.
Qed.
Section BUILTIN_STRENGTH_REDUCTION.
-Variable app: D.t.
-Variable sp: val.
+
+Variable bc: block_classification.
+Hypothesis GE: genv_match bc ge.
+Variable ae: AE.t.
Variable rs: regset.
-Hypothesis MATCH: forall r, val_match_approx ge sp (approx_reg app r) rs#r.
+Hypothesis MATCH: ematch bc rs ae.
Lemma annot_strength_reduction_correct:
forall targs args targs' args' eargs,
- annot_strength_reduction app targs args = (targs', args') ->
+ annot_strength_reduction ae targs args = (targs', args') ->
eventval_list_match ge eargs (annot_args_typ targs) rs##args ->
exists eargs',
eventval_list_match ge eargs' (annot_args_typ targs') rs##args'
@@ -507,7 +221,7 @@ Proof.
- inv H. simpl. exists eargs; auto.
- destruct a.
+ destruct args as [ | arg args0]; simpl in H0; inv H0.
- destruct (annot_strength_reduction app targs args0) as [targs'' args''] eqn:E.
+ destruct (annot_strength_reduction ae targs args0) as [targs'' args''] eqn:E.
exploit IHtargs; eauto. intros [eargs'' [A B]].
assert (DFL:
exists eargs',
@@ -517,41 +231,48 @@ Proof.
exists (ev1 :: eargs''); split.
simpl; constructor; auto. simpl. congruence.
}
- destruct ty; destruct (approx_reg app arg) as [] eqn:E2; inv H; auto.
- * exists eargs''; split; auto; simpl; f_equal; auto.
- generalize (MATCH arg); rewrite E2; simpl; intros E3;
- rewrite E3 in H5; inv H5; auto.
+ destruct ty; destruct (areg ae arg) as [] eqn:E2; inv H; auto.
+ * exists eargs''; split; auto; simpl; f_equal; auto.
+ generalize (MATCH arg); fold (areg ae arg); rewrite E2; intros VM.
+ inv VM. rewrite <- H0 in *. inv H5; auto.
* destruct (generate_float_constants tt); inv H1; auto.
- exists eargs''; split; auto; simpl; f_equal; auto.
- generalize (MATCH arg); rewrite E2; simpl; intros E3;
- rewrite E3 in H5; inv H5; auto.
- + destruct (annot_strength_reduction app targs args) as [targs'' args''] eqn:E.
+ exists eargs''; split; auto; simpl; f_equal; auto.
+ generalize (MATCH arg); fold (areg ae arg); rewrite E2; intros VM.
+ inv VM. rewrite <- H0 in *. inv H5; auto.
+ + destruct (annot_strength_reduction ae targs args) as [targs'' args''] eqn:E.
inv H.
exploit IHtargs; eauto. intros [eargs'' [A B]].
exists eargs''; simpl; split; auto. congruence.
- + destruct (annot_strength_reduction app targs args) as [targs'' args''] eqn:E.
+ + destruct (annot_strength_reduction ae targs args) as [targs'' args''] eqn:E.
inv H.
exploit IHtargs; eauto. intros [eargs'' [A B]].
exists eargs''; simpl; split; auto. congruence.
Qed.
+Lemma vmatch_ptr_gl':
+ forall v id ofs,
+ vmatch bc v (Ptr (Gl id ofs)) ->
+ v = Vundef \/ exists b, Genv.find_symbol ge id = Some b /\ v = Vptr b ofs.
+Proof.
+ intros. inv H; auto. inv H2. right; exists b; split; auto. eapply GE; eauto.
+Qed.
+
Lemma builtin_strength_reduction_correct:
forall ef args m t vres m',
external_call ef ge rs##args m t vres m' ->
- let (ef', args') := builtin_strength_reduction app ef args in
+ let (ef', args') := builtin_strength_reduction ae ef args in
external_call ef' ge rs##args' m t vres m'.
Proof.
- intros until m'. functional induction (builtin_strength_reduction app ef args); intros; auto.
-+ generalize (MATCH r1); rewrite e1; simpl; intros E. simpl in H.
- unfold symbol_address in E. destruct (Genv.find_symbol ge symb) as [b|] eqn:?; rewrite E in H.
- rewrite volatile_load_global_charact. exists b; auto.
- inv H.
-+ generalize (MATCH r1); rewrite e1; simpl; intros E. simpl in H.
- unfold symbol_address in E. destruct (Genv.find_symbol ge symb) as [b|] eqn:?; rewrite E in H.
- rewrite volatile_store_global_charact. exists b; auto.
- inv H.
-+ inv H. exploit annot_strength_reduction_correct; eauto.
- intros [eargs' [A B]].
+ intros until m'. functional induction (builtin_strength_reduction ae ef args); intros; auto.
++ simpl in H. assert (V: vmatch bc (rs#r1) (Ptr (Gl symb n1))) by (rewrite <- e1; apply MATCH).
+ exploit vmatch_ptr_gl'; eauto. intros [A | [b [A B]]].
+ * simpl in H; rewrite A in H; inv H.
+ * simpl; rewrite volatile_load_global_charact. exists b; split; congruence.
++ simpl in H. assert (V: vmatch bc (rs#r1) (Ptr (Gl symb n1))) by (rewrite <- e1; apply MATCH).
+ exploit vmatch_ptr_gl'; eauto. intros [A | [b [A B]]].
+ * simpl in H; rewrite A in H; inv H.
+ * simpl; rewrite volatile_store_global_charact. exists b; split; congruence.
++ inv H. exploit annot_strength_reduction_correct; eauto. intros [eargs' [A B]].
rewrite <- B. econstructor; eauto.
Qed.
@@ -575,9 +296,8 @@ End BUILTIN_STRENGTH_REDUCTION.
and an initial state [st2] in the transformed code.
This invariant expresses that all code fragments appearing in [st2]
are obtained by [transf_code] transformation of the corresponding
- fragments in [st1]. Moreover, the values of registers in [st1]
- must match their compile-time approximations at the current program
- point.
+ fragments in [st1]. Moreover, the state [st1] must match its compile-time
+ approximations at the current program point.
These two parts of the diagram are the hypotheses. In conclusions,
we want to prove the other two parts: the right vertical arrow,
which is a transition in the transformed RTL code, and the bottom
@@ -588,72 +308,63 @@ Inductive match_stackframes: stackframe -> stackframe -> Prop :=
match_stackframe_intro:
forall res sp pc rs f rs',
regs_lessdef rs rs' ->
- (forall v, regs_match_approx sp (analyze gapp f)!!pc (rs#res <- v)) ->
match_stackframes
(Stackframe res f sp pc rs)
- (Stackframe res (transf_function gapp f) sp pc rs').
+ (Stackframe res (transf_function rm f) sp pc rs').
Inductive match_states: nat -> state -> state -> Prop :=
| match_states_intro:
- forall s sp pc rs m f s' pc' rs' m' app n
- (MATCH1: regs_match_approx sp app rs)
- (MATCH2: regs_match_approx sp (analyze gapp f)!!pc rs)
- (GMATCH: mem_match_approx m)
+ forall s sp pc rs m f s' pc' rs' m' bc ae n
+ (MATCH: ematch bc rs ae)
(STACKS: list_forall2 match_stackframes s s')
- (PC: match_pc f app n pc pc')
+ (PC: match_pc f ae n pc pc')
(REGS: regs_lessdef rs rs')
(MEM: Mem.extends m m'),
match_states n (State s f sp pc rs m)
- (State s' (transf_function gapp f) sp pc' rs' m')
+ (State s' (transf_function rm f) sp pc' rs' m')
| match_states_call:
forall s f args m s' args' m'
- (GMATCH: mem_match_approx m)
(STACKS: list_forall2 match_stackframes s s')
(ARGS: Val.lessdef_list args args')
(MEM: Mem.extends m m'),
match_states O (Callstate s f args m)
- (Callstate s' (transf_fundef gapp f) args' m')
+ (Callstate s' (transf_fundef rm f) args' m')
| match_states_return:
forall s v m s' v' m'
- (GMATCH: mem_match_approx 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 O (Returnstate s v m)
- (Returnstate s' v' m').
+ (Returnstate s' v' m').
Lemma match_states_succ:
- forall s f sp pc2 rs m s' rs' m' pc1 i,
- f.(fn_code)!pc1 = Some i ->
- In pc2 (successors_instr i) ->
- regs_match_approx sp (transfer gapp f pc1 (analyze gapp f)!!pc1) rs ->
- mem_match_approx m ->
+ forall s f sp pc rs m s' rs' m',
+ sound_state prog (State s f sp pc rs m) ->
list_forall2 match_stackframes s s' ->
regs_lessdef rs rs' ->
Mem.extends m m' ->
- match_states O (State s f sp pc2 rs m)
- (State s' (transf_function gapp f) sp pc2 rs' m').
+ match_states O (State s f sp pc rs m)
+ (State s' (transf_function rm f) sp pc rs' m').
Proof.
- intros.
- assert (regs_match_approx sp (analyze gapp f)!!pc2 rs).
- eapply analyze_correct_1; eauto.
- apply match_states_intro with (app := (analyze gapp f)!!pc2); auto.
+ intros. inv H.
+ apply match_states_intro with (bc := bc) (ae := ae); auto.
constructor.
Qed.
Lemma transf_instr_at:
forall f pc i,
f.(fn_code)!pc = Some i ->
- (transf_function gapp f).(fn_code)!pc = Some(transf_instr gapp f (analyze gapp f) pc i).
+ (transf_function rm f).(fn_code)!pc = Some(transf_instr f (analyze rm f) rm pc i).
Proof.
- intros. simpl. unfold transf_code. rewrite PTree.gmap. rewrite H. auto.
+ intros. simpl. rewrite PTree.gmap. rewrite H. auto.
Qed.
Ltac TransfInstr :=
match goal with
- | H: (PTree.get ?pc (fn_code ?f) = Some ?instr) |- _ =>
- generalize (transf_instr_at _ _ _ H); simpl
+ | H1: (PTree.get ?pc (fn_code ?f) = Some ?instr),
+ H2: (analyze (romem_for_program prog) ?f)#?pc = VA.State ?ae ?am |- _ =>
+ fold rm in H2; generalize (transf_instr_at _ _ _ H1); unfold transf_instr; rewrite H2
end.
(** The proof of simulation proceeds by case analysis on the transition
@@ -662,113 +373,107 @@ Ltac TransfInstr :=
Lemma transf_step_correct:
forall s1 t s2,
step ge s1 t s2 ->
- forall n1 s1' (MS: match_states n1 s1 s1'),
+ forall n1 s1' (SS1: sound_state prog s1) (SS2: sound_state prog s2) (MS: match_states n1 s1 s1'),
(exists n2, exists s2', step tge s1' t s2' /\ match_states n2 s2 s2')
\/ (exists n2, n2 < n1 /\ t = E0 /\ match_states n2 s2 s1')%nat.
Proof.
- induction 1; intros; inv MS; try (inv PC; try congruence).
+ induction 1; intros; inv SS1; inv MS; try (inv PC; try congruence).
(* Inop, preserved *)
- rename pc'0 into pc. TransfInstr; intro.
+ rename pc'0 into pc. TransfInstr; intros.
left; econstructor; econstructor; split.
eapply exec_Inop; eauto.
- eapply match_states_succ; eauto. simpl; auto.
- unfold transfer; rewrite H. auto.
+ eapply match_states_succ; eauto.
(* Inop, skipped over *)
- rewrite H0 in H; inv H.
+ assert (s0 = pc') by congruence. subst s0.
right; exists n; split. omega. split. auto.
- apply match_states_intro with app; auto.
- eapply analyze_correct_1; eauto. simpl; auto.
- unfold transfer; rewrite H0. auto.
+ apply match_states_intro with bc0 ae0; auto.
(* Iop *)
rename pc'0 into pc. TransfInstr.
- set (app_before := (analyze gapp f)#pc).
- set (a := eval_static_operation op (approx_regs app_before args)).
- set (app_after := D.set res a app_before).
- assert (VMATCH: val_match_approx ge sp a v).
- eapply eval_static_operation_correct; eauto.
- apply approx_regs_val_list; auto.
- assert (MATCH': regs_match_approx sp app_after rs#res <- v).
- apply regs_match_approx_update; auto.
- assert (MATCH'': regs_match_approx sp (analyze gapp f) # pc' rs # res <- v).
- eapply analyze_correct_1 with (pc := pc); eauto. simpl; auto.
- unfold transfer; rewrite H. auto.
+ set (a := eval_static_operation op (aregs ae args)).
+ set (ae' := AE.set res a ae).
+ assert (VMATCH: vmatch bc v a) by (eapply eval_static_operation_sound; eauto with va).
+ assert (MATCH': ematch bc (rs#res <- v) ae') by (eapply ematch_update; eauto).
destruct (const_for_result a) as [cop|] eqn:?; intros.
(* constant is propagated *)
+ exploit const_for_result_correct; eauto. intros (v' & A & B).
left; econstructor; econstructor; split.
eapply exec_Iop; eauto.
- eapply const_for_result_correct; eauto.
- apply match_states_intro with app_after; auto.
+ apply match_states_intro with bc ae'; auto.
apply match_successor.
apply set_reg_lessdef; auto.
(* operator is strength-reduced *)
- exploit op_strength_reduction_correct. eexact MATCH2. reflexivity. eauto.
- fold app_before.
- destruct (op_strength_reduction op args (approx_regs app_before 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.
+ assert(OP:
+ let (op', args') := op_strength_reduction op args (aregs ae args) in
+ exists v',
+ eval_operation ge (Vptr sp0 Int.zero) op' rs ## args' m = Some v' /\
+ Val.lessdef v v').
+ { eapply op_strength_reduction_correct with (ae := ae); eauto with va. }
+ destruct (op_strength_reduction op args (aregs ae args)) as [op' args'].
+ destruct OP as [v' [EV' LD']].
+ assert (EV'': exists v'', eval_operation ge (Vptr sp0 Int.zero) op' rs'##args' m' = Some v'' /\ Val.lessdef v' v'').
+ { eapply eval_operation_lessdef; eauto. eapply regs_lessdef_regs; eauto. }
destruct EV'' as [v'' [EV'' LD'']].
left; econstructor; econstructor; split.
eapply exec_Iop; eauto.
erewrite eval_operation_preserved. eexact EV''. exact symbols_preserved.
- apply match_states_intro with app_after; auto.
+ apply match_states_intro with bc ae'; auto.
apply match_successor.
apply set_reg_lessdef; auto. eapply Val.lessdef_trans; eauto.
(* Iload *)
- rename pc'0 into pc. TransfInstr.
- set (ap1 := eval_static_addressing addr
- (approx_regs (analyze gapp f) # pc args)).
- set (ap2 := eval_static_load gapp chunk ap1).
- assert (VM1: val_match_approx ge sp ap1 a).
- eapply eval_static_addressing_correct; eauto.
- eapply approx_regs_val_list; eauto.
- assert (VM2: val_match_approx ge sp ap2 v).
- eapply eval_static_load_sound; eauto.
- destruct (const_for_result ap2) as [cop|] eqn:?; intros.
+ rename pc'0 into pc. TransfInstr.
+ set (aa := eval_static_addressing addr (aregs ae args)).
+ assert (VM1: vmatch bc a aa) by (eapply eval_static_addressing_sound; eauto with va).
+ set (av := loadv chunk rm am aa).
+ assert (VM2: vmatch bc v av) by (eapply loadv_sound; eauto).
+ destruct (const_for_result av) as [cop|] eqn:?; intros.
(* constant-propagated *)
+ exploit const_for_result_correct; eauto. intros (v' & A & B).
left; econstructor; econstructor; split.
- eapply exec_Iop; eauto. eapply const_for_result_correct; eauto.
- eapply match_states_succ; eauto. simpl; auto.
- unfold transfer; rewrite H. apply regs_match_approx_update; auto.
+ eapply exec_Iop; eauto.
+ eapply match_states_succ; eauto.
apply set_reg_lessdef; auto.
(* strength-reduced *)
- generalize (addr_strength_reduction_correct ge sp (analyze gapp f)!!pc rs
- MATCH2 addr args (approx_regs (analyze gapp f) # pc args) (refl_equal _)).
- destruct (addr_strength_reduction addr args (approx_regs (analyze gapp f) # pc args)) as [addr' args'].
- rewrite H0. intros 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]].
+ assert (ADDR:
+ let (addr', args') := addr_strength_reduction addr args (aregs ae args) in
+ exists a',
+ eval_addressing ge (Vptr sp0 Int.zero) addr' rs ## args' = Some a' /\
+ Val.lessdef a a').
+ { eapply addr_strength_reduction_correct with (ae := ae); eauto with va. }
+ destruct (addr_strength_reduction addr args (aregs ae args)) as [addr' args'].
+ destruct ADDR as (a' & P & Q).
+ exploit eval_addressing_lessdef. eapply regs_lessdef_regs; eauto. eexact P.
+ intros (a'' & U & V).
+ assert (W: eval_addressing tge (Vptr sp0 Int.zero) addr' rs'##args' = Some a'').
+ { rewrite <- U. apply eval_addressing_preserved. exact symbols_preserved. }
+ exploit Mem.loadv_extends. eauto. eauto. apply Val.lessdef_trans with a'; eauto.
+ intros (v' & X & Y).
left; econstructor; econstructor; split.
eapply exec_Iload; eauto.
- eapply match_states_succ; eauto. simpl; auto.
- unfold transfer; rewrite H. apply regs_match_approx_update; auto.
- apply set_reg_lessdef; auto.
+ eapply match_states_succ; eauto. apply set_reg_lessdef; auto.
(* Istore *)
rename pc'0 into pc. TransfInstr.
- generalize (addr_strength_reduction_correct ge sp (analyze gapp f)!!pc rs
- MATCH2 addr args (approx_regs (analyze gapp f) # pc args) (refl_equal _)).
- destruct (addr_strength_reduction addr args (approx_regs (analyze gapp 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]].
+ assert (ADDR:
+ let (addr', args') := addr_strength_reduction addr args (aregs ae args) in
+ exists a',
+ eval_addressing ge (Vptr sp0 Int.zero) addr' rs ## args' = Some a' /\
+ Val.lessdef a a').
+ { eapply addr_strength_reduction_correct with (ae := ae); eauto with va. }
+ destruct (addr_strength_reduction addr args (aregs ae args)) as [addr' args'].
+ destruct ADDR as (a' & P & Q).
+ exploit eval_addressing_lessdef. eapply regs_lessdef_regs; eauto. eexact P.
+ intros (a'' & U & V).
+ assert (W: eval_addressing tge (Vptr sp0 Int.zero) addr' rs'##args' = Some a'').
+ { rewrite <- U. apply eval_addressing_preserved. exact symbols_preserved. }
+ exploit Mem.storev_extends. eauto. eauto. apply Val.lessdef_trans with a'; eauto. apply REGS.
+ intros (m2' & X & Y).
left; econstructor; econstructor; split.
eapply exec_Istore; eauto.
- eapply match_states_succ; eauto. simpl; auto.
- unfold transfer; rewrite H. auto.
- eapply mem_match_approx_store; eauto.
+ eapply match_states_succ; eauto.
(* Icall *)
rename pc'0 into pc.
@@ -777,10 +482,7 @@ Proof.
left; econstructor; econstructor; split.
eapply exec_Icall; eauto. apply sig_function_translated; auto.
constructor; auto. constructor; auto.
- econstructor; eauto.
- intros. eapply analyze_correct_1; eauto. simpl; auto.
- unfold transfer; rewrite H.
- apply regs_match_approx_update; auto. simpl. auto.
+ econstructor; eauto.
apply regs_lessdef_regs; auto.
(* Itailcall *)
@@ -790,7 +492,6 @@ Proof.
left; econstructor; econstructor; split.
eapply exec_Itailcall; eauto. apply sig_function_translated; auto.
constructor; auto.
- eapply mem_match_approx_free; eauto.
apply regs_lessdef_regs; auto.
(* Ibuiltin *)
@@ -798,7 +499,7 @@ Proof.
Opaque builtin_strength_reduction.
exploit builtin_strength_reduction_correct; eauto.
TransfInstr.
- destruct (builtin_strength_reduction (analyze gapp f)#pc ef args) as [ef' args'].
+ destruct (builtin_strength_reduction ae ef args) as [ef' args'].
intros P Q.
exploit external_call_mem_extends; eauto.
instantiate (1 := rs'##args'). apply regs_lessdef_regs; auto.
@@ -808,74 +509,68 @@ Opaque builtin_strength_reduction.
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
eapply match_states_succ; eauto. simpl; auto.
- unfold transfer; rewrite H.
- apply regs_match_approx_update; auto. simpl; auto.
- eapply mem_match_approx_extcall; eauto.
apply set_reg_lessdef; auto.
(* Icond, preserved *)
- rename pc'0 into pc. TransfInstr.
- generalize (cond_strength_reduction_correct ge sp (analyze gapp f)#pc rs m
- MATCH2 cond args (approx_regs (analyze gapp f) # pc args) (refl_equal _)).
- destruct (cond_strength_reduction cond args (approx_regs (analyze gapp f) # pc args)) as [cond' args'].
+ rename pc' into pc. TransfInstr.
+ set (ac := eval_static_condition cond (aregs ae args)).
+ assert (C: cmatch (eval_condition cond rs ## args m) ac)
+ by (eapply eval_static_condition_sound; eauto with va).
+ rewrite H0 in C.
+ generalize (cond_strength_reduction_correct bc ae rs m EM cond args (aregs ae args) (refl_equal _)).
+ destruct (cond_strength_reduction cond args (aregs ae args)) as [cond' args'].
intros EV1 TCODE.
- left; exists O; exists (State s' (transf_function gapp f) sp (if b then ifso else ifnot) rs' m'); split.
- destruct (eval_static_condition cond (approx_regs (analyze gapp f) # pc args)) 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.
+ left; exists O; exists (State s' (transf_function rm f) (Vptr sp0 Int.zero) (if b then ifso else ifnot) rs' m'); split.
+ destruct (resolve_branch ac) eqn: RB.
+ assert (b0 = b) by (eapply resolve_branch_sound; eauto). subst b0.
destruct b; eapply exec_Inop; eauto.
eapply exec_Icond; eauto.
eapply eval_condition_lessdef with (vl1 := rs##args'); eauto. eapply regs_lessdef_regs; eauto. congruence.
eapply match_states_succ; eauto.
- destruct b; simpl; auto.
- unfold transfer; rewrite H. auto.
(* Icond, skipped over *)
rewrite H1 in H; inv H.
- 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.
- right; exists n; split. omega. split. auto.
- assert (MATCH': regs_match_approx sp (analyze gapp f) # (if b then ifso else ifnot) rs).
- eapply analyze_correct_1; eauto. destruct b; simpl; auto.
- unfold transfer; rewrite H1; auto.
- econstructor; eauto. constructor.
+ set (ac := eval_static_condition cond (aregs ae0 args)) in *.
+ assert (C: cmatch (eval_condition cond rs ## args m) ac)
+ by (eapply eval_static_condition_sound; eauto with va).
+ rewrite H0 in C.
+ assert (b0 = b) by (eapply resolve_branch_sound; eauto). subst b0.
+ right; exists n; split. omega. split. auto.
+ econstructor; eauto.
(* Ijumptable *)
rename pc'0 into pc.
- assert (A: (fn_code (transf_function gapp f))!pc = Some(Ijumptable arg tbl)
- \/ (fn_code (transf_function gapp f))!pc = Some(Inop pc')).
- TransfInstr. destruct (approx_reg (analyze gapp f) # pc arg) eqn:?; auto.
- generalize (MATCH2 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.
- left; exists O; exists (State s' (transf_function gapp f) sp pc' rs' m'); split.
+ assert (A: (fn_code (transf_function rm f))!pc = Some(Ijumptable arg tbl)
+ \/ (fn_code (transf_function rm f))!pc = Some(Inop pc')).
+ { TransfInstr.
+ destruct (areg ae arg) eqn:A; auto.
+ generalize (EM arg). fold (areg ae arg); rewrite A.
+ intros V; inv V. replace n0 with n by congruence.
+ rewrite H1. auto. }
+ assert (rs'#arg = Vint n).
+ { generalize (REGS arg). rewrite H0. intros LD; inv LD; auto. }
+ left; exists O; exists (State s' (transf_function rm f) (Vptr sp0 Int.zero) pc' rs' m'); split.
destruct A. eapply exec_Ijumptable; eauto. eapply exec_Inop; eauto.
eapply match_states_succ; eauto.
- simpl. eapply list_nth_z_in; eauto.
- unfold transfer; rewrite H; auto.
(* Ireturn *)
exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]].
left; exists O; exists (Returnstate s' (regmap_optget or Vundef rs') m2'); split.
eapply exec_Ireturn; eauto. TransfInstr; auto.
constructor; auto.
- eapply mem_match_approx_free; eauto.
destruct or; simpl; auto.
(* internal function *)
exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl.
intros [m2' [A B]].
+ assert (X: exists bc ae, ematch bc (init_regs args (fn_params f)) ae).
+ { inv SS2. exists bc0; exists ae; auto. }
+ destruct X as (bc1 & ae1 & MATCH).
simpl. unfold transf_function.
left; exists O; econstructor; split.
eapply exec_function_internal; simpl; eauto.
simpl. econstructor; eauto.
- apply analyze_correct_3; auto.
- apply analyze_correct_3; auto.
- eapply mem_match_approx_alloc; eauto.
- instantiate (1 := f). constructor.
+ constructor.
apply init_regs_lessdef; auto.
(* external function *)
@@ -886,9 +581,11 @@ Opaque builtin_strength_reduction.
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
constructor; auto.
- eapply mem_match_approx_extcall; eauto.
(* return *)
+ assert (X: exists bc ae, ematch bc (rs#res <- vres) ae).
+ { inv SS2. exists bc0; exists ae; auto. }
+ destruct X as (bc1 & ae1 & MATCH).
inv H4. inv H1.
left; exists O; econstructor; split.
eapply exec_return; eauto.
@@ -901,16 +598,14 @@ Lemma transf_initial_states:
Proof.
intros. inversion H.
exploit function_ptr_translated; eauto. intro FIND.
- exists O; exists (Callstate nil (transf_fundef gapp f) nil m0); split.
+ exists O; exists (Callstate nil (transf_fundef rm 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.
- eapply mem_match_approx_init; eauto.
- constructor. constructor. apply Mem.extends_refl.
+ constructor. constructor. constructor. apply Mem.extends_refl.
Qed.
Lemma transf_final_states:
@@ -926,16 +621,21 @@ Qed.
Theorem transf_program_correct:
forward_simulation (RTL.semantics prog) (RTL.semantics tprog).
Proof.
- eapply Forward_simulation with (fsim_order := lt); simpl.
- apply lt_wf.
- eexact transf_initial_states.
- eexact transf_final_states.
- fold ge; fold tge. intros.
- exploit transf_step_correct; eauto.
- intros [ [n2 [s2' [A B]]] | [n2 [A [B C]]]].
- exists n2; exists s2'; split; auto. left; apply plus_one; auto.
- exists n2; exists s2; split; auto. right; split; auto. subst t; apply star_refl.
- eexact symbols_preserved.
+ apply Forward_simulation with
+ (fsim_order := lt)
+ (fsim_match_states := fun n s1 s2 => sound_state prog s1 /\ match_states n s1 s2).
+- apply lt_wf.
+- simpl; intros. exploit transf_initial_states; eauto. intros (n & st2 & A & B).
+ exists n, st2; intuition. eapply sound_initial; eauto.
+- simpl; intros. destruct H. eapply transf_final_states; eauto.
+- simpl; intros. destruct H0.
+ assert (sound_state prog s1') by (eapply sound_step; eauto).
+ fold ge; fold tge.
+ exploit transf_step_correct; eauto.
+ intros [ [n2 [s2' [A B]]] | [n2 [A [B C]]]].
+ exists n2; exists s2'; split; auto. left; apply plus_one; auto.
+ exists n2; exists s2; split; auto. right; split; auto. subst t; apply star_refl.
+- eexact symbols_preserved.
Qed.
End PRESERVATION.
diff --git a/backend/Deadcode.v b/backend/Deadcode.v
new file mode 100644
index 0000000..9efeca1
--- /dev/null
+++ b/backend/Deadcode.v
@@ -0,0 +1,192 @@
+(* *********************************************************************)
+(* *)
+(* 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 unneeded computations over RTL. *)
+
+Require Import Coqlib.
+Require Import Errors.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Memory.
+Require Import Registers.
+Require Import Op.
+Require Import RTL.
+Require Import Lattice.
+Require Import Kildall.
+Require Import ValueDomain.
+Require Import ValueAnalysis.
+Require Import NeedDomain.
+Require Import NeedOp.
+
+(** * Part 1: the static analysis *)
+
+Definition add_need (r: reg) (nv: nval) (ne: nenv) : nenv :=
+ NE.set r (nlub nv (NE.get r ne)) ne.
+
+Fixpoint add_needs (rl: list reg) (nv: nval) (ne: nenv) : nenv :=
+ match rl with
+ | nil => ne
+ | r1 :: rs => add_need r1 nv (add_needs rs nv ne)
+ end.
+
+Definition add_ros_need (ros: reg + ident) (ne: nenv) : nenv :=
+ match ros with
+ | inl r => add_need r All ne
+ | inr s => ne
+ end.
+
+Definition add_opt_need (or: option reg) (ne: nenv) : nenv :=
+ match or with
+ | Some r => add_need r All ne
+ | None => ne
+ end.
+
+Definition kill (r: reg) (ne: nenv) : nenv := NE.set r Nothing ne.
+
+Definition is_dead (v: nval) :=
+ match v with Nothing => true | _ => false end.
+
+Definition is_int_zero (v: nval) :=
+ match v with I n => Int.eq n Int.zero | _ => false end.
+
+Function transfer_builtin (app: VA.t) (ef: external_function) (args: list reg) (res: reg)
+ (ne: NE.t) (nm: nmem) : NA.t :=
+ match ef, args with
+ | EF_vload chunk, a1::nil =>
+ (add_needs args All (kill res ne),
+ nmem_add nm (aaddr app a1) (size_chunk chunk))
+ | EF_vload_global chunk id ofs, nil =>
+ (add_needs args All (kill res ne),
+ nmem_add nm (Gl id ofs) (size_chunk chunk))
+ | EF_vstore chunk, a1::a2::nil =>
+ (add_need a1 All (add_need a2 (store_argument chunk) (kill res ne)), nm)
+ | EF_vstore_global chunk id ofs, a1::nil =>
+ (add_need a1 (store_argument chunk) (kill res ne), nm)
+ | EF_memcpy sz al, dst::src::nil =>
+ if nmem_contains nm (aaddr app dst) sz then
+ (add_needs args All (kill res ne),
+ nmem_add (nmem_remove nm (aaddr app dst) sz) (aaddr app src) sz)
+ else (ne, nm)
+ | EF_annot txt targs, _ =>
+ (add_needs args All (kill res ne), nm)
+ | EF_annot_val txt targ, _ =>
+ (add_needs args All (kill res ne), nm)
+ | _, _ =>
+ (add_needs args All (kill res ne), nmem_all)
+ end.
+
+Definition transfer (f: function) (approx: PMap.t VA.t)
+ (pc: node) (after: NA.t) : NA.t :=
+ let (ne, nm) := after in
+ match f.(fn_code)!pc with
+ | None =>
+ NA.bot
+ | Some (Inop s) =>
+ after
+ | Some (Iop op args res s) =>
+ let nres := nreg ne res in
+ if is_dead nres then after
+ else if is_int_zero nres then (kill res ne, nm)
+ else (add_needs args (needs_of_operation op nres) (kill res ne), nm)
+ | Some (Iload chunk addr args dst s) =>
+ let ndst := nreg ne dst in
+ if is_dead ndst then after
+ else if is_int_zero ndst then (kill dst ne, nm)
+ else (add_needs args All (kill dst ne),
+ nmem_add nm (aaddressing approx!!pc addr args) (size_chunk chunk))
+ | Some (Istore chunk addr args src s) =>
+ let p := aaddressing approx!!pc addr args in
+ if nmem_contains nm p (size_chunk chunk)
+ then (add_needs args All (add_need src (store_argument chunk) ne),
+ nmem_remove nm p (size_chunk chunk))
+ else after
+ | Some(Icall sig ros args res s) =>
+ (add_needs args All (add_ros_need ros (kill res ne)), nmem_all)
+ | Some(Itailcall sig ros args) =>
+ (add_needs args All (add_ros_need ros NE.bot),
+ nmem_dead_stack f.(fn_stacksize))
+ | Some(Ibuiltin ef args res s) =>
+ transfer_builtin approx!!pc ef args res ne nm
+ | Some(Icond cond args s1 s2) =>
+ (add_needs args (needs_of_condition cond) ne, nm)
+ | Some(Ijumptable arg tbl) =>
+ (add_need arg All ne, nm)
+ | Some(Ireturn optarg) =>
+ (add_opt_need optarg ne, nmem_dead_stack f.(fn_stacksize))
+ end.
+
+Module DS := Backward_Dataflow_Solver(NA)(NodeSetBackward).
+
+Definition analyze (approx: PMap.t VA.t) (f: function): option (PMap.t NA.t) :=
+ DS.fixpoint f.(fn_code) successors_instr
+ (transfer f approx).
+
+(** * Part 2: the code transformation *)
+
+Definition transf_instr (approx: PMap.t VA.t) (an: PMap.t NA.t)
+ (pc: node) (instr: instruction) :=
+ match instr with
+ | Iop op args res s =>
+ let nres := nreg (fst an!!pc) res in
+ if is_dead nres then
+ Inop s
+ else if is_int_zero nres then
+ Iop (Ointconst Int.zero) nil res s
+ else if operation_is_redundant op nres then
+ match args with arg :: _ => Iop Omove (arg :: nil) res s | nil => instr end
+ else
+ instr
+ | Iload chunk addr args dst s =>
+ let ndst := nreg (fst an!!pc) dst in
+ if is_dead ndst then
+ Inop s
+ else if is_int_zero ndst then
+ Iop (Ointconst Int.zero) nil dst s
+ else
+ instr
+ | Istore chunk addr args src s =>
+ let p := aaddressing approx!!pc addr args in
+ if nmem_contains (snd an!!pc) p (size_chunk chunk)
+ then instr
+ else Inop s
+ | Ibuiltin (EF_memcpy sz al) (dst :: src :: nil) res s =>
+ if nmem_contains (snd an!!pc) (aaddr approx!!pc dst) sz
+ then instr
+ else Inop s
+ | _ =>
+ instr
+ end.
+
+Definition vanalyze := ValueAnalysis.analyze.
+
+Definition transf_function (rm: romem) (f: function) : res function :=
+ let approx := vanalyze rm f in
+ match analyze approx f with
+ | Some an =>
+ OK {| fn_sig := f.(fn_sig);
+ fn_params := f.(fn_params);
+ fn_stacksize := f.(fn_stacksize);
+ fn_code := PTree.map (transf_instr approx an) f.(fn_code);
+ fn_entrypoint := f.(fn_entrypoint) |}
+ | None =>
+ Error (msg "Neededness analysis failed")
+ end.
+
+
+Definition transf_fundef (rm: romem) (fd: fundef) : res fundef :=
+ AST.transf_partial_fundef (transf_function rm) fd.
+
+Definition transf_program (p: program) : res program :=
+ transform_partial_program (transf_fundef (romem_for_program p)) p.
+
diff --git a/backend/Deadcodeproof.v b/backend/Deadcodeproof.v
new file mode 100644
index 0000000..deb8628
--- /dev/null
+++ b/backend/Deadcodeproof.v
@@ -0,0 +1,1014 @@
+(* *********************************************************************)
+(* *)
+(* 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 unneeded computations over RTL: correctness proof. *)
+
+Require Import Coqlib.
+Require Import Errors.
+Require Import Maps.
+Require Import IntvSets.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Events.
+Require Import Smallstep.
+Require Import Op.
+Require Import Registers.
+Require Import RTL.
+Require Import Lattice.
+Require Import Kildall.
+Require Import ValueDomain.
+Require Import ValueAnalysis.
+Require Import NeedDomain.
+Require Import NeedOp.
+Require Import Deadcode.
+
+(** * Relating the memory states *)
+
+(** The [magree] predicate is a variant of [Mem.extends] where we
+ allow the contents of the two memory states to differ arbitrarily
+ on some locations. The predicate [P] is true on the locations whose
+ contents must be in the [lessdef] relation. *)
+
+Definition locset := block -> Z -> Prop.
+
+Record magree (m1 m2: mem) (P: locset) : Prop := mk_magree {
+ ma_perm:
+ forall b ofs k p,
+ Mem.perm m1 b ofs k p ->
+ Mem.perm m2 b ofs k p;
+ ma_memval:
+ forall b ofs,
+ Mem.perm m1 b ofs Cur Readable ->
+ P b ofs ->
+ memval_lessdef (ZMap.get ofs (PMap.get b (Mem.mem_contents m1)))
+ (ZMap.get ofs (PMap.get b (Mem.mem_contents m2)));
+ ma_nextblock:
+ Mem.nextblock m2 = Mem.nextblock m1
+}.
+
+Lemma magree_monotone:
+ forall m1 m2 (P Q: locset),
+ magree m1 m2 P ->
+ (forall b ofs, Q b ofs -> P b ofs) ->
+ magree m1 m2 Q.
+Proof.
+ intros. destruct H. constructor; auto.
+Qed.
+
+Lemma mextends_agree:
+ forall m1 m2 P, Mem.extends m1 m2 -> magree m1 m2 P.
+Proof.
+ intros. destruct H. destruct mext_inj. constructor; intros.
+- replace ofs with (ofs + 0) by omega. eapply mi_perm; eauto. auto.
+- exploit mi_memval; eauto. unfold inject_id; eauto.
+ rewrite Zplus_0_r. auto.
+- auto.
+Qed.
+
+Lemma magree_extends:
+ forall m1 m2 (P: locset),
+ (forall b ofs, P b ofs) ->
+ magree m1 m2 P -> Mem.extends m1 m2.
+Proof.
+ intros. destruct H0. constructor; auto. constructor; unfold inject_id; intros.
+- inv H0. rewrite Zplus_0_r. eauto.
+- inv H0. apply Zdivide_0.
+- inv H0. rewrite Zplus_0_r. eapply ma_memval0; eauto.
+Qed.
+
+Lemma magree_loadbytes:
+ forall m1 m2 P b ofs n bytes,
+ magree m1 m2 P ->
+ Mem.loadbytes m1 b ofs n = Some bytes ->
+ (forall i, ofs <= i < ofs + n -> P b i) ->
+ exists bytes', Mem.loadbytes m2 b ofs n = Some bytes' /\ list_forall2 memval_lessdef bytes bytes'.
+Proof.
+ assert (GETN: forall c1 c2 n ofs,
+ (forall i, ofs <= i < ofs + Z.of_nat n -> memval_lessdef (ZMap.get i c1) (ZMap.get i c2)) ->
+ list_forall2 memval_lessdef (Mem.getN n ofs c1) (Mem.getN n ofs c2)).
+ {
+ induction n; intros; simpl.
+ constructor.
+ rewrite inj_S in H. constructor.
+ apply H. omega.
+ apply IHn. intros; apply H; omega.
+ }
+Local Transparent Mem.loadbytes.
+ unfold Mem.loadbytes; intros. destruct H.
+ destruct (Mem.range_perm_dec m1 b ofs (ofs + n) Cur Readable); inv H0.
+ rewrite pred_dec_true. econstructor; split; eauto.
+ apply GETN. intros. rewrite nat_of_Z_max in H.
+ assert (ofs <= i < ofs + n) by xomega.
+ apply ma_memval0; auto.
+ red; intros; eauto.
+Qed.
+
+Lemma magree_load:
+ forall m1 m2 P chunk b ofs v,
+ magree m1 m2 P ->
+ Mem.load chunk m1 b ofs = Some v ->
+ (forall i, ofs <= i < ofs + size_chunk chunk -> P b i) ->
+ exists v', Mem.load chunk m2 b ofs = Some v' /\ Val.lessdef v v'.
+Proof.
+ intros. exploit Mem.load_valid_access; eauto. intros [A B].
+ exploit Mem.load_loadbytes; eauto. intros [bytes [C D]].
+ exploit magree_loadbytes; eauto. intros [bytes' [E F]].
+ exists (decode_val chunk bytes'); split.
+ apply Mem.loadbytes_load; auto.
+ apply val_inject_id. subst v. apply decode_val_inject; auto.
+Qed.
+
+Lemma magree_storebytes_parallel:
+ forall m1 m2 (P Q: locset) b ofs bytes1 m1' bytes2,
+ magree m1 m2 P ->
+ Mem.storebytes m1 b ofs bytes1 = Some m1' ->
+ (forall b' i, Q b' i ->
+ b' <> b \/ i < ofs \/ ofs + Z_of_nat (length bytes1) <= i ->
+ P b' i) ->
+ list_forall2 memval_lessdef bytes1 bytes2 ->
+ exists m2', Mem.storebytes m2 b ofs bytes2 = Some m2' /\ magree m1' m2' Q.
+Proof.
+ assert (SETN: forall (access: Z -> Prop) bytes1 bytes2,
+ list_forall2 memval_lessdef bytes1 bytes2 ->
+ forall p c1 c2,
+ (forall i, access i -> i < p \/ p + Z.of_nat (length bytes1) <= i -> memval_lessdef (ZMap.get i c1) (ZMap.get i c2)) ->
+ forall q, access q ->
+ memval_lessdef (ZMap.get q (Mem.setN bytes1 p c1))
+ (ZMap.get q (Mem.setN bytes2 p c2))).
+ {
+ induction 1; intros; simpl.
+ - apply H; auto. simpl. omega.
+ - simpl length in H1; rewrite inj_S in H1.
+ apply IHlist_forall2; auto.
+ intros. rewrite ! ZMap.gsspec. destruct (ZIndexed.eq i p). auto.
+ apply H1; auto. unfold ZIndexed.t in *; omega.
+ }
+ intros.
+ destruct (Mem.range_perm_storebytes m2 b ofs bytes2) as [m2' ST2].
+ { erewrite <- list_forall2_length by eauto. red; intros.
+ eapply ma_perm; eauto.
+ eapply Mem.storebytes_range_perm; eauto. }
+ exists m2'; split; auto.
+ constructor; intros.
+- eapply Mem.perm_storebytes_1; eauto. eapply ma_perm; eauto.
+ eapply Mem.perm_storebytes_2; eauto.
+- rewrite (Mem.storebytes_mem_contents _ _ _ _ _ H0).
+ rewrite (Mem.storebytes_mem_contents _ _ _ _ _ ST2).
+ rewrite ! PMap.gsspec. destruct (peq b0 b).
++ subst b0. apply SETN with (access := fun ofs => Mem.perm m1' b ofs Cur Readable /\ Q b ofs); auto.
+ intros. destruct H5. eapply ma_memval; eauto.
+ eapply Mem.perm_storebytes_2; eauto.
+ apply H1; auto.
++ eapply ma_memval; eauto. eapply Mem.perm_storebytes_2; eauto. apply H1; auto.
+- rewrite (Mem.nextblock_storebytes _ _ _ _ _ H0).
+ rewrite (Mem.nextblock_storebytes _ _ _ _ _ ST2).
+ eapply ma_nextblock; eauto.
+Qed.
+
+Lemma magree_store_parallel:
+ forall m1 m2 (P Q: locset) chunk b ofs v1 m1' v2,
+ magree m1 m2 P ->
+ Mem.store chunk m1 b ofs v1 = Some m1' ->
+ vagree v1 v2 (store_argument chunk) ->
+ (forall b' i, Q b' i ->
+ b' <> b \/ i < ofs \/ ofs + size_chunk chunk <= i ->
+ P b' i) ->
+ exists m2', Mem.store chunk m2 b ofs v2 = Some m2' /\ magree m1' m2' Q.
+Proof.
+ intros.
+ exploit Mem.store_valid_access_3; eauto. intros [A B].
+ exploit Mem.store_storebytes; eauto. intros SB1.
+ exploit magree_storebytes_parallel. eauto. eauto.
+ instantiate (1 := Q). intros. rewrite encode_val_length in H4.
+ rewrite <- size_chunk_conv in H4. apply H2; auto.
+ eapply store_argument_sound; eauto.
+ intros [m2' [SB2 AG]].
+ exists m2'; split; auto.
+ apply Mem.storebytes_store; auto.
+Qed.
+
+Lemma magree_storebytes_left:
+ forall m1 m2 P b ofs bytes1 m1',
+ magree m1 m2 P ->
+ Mem.storebytes m1 b ofs bytes1 = Some m1' ->
+ (forall i, ofs <= i < ofs + Z_of_nat (length bytes1) -> ~(P b i)) ->
+ magree m1' m2 P.
+Proof.
+ intros. constructor; intros.
+- eapply ma_perm; eauto. eapply Mem.perm_storebytes_2; eauto.
+- rewrite (Mem.storebytes_mem_contents _ _ _ _ _ H0).
+ rewrite PMap.gsspec. destruct (peq b0 b).
++ subst b0. rewrite Mem.setN_outside. eapply ma_memval; eauto. eapply Mem.perm_storebytes_2; eauto.
+ destruct (zlt ofs0 ofs); auto. destruct (zle (ofs + Z.of_nat (length bytes1)) ofs0); try omega.
+ elim (H1 ofs0). omega. auto.
++ eapply ma_memval; eauto. eapply Mem.perm_storebytes_2; eauto.
+- rewrite (Mem.nextblock_storebytes _ _ _ _ _ H0).
+ eapply ma_nextblock; eauto.
+Qed.
+
+Lemma magree_store_left:
+ forall m1 m2 P chunk b ofs v1 m1',
+ magree m1 m2 P ->
+ Mem.store chunk m1 b ofs v1 = Some m1' ->
+ (forall i, ofs <= i < ofs + size_chunk chunk -> ~(P b i)) ->
+ magree m1' m2 P.
+Proof.
+ intros. eapply magree_storebytes_left; eauto.
+ eapply Mem.store_storebytes; eauto.
+ intros. rewrite encode_val_length in H2.
+ rewrite <- size_chunk_conv in H2. apply H1; auto.
+Qed.
+
+Lemma magree_free:
+ forall m1 m2 (P Q: locset) b lo hi m1',
+ magree m1 m2 P ->
+ Mem.free m1 b lo hi = Some m1' ->
+ (forall b' i, Q b' i ->
+ b' <> b \/ ~(lo <= i < hi) ->
+ P b' i) ->
+ exists m2', Mem.free m2 b lo hi = Some m2' /\ magree m1' m2' Q.
+Proof.
+ intros.
+ destruct (Mem.range_perm_free m2 b lo hi) as [m2' FREE].
+ red; intros. eapply ma_perm; eauto. eapply Mem.free_range_perm; eauto.
+ exists m2'; split; auto.
+ constructor; intros.
+- (* permissions *)
+ assert (Mem.perm m2 b0 ofs k p). { eapply ma_perm; eauto. eapply Mem.perm_free_3; eauto. }
+ exploit Mem.perm_free_inv; eauto. intros [[A B] | A]; auto.
+ subst b0. eelim Mem.perm_free_2. eexact H0. eauto. eauto.
+- (* contents *)
+ rewrite (Mem.free_result _ _ _ _ _ H0).
+ rewrite (Mem.free_result _ _ _ _ _ FREE).
+ simpl. eapply ma_memval; eauto. eapply Mem.perm_free_3; eauto.
+ apply H1; auto. destruct (eq_block b0 b); auto.
+ subst b0. right. red; intros. eelim Mem.perm_free_2. eexact H0. eauto. eauto.
+- (* nextblock *)
+ rewrite (Mem.free_result _ _ _ _ _ H0).
+ rewrite (Mem.free_result _ _ _ _ _ FREE).
+ simpl. eapply ma_nextblock; eauto.
+Qed.
+
+(** * Properties of the need environment *)
+
+Lemma add_need_ge:
+ forall r nv ne,
+ nge (NE.get r (add_need r nv ne)) nv /\ NE.ge (add_need r nv ne) ne.
+Proof.
+ intros. unfold add_need. split.
+ rewrite NE.gsspec; rewrite peq_true. apply nge_lub_l.
+ red. intros. rewrite NE.gsspec. destruct (peq p r).
+ subst. apply NVal.ge_lub_right.
+ apply NVal.ge_refl. apply NVal.eq_refl.
+Qed.
+
+Lemma add_needs_ge:
+ forall rl nv ne,
+ (forall r, In r rl -> nge (NE.get r (add_needs rl nv ne)) nv)
+ /\ NE.ge (add_needs rl nv ne) ne.
+Proof.
+ induction rl; simpl; intros.
+ split. tauto. apply NE.ge_refl. apply NE.eq_refl.
+ destruct (IHrl nv ne) as [A B].
+ split; intros.
+ destruct H. subst a. apply add_need_ge.
+ apply nge_trans with (NE.get r (add_needs rl nv ne)).
+ apply add_need_ge. apply A; auto.
+ eapply NE.ge_trans; eauto. apply add_need_ge.
+Qed.
+
+Lemma add_need_eagree:
+ forall e e' r nv ne, eagree e e' (add_need r nv ne) -> eagree e e' ne.
+Proof.
+ intros. eapply eagree_ge; eauto. apply add_need_ge.
+Qed.
+
+Lemma add_need_vagree:
+ forall e e' r nv ne, eagree e e' (add_need r nv ne) -> vagree e#r e'#r nv.
+Proof.
+ intros. eapply nge_agree. eapply add_need_ge. apply H.
+Qed.
+
+Lemma add_needs_eagree:
+ forall nv rl e e' ne, eagree e e' (add_needs rl nv ne) -> eagree e e' ne.
+Proof.
+ intros. eapply eagree_ge; eauto. apply add_needs_ge.
+Qed.
+
+Lemma add_needs_vagree:
+ forall nv rl e e' ne, eagree e e' (add_needs rl nv ne) -> vagree_list e##rl e'##rl nv.
+Proof.
+ intros. destruct (add_needs_ge rl nv ne) as [A B].
+ set (ne' := add_needs rl nv ne) in *.
+ revert A; generalize rl. induction rl0; simpl; intros.
+ constructor.
+ constructor. eapply nge_agree; eauto. apply IHrl0. auto.
+Qed.
+
+Lemma add_need_lessdef:
+ forall e e' r ne, eagree e e' (add_need r All ne) -> Val.lessdef e#r e'#r.
+Proof.
+ intros. apply lessdef_vagree. eapply add_need_vagree; eauto.
+Qed.
+
+Lemma add_needs_lessdef:
+ forall e e' rl ne, eagree e e' (add_needs rl All ne) -> Val.lessdef_list e##rl e'##rl.
+Proof.
+ intros. exploit add_needs_vagree; eauto.
+ generalize rl. induction rl0; simpl; intros V; inv V.
+ constructor.
+ constructor; auto.
+Qed.
+
+Lemma add_ros_need_eagree:
+ forall e e' ros ne, eagree e e' (add_ros_need ros ne) -> eagree e e' ne.
+Proof.
+ intros. destruct ros; simpl in *. eapply add_need_eagree; eauto. auto.
+Qed.
+
+Hint Resolve add_need_eagree add_need_vagree add_need_lessdef
+ add_needs_eagree add_needs_vagree add_needs_lessdef
+ add_ros_need_eagree: na.
+
+Lemma eagree_init_regs:
+ forall rl vl1 vl2 ne,
+ Val.lessdef_list vl1 vl2 ->
+ eagree (init_regs vl1 rl) (init_regs vl2 rl) ne.
+Proof.
+ induction rl; intros until ne; intros LD; simpl.
+- red; auto with na.
+- inv LD.
+ + red; auto with na.
+ + apply eagree_update; auto with na.
+Qed.
+
+(** * Basic properties of the translation *)
+
+Section PRESERVATION.
+
+Variable prog: program.
+Variable tprog: program.
+Hypothesis TRANSF: transf_program prog = OK tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+Let rm := romem_for_program prog.
+
+Lemma symbols_preserved:
+ forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
+Proof.
+ intro. unfold ge, tge.
+ apply Genv.find_symbol_transf_partial with (transf_fundef rm).
+ exact TRANSF.
+Qed.
+
+Lemma varinfo_preserved:
+ forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
+Proof.
+ intro. unfold ge, tge.
+ apply Genv.find_var_info_transf_partial with (transf_fundef rm).
+ exact TRANSF.
+Qed.
+
+Lemma functions_translated:
+ forall (v: val) (f: RTL.fundef),
+ Genv.find_funct ge v = Some f ->
+ exists tf,
+ Genv.find_funct tge v = Some tf /\ transf_fundef rm f = OK tf.
+Proof (Genv.find_funct_transf_partial (transf_fundef rm) _ TRANSF).
+
+Lemma function_ptr_translated:
+ forall (b: block) (f: RTL.fundef),
+ Genv.find_funct_ptr ge b = Some f ->
+ exists tf,
+ Genv.find_funct_ptr tge b = Some tf /\ transf_fundef rm f = OK tf.
+Proof (Genv.find_funct_ptr_transf_partial (transf_fundef rm) _ TRANSF).
+
+Lemma sig_function_translated:
+ forall f tf,
+ transf_fundef rm f = OK tf ->
+ funsig tf = funsig f.
+Proof.
+ intros; destruct f; monadInv H.
+ unfold transf_function in EQ.
+ destruct (analyze (vanalyze rm f) f); inv EQ; auto.
+ auto.
+Qed.
+
+Lemma stacksize_translated:
+ forall f tf,
+ transf_function rm f = OK tf -> tf.(fn_stacksize) = f.(fn_stacksize).
+Proof.
+ unfold transf_function; intros. destruct (analyze (vanalyze rm f) f); inv H; auto.
+Qed.
+
+Lemma transf_function_at:
+ forall f tf an pc instr,
+ transf_function rm f = OK tf ->
+ analyze (vanalyze rm f) f = Some an ->
+ f.(fn_code)!pc = Some instr ->
+ tf.(fn_code)!pc = Some(transf_instr (vanalyze rm f) an pc instr).
+Proof.
+ intros. unfold transf_function in H. rewrite H0 in H. inv H; simpl.
+ rewrite PTree.gmap. rewrite H1; auto.
+Qed.
+
+Lemma is_dead_sound_1:
+ forall nv, is_dead nv = true -> nv = Nothing.
+Proof.
+ destruct nv; simpl; congruence.
+Qed.
+
+Lemma is_dead_sound_2:
+ forall nv, is_dead nv = false -> nv <> Nothing.
+Proof.
+ intros; red; intros. subst nv; discriminate.
+Qed.
+
+Hint Resolve is_dead_sound_1 is_dead_sound_2: na.
+
+Lemma is_int_zero_sound:
+ forall nv, is_int_zero nv = true -> nv = I Int.zero.
+Proof.
+ unfold is_int_zero; destruct nv; try discriminate.
+ predSpec Int.eq Int.eq_spec m Int.zero; congruence.
+Qed.
+
+Lemma find_function_translated:
+ forall ros rs fd trs ne,
+ find_function ge ros rs = Some fd ->
+ eagree rs trs (add_ros_need ros ne) ->
+ exists tfd, find_function tge ros trs = Some tfd /\ transf_fundef rm fd = OK tfd.
+Proof.
+ intros. destruct ros as [r|id]; simpl in *.
+- assert (LD: Val.lessdef rs#r trs#r) by eauto with na. inv LD.
+ apply functions_translated; auto.
+ rewrite <- H2 in H; discriminate.
+- rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try discriminate.
+ apply function_ptr_translated; auto.
+Qed.
+
+(** * Semantic invariant *)
+
+Inductive match_stackframes: stackframe -> stackframe -> Prop :=
+ | match_stackframes_intro:
+ forall res f sp pc e tf te an
+ (FUN: transf_function rm f = OK tf)
+ (ANL: analyze (vanalyze rm f) f = Some an)
+ (RES: forall v tv,
+ Val.lessdef v tv ->
+ eagree (e#res <- v) (te#res<- tv)
+ (fst (transfer f (vanalyze rm f) pc an!!pc))),
+ match_stackframes (Stackframe res f (Vptr sp Int.zero) pc e)
+ (Stackframe res tf (Vptr sp Int.zero) pc te).
+
+Inductive match_states: state -> state -> Prop :=
+ | match_regular_states:
+ forall s f sp pc e m ts tf te tm an
+ (STACKS: list_forall2 match_stackframes s ts)
+ (FUN: transf_function rm f = OK tf)
+ (ANL: analyze (vanalyze rm f) f = Some an)
+ (ENV: eagree e te (fst (transfer f (vanalyze rm f) pc an!!pc)))
+ (MEM: magree m tm (nlive ge sp (snd (transfer f (vanalyze rm f) pc an!!pc)))),
+ match_states (State s f (Vptr sp Int.zero) pc e m)
+ (State ts tf (Vptr sp Int.zero) pc te tm)
+ | match_call_states:
+ forall s f args m ts tf targs tm
+ (STACKS: list_forall2 match_stackframes s ts)
+ (FUN: transf_fundef rm f = OK tf)
+ (ARGS: Val.lessdef_list args targs)
+ (MEM: Mem.extends m tm),
+ match_states (Callstate s f args m)
+ (Callstate ts tf targs tm)
+ | match_return_states:
+ forall s v m ts tv tm
+ (STACKS: list_forall2 match_stackframes s ts)
+ (RES: Val.lessdef v tv)
+ (MEM: Mem.extends m tm),
+ match_states (Returnstate s v m)
+ (Returnstate ts tv tm).
+
+(** [match_states] and CFG successors *)
+
+Lemma analyze_successors:
+ forall f an pc instr pc',
+ analyze (vanalyze rm f) f = Some an ->
+ f.(fn_code)!pc = Some instr ->
+ In pc' (successors_instr instr) ->
+ NA.ge an!!pc (transfer f (vanalyze rm f) pc' an!!pc').
+Proof.
+ intros. eapply DS.fixpoint_solution; eauto.
+ intros. unfold transfer; rewrite H2. destruct a. apply DS.L.eq_refl.
+Qed.
+
+Lemma match_succ_states:
+ forall s f sp pc e m ts tf te tm an pc' instr ne nm
+ (STACKS: list_forall2 match_stackframes s ts)
+ (FUN: transf_function rm f = OK tf)
+ (ANL: analyze (vanalyze rm f) f = Some an)
+ (INSTR: f.(fn_code)!pc = Some instr)
+ (SUCC: In pc' (successors_instr instr))
+ (ANPC: an!!pc = (ne, nm))
+ (ENV: eagree e te ne)
+ (MEM: magree m tm (nlive ge sp nm)),
+ match_states (State s f (Vptr sp Int.zero) pc' e m)
+ (State ts tf (Vptr sp Int.zero) pc' te tm).
+Proof.
+ intros. exploit analyze_successors; eauto. rewrite ANPC; simpl. intros [A B].
+ econstructor; eauto.
+ eapply eagree_ge; eauto.
+ eapply magree_monotone; eauto. intros; apply B; auto.
+Qed.
+
+(** Properties of volatile memory accesses *)
+
+(*
+Lemma transf_volatile_load:
+
+ forall s f sp pc e m te r tm nm chunk t v m',
+
+ volatile_load_sem chunk ge (addr :: nil) m t v m' ->
+ Val.lessdef addr taddr ->
+ genv_match bc ge ->
+ bc sp = BCstack ->
+ pmatch
+
+ sound_state prog (State s f (Vptr sp Int.zero) pc e m) ->
+ Val.lessdef e#r te#r ->
+ magree m tm
+ (nlive ge sp
+ (nmem_add nm (aaddr (vanalyze rm f) # pc r) (size_chunk chunk))) ->
+ m' = m /\
+ exists tv, volatile_load_sem chunk ge (te#r :: nil) tm t tv tm /\ Val.lessdef v tv.
+Proof.
+ intros. inv H2. split; auto. rewrite <- H3 in H0; inv H0. inv H4.
+- (* volatile *)
+ exists (Val.load_result chunk v0); split; auto.
+ constructor. constructor; auto.
+- (* not volatile *)
+ exploit magree_load; eauto.
+ exploit aaddr_sound; eauto. intros (bc & P & Q & R).
+ intros. eapply nlive_add; eauto.
+ intros (v' & P & Q).
+ exists v'; split. constructor. econstructor; eauto. auto.
+Qed.
+*)
+
+Lemma transf_volatile_store:
+ forall v1 v2 v1' v2' m tm chunk sp nm t v m',
+ volatile_store_sem chunk ge (v1::v2::nil) m t v m' ->
+ Val.lessdef v1 v1' ->
+ vagree v2 v2' (store_argument chunk) ->
+ magree m tm (nlive ge sp nm) ->
+ v = Vundef /\
+ exists tm', volatile_store_sem chunk ge (v1'::v2'::nil) tm t Vundef tm'
+ /\ magree m' tm' (nlive ge sp nm).
+Proof.
+ intros. inv H. split; auto.
+ inv H0. inv H9.
+- (* volatile *)
+ exists tm; split; auto. econstructor. econstructor; eauto.
+ eapply eventval_match_lessdef; eauto. apply store_argument_load_result; auto.
+- (* not volatile *)
+ exploit magree_store_parallel. eauto. eauto. eauto.
+ instantiate (1 := nlive ge sp nm). auto.
+ intros (tm' & P & Q).
+ exists tm'; split. econstructor. econstructor; eauto. auto.
+Qed.
+
+Lemma eagree_set_undef:
+ forall e1 e2 ne r, eagree e1 e2 ne -> eagree (e1#r <- Vundef) e2 ne.
+Proof.
+ intros; red; intros. rewrite PMap.gsspec. destruct (peq r0 r); auto with na.
+Qed.
+
+(** * The simulation diagram *)
+
+Theorem step_simulation:
+ forall S1 t S2, step ge S1 t S2 ->
+ forall S1', match_states S1 S1' -> sound_state prog S1 ->
+ exists S2', step tge S1' t S2' /\ match_states S2 S2'.
+Proof.
+
+Ltac TransfInstr :=
+ match goal with
+ | [INSTR: (fn_code _)!_ = Some _,
+ FUN: transf_function _ _ = OK _,
+ ANL: analyze _ _ = Some _ |- _ ] =>
+ generalize (transf_function_at _ _ _ _ _ FUN ANL INSTR);
+ intro TI;
+ unfold transf_instr in TI
+ end.
+
+Ltac UseTransfer :=
+ match goal with
+ | [INSTR: (fn_code _)!?pc = Some _,
+ ANL: analyze _ _ = Some ?an |- _ ] =>
+ destruct (an!!pc) as [ne nm] eqn:ANPC;
+ unfold transfer in *;
+ rewrite INSTR in *;
+ simpl in *
+ end.
+
+ induction 1; intros S1' MS SS; inv MS.
+
+- (* nop *)
+ TransfInstr; UseTransfer.
+ econstructor; split.
+ eapply exec_Inop; eauto.
+ eapply match_succ_states; eauto. simpl; auto.
+
+- (* op *)
+ TransfInstr; UseTransfer.
+ destruct (is_dead (nreg ne res)) eqn:DEAD;
+ [idtac|destruct (is_int_zero (nreg ne res)) eqn:INTZERO;
+ [idtac|destruct (operation_is_redundant op (nreg ne res)) eqn:REDUNDANT]].
++ (* dead instruction, turned into a nop *)
+ econstructor; split.
+ eapply exec_Inop; eauto.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update_dead; auto with na.
++ (* instruction with needs = [I Int.zero], turned into a load immediate of zero. *)
+ econstructor; split.
+ eapply exec_Iop with (v := Vint Int.zero); eauto.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; auto.
+ rewrite is_int_zero_sound by auto.
+ destruct v; simpl; auto. apply iagree_zero.
++ (* redundant operation *)
+ destruct args.
+ * (* kept as is because no arguments -- should never happen *)
+ simpl in *.
+ exploit needs_of_operation_sound. eapply ma_perm; eauto.
+ eauto. instantiate (1 := nreg ne res). eauto with na. eauto with na. intros [tv [A B]].
+ econstructor; split.
+ eapply exec_Iop with (v := tv); eauto.
+ rewrite <- A. apply eval_operation_preserved. exact symbols_preserved.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; auto.
+ * (* turned into a move *)
+ simpl in *.
+ exploit operation_is_redundant_sound. eauto. eauto. eapply add_need_vagree. eauto.
+ intros VA.
+ econstructor; split.
+ eapply exec_Iop; eauto. simpl; reflexivity.
+ eapply match_succ_states; eauto. simpl; auto.
+ eapply eagree_update; eauto with na.
++ (* preserved operation *)
+ simpl in *.
+ exploit needs_of_operation_sound. eapply ma_perm; eauto. eauto. eauto with na. eauto with na.
+ intros [tv [A B]].
+ econstructor; split.
+ eapply exec_Iop with (v := tv); eauto.
+ rewrite <- A. apply eval_operation_preserved. exact symbols_preserved.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto with na.
+
+- (* load *)
+ TransfInstr; UseTransfer.
+ destruct (is_dead (nreg ne dst)) eqn:DEAD;
+ [idtac|destruct (is_int_zero (nreg ne dst)) eqn:INTZERO];
+ simpl in *.
++ (* dead instruction, turned into a nop *)
+ econstructor; split.
+ eapply exec_Inop; eauto.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update_dead; auto with na.
++ (* instruction with needs = [I Int.zero], turned into a load immediate of zero. *)
+ econstructor; split.
+ eapply exec_Iop with (v := Vint Int.zero); eauto.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; auto.
+ rewrite is_int_zero_sound by auto.
+ destruct v; simpl; auto. apply iagree_zero.
++ (* preserved *)
+ exploit eval_addressing_lessdef. eapply add_needs_lessdef; eauto. eauto.
+ intros (ta & U & V). inv V; try discriminate.
+ destruct ta; simpl in H1; try discriminate.
+ exploit magree_load; eauto.
+ exploit aaddressing_sound; eauto. intros (bc & A & B & C).
+ intros. apply nlive_add with bc i; assumption.
+ intros (tv & P & Q).
+ econstructor; split.
+ eapply exec_Iload with (a := Vptr b i); eauto.
+ rewrite <- U. apply eval_addressing_preserved. exact symbols_preserved.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto with na.
+ eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto.
+
+- (* store *)
+ TransfInstr; UseTransfer.
+ destruct (nmem_contains nm (aaddressing (vanalyze rm f) # pc addr args)
+ (size_chunk chunk)) eqn:CONTAINS.
++ (* preserved *)
+ simpl in *.
+ exploit eval_addressing_lessdef. eapply add_needs_lessdef; eauto. eauto.
+ intros (ta & U & V). inv V; try discriminate.
+ destruct ta; simpl in H1; try discriminate.
+ exploit magree_store_parallel. eauto. eauto. instantiate (1 := te#src). eauto with na.
+ instantiate (1 := nlive ge sp0 nm).
+ exploit aaddressing_sound; eauto. intros (bc & A & B & C).
+ intros. apply nlive_remove with bc b i; assumption.
+ intros (tm' & P & Q).
+ econstructor; split.
+ eapply exec_Istore with (a := Vptr b i); eauto.
+ rewrite <- U. apply eval_addressing_preserved. exact symbols_preserved.
+ eapply match_succ_states; eauto. simpl; auto.
+ eauto with na.
++ (* dead instruction, turned into a nop *)
+ destruct a; simpl in H1; try discriminate.
+ econstructor; split.
+ eapply exec_Inop; eauto.
+ eapply match_succ_states; eauto. simpl; auto.
+ eapply magree_store_left; eauto.
+ exploit aaddressing_sound; eauto. intros (bc & A & B & C).
+ intros. eapply nlive_contains; eauto.
+
+- (* call *)
+ TransfInstr; UseTransfer.
+ exploit find_function_translated; eauto with na. intros (tfd & A & B).
+ econstructor; split.
+ eapply exec_Icall; eauto. apply sig_function_translated; auto.
+ constructor.
+ constructor; auto. econstructor; eauto.
+ intros.
+ edestruct analyze_successors; eauto. simpl; eauto.
+ eapply eagree_ge; eauto. rewrite ANPC. simpl.
+ apply eagree_update; eauto with na.
+ auto. eauto with na. eapply magree_extends; eauto. apply nlive_all.
+
+- (* tailcall *)
+ TransfInstr; UseTransfer.
+ exploit find_function_translated; eauto with na. intros (tfd & A & B).
+ exploit magree_free. eauto. eauto. instantiate (1 := nlive ge stk nmem_all).
+ intros; eapply nlive_dead_stack; eauto.
+ intros (tm' & C & D).
+ econstructor; split.
+ eapply exec_Itailcall; eauto. apply sig_function_translated; auto.
+ erewrite stacksize_translated by eauto. eexact C.
+ constructor; eauto with na. eapply magree_extends; eauto. apply nlive_all.
+
+- (* builtin *)
+ TransfInstr; UseTransfer. revert ENV MEM TI.
+ functional induction (transfer_builtin (vanalyze rm f)#pc ef args res ne nm);
+ simpl in *; intros.
++ (* volatile load *)
+ assert (LD: Val.lessdef rs#a1 te#a1) by eauto with na.
+ inv H0. rewrite <- H1 in LD; inv LD.
+ assert (X: exists tv, volatile_load ge chunk tm b ofs t tv /\ Val.lessdef v tv).
+ {
+ inv H2.
+ * exists (Val.load_result chunk v0); split; auto. constructor; auto.
+ * exploit magree_load; eauto.
+ exploit aaddr_sound; eauto. intros (bc & A & B & C).
+ intros. eapply nlive_add; eassumption.
+ intros (tv & P & Q).
+ exists tv; split; auto. constructor; auto.
+ }
+ destruct X as (tv & A & B).
+ econstructor; split.
+ eapply exec_Ibuiltin; eauto.
+ eapply external_call_symbols_preserved.
+ simpl. rewrite <- H4. constructor. eauto.
+ exact symbols_preserved. exact varinfo_preserved.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto with na.
+ eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto.
++ (* volatile global load *)
+ inv H0.
+ assert (X: exists tv, volatile_load ge chunk tm b ofs t tv /\ Val.lessdef v tv).
+ {
+ inv H2.
+ * exists (Val.load_result chunk v0); split; auto. constructor; auto.
+ * exploit magree_load; eauto.
+ inv SS. intros. eapply nlive_add; eauto. constructor. apply GE. auto.
+ intros (tv & P & Q).
+ exists tv; split; auto. constructor; auto.
+ }
+ destruct X as (tv & A & B).
+ econstructor; split.
+ eapply exec_Ibuiltin; eauto.
+ eapply external_call_symbols_preserved.
+ simpl. econstructor; eauto.
+ exact symbols_preserved. exact varinfo_preserved.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto with na.
+ eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto.
++ (* volatile store *)
+ exploit transf_volatile_store. eauto.
+ instantiate (1 := te#a1). eauto with na.
+ instantiate (1 := te#a2). eauto with na.
+ eauto.
+ intros (EQ & tm' & A & B). subst v.
+ econstructor; split.
+ eapply exec_Ibuiltin; eauto.
+ eapply external_call_symbols_preserved. simpl; eauto.
+ exact symbols_preserved. exact varinfo_preserved.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto with na.
++ (* volatile global store *)
+ rewrite volatile_store_global_charact in H0. destruct H0 as (b & P & Q).
+ exploit transf_volatile_store. eauto. eauto.
+ instantiate (1 := te#a1). eauto with na.
+ eauto.
+ intros (EQ & tm' & A & B). subst v.
+ econstructor; split.
+ eapply exec_Ibuiltin; eauto.
+ eapply external_call_symbols_preserved. simpl.
+ rewrite volatile_store_global_charact. exists b; split; eauto.
+ exact symbols_preserved. exact varinfo_preserved.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto with na.
++ (* memcpy *)
+ rewrite e1 in TI.
+ inv H0.
+ set (adst := aaddr (vanalyze rm f) # pc dst) in *.
+ set (asrc := aaddr (vanalyze rm f) # pc src) in *.
+ exploit magree_loadbytes. eauto. eauto.
+ exploit aaddr_sound. eauto. symmetry; eexact H2.
+ intros (bc & A & B & C).
+ intros. eapply nlive_add; eassumption.
+ intros (tbytes & P & Q).
+ exploit magree_storebytes_parallel.
+ eapply magree_monotone. eexact MEM.
+ instantiate (1 := nlive ge sp0 (nmem_remove nm adst sz)).
+ intros. apply incl_nmem_add; auto.
+ eauto.
+ instantiate (1 := nlive ge sp0 nm).
+ exploit aaddr_sound. eauto. symmetry; eexact H1.
+ intros (bc & A & B & C).
+ intros. eapply nlive_remove; eauto.
+ erewrite Mem.loadbytes_length in H10 by eauto.
+ rewrite nat_of_Z_eq in H10 by omega. auto.
+ eauto.
+ intros (tm' & A & B).
+ assert (LD1: Val.lessdef rs#src te#src) by eauto with na. rewrite <- H2 in LD1.
+ assert (LD2: Val.lessdef rs#dst te#dst) by eauto with na. rewrite <- H1 in LD2.
+ econstructor; split.
+ eapply exec_Ibuiltin; eauto.
+ eapply external_call_symbols_preserved. simpl.
+ inv LD1. inv LD2. econstructor; eauto.
+ exact symbols_preserved. exact varinfo_preserved.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto with na.
++ (* memcpy eliminated *)
+ rewrite e1 in TI. inv H0.
+ set (adst := aaddr (vanalyze rm f) # pc dst) in *.
+ set (asrc := aaddr (vanalyze rm f) # pc src) in *.
+ econstructor; split.
+ eapply exec_Inop; eauto.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_set_undef; auto.
+ eapply magree_storebytes_left; eauto.
+ exploit aaddr_sound. eauto. symmetry; eexact H1.
+ intros (bc & A & B & C).
+ intros. eapply nlive_contains; eauto.
+ erewrite Mem.loadbytes_length in H0 by eauto.
+ rewrite nat_of_Z_eq in H0 by omega. auto.
++ (* annot *)
+ inv H0.
+ econstructor; split.
+ eapply exec_Ibuiltin; eauto.
+ eapply external_call_symbols_preserved. simpl; constructor.
+ eapply eventval_list_match_lessdef; eauto with na.
+ exact symbols_preserved. exact varinfo_preserved.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto with na.
++ (* annot val *)
+ inv H0. destruct _x; inv H1. destruct _x; inv H4.
+ econstructor; split.
+ eapply exec_Ibuiltin; eauto.
+ eapply external_call_symbols_preserved. simpl; constructor.
+ eapply eventval_match_lessdef; eauto with na.
+ exact symbols_preserved. exact varinfo_preserved.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto with na.
++ (* all other builtins *)
+ assert ((fn_code tf)!pc = Some(Ibuiltin _x _x0 res pc')).
+ {
+ destruct _x; auto. destruct _x0; auto. destruct _x0; auto. destruct _x0; auto. contradiction.
+ }
+ clear y TI.
+ exploit external_call_mem_extends; eauto with na.
+ eapply magree_extends; eauto. intros. apply nlive_all.
+ intros (v' & tm' & A & B & C & D & E).
+ econstructor; split.
+ eapply exec_Ibuiltin; eauto.
+ eapply external_call_symbols_preserved. eauto.
+ exact symbols_preserved. exact varinfo_preserved.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto with na.
+ eapply mextends_agree; eauto.
+
+- (* conditional *)
+ TransfInstr; UseTransfer.
+ econstructor; split.
+ eapply exec_Icond; eauto.
+ eapply needs_of_condition_sound. eapply ma_perm; eauto. eauto. eauto with na.
+ eapply match_succ_states; eauto with na.
+ simpl; destruct b; auto.
+
+- (* jumptable *)
+ TransfInstr; UseTransfer.
+ assert (LD: Val.lessdef rs#arg te#arg) by eauto with na.
+ rewrite H0 in LD. inv LD.
+ econstructor; split.
+ eapply exec_Ijumptable; eauto.
+ eapply match_succ_states; eauto with na.
+ simpl. eapply list_nth_z_in; eauto.
+
+- (* return *)
+ TransfInstr; UseTransfer.
+ exploit magree_free. eauto. eauto. instantiate (1 := nlive ge stk nmem_all).
+ intros; eapply nlive_dead_stack; eauto.
+ intros (tm' & A & B).
+ econstructor; split.
+ eapply exec_Ireturn; eauto.
+ erewrite stacksize_translated by eauto. eexact A.
+ constructor; auto.
+ destruct or; simpl; eauto with na.
+ eapply magree_extends; eauto. apply nlive_all.
+
+- (* internal function *)
+ monadInv FUN. generalize EQ. unfold transf_function. intros EQ'.
+ destruct (analyze (vanalyze rm f) f) as [an|] eqn:AN; inv EQ'.
+ exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl.
+ intros (tm' & A & B).
+ econstructor; split.
+ econstructor; simpl; eauto.
+ simpl. econstructor; eauto.
+ apply eagree_init_regs; auto.
+ apply mextends_agree; auto.
+
+- (* external function *)
+ exploit external_call_mem_extends; eauto.
+ intros (res' & tm' & A & B & C & D & E).
+ simpl in FUN. inv FUN.
+ econstructor; split.
+ econstructor; eauto.
+ eapply external_call_symbols_preserved; eauto.
+ exact symbols_preserved. exact varinfo_preserved.
+ econstructor; eauto.
+
+- (* return *)
+ inv STACKS. inv H1.
+ econstructor; split.
+ constructor.
+ econstructor; eauto. apply mextends_agree; auto.
+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. intros (tf & A & B).
+ exists (Callstate nil tf nil m0); split.
+ econstructor; eauto.
+ eapply Genv.init_mem_transf_partial; eauto.
+ rewrite (transform_partial_program_main _ _ TRANSF).
+ rewrite symbols_preserved. eauto.
+ rewrite <- H3. apply sig_function_translated; auto.
+ constructor. constructor. auto. 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 STACKS. inv RES. constructor.
+Qed.
+
+(** * Semantic preservation *)
+
+Theorem transf_program_correct:
+ forward_simulation (RTL.semantics prog) (RTL.semantics tprog).
+Proof.
+ intros.
+ apply forward_simulation_step with
+ (match_states := fun s1 s2 => sound_state prog s1 /\ match_states s1 s2).
+- exact symbols_preserved.
+- simpl; intros. exploit transf_initial_states; eauto. intros [st2 [A B]].
+ exists st2; intuition. eapply sound_initial; eauto.
+- simpl; intros. destruct H. eapply transf_final_states; eauto.
+- simpl; intros. destruct H0.
+ assert (sound_state prog s1') by (eapply sound_step; eauto).
+ fold ge; fold tge. exploit step_simulation; eauto. intros [st2' [A B]].
+ exists st2'; auto.
+Qed.
+
+End PRESERVATION.
+
+
diff --git a/backend/Kildall.v b/backend/Kildall.v
index a071f30..0d414d2 100644
--- a/backend/Kildall.v
+++ b/backend/Kildall.v
@@ -25,7 +25,7 @@ Local Unset Case Analysis Schemes.
- [X(s) >= transf n X(n)]
if program point [s] is a successor of program point [n]
- [X(n) >= a]
- if [(n, a)] belongs to a given list of (program points, approximations).
+ if [n] is an entry point and [a] its minimal approximation.
The unknowns are the [X(n)], indexed by program points (e.g. nodes in the
CFG graph of a RTL function). They range over a given ordered set that
@@ -39,7 +39,7 @@ Symmetrically, a backward dataflow problem is a set of inequations of the form
- [X(n) >= transf s X(s)]
if program point [s] is a successor of program point [n]
- [X(n) >= a]
- if [(n, a)] belongs to a given list of (program points, approximations).
+ if [n] is an entry point and [a] its minimal approximation.
The only difference with a forward dataflow problem is that the transfer
function [transf] now computes the approximation before a program point [s]
@@ -59,11 +59,6 @@ approximations do not exist or are too expensive to compute. *)
(** * Solving forward dataflow problems using Kildall's algorithm *)
-Definition successors_list (successors: PTree.t (list positive)) (pc: positive) : list positive :=
- match successors!pc with None => nil | Some l => l end.
-
-Notation "a !!! b" := (successors_list a b) (at level 1).
-
(** A forward dataflow solver has the following generic interface.
Unknowns range over the type [L.t], which is equipped with
semi-lattice operations (see file [Lattice]). *)
@@ -72,53 +67,52 @@ Module Type DATAFLOW_SOLVER.
Declare Module L: SEMILATTICE.
+ (** [fixpoint successors transf ep ev] is the solver.
+ It returns either an error or a mapping from program points to
+ values of type [L.t] representing the solution. [successors]
+ is a finite map returning the list of successors of the given program
+ point. [transf] is the transfer function, [ep] the entry point,
+ and [ev] the minimal abstract value for [ep]. *)
+
Variable fixpoint:
forall {A: Type} (code: PTree.t A) (successors: A -> list positive)
(transf: positive -> L.t -> L.t)
- (entrypoints: list (positive * L.t)),
+ (ep: positive) (ev: L.t),
option (PMap.t L.t).
- (** [fixpoint successors transf entrypoints] is the solver.
- It returns either an error or a mapping from program points to
- values of type [L.t] representing the solution. [successors]
- is a finite map returning the list of successors of the given program
- point. [transf] is the transfer function, and [entrypoints] the additional
- constraints imposed on the solution. *)
+ (** The [fixpoint_solution] theorem shows that the returned solution,
+ if any, satisfies the dataflow inequations. *)
Hypothesis fixpoint_solution:
- forall A (code: PTree.t A) successors transf entrypoints res n instr s,
- fixpoint code successors transf entrypoints = Some res ->
+ forall A (code: PTree.t A) successors transf ep ev res n instr s,
+ fixpoint code successors transf ep ev = Some res ->
code!n = Some instr -> In s (successors instr) ->
+ (forall n, L.eq (transf n L.bot) L.bot) ->
L.ge res!!s (transf n res!!n).
- (** The [fixpoint_solution] theorem shows that the returned solution,
- if any, satisfies the dataflow inequations. *)
+ (** The [fixpoint_entry] theorem shows that the returned solution,
+ if any, satisfies the additional constraint over the entry point. *)
Hypothesis fixpoint_entry:
- forall A (code: PTree.t A) successors transf entrypoints res n v,
- fixpoint code successors transf entrypoints = Some res ->
- In (n, v) entrypoints ->
- L.ge res!!n v.
+ forall A (code: PTree.t A) successors transf ep ev res,
+ fixpoint code successors transf ep ev = Some res ->
+ L.ge res!!ep ev.
- (** The [fixpoint_entry] theorem shows that the returned solution,
- if any, satisfies the additional constraints expressed
- by [entrypoints]. *)
+ (** Finally, any property that is preserved by [L.lub] and [transf]
+ and that holds for [L.bot] also holds for the results of
+ the analysis. *)
Hypothesis fixpoint_invariant:
- forall A (code: PTree.t A) successors transf entrypoints
+ forall A (code: PTree.t A) successors transf ep ev
(P: L.t -> Prop),
P L.bot ->
(forall x y, P x -> P y -> P (L.lub x y)) ->
(forall pc instr x, code!pc = Some instr -> P x -> P (transf pc x)) ->
- (forall n v, In (n, v) entrypoints -> P v) ->
+ P ev ->
forall res pc,
- fixpoint code successors transf entrypoints = Some res ->
+ fixpoint code successors transf ep ev = Some res ->
P res!!pc.
- (** Finally, any property that is preserved by [L.lub] and [transf]
- and that holds for [L.bot] also holds for the results of
- the analysis. *)
-
End DATAFLOW_SOLVER.
(** Kildall's algorithm manipulates worklists, which are sets of CFG nodes
@@ -131,11 +125,14 @@ End DATAFLOW_SOLVER.
Module Type NODE_SET.
Variable t: Type.
+ Variable empty: t.
Variable add: positive -> t -> t.
Variable pick: t -> option (positive * t).
- Variable initial: forall {A: Type}, PTree.t A -> t.
+ Variable all_nodes: forall {A: Type}, PTree.t A -> t.
Variable In: positive -> t -> Prop.
+ Hypothesis empty_spec:
+ forall n, ~In n empty.
Hypothesis add_spec:
forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
Hypothesis pick_none:
@@ -143,16 +140,48 @@ Module Type NODE_SET.
Hypothesis pick_some:
forall s n s', pick s = Some(n, s') ->
forall n', In n' s <-> n = n' \/ In n' s'.
- Hypothesis initial_spec:
+ Hypothesis all_nodes_spec:
forall A (code: PTree.t A) n instr,
- code!n = Some instr -> In n (initial code).
+ code!n = Some instr -> In n (all_nodes code).
End NODE_SET.
-(** We now define a generic solver that works over
- any semi-lattice structure. *)
+(** Reachability in a control-flow graph. *)
-Module Dataflow_Solver (LAT: SEMILATTICE) (NS: NODE_SET):
+Section REACHABLE.
+
+Context {A: Type} (code: PTree.t A) (successors: A -> list positive).
+
+Inductive reachable: positive -> positive -> Prop :=
+ | reachable_refl: forall n, reachable n n
+ | reachable_left: forall n1 n2 n3 i,
+ code!n1 = Some i -> In n2 (successors i) -> reachable n2 n3 ->
+ reachable n1 n3.
+
+Scheme reachable_ind := Induction for reachable Sort Prop.
+
+Lemma reachable_trans:
+ forall n1 n2, reachable n1 n2 -> forall n3, reachable n2 n3 -> reachable n1 n3.
+Proof.
+ induction 1; intros.
+- auto.
+- econstructor; eauto.
+Qed.
+
+Lemma reachable_right:
+ forall n1 n2 n3 i,
+ reachable n1 n2 -> code!n2 = Some i -> In n3 (successors i) ->
+ reachable n1 n3.
+Proof.
+ intros. apply reachable_trans with n2; auto. econstructor; eauto. constructor.
+Qed.
+
+End REACHABLE.
+
+(** We now define a generic solver for forward dataflow inequations
+ that works over any semi-lattice structure. *)
+
+Module Dataflow_Solver (LAT: SEMILATTICE) (NS: NODE_SET) <:
DATAFLOW_SOLVER with Module L := LAT.
Module L := LAT.
@@ -163,61 +192,64 @@ Context {A: Type}.
Variable code: PTree.t A.
Variable successors: A -> list positive.
Variable transf: positive -> L.t -> L.t.
-Variable entrypoints: list (positive * L.t).
-(** The state of the iteration has two components:
-- A mapping from program points to values of type [L.t] representing
+(** The state of the iteration has three components:
+- [aval]: A mapping from program points to values of type [L.t] representing
the candidate solution found so far.
-- A worklist of program points that remain to be considered.
+- [worklist]: A worklist of program points that remain to be considered.
+- [visited]: A set of program points that were visited already
+ (i.e. put on the worklist at some point in the past).
+
+Only the first two components are computationally relevant. The third
+is a ghost variable used only for stating and proving invariants.
+For this reason, [visited] is defined at sort [Prop] so that it is
+erased during program extraction.
*)
Record state : Type :=
- mkstate { st_in: PMap.t L.t; st_wrk: NS.t }.
+ mkstate { aval: PTree.t L.t; worklist: NS.t; visited: positive -> Prop }.
+
+Definition abstr_value (n: positive) (s: state) : L.t :=
+ match s.(aval)!n with
+ | None => L.bot
+ | Some v => v
+ end.
(** Kildall's algorithm, in pseudo-code, is as follows:
<<
- while st_wrk is not empty, do
- extract a node n from st_wrk
- compute out = transf n st_in[n]
+ while worklist is not empty, do
+ extract a node n from worklist
+ compute out = transf n aval[n]
for each successor s of n:
- compute in = lub st_in[s] out
- if in <> st_in[s]:
- st_in[s] := in
- st_wrk := st_wrk union {s}
+ compute in = lub aval[s] out
+ if in <> aval[s]:
+ aval[s] := in
+ worklist := worklist union {s}
+ visited := visited union {s}
end if
end for
end while
- return st_in
+ return aval
>>
-
-The initial state is built as follows:
-- The initial mapping sets all program points to [L.bot], except
- those mentioned in the [entrypoints] list, for which we take
- the associated approximation as initial value. Since a program
- point can be mentioned several times in [entrypoints], with different
- approximations, we actually take the l.u.b. of these approximations.
-- The initial worklist contains all the program points. *)
-
-Fixpoint start_state_in (ep: list (positive * L.t)) : PMap.t L.t :=
- match ep with
- | nil =>
- PMap.init L.bot
- | (n, v) :: rem =>
- let m := start_state_in rem in PMap.set n (L.lub m!!n v) m
- end.
-
-Definition start_state :=
- mkstate (start_state_in entrypoints) (NS.initial code).
+*)
(** [propagate_succ] corresponds, in the pseudocode,
to the body of the [for] loop iterating over all successors. *)
Definition propagate_succ (s: state) (out: L.t) (n: positive) :=
- let oldl := s.(st_in)!!n in
- let newl := L.lub oldl out in
- if L.beq oldl newl
- then s
- else mkstate (PMap.set n newl s.(st_in)) (NS.add n s.(st_wrk)).
+ match s.(aval)!n with
+ | None =>
+ {| aval := PTree.set n out s.(aval);
+ worklist := NS.add n s.(worklist);
+ visited := fun p => p = n \/ s.(visited) p |}
+ | Some oldl =>
+ let newl := L.lub oldl out in
+ if L.beq oldl newl
+ then s
+ else {| aval := PTree.set n newl s.(aval);
+ worklist := NS.add n s.(worklist);
+ visited := fun p => p = n \/ s.(visited) p |}
+ end.
(** [propagate_succ_list] corresponds, in the pseudocode,
to the [for] loop iterating over all successors. *)
@@ -233,366 +265,530 @@ Fixpoint propagate_succ_list (s: state) (out: L.t) (succs: list positive)
pseudocode. *)
Definition step (s: state) : PMap.t L.t + state :=
- match NS.pick s.(st_wrk) with
+ match NS.pick s.(worklist) with
| None =>
- inl _ s.(st_in)
+ inl _ (L.bot, s.(aval))
| Some(n, rem) =>
match code!n with
- | None => inr _ (mkstate s.(st_in) rem)
+ | None =>
+ inr _ {| aval := s.(aval); worklist := rem; visited := s.(visited) |}
| Some instr =>
inr _ (propagate_succ_list
- (mkstate s.(st_in) rem)
- (transf n s.(st_in)!!n)
+ {| aval := s.(aval); worklist := rem; visited := s.(visited) |}
+ (transf n (abstr_value n s))
(successors instr))
end
end.
(** The whole fixpoint computation is the iteration of [step] from
- the start state. *)
+ an initial state. *)
-Definition fixpoint : option (PMap.t L.t) :=
- PrimIter.iterate _ _ step start_state.
+Definition fixpoint_from (start: state) : option (PMap.t L.t) :=
+ PrimIter.iterate _ _ step start.
-(** ** Monotonicity properties *)
+(** There are several ways to build the initial state. For forward
+ dataflow analyses, the initial worklist is the function entry point,
+ and the initial mapping sets the function entry point to the given
+ abstract value, and leaves unset all other program points, which
+ corresponds to [L.bot] initial abstract values. *)
+
+Definition start_state (enode: positive) (eval: L.t) :=
+ {| aval := PTree.set enode eval (PTree.empty L.t);
+ worklist := NS.add enode NS.empty;
+ visited := fun n => n = enode |}.
+
+Definition fixpoint (enode: positive) (eval: L.t) :=
+ fixpoint_from (start_state enode eval).
-(** We first show that the [st_in] part of the state evolves monotonically:
- at each step, the values of the [st_in[n]] either remain the same or
- increase with respect to the [L.ge] ordering. *)
+(** For backward analyses (viewed as forward analyses on the reversed CFG),
+ the following two variants are more useful. Both start with an
+ empty initial mapping, where all program points start at [L.bot].
+ The first initializes the worklist with a given set of entry points
+ in the reversed CFG. (See the backward dataflow solver below for
+ how this list is computed.) The second start state construction
+ initializes the worklist with all program points of the given CFG. *)
-Definition in_incr (in1 in2: PMap.t L.t) : Prop :=
- forall n, L.ge in2!!n in1!!n.
+Definition start_state_nodeset (enodes: NS.t) :=
+ {| aval := PTree.empty L.t;
+ worklist := enodes;
+ visited := fun n => NS.In n enodes |}.
-Lemma in_incr_refl:
- forall in1, in_incr in1 in1.
+Definition fixpoint_nodeset (enodes: NS.t) :=
+ fixpoint_from (start_state_nodeset enodes).
+
+Definition start_state_allnodes :=
+ {| aval := PTree.empty L.t;
+ worklist := NS.all_nodes code;
+ visited := fun n => exists instr, code!n = Some instr |}.
+
+Definition fixpoint_allnodes :=
+ fixpoint_from start_state_allnodes.
+
+(** ** Characterization of the propagation functions *)
+
+Inductive optge: option L.t -> option L.t -> Prop :=
+ | optge_some: forall l l',
+ L.ge l l' -> optge (Some l) (Some l')
+ | optge_none: forall ol,
+ optge ol None.
+
+Remark optge_refl: forall ol, optge ol ol.
+Proof. destruct ol; constructor. apply L.ge_refl; apply L.eq_refl. Qed.
+
+Remark optge_trans: forall ol1 ol2 ol3, optge ol1 ol2 -> optge ol2 ol3 -> optge ol1 ol3.
Proof.
- unfold in_incr; intros. apply L.ge_refl. apply L.eq_refl.
+ intros. inv H0.
+ inv H. constructor. eapply L.ge_trans; eauto.
+ constructor.
Qed.
-Lemma in_incr_trans:
- forall in1 in2 in3, in_incr in1 in2 -> in_incr in2 in3 -> in_incr in1 in3.
+Remark optge_abstr_value:
+ forall st st' n,
+ optge st.(aval)!n st'.(aval)!n ->
+ L.ge (abstr_value n st) (abstr_value n st').
Proof.
- unfold in_incr; intros. apply L.ge_trans with in2!!n; auto.
+ intros. unfold abstr_value. inv H. auto. apply L.ge_bot.
Qed.
-Lemma propagate_succ_incr:
+Lemma propagate_succ_charact:
forall st out n,
- in_incr st.(st_in) (propagate_succ st out n).(st_in).
+ let st' := propagate_succ st out n in
+ optge st'.(aval)!n (Some out)
+ /\ (forall s, n <> s -> st'.(aval)!s = st.(aval)!s)
+ /\ (forall s, optge st'.(aval)!s st.(aval)!s)
+ /\ (NS.In n st'.(worklist) \/ st'.(aval)!n = st.(aval)!n)
+ /\ (forall n', NS.In n' st.(worklist) -> NS.In n' st'.(worklist))
+ /\ (forall n', NS.In n' st'.(worklist) -> n' = n \/ NS.In n' st.(worklist))
+ /\ (forall n', st.(visited) n' -> st'.(visited) n')
+ /\ (forall n', st'.(visited) n' -> NS.In n' st'.(worklist) \/ st.(visited) n')
+ /\ (forall n', st.(aval)!n' = None -> st'.(aval)!n' <> None -> st'.(visited) n').
Proof.
- unfold in_incr, propagate_succ; simpl; intros.
- case (L.beq st.(st_in)!!n (L.lub st.(st_in)!!n out)).
- apply L.ge_refl. apply L.eq_refl.
- simpl. case (peq n n0); intro.
- subst n0. rewrite PMap.gss. apply L.ge_lub_left.
- rewrite PMap.gso; auto. apply L.ge_refl. apply L.eq_refl.
+ unfold propagate_succ; intros; simpl.
+ destruct st.(aval)!n as [v|] eqn:E;
+ [predSpec L.beq L.beq_correct v (L.lub v out) | idtac].
+- (* already there, unchanged *)
+ repeat split; intros.
+ + rewrite E. constructor. eapply L.ge_trans. apply L.ge_refl. apply H; auto. apply L.ge_lub_right.
+ + apply optge_refl.
+ + right; auto.
+ + auto.
+ + auto.
+ + auto.
+ + auto.
+ + congruence.
+- (* already there, updated *)
+ simpl; repeat split; intros.
+ + rewrite PTree.gss. constructor. apply L.ge_lub_right.
+ + rewrite PTree.gso by auto. auto.
+ + rewrite PTree.gsspec. destruct (peq s n).
+ subst s. rewrite E. constructor. apply L.ge_lub_left.
+ apply optge_refl.
+ + rewrite NS.add_spec. auto.
+ + rewrite NS.add_spec. auto.
+ + rewrite NS.add_spec in H0. intuition.
+ + auto.
+ + destruct H0; auto. subst n'. rewrite NS.add_spec; auto.
+ + rewrite PTree.gsspec in H1. destruct (peq n' n). auto. congruence.
+- (* not previously there, updated *)
+ simpl; repeat split; intros.
+ + rewrite PTree.gss. apply optge_refl.
+ + rewrite PTree.gso by auto. auto.
+ + rewrite PTree.gsspec. destruct (peq s n).
+ subst s. rewrite E. constructor.
+ apply optge_refl.
+ + rewrite NS.add_spec. auto.
+ + rewrite NS.add_spec. auto.
+ + rewrite NS.add_spec in H. intuition.
+ + auto.
+ + destruct H; auto. subst n'. rewrite NS.add_spec. auto.
+ + rewrite PTree.gsspec in H0. destruct (peq n' n). auto. congruence.
Qed.
-Lemma propagate_succ_list_incr:
- forall out scs st,
- in_incr st.(st_in) (propagate_succ_list st out scs).(st_in).
+Lemma propagate_succ_list_charact:
+ forall out l st,
+ let st' := propagate_succ_list st out l in
+ (forall n, In n l -> optge st'.(aval)!n (Some out))
+ /\ (forall n, ~In n l -> st'.(aval)!n = st.(aval)!n)
+ /\ (forall n, optge st'.(aval)!n st.(aval)!n)
+ /\ (forall n, NS.In n st'.(worklist) \/ st'.(aval)!n = st.(aval)!n)
+ /\ (forall n', NS.In n' st.(worklist) -> NS.In n' st'.(worklist))
+ /\ (forall n', NS.In n' st'.(worklist) -> In n' l \/ NS.In n' st.(worklist))
+ /\ (forall n', st.(visited) n' -> st'.(visited) n')
+ /\ (forall n', st'.(visited) n' -> NS.In n' st'.(worklist) \/ st.(visited) n')
+ /\ (forall n', st.(aval)!n' = None -> st'.(aval)!n' <> None -> st'.(visited) n').
Proof.
- induction scs; simpl; intros.
- apply in_incr_refl.
- apply in_incr_trans with (propagate_succ st out a).(st_in).
- apply propagate_succ_incr. auto.
-Qed.
+ induction l; simpl; intros.
+- repeat split; intros.
+ + contradiction.
+ + apply optge_refl.
+ + auto.
+ + auto.
+ + auto.
+ + auto.
+ + auto.
+ + congruence.
+- generalize (propagate_succ_charact st out a).
+ set (st1 := propagate_succ st out a).
+ intros (A1 & A2 & A3 & A4 & A5 & A6 & A7 & A8 & A9).
+ generalize (IHl st1).
+ set (st2 := propagate_succ_list st1 out l).
+ intros (B1 & B2 & B3 & B4 & B5 & B6 & B7 & B8 & B9). clear IHl.
+ repeat split; intros.
+ + destruct H.
+ * subst n. eapply optge_trans; eauto.
+ * auto.
+ + rewrite B2 by tauto. apply A2; tauto.
+ + eapply optge_trans; eauto.
+ + destruct (B4 n). auto.
+ destruct (peq n a).
+ * subst n. destruct A4. left; auto. right; congruence.
+ * right. rewrite H. auto.
+ + eauto.
+ + exploit B6; eauto. intros [P|P]. auto.
+ exploit A6; eauto. intuition.
+ + eauto.
+ + specialize (B8 n'); specialize (A8 n'). intuition.
+ + destruct st1.(aval)!n' eqn:ST1.
+ apply B7. apply A9; auto. congruence.
+ apply B9; auto.
+Qed.
-Lemma fixpoint_incr:
- forall res,
- fixpoint = Some res -> in_incr (start_state_in entrypoints) res.
+(** Characterization of [fixpoint_from]. *)
+
+Inductive steps: state -> state -> Prop :=
+ | steps_base: forall s, steps s s
+ | steps_right: forall s1 s2 s3, steps s1 s2 -> step s2 = inr s3 -> steps s1 s3.
+
+Scheme steps_ind := Induction for steps Sort Prop.
+
+Lemma fixpoint_from_charact:
+ forall start res,
+ fixpoint_from start = Some res ->
+ exists st, steps start st /\ NS.pick st.(worklist) = None /\ res = (L.bot, st.(aval)).
Proof.
unfold fixpoint; intros.
- change (start_state_in entrypoints) with start_state.(st_in).
eapply (PrimIter.iterate_prop _ _ step
- (fun st => in_incr start_state.(st_in) st.(st_in))
- (fun res => in_incr start_state.(st_in) res)).
-
- intros st INCR. unfold step.
- destruct (NS.pick st.(st_wrk)) as [ [n rem] | ].
- destruct (code!n) as [instr | ].
- apply in_incr_trans with st.(st_in). auto.
- change st.(st_in) with (mkstate st.(st_in) rem).(st_in).
- apply propagate_succ_list_incr.
- auto.
- auto.
- eauto.
- apply in_incr_refl.
+ (fun st => steps start st)
+ (fun res => exists st, steps start st /\ NS.pick (worklist st) = None /\ res = (L.bot, aval st))); eauto.
+ intros. destruct (step a) eqn:E.
+ exists a; split; auto.
+ unfold step in E. destruct (NS.pick (worklist a)) as [[n rem]|].
+ destruct (code!n); discriminate.
+ inv E. auto.
+ eapply steps_right; eauto.
+ constructor.
Qed.
-(** ** Correctness invariant *)
-
-(** The following invariant is preserved at each iteration of Kildall's
- algorithm: for all program points [n], either
- [n] is in the worklist, or the inequations associated with [n]
- ([st_in[s] >= transf n st_in[n]] for all successors [s] of [n])
- hold. In other terms, the worklist contains all nodes that do not
- yet satisfy their inequations. *)
-
-Definition good_state (st: state) : Prop :=
- forall n,
- NS.In n st.(st_wrk) \/
- (forall instr s,
- code!n = Some instr ->
- In s (successors instr) ->
- L.ge st.(st_in)!!s (transf n st.(st_in)!!n)).
+(** ** Monotonicity properties *)
-(** We show that the start state satisfies the invariant, and that
- the [step] function preserves it. *)
+(** We first show that the [aval] and [visited] parts of the state
+evolve monotonically:
+- at each step, the values of the [aval[n]] either remain the same or
+ increase with respect to the [optge] ordering;
+- every node visited in the past remains visited in the future.
+*)
-Lemma start_state_good:
- good_state start_state.
+Lemma step_incr:
+ forall n s1 s2, step s1 = inr s2 ->
+ optge s2.(aval)!n s1.(aval)!n /\ (s1.(visited) n -> s2.(visited) n).
Proof.
- unfold good_state, start_state; intros.
- destruct (code!n) as [instr|] eqn:INSTR.
- left; simpl. eapply NS.initial_spec; eauto.
- right; intros. discriminate.
+ unfold step; intros.
+ destruct (NS.pick (worklist s1)) as [[p rem] | ]; try discriminate.
+ destruct (code!p) as [instr|]; inv H.
+ + generalize (propagate_succ_list_charact
+ (transf p (abstr_value p s1))
+ (successors instr)
+ {| aval := aval s1; worklist := rem; visited := visited s1 |}).
+ simpl.
+ set (s' := propagate_succ_list {| aval := aval s1; worklist := rem; visited := visited s1 |}
+ (transf p (abstr_value p s1)) (successors instr)).
+ intros (A1 & A2 & A3 & A4 & A5 & A6 & A7 & A8 & A9).
+ auto.
+ + split. apply optge_refl. auto.
Qed.
-Lemma propagate_succ_charact:
- forall st out n,
- let st' := propagate_succ st out n in
- L.ge st'.(st_in)!!n out /\
- (forall s, n <> s -> st'.(st_in)!!s = st.(st_in)!!s).
+Lemma steps_incr:
+ forall n s1 s2, steps s1 s2 ->
+ optge s2.(aval)!n s1.(aval)!n /\ (s1.(visited) n -> s2.(visited) n).
Proof.
- unfold propagate_succ; intros; simpl.
- predSpec L.beq L.beq_correct
- ((st_in st) !! n) (L.lub (st_in st) !! n out).
- split.
- eapply L.ge_trans. apply L.ge_refl. apply H; auto.
- apply L.ge_lub_right.
- auto.
-
- simpl. split.
- rewrite PMap.gss.
- apply L.ge_lub_right.
- intros. rewrite PMap.gso; auto.
+ induction 1.
+- split. apply optge_refl. auto.
+- destruct IHsteps. exploit (step_incr n); eauto. intros [P Q].
+ split. eapply optge_trans; eauto. eauto.
Qed.
-Lemma propagate_succ_list_charact:
- forall out scs st,
- let st' := propagate_succ_list st out scs in
- forall s,
- (In s scs -> L.ge st'.(st_in)!!s out) /\
- (~(In s scs) -> st'.(st_in)!!s = st.(st_in)!!s).
+(** ** Correctness invariant *)
+
+(** The following invariant is preserved at each iteration of Kildall's
+ algorithm: for all visited program point [n], either
+ [n] is in the worklist, or the inequations associated with [n]
+ ([aval[s] >= transf n aval[n]] for all successors [s] of [n])
+ hold. In other terms, the worklist contains all nodes that were
+ visited but do not yet satisfy their inequations.
+
+ The second part of the invariant shows that nodes that already have
+ an abstract value associated with them have been visited. *)
+
+Record good_state (st: state) : Prop := {
+ gs_stable: forall n,
+ st.(visited) n ->
+ NS.In n st.(worklist) \/
+ (forall i s,
+ code!n = Some i -> In s (successors i) ->
+ optge st.(aval)!s (Some (transf n (abstr_value n st))));
+ gs_defined: forall n v,
+ st.(aval)!n = Some v -> st.(visited) n
+}.
+
+(** We show that the [step] function preserves this invariant. *)
+
+Lemma step_state_good:
+ forall st pc rem instr,
+ NS.pick st.(worklist) = Some (pc, rem) ->
+ code!pc = Some instr ->
+ good_state st ->
+ good_state (propagate_succ_list (mkstate st.(aval) rem st.(visited))
+ (transf pc (abstr_value pc st))
+ (successors instr)).
Proof.
- induction scs; simpl; intros.
- tauto.
- generalize (IHscs (propagate_succ st out a) s). intros [P Q].
- generalize (propagate_succ_charact st out a). intros [U V].
- split; intros.
- elim H; intro.
- subst s.
- apply L.ge_trans with (propagate_succ st out a).(st_in)!!a.
- apply propagate_succ_list_incr. assumption.
- apply P. auto.
- transitivity (propagate_succ st out a).(st_in)!!s.
- apply Q. tauto.
- apply V. tauto.
+ intros until instr; intros PICK CODEAT [GOOD1 GOOD2].
+ generalize (NS.pick_some _ _ _ PICK); intro PICK2.
+ set (out := transf pc (abstr_value pc st)).
+ generalize (propagate_succ_list_charact out (successors instr) {| aval := aval st; worklist := rem; visited := visited st |}).
+ set (st' := propagate_succ_list {| aval := aval st; worklist := rem; visited := visited st |} out
+ (successors instr)).
+ simpl; intros (A1 & A2 & A3 & A4 & A5 & A6 & A7 & A8 & A9).
+ constructor; intros.
+- (* stable *)
+ destruct (A8 n H); auto. destruct (A4 n); auto.
+ replace (abstr_value n st') with (abstr_value n st)
+ by (unfold abstr_value; rewrite H1; auto).
+ exploit GOOD1; eauto. intros [P|P].
++ (* n was on the worklist *)
+ rewrite PICK2 in P; destruct P.
+ * (* node n is our node pc *)
+ subst n. fold out. right; intros.
+ assert (i = instr) by congruence. subst i.
+ apply A1; auto.
+ * (* n was already on the worklist *)
+ left. apply A5; auto.
++ (* n was stable before, still is *)
+ right; intros. apply optge_trans with st.(aval)!s; eauto.
+- (* defined *)
+ destruct st.(aval)!n as [v'|] eqn:ST.
+ + apply A7. eapply GOOD2; eauto.
+ + apply A9; auto. congruence.
Qed.
-Lemma propagate_succ_incr_worklist:
- forall st out n x,
- NS.In x st.(st_wrk) -> NS.In x (propagate_succ st out n).(st_wrk).
+Lemma step_state_good_2:
+ forall st pc rem,
+ good_state st ->
+ NS.pick (worklist st) = Some (pc, rem) ->
+ code!pc = None ->
+ good_state (mkstate st.(aval) rem st.(visited)).
Proof.
- intros. unfold propagate_succ.
- case (L.beq (st_in st) !! n (L.lub (st_in st) !! n out)).
- auto.
- simpl. rewrite NS.add_spec. auto.
+ intros until rem; intros [GOOD1 GOOD2] PICK CODE.
+ generalize (NS.pick_some _ _ _ PICK); intro PICK2.
+ constructor; simpl; intros.
+- (* stable *)
+ exploit GOOD1; eauto. intros [P | P].
+ + rewrite PICK2 in P. destruct P; auto.
+ subst n. right; intros. congruence.
+ + right; exact P.
+- (* defined *)
+ eapply GOOD2; eauto.
Qed.
-Lemma propagate_succ_list_incr_worklist:
- forall out scs st x,
- NS.In x st.(st_wrk) -> NS.In x (propagate_succ_list st out scs).(st_wrk).
+Lemma steps_state_good:
+ forall st1 st2, steps st1 st2 -> good_state st1 -> good_state st2.
Proof.
- induction scs; simpl; intros.
- auto.
- apply IHscs. apply propagate_succ_incr_worklist. auto.
+ induction 1; intros.
+- auto.
+- unfold step in e.
+ destruct (NS.pick (worklist s2)) as [[n rem] | ] eqn:PICK; try discriminate.
+ destruct (code!n) as [instr|] eqn:CODE; inv e.
+ eapply step_state_good; eauto.
+ eapply step_state_good_2; eauto.
Qed.
-Lemma propagate_succ_records_changes:
- forall st out n s,
- let st' := propagate_succ st out n in
- NS.In s st'.(st_wrk) \/ st'.(st_in)!!s = st.(st_in)!!s.
+(** We show that initial states satisfy the invariant. *)
+
+Lemma start_state_good:
+ forall enode eval, good_state (start_state enode eval).
Proof.
- simpl. intros. unfold propagate_succ.
- case (L.beq (st_in st) !! n (L.lub (st_in st) !! n out)).
- right; auto.
- case (peq s n); intro.
- subst s. left. simpl. rewrite NS.add_spec. auto.
- right. simpl. apply PMap.gso. auto.
+ intros. unfold start_state; constructor; simpl; intros.
+- subst n. rewrite NS.add_spec; auto.
+- rewrite PTree.gsspec in H. rewrite PTree.gempty in H.
+ destruct (peq n enode). auto. discriminate.
Qed.
-Lemma propagate_succ_list_records_changes:
- forall out scs st s,
- let st' := propagate_succ_list st out scs in
- NS.In s st'.(st_wrk) \/ st'.(st_in)!!s = st.(st_in)!!s.
+Lemma start_state_nodeset_good:
+ forall enodes, good_state (start_state_nodeset enodes).
Proof.
- induction scs; simpl; intros.
- right; auto.
- elim (propagate_succ_records_changes st out a s); intro.
- left. apply propagate_succ_list_incr_worklist. auto.
- rewrite <- H. auto.
+ intros. unfold start_state_nodeset; constructor; simpl; intros.
+- left. auto.
+- rewrite PTree.gempty in H. congruence.
Qed.
-Lemma step_state_good:
- forall st n instr rem,
- NS.pick st.(st_wrk) = Some(n, rem) ->
- code!n = Some instr ->
- good_state st ->
- good_state (propagate_succ_list (mkstate st.(st_in) rem)
- (transf n st.(st_in)!!n)
- (successors instr)).
+Lemma start_state_allnodes_good:
+ good_state start_state_allnodes.
Proof.
- unfold good_state. intros st n instr rem WKL INSTR GOOD x.
- generalize (NS.pick_some _ _ _ WKL); intro PICK.
- set (out := transf n st.(st_in)!!n).
- elim (propagate_succ_list_records_changes
- out (successors instr) (mkstate st.(st_in) rem) x).
- intro; left; auto.
- simpl; intros EQ. rewrite EQ.
- (* Case 1: x = n *)
- destruct (peq x n). subst x.
- right; intros.
- assert (instr0 = instr) by congruence. subst instr0.
- elim (propagate_succ_list_charact out (successors instr)
- (mkstate st.(st_in) rem) s); intros.
- auto.
- (* Case 2: x <> n *)
- elim (GOOD x); intro.
- (* Case 2.1: x was already in worklist, still is *)
- left. apply propagate_succ_list_incr_worklist.
- simpl. rewrite PICK in H. elim H; intro. congruence. auto.
- (* Case 2.2: x was not in worklist *)
- right; intros.
- case (In_dec peq s (successors instr)); intro.
- (* Case 2.2.1: s is a successor of n, it may have increased *)
- apply L.ge_trans with st.(st_in)!!s.
- change st.(st_in)!!s with (mkstate st.(st_in) rem).(st_in)!!s.
- apply propagate_succ_list_incr.
- eauto.
- (* Case 2.2.2: s is not a successor of n, it did not change *)
- elim (propagate_succ_list_charact out (successors instr)
- (mkstate st.(st_in) rem) s); intros.
- rewrite H3. simpl. eauto. auto.
+ unfold start_state_allnodes; constructor; simpl; intros.
+- destruct H as [instr CODE]. left. eapply NS.all_nodes_spec; eauto.
+- rewrite PTree.gempty in H. congruence.
Qed.
-Lemma step_state_good_2:
- forall st n rem,
- good_state st ->
- NS.pick (st_wrk st) = Some (n, rem) ->
- code!n = None ->
- good_state (mkstate st.(st_in) rem).
+(** Reachability in final states. *)
+
+Lemma reachable_visited:
+ forall st, good_state st -> NS.pick st.(worklist) = None ->
+ forall p q, reachable code successors p q -> st.(visited) p -> st.(visited) q.
Proof.
- intros; red; intros; simpl.
- destruct (H n0).
- erewrite NS.pick_some in H2 by eauto. destruct H2; auto.
- subst n0. right; intros; congruence.
- right; auto.
+ intros st [GOOD1 GOOD2] PICK. induction 1; intros.
+- auto.
+- eapply IHreachable; eauto.
+ exploit GOOD1; eauto. intros [P | P].
+ eelim NS.pick_none; eauto.
+ exploit P; eauto. intros OGE; inv OGE. eapply GOOD2; eauto.
Qed.
-(** ** Correctness of the solution returned by [iterate]. *)
+(** ** Correctness of the solution returned by [fixpoint]. *)
(** As a consequence of the [good_state] invariant, the result of
- [fixpoint], if defined, is a solution of the dataflow inequations,
- since [st_wrk] is empty when the iteration terminates. *)
+ [fixpoint], if defined, is a solution of the dataflow inequations.
+ This assumes that the transfer function maps [L.bot] to [L.bot]. *)
Theorem fixpoint_solution:
- forall res n instr s,
- fixpoint = Some res ->
+ forall ep ev res n instr s,
+ fixpoint ep ev = Some res ->
code!n = Some instr ->
In s (successors instr) ->
+ (forall n, L.eq (transf n L.bot) L.bot) ->
L.ge res!!s (transf n res!!n).
Proof.
- intros until s. unfold fixpoint. intros PI. revert n instr s.
- pattern res.
- eapply (PrimIter.iterate_prop _ _ step good_state).
-
- intros st GOOD. unfold step.
- destruct (NS.pick st.(st_wrk)) as [[n rem] | ] eqn:PICK.
- destruct (code!n) as [instr | ] eqn:INSTR.
- apply step_state_good; auto.
- eapply step_state_good_2; eauto.
- intros. destruct (GOOD n). elim (NS.pick_none _ n PICK). auto. eauto.
+ unfold fixpoint; intros.
+ exploit fixpoint_from_charact; eauto. intros (st & STEPS & PICK & RES).
+ exploit steps_state_good; eauto. apply start_state_good. intros [GOOD1 GOOD2].
+ rewrite RES; unfold PMap.get; simpl.
+ destruct st.(aval)!n as [v|] eqn:STN.
+- destruct (GOOD1 n) as [P|P]; eauto.
+ eelim NS.pick_none; eauto.
+ exploit P; eauto. unfold abstr_value; rewrite STN. intros OGE; inv OGE. auto.
+- apply L.ge_trans with L.bot. apply L.ge_bot. apply L.ge_refl. apply L.eq_sym. eauto.
+Qed.
+
+(** Moreover, the result of [fixpoint], if defined, satisfies the additional
+ constraint given on the entry point. *)
- eauto. apply start_state_good.
+Theorem fixpoint_entry:
+ forall ep ev res,
+ fixpoint ep ev = Some res ->
+ L.ge res!!ep ev.
+Proof.
+ unfold fixpoint; intros.
+ exploit fixpoint_from_charact; eauto. intros (st & STEPS & PICK & RES).
+ exploit (steps_incr ep); eauto. simpl. rewrite PTree.gss. intros [P Q].
+ rewrite RES; unfold PMap.get; simpl. inv P; auto.
Qed.
-(** As a consequence of the monotonicity property, the result of
- [fixpoint], if defined, is pointwise greater than or equal the
- initial mapping. Therefore, it satisfies the additional constraints
- stated in [entrypoints]. *)
+(** For [fixpoint_allnodes], we show that the result is a solution
+ without assuming [transf n L.bot = L.bot]. *)
-Lemma start_state_in_entry:
- forall ep n v,
- In (n, v) ep ->
- L.ge (start_state_in ep)!!n v.
+Theorem fixpoint_allnodes_solution:
+ forall res n instr s,
+ fixpoint_allnodes = Some res ->
+ code!n = Some instr ->
+ In s (successors instr) ->
+ L.ge res!!s (transf n res!!n).
Proof.
- induction ep; simpl; intros.
- elim H.
- elim H; intros.
- subst a. rewrite PMap.gss.
- apply L.ge_lub_right.
- destruct a. rewrite PMap.gsspec. case (peq n p); intro.
- subst p. apply L.ge_trans with (start_state_in ep)!!n.
- apply L.ge_lub_left. auto.
- auto.
+ unfold fixpoint_allnodes; intros.
+ exploit fixpoint_from_charact; eauto. intros (st & STEPS & PICK & RES).
+ exploit steps_state_good; eauto. apply start_state_allnodes_good. intros [GOOD1 GOOD2].
+ exploit (steps_incr n); eauto. simpl. intros [U V].
+ exploit (GOOD1 n). apply V. exists instr; auto. intros [P|P].
+ eelim NS.pick_none; eauto.
+ exploit P; eauto. intros OGE. rewrite RES; unfold PMap.get; simpl.
+ inv OGE. assumption.
Qed.
-Theorem fixpoint_entry:
- forall res n v,
- fixpoint = Some res ->
- In (n, v) entrypoints ->
- L.ge res!!n v.
+(** For [fixpoint_nodeset], we show that the result is a solution
+ at all program points that are reachable from the given entry points. *)
+
+Theorem fixpoint_nodeset_solution:
+ forall enodes res e n instr s,
+ fixpoint_nodeset enodes = Some res ->
+ NS.In e enodes ->
+ reachable code successors e n ->
+ code!n = Some instr ->
+ In s (successors instr) ->
+ L.ge res!!s (transf n res!!n).
Proof.
- intros.
- apply L.ge_trans with (start_state_in entrypoints)!!n.
- apply fixpoint_incr. auto.
- apply start_state_in_entry. auto.
+ unfold fixpoint_nodeset; intros.
+ exploit fixpoint_from_charact; eauto. intros (st & STEPS & PICK & RES).
+ exploit steps_state_good; eauto. apply start_state_nodeset_good. intros GOOD.
+ exploit (steps_incr e); eauto. simpl. intros [U V].
+ assert (st.(visited) n).
+ { eapply reachable_visited; eauto. }
+ destruct GOOD as [GOOD1 GOOD2].
+ exploit (GOOD1 n); eauto. intros [P|P].
+ eelim NS.pick_none; eauto.
+ exploit P; eauto. intros OGE. rewrite RES; unfold PMap.get; simpl.
+ inv OGE. assumption.
Qed.
(** ** Preservation of a property over solutions *)
-Variable P: L.t -> Prop.
-Hypothesis P_bot: P L.bot.
-Hypothesis P_lub: forall x y, P x -> P y -> P (L.lub x y).
-Hypothesis P_transf: forall pc instr x, code!pc = Some instr -> P x -> P (transf pc x).
-Hypothesis P_entrypoints: forall n v, In (n, v) entrypoints -> P v.
-
Theorem fixpoint_invariant:
- forall res pc,
- fixpoint = Some res ->
+ forall ep ev
+ (P: L.t -> Prop)
+ (P_bot: P L.bot)
+ (P_lub: forall x y, P x -> P y -> P (L.lub x y))
+ (P_transf: forall pc instr x, code!pc = Some instr -> P x -> P (transf pc x))
+ (P_entrypoint: P ev)
+ res pc,
+ fixpoint ep ev = Some res ->
P res!!pc.
Proof.
- assert (forall ep,
- (forall n v, In (n, v) ep -> P v) ->
- forall pc, P (start_state_in ep)!!pc).
- induction ep; intros; simpl.
- rewrite PMap.gi. auto.
- simpl in H.
- assert (P (start_state_in ep)!!pc). apply IHep. eauto.
- destruct a as [n v]. rewrite PMap.gsspec. destruct (peq pc n).
- apply P_lub. subst. auto. eapply H. left; reflexivity. auto.
- set (inv := fun st => forall pc, P (st.(st_in)!!pc)).
+ intros.
+ set (inv := fun st => forall x, P (abstr_value x st)).
+ assert (inv (start_state ep ev)).
+ {
+ red; simpl; intros. unfold abstr_value, start_state; simpl.
+ rewrite PTree.gsspec. rewrite PTree.gempty.
+ destruct (peq x ep). auto. auto.
+ }
assert (forall st v n, inv st -> P v -> inv (propagate_succ st v n)).
- unfold inv, propagate_succ. intros.
- destruct (LAT.beq (st_in st)!!n (LAT.lub (st_in st)!!n v)).
- auto. simpl. rewrite PMap.gsspec. destruct (peq pc n).
- apply P_lub. subst n; auto. auto.
+ {
+ unfold inv, propagate_succ. intros.
+ destruct (aval st)!n as [oldl|] eqn:E.
+ destruct (L.beq oldl (L.lub oldl v)).
+ auto.
+ unfold abstr_value. simpl. rewrite PTree.gsspec. destruct (peq x n).
+ apply P_lub; auto. replace oldl with (abstr_value n st). auto.
+ unfold abstr_value; rewrite E; auto.
+ apply H1.
+ unfold abstr_value. simpl. rewrite PTree.gsspec. destruct (peq x n).
auto.
+ apply H1.
+ }
assert (forall l st v, inv st -> P v -> inv (propagate_succ_list st v l)).
+ {
induction l; intros; simpl. auto.
apply IHl; auto.
- assert (forall res, fixpoint = Some res -> forall pc, P res!!pc).
- unfold fixpoint. intros res0 RES0. pattern res0.
- eapply (PrimIter.iterate_prop _ _ step inv).
- intros. unfold step.
- destruct (NS.pick (st_wrk a)) as [[n rem] | ].
- destruct (code!n) as [instr | ] eqn:INSTR.
- apply H1. auto. eapply P_transf; eauto.
- assumption.
- eauto.
- eauto.
- unfold inv, start_state; simpl. auto.
- intros. auto.
+ }
+ assert (forall st1 st2, steps st1 st2 -> inv st1 -> inv st2).
+ {
+ induction 1; intros.
+ auto.
+ unfold step in e. destruct (NS.pick (worklist s2)) as [[n rem]|]; try discriminate.
+ destruct (code!n) as [instr|] eqn:INSTR; inv e.
+ apply H2. apply IHsteps; auto. eapply P_transf; eauto. apply IHsteps; auto.
+ apply IHsteps; auto.
+ }
+ unfold fixpoint in H. exploit fixpoint_from_charact; eauto.
+ intros (st & STEPS & PICK & RES).
+ replace (res!!pc) with (abstr_value pc st). eapply H3; eauto.
+ rewrite RES; auto.
Qed.
End Kildall.
@@ -606,7 +802,12 @@ End Dataflow_Solver.
successors. We exploit this observation to cheaply derive a backward
solver from the forward solver. *)
-(** ** Construction of the predecessor relation *)
+(** ** Construction of the reversed flow graph (the predecessor relation) *)
+
+Definition successors_list (successors: PTree.t (list positive)) (pc: positive) : list positive :=
+ match successors!pc with None => nil | Some l => l end.
+
+Notation "a !!! b" := (successors_list a b) (at level 1).
Section Predecessor.
@@ -672,6 +873,17 @@ Proof.
contradiction.
Qed.
+Lemma reachable_predecessors:
+ forall p q,
+ reachable code successors p q ->
+ reachable make_predecessors (fun l => l) q p.
+Proof.
+ induction 1.
+- constructor.
+- exploit make_predecessors_correct_2; eauto. intros [l [P Q]].
+ eapply reachable_right; eauto.
+Qed.
+
End Predecessor.
(** ** Solving backward dataflow problems *)
@@ -682,33 +894,40 @@ Module Type BACKWARD_DATAFLOW_SOLVER.
Declare Module L: SEMILATTICE.
+ (** [fixpoint successors transf] is the solver.
+ It returns either an error or a mapping from program points to
+ values of type [L.t] representing the solution. [successors]
+ is a finite map returning the list of successors of the given program
+ point. [transf] is the transfer function. *)
+
Variable fixpoint:
forall {A: Type} (code: PTree.t A) (successors: A -> list positive)
- (transf: positive -> L.t -> L.t)
- (entrypoints: list (positive * L.t)),
+ (transf: positive -> L.t -> L.t),
option (PMap.t L.t).
+ (** The [fixpoint_solution] theorem shows that the returned solution,
+ if any, satisfies the backward dataflow inequations. *)
+
Hypothesis fixpoint_solution:
- forall A (code: PTree.t A) successors transf entrypoints res n instr s,
- fixpoint code successors transf entrypoints = Some res ->
+ forall A (code: PTree.t A) successors transf res n instr s,
+ fixpoint code successors transf = Some res ->
code!n = Some instr -> In s (successors instr) ->
+ (forall n a, code!n = None -> L.eq (transf n a) L.bot) ->
L.ge res!!n (transf s res!!s).
- Hypothesis fixpoint_entry:
- forall A (code: PTree.t A) successors transf entrypoints res n v,
- fixpoint code successors transf entrypoints = Some res ->
- In (n, v) entrypoints ->
- L.ge res!!n v.
+ (** [fixpoint_allnodes] is a variant of [fixpoint], less algorithmically
+ efficient, but correct without any hypothesis on the transfer function. *)
- Hypothesis fixpoint_invariant:
- forall A (code: PTree.t A) successors transf entrypoints (P: L.t -> Prop),
- P L.bot ->
- (forall x y, P x -> P y -> P (L.lub x y)) ->
- (forall pc x, P x -> P (transf pc x)) ->
- (forall n v, In (n, v) entrypoints -> P v) ->
- forall res pc,
- fixpoint code successors transf entrypoints = Some res ->
- P res!!pc.
+ Variable fixpoint_allnodes:
+ forall {A: Type} (code: PTree.t A) (successors: A -> list positive)
+ (transf: positive -> L.t -> L.t),
+ option (PMap.t L.t).
+
+ Hypothesis fixpoint_allnodes_solution:
+ forall A (code: PTree.t A) successors transf res n instr s,
+ fixpoint_allnodes code successors transf = Some res ->
+ code!n = Some instr -> In s (successors instr) ->
+ L.ge res!!n (transf s res!!s).
End BACKWARD_DATAFLOW_SOLVER.
@@ -729,45 +948,127 @@ Context {A: Type}.
Variable code: PTree.t A.
Variable successors: A -> list positive.
Variable transf: positive -> L.t -> L.t.
-Variable entrypoints: list (positive * L.t).
+
+(** Finding entry points for the reverse control-flow graph. *)
+
+Section Exit_points.
+
+(** Assuming that the nodes of the CFG [code] are numbered in reverse
+ postorder (cf. pass [Renumber]), an edge from [n] to [s] is a
+ normal edge if [s < n] and a back-edge otherwise.
+ [sequential_node] returns [true] if the given node has at least one
+ normal outgoing edge. It returns [false] if the given node is an exit
+ node (no outgoing edges) or the final node of a loop body
+ (all outgoing edges are back-edges). As we prove later, the set
+ of all non-sequential node is an appropriate set of entry points
+ for exploring the reverse CFG. *)
+
+Definition sequential_node (pc: positive) (instr: A): bool :=
+ existsb (fun s => match code!s with None => false | Some _ => plt s pc end)
+ (successors instr).
+
+Definition exit_points : NS.t :=
+ PTree.fold
+ (fun ep pc instr =>
+ if sequential_node pc instr
+ then ep
+ else NS.add pc ep)
+ code NS.empty.
+
+Lemma exit_points_charact:
+ forall n,
+ NS.In n exit_points <-> exists i, code!n = Some i /\ sequential_node n i = false.
+Proof.
+ intros n. unfold exit_points. eapply PTree_Properties.fold_rec.
+- (* extensionality *)
+ intros. rewrite <- H. auto.
+- (* base case *)
+ simpl. split; intros.
+ eelim NS.empty_spec; eauto.
+ destruct H as [i [P Q]]. rewrite PTree.gempty in P. congruence.
+- (* inductive case *)
+ intros. destruct (sequential_node k v) eqn:SN.
+ + rewrite H1. rewrite PTree.gsspec. destruct (peq n k).
+ subst. split; intros [i [P Q]]. congruence. inv P. congruence.
+ tauto.
+ + rewrite NS.add_spec. rewrite H1. rewrite PTree.gsspec. destruct (peq n k).
+ subst. split. intros. exists v; auto. auto.
+ split. intros [P | [i [P Q]]]. congruence. exists i; auto.
+ intros [i [P Q]]. right; exists i; auto.
+Qed.
+
+Lemma reachable_exit_points:
+ forall pc i,
+ code!pc = Some i -> exists x, NS.In x exit_points /\ reachable code successors pc x.
+Proof.
+ intros pc0. pattern pc0. apply (well_founded_ind Plt_wf).
+ intros pc HR i CODE.
+ destruct (sequential_node pc i) eqn:SN.
+- (* at least one successor that decreases the pc *)
+ unfold sequential_node in SN. rewrite existsb_exists in SN.
+ destruct SN as [s [P Q]]. destruct (code!s) as [i'|] eqn:CS; try discriminate. InvBooleans.
+ exploit (HR s); eauto. intros [x [U V]].
+ exists x; split; auto. eapply reachable_left; eauto.
+- (* otherwise we are an exit point *)
+ exists pc; split.
+ rewrite exit_points_charact. exists i; auto. constructor.
+Qed.
+
+(** The crucial property of exit points is that any nonempty node in the
+ CFG is reverse-reachable from an exit point. *)
+
+Lemma reachable_exit_points_predecessor:
+ forall pc i,
+ code!pc = Some i ->
+ exists x, NS.In x exit_points /\ reachable (make_predecessors code successors) (fun l => l) x pc.
+Proof.
+ intros. exploit reachable_exit_points; eauto. intros [x [P Q]].
+ exists x; split; auto. apply reachable_predecessors. auto.
+Qed.
+
+End Exit_points.
+
+(** The efficient backward solver. *)
Definition fixpoint :=
- DS.fixpoint
+ DS.fixpoint_nodeset
(make_predecessors code successors) (fun l => l)
- transf entrypoints.
+ transf exit_points.
Theorem fixpoint_solution:
forall res n instr s,
fixpoint = Some res ->
code!n = Some instr -> In s (successors instr) ->
+ (forall n a, code!n = None -> L.eq (transf n a) L.bot) ->
L.ge res!!n (transf s res!!s).
Proof.
intros.
exploit (make_predecessors_correct_2 code); eauto. intros [l [P Q]].
- eapply DS.fixpoint_solution; eauto.
+ destruct code!s as [instr'|] eqn:CS.
+- exploit reachable_exit_points_predecessor. eexact CS. intros (ep & U & V).
+ unfold fixpoint in H. eapply DS.fixpoint_nodeset_solution; eauto.
+- apply L.ge_trans with L.bot. apply L.ge_bot.
+ apply L.ge_refl. apply L.eq_sym. auto.
Qed.
-Theorem fixpoint_entry:
- forall res n v,
- fixpoint = Some res ->
- In (n, v) entrypoints ->
- L.ge res!!n v.
-Proof.
- intros. eapply DS.fixpoint_entry. eexact H. auto.
-Qed.
+(** The alternate solver that starts with all nodes of the CFG instead
+ of just the exit points. *)
-Theorem fixpoint_invariant:
- forall (P: L.t -> Prop),
- P L.bot ->
- (forall x y, P x -> P y -> P (L.lub x y)) ->
- (forall pc x, P x -> P (transf pc x)) ->
- (forall n v, In (n, v) entrypoints -> P v) ->
- forall res pc,
- fixpoint = Some res ->
- P res!!pc.
+Definition fixpoint_allnodes :=
+ DS.fixpoint_allnodes
+ (make_predecessors code successors) (fun l => l)
+ transf.
+
+Theorem fixpoint_allnodes_solution:
+ forall res n instr s,
+ fixpoint_allnodes = Some res ->
+ code!n = Some instr -> In s (successors instr) ->
+ L.ge res!!n (transf s res!!s).
Proof.
- intros.
- eapply DS.fixpoint_invariant with (code := make_predecessors code successors) (transf := transf); eauto.
+ intros.
+ exploit (make_predecessors_correct_2 code); eauto. intros [l [P Q]].
+ unfold fixpoint_allnodes in H.
+ eapply DS.fixpoint_allnodes_solution; eauto.
Qed.
End Kildall.
@@ -861,24 +1162,24 @@ Definition result := PMap.t L.t.
*)
Record state : Type := mkstate
- { st_in: result; st_wrk: list positive }.
+ { aval: result; worklist: list positive }.
(** The ``extended basic block'' algorithm, in pseudo-code, is as follows:
<<
- st_wrk := the set of all points n having multiple predecessors
- st_in := the mapping n -> L.top
+ worklist := the set of all points n having multiple predecessors
+ aval := the mapping n -> L.top
- while st_wrk is not empty, do
- extract a node n from st_wrk
- compute out = transf n st_in[n]
+ while worklist is not empty, do
+ extract a node n from worklist
+ compute out = transf n aval[n]
for each successor s of n:
if s has only one predecessor (namely, n):
- st_in[s] := out
- st_wrk := st_wrk union {s}
+ aval[s] := out
+ worklist := worklist union {s}
end if
end for
end while
- return st_in
+ return aval
>>
**)
@@ -892,22 +1193,22 @@ Fixpoint propagate_successors
propagate_successors bb sl l st
else
propagate_successors bb sl l
- (mkstate (PMap.set s1 l st.(st_in))
- (s1 :: st.(st_wrk)))
+ (mkstate (PMap.set s1 l st.(aval))
+ (s1 :: st.(worklist)))
end.
Definition step (bb: bbmap) (st: state) : result + state :=
- match st.(st_wrk) with
- | nil => inl _ st.(st_in)
+ match st.(worklist) with
+ | nil => inl _ st.(aval)
| pc :: rem =>
match code!pc with
| None =>
- inr _ (mkstate st.(st_in) rem)
+ inr _ (mkstate st.(aval) rem)
| Some instr =>
inr _ (propagate_successors
bb (successors instr)
- (transf pc st.(st_in)!!pc)
- (mkstate st.(st_in) rem))
+ (transf pc st.(aval)!!pc)
+ (mkstate st.(aval) rem))
end
end.
@@ -989,34 +1290,34 @@ Qed.
*)
Definition state_invariant (st: state) : Prop :=
- (forall n, basic_block_map n = true -> st.(st_in)!!n = L.top)
+ (forall n, basic_block_map n = true -> st.(aval)!!n = L.top)
/\
(forall n,
- In n st.(st_wrk) \/
+ In n st.(worklist) \/
(forall instr s, code!n = Some instr -> In s (successors instr) ->
- L.ge st.(st_in)!!s (transf n st.(st_in)!!n))).
+ L.ge st.(aval)!!s (transf n st.(aval)!!n))).
Lemma propagate_successors_charact1:
forall bb succs l st,
- incl st.(st_wrk)
- (propagate_successors bb succs l st).(st_wrk).
+ incl st.(worklist)
+ (propagate_successors bb succs l st).(worklist).
Proof.
induction succs; simpl; intros.
apply incl_refl.
case (bb a).
auto.
- apply incl_tran with (a :: st_wrk st).
+ apply incl_tran with (a :: worklist st).
apply incl_tl. apply incl_refl.
- set (st1 := (mkstate (PMap.set a l (st_in st)) (a :: st_wrk st))).
- change (a :: st_wrk st) with (st_wrk st1).
+ set (st1 := (mkstate (PMap.set a l (aval st)) (a :: worklist st))).
+ change (a :: worklist st) with (worklist st1).
auto.
Qed.
Lemma propagate_successors_charact2:
forall bb succs l st n,
let st' := propagate_successors bb succs l st in
- (In n succs -> bb n = false -> In n st'.(st_wrk) /\ st'.(st_in)!!n = l)
-/\ (~In n succs \/ bb n = true -> st'.(st_in)!!n = st.(st_in)!!n).
+ (In n succs -> bb n = false -> In n st'.(worklist) /\ st'.(aval)!!n = l)
+/\ (~In n succs \/ bb n = true -> st'.(aval)!!n = st.(aval)!!n).
Proof.
induction succs; simpl; intros.
(* Base case *)
@@ -1027,7 +1328,7 @@ Proof.
split; intros. apply U; auto.
elim H0; intro. subst a. congruence. auto.
apply V. tauto.
- set (st1 := mkstate (PMap.set a l (st_in st)) (a :: st_wrk st)).
+ set (st1 := mkstate (PMap.set a l (aval st)) (a :: worklist st)).
elim (IHsuccs l st1 n); intros U V.
split; intros.
elim H0; intros.
@@ -1069,7 +1370,7 @@ Proof.
right; intros.
assert (instr0 = instr) by congruence. subst instr0.
elim (U s); intros C D.
- replace (st1.(st_in)!!pc) with res!!pc. fold l.
+ replace (st1.(aval)!!pc) with res!!pc. fold l.
destruct (basic_block_map s) eqn:BB.
rewrite D. simpl. rewrite INV1. apply L.top_ge. auto. tauto.
elim (C H0 (refl_equal _)). intros X Y. rewrite Y. apply L.refl_ge.
@@ -1082,7 +1383,7 @@ Proof.
(* Case 2.1: n was already in worklist, still is *)
left. apply V. simpl. tauto.
(* Case 2.2: n was not in worklist *)
- assert (INV3: forall s instr', code!n = Some instr' -> In s (successors instr') -> st1.(st_in)!!s = res!!s).
+ assert (INV3: forall s instr', code!n = Some instr' -> In s (successors instr') -> st1.(aval)!!s = res!!s).
(* Amazingly, successors of n do not change. The only way
they could change is if they were successors of pc as well,
but that gives them two different predecessors, so
@@ -1181,7 +1482,7 @@ Qed.
(** ** Preservation of a property over solutions *)
Definition Pstate (st: state) : Prop :=
- forall pc, P st.(st_in)!!pc.
+ forall pc, P st.(aval)!!pc.
Lemma propagate_successors_P:
forall bb l,
@@ -1204,9 +1505,9 @@ Proof.
unfold fixpoint; intros. pattern res.
eapply (PrimIter.iterate_prop _ _ (step basic_block_map) Pstate).
- intros st PS. unfold step. destruct (st.(st_wrk)).
+ intros st PS. unfold step. destruct (st.(worklist)).
apply PS.
- assert (PS2: Pstate (mkstate st.(st_in) l)).
+ assert (PS2: Pstate (mkstate st.(aval) l)).
red; intro; simpl. apply PS.
destruct (code!p) as [instr|] eqn:CODE.
apply propagate_successors_P. eauto. auto.
@@ -1239,16 +1540,23 @@ Require Import Heaps.
Module NodeSetForward <: NODE_SET.
Definition t := PHeap.t.
+ Definition empty := PHeap.empty.
Definition add (n: positive) (s: t) : t := PHeap.insert n s.
Definition pick (s: t) :=
match PHeap.findMax s with
| Some n => Some(n, PHeap.deleteMax s)
| None => None
end.
- Definition initial {A: Type} (code: PTree.t A) :=
+ Definition all_nodes {A: Type} (code: PTree.t A) :=
PTree.fold (fun s pc instr => PHeap.insert pc s) code PHeap.empty.
Definition In := PHeap.In.
+ Lemma empty_spec:
+ forall n, ~In n empty.
+ Proof.
+ intros. apply PHeap.In_empty.
+ Qed.
+
Lemma add_spec:
forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
Proof.
@@ -1273,9 +1581,9 @@ Module NodeSetForward <: NODE_SET.
congruence.
Qed.
- Lemma initial_spec:
+ Lemma all_nodes_spec:
forall A (code: PTree.t A) n instr,
- code!n = Some instr -> In n (initial code).
+ code!n = Some instr -> In n (all_nodes code).
Proof.
intros A code n instr.
apply PTree_Properties.fold_rec with
@@ -1292,16 +1600,21 @@ End NodeSetForward.
Module NodeSetBackward <: NODE_SET.
Definition t := PHeap.t.
+ Definition empty := PHeap.empty.
Definition add (n: positive) (s: t) : t := PHeap.insert n s.
Definition pick (s: t) :=
match PHeap.findMin s with
| Some n => Some(n, PHeap.deleteMin s)
| None => None
end.
- Definition initial {A: Type} (code: PTree.t A) :=
+ Definition all_nodes {A: Type} (code: PTree.t A) :=
PTree.fold (fun s pc instr => PHeap.insert pc s) code PHeap.empty.
Definition In := PHeap.In.
+ Lemma empty_spec:
+ forall n, ~In n empty.
+ Proof NodeSetForward.empty_spec.
+
Lemma add_spec:
forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
Proof NodeSetForward.add_spec.
@@ -1324,9 +1637,9 @@ Module NodeSetBackward <: NODE_SET.
congruence.
Qed.
- Lemma initial_spec:
+ Lemma all_nodes_spec:
forall A (code: PTree.t A) n instr,
- code!n = Some instr -> In n (initial code).
- Proof NodeSetForward.initial_spec.
+ code!n = Some instr -> In n (all_nodes code).
+ Proof NodeSetForward.all_nodes_spec.
End NodeSetBackward.
diff --git a/backend/Linearize.v b/backend/Linearize.v
index a4d1c0d..b1102e2 100644
--- a/backend/Linearize.v
+++ b/backend/Linearize.v
@@ -93,7 +93,7 @@ Definition reachable_aux (f: LTL.function) : option (PMap.t bool) :=
DS.fixpoint
(LTL.fn_code f) successors_block
(fun pc r => r)
- ((f.(fn_entrypoint), true) :: nil).
+ f.(fn_entrypoint) true.
Definition reachable (f: LTL.function) : PMap.t bool :=
match reachable_aux f with
diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v
index 93d38dd..3b22fc6 100644
--- a/backend/Linearizeproof.v
+++ b/backend/Linearizeproof.v
@@ -108,7 +108,7 @@ Proof.
caseEq (reachable_aux f).
unfold reachable_aux; intros reach A.
assert (LBoolean.ge reach!!(f.(fn_entrypoint)) true).
- eapply DS.fixpoint_entry. eexact A. auto with coqlib.
+ eapply DS.fixpoint_entry. eexact A. auto.
unfold LBoolean.ge in H. tauto.
intros. apply PMap.gi.
Qed.
@@ -126,7 +126,7 @@ Proof.
unfold reachable_aux. intro reach; intros.
assert (LBoolean.ge reach!!pc' reach!!pc).
change (reach!!pc) with ((fun pc r => r) pc (reach!!pc)).
- eapply DS.fixpoint_solution; eauto.
+ eapply DS.fixpoint_solution; eauto. intros; apply DS.L.eq_refl.
elim H3; intro. congruence. auto.
intros. apply PMap.gi.
Qed.
diff --git a/backend/Liveness.v b/backend/Liveness.v
index 23faf41..3a5bde9 100644
--- a/backend/Liveness.v
+++ b/backend/Liveness.v
@@ -110,7 +110,7 @@ Module RegsetLat := LFSet(Regset).
Module DS := Backward_Dataflow_Solver(RegsetLat)(NodeSetBackward).
Definition analyze (f: function): option (PMap.t Regset.t) :=
- DS.fixpoint f.(fn_code) successors_instr (transfer f) nil.
+ DS.fixpoint f.(fn_code) successors_instr (transfer f).
(** Basic property of the liveness information computed by [analyze]. *)
@@ -122,6 +122,7 @@ Lemma analyze_solution:
Regset.Subset (transfer f s live!!s) live!!n.
Proof.
unfold analyze; intros. eapply DS.fixpoint_solution; eauto.
+ intros. unfold transfer; rewrite H2. apply DS.L.eq_refl.
Qed.
(** Given an RTL function, compute (for every PC) the list of
diff --git a/backend/NeedDomain.v b/backend/NeedDomain.v
new file mode 100644
index 0000000..568c80e
--- /dev/null
+++ b/backend/NeedDomain.v
@@ -0,0 +1,1515 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Abstract domain for neededness analysis *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import IntvSets.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Events.
+Require Import Lattice.
+Require Import Registers.
+Require Import ValueDomain.
+Require Import Op.
+Require Import RTL.
+
+(** * Neededness for values *)
+
+Inductive nval : Type :=
+ | Nothing (**r value is entirely unused *)
+ | I (m: int) (**r only need the bits that are 1 in [m] *)
+ | Fsingle (**r only need the value after conversion to single float *)
+ | All. (**r every bit of the value is used *)
+
+Definition eq_nval (x y: nval) : {x=y} + {x<>y}.
+Proof.
+ decide equality. apply Int.eq_dec.
+Defined.
+
+(** ** Agreement between two values relative to a need. *)
+
+Definition iagree (p q mask: int) : Prop :=
+ forall i, 0 <= i < Int.zwordsize -> Int.testbit mask i = true ->
+ Int.testbit p i = Int.testbit q i.
+
+Fixpoint vagree (v w: val) (x: nval) {struct x}: Prop :=
+ match x with
+ | Nothing => True
+ | I m =>
+ match v, w with
+ | Vint p, Vint q => iagree p q m
+ | Vint p, _ => False
+ | _, _ => True
+ end
+ | Fsingle =>
+ match v, w with
+ | Vfloat f, Vfloat g => Float.singleoffloat f = Float.singleoffloat g
+ | Vfloat _, _ => False
+ | _, _ => True
+ end
+ | All => Val.lessdef v w
+ end.
+
+Lemma vagree_same: forall v x, vagree v v x.
+Proof.
+ intros. destruct x; simpl; auto; destruct v; auto. red; auto.
+Qed.
+
+Lemma vagree_lessdef: forall v w x, Val.lessdef v w -> vagree v w x.
+Proof.
+ intros. inv H. apply vagree_same. destruct x; simpl; auto.
+Qed.
+
+Lemma lessdef_vagree: forall v w, vagree v w All -> Val.lessdef v w.
+Proof.
+ intros. simpl in H. auto.
+Qed.
+
+Hint Resolve vagree_same vagree_lessdef lessdef_vagree: na.
+
+Definition vagree_list (vl1 vl2: list val) (nv: nval) : Prop :=
+ list_forall2 (fun v1 v2 => vagree v1 v2 nv) vl1 vl2.
+
+Lemma lessdef_vagree_list:
+ forall vl1 vl2, vagree_list vl1 vl2 All -> Val.lessdef_list vl1 vl2.
+Proof.
+ induction 1; constructor; auto with na.
+Qed.
+
+Lemma vagree_lessdef_list:
+ forall x vl1 vl2, Val.lessdef_list vl1 vl2 -> vagree_list vl1 vl2 x.
+Proof.
+ induction 1; constructor; auto with na.
+Qed.
+
+Hint Resolve lessdef_vagree_list vagree_lessdef_list: na.
+
+(** ** Ordering and least upper bound between value needs *)
+
+Inductive nge: nval -> nval -> Prop :=
+ | nge_nothing: forall x, nge All x
+ | nge_all: forall x, nge x Nothing
+ | nge_int: forall m1 m2,
+ (forall i, 0 <= i < Int.zwordsize -> Int.testbit m2 i = true -> Int.testbit m1 i = true) ->
+ nge (I m1) (I m2)
+ | nge_single:
+ nge Fsingle Fsingle.
+
+Lemma nge_refl: forall x, nge x x.
+Proof.
+ destruct x; constructor; auto.
+Qed.
+
+Hint Constructors nge: na.
+Hint Resolve nge_refl: na.
+
+Lemma nge_trans: forall x y, nge x y -> forall z, nge y z -> nge x z.
+Proof.
+ induction 1; intros w VG; inv VG; eauto with na.
+Qed.
+
+Lemma nge_agree:
+ forall v w x y, nge x y -> vagree v w x -> vagree v w y.
+Proof.
+ induction 1; simpl; auto.
+- destruct v; auto with na.
+- destruct v, w; intuition. red; auto.
+Qed.
+
+Definition nlub (x y: nval) : nval :=
+ match x, y with
+ | Nothing, _ => y
+ | _, Nothing => x
+ | I m1, I m2 => I (Int.or m1 m2)
+ | Fsingle, Fsingle => Fsingle
+ | _, _ => All
+ end.
+
+Lemma nge_lub_l:
+ forall x y, nge (nlub x y) x.
+Proof.
+ unfold nlub; destruct x, y; auto with na.
+ constructor. intros. autorewrite with ints; auto. rewrite H0; auto.
+Qed.
+
+Lemma nge_lub_r:
+ forall x y, nge (nlub x y) y.
+Proof.
+ unfold nlub; destruct x, y; auto with na.
+ constructor. intros. autorewrite with ints; auto. rewrite H0. apply orb_true_r; auto.
+Qed.
+
+(** ** Properties of agreement between integers *)
+
+Lemma iagree_refl:
+ forall p m, iagree p p m.
+Proof.
+ intros; red; auto.
+Qed.
+
+Remark eq_same_bits:
+ forall i x y, x = y -> Int.testbit x i = Int.testbit y i.
+Proof.
+ intros; congruence.
+Qed.
+
+Lemma iagree_and_eq:
+ forall x y mask,
+ iagree x y mask <-> Int.and x mask = Int.and y mask.
+Proof.
+ intros; split; intros.
+- Int.bit_solve. specialize (H i H0).
+ destruct (Int.testbit mask i).
+ rewrite ! andb_true_r; auto.
+ rewrite ! andb_false_r; auto.
+- red; intros. exploit (eq_same_bits i); eauto; autorewrite with ints; auto.
+ rewrite H1. rewrite ! andb_true_r; auto.
+Qed.
+
+Lemma iagree_mone:
+ forall p q, iagree p q Int.mone -> p = q.
+Proof.
+ intros. rewrite iagree_and_eq in H. rewrite ! Int.and_mone in H. auto.
+Qed.
+
+Lemma iagree_zero:
+ forall p q, iagree p q Int.zero.
+Proof.
+ intros. rewrite iagree_and_eq. rewrite ! Int.and_zero; auto.
+Qed.
+
+Lemma iagree_and:
+ forall x y n m,
+ iagree x y (Int.and m n) -> iagree (Int.and x n) (Int.and y n) m.
+Proof.
+ intros. rewrite iagree_and_eq in *. rewrite ! Int.and_assoc.
+ rewrite (Int.and_commut n). auto.
+Qed.
+
+Lemma iagree_not:
+ forall x y m, iagree x y m -> iagree (Int.not x) (Int.not y) m.
+Proof.
+ intros; red; intros; autorewrite with ints; auto. f_equal; auto.
+Qed.
+
+Lemma iagree_not':
+ forall x y m, iagree (Int.not x) (Int.not y) m -> iagree x y m.
+Proof.
+ intros. rewrite <- (Int.not_involutive x). rewrite <- (Int.not_involutive y).
+ apply iagree_not; auto.
+Qed.
+
+Lemma iagree_or:
+ forall x y n m,
+ iagree x y (Int.and m (Int.not n)) -> iagree (Int.or x n) (Int.or y n) m.
+Proof.
+ intros. apply iagree_not'. rewrite ! Int.not_or_and_not. apply iagree_and.
+ apply iagree_not; auto.
+Qed.
+
+Lemma iagree_bitwise_binop:
+ forall sem f,
+ (forall x y i, 0 <= i < Int.zwordsize ->
+ Int.testbit (f x y) i = sem (Int.testbit x i) (Int.testbit y i)) ->
+ forall x1 x2 y1 y2 m,
+ iagree x1 y1 m -> iagree x2 y2 m -> iagree (f x1 x2) (f y1 y2) m.
+Proof.
+ intros; red; intros. rewrite ! H by auto. f_equal; auto.
+Qed.
+
+Lemma iagree_shl:
+ forall x y m n,
+ iagree x y (Int.shru m n) -> iagree (Int.shl x n) (Int.shl y n) m.
+Proof.
+ intros; red; intros. autorewrite with ints; auto.
+ destruct (zlt i (Int.unsigned n)).
+- auto.
+- generalize (Int.unsigned_range n); intros.
+ apply H. omega. rewrite Int.bits_shru by omega.
+ replace (i - Int.unsigned n + Int.unsigned n) with i by omega.
+ rewrite zlt_true by omega. auto.
+Qed.
+
+Lemma iagree_shru:
+ forall x y m n,
+ iagree x y (Int.shl m n) -> iagree (Int.shru x n) (Int.shru y n) m.
+Proof.
+ intros; red; intros. autorewrite with ints; auto.
+ destruct (zlt (i + Int.unsigned n) Int.zwordsize).
+- generalize (Int.unsigned_range n); intros.
+ apply H. omega. rewrite Int.bits_shl by omega.
+ replace (i + Int.unsigned n - Int.unsigned n) with i by omega.
+ rewrite zlt_false by omega. auto.
+- auto.
+Qed.
+
+Lemma iagree_shr_1:
+ forall x y m n,
+ Int.shru (Int.shl m n) n = m ->
+ iagree x y (Int.shl m n) -> iagree (Int.shr x n) (Int.shr y n) m.
+Proof.
+ intros; red; intros. rewrite <- H in H2. rewrite Int.bits_shru in H2 by auto.
+ rewrite ! Int.bits_shr by auto.
+ destruct (zlt (i + Int.unsigned n) Int.zwordsize).
+- apply H0; auto. generalize (Int.unsigned_range n); omega.
+- discriminate.
+Qed.
+
+Lemma iagree_shr:
+ forall x y m n,
+ iagree x y (Int.or (Int.shl m n) (Int.repr Int.min_signed)) ->
+ iagree (Int.shr x n) (Int.shr y n) m.
+Proof.
+ intros; red; intros. rewrite ! Int.bits_shr by auto.
+ generalize (Int.unsigned_range n); intros.
+ set (j := if zlt (i + Int.unsigned n) Int.zwordsize
+ then i + Int.unsigned n
+ else Int.zwordsize - 1).
+ assert (0 <= j < Int.zwordsize).
+ { unfold j; destruct (zlt (i + Int.unsigned n) Int.zwordsize); omega. }
+ apply H; auto. autorewrite with ints; auto. apply orb_true_intro.
+ unfold j; destruct (zlt (i + Int.unsigned n) Int.zwordsize).
+- left. rewrite zlt_false by omega.
+ replace (i + Int.unsigned n - Int.unsigned n) with i by omega.
+ auto.
+- right. reflexivity.
+Qed.
+
+Lemma iagree_rol:
+ forall p q m amount,
+ iagree p q (Int.ror m amount) ->
+ iagree (Int.rol p amount) (Int.rol q amount) m.
+Proof.
+ intros. assert (Int.zwordsize > 0) by (compute; auto).
+ red; intros. rewrite ! Int.bits_rol by auto. apply H.
+ apply Z_mod_lt; auto.
+ rewrite Int.bits_ror.
+ replace (((i - Int.unsigned amount) mod Int.zwordsize + Int.unsigned amount)
+ mod Int.zwordsize) with i. auto.
+ apply Int.eqmod_small_eq with Int.zwordsize; auto.
+ apply Int.eqmod_trans with ((i - Int.unsigned amount) + Int.unsigned amount).
+ apply Int.eqmod_refl2; omega.
+ eapply Int.eqmod_trans. 2: apply Int.eqmod_mod; auto.
+ apply Int.eqmod_add.
+ apply Int.eqmod_mod; auto.
+ apply Int.eqmod_refl.
+ apply Z_mod_lt; auto.
+ apply Z_mod_lt; auto.
+Qed.
+
+Lemma iagree_ror:
+ forall p q m amount,
+ iagree p q (Int.rol m amount) ->
+ iagree (Int.ror p amount) (Int.ror q amount) m.
+Proof.
+ intros. rewrite ! Int.ror_rol_neg by apply int_wordsize_divides_modulus.
+ apply iagree_rol.
+ rewrite Int.ror_rol_neg by apply int_wordsize_divides_modulus.
+ rewrite Int.neg_involutive; auto.
+Qed.
+
+Lemma eqmod_iagree:
+ forall m x y,
+ Int.eqmod (two_p (Int.size m)) x y ->
+ iagree (Int.repr x) (Int.repr y) m.
+Proof.
+ intros. set (p := nat_of_Z (Int.size m)).
+ generalize (Int.size_range m); intros RANGE.
+ assert (EQ: Int.size m = Z_of_nat p). { symmetry; apply nat_of_Z_eq. omega. }
+ rewrite EQ in H; rewrite <- two_power_nat_two_p in H.
+ red; intros. rewrite ! Int.testbit_repr by auto.
+ destruct (zlt i (Int.size m)).
+ eapply Int.same_bits_eqmod; eauto. omega.
+ assert (Int.testbit m i = false) by (eapply Int.bits_size_2; omega).
+ congruence.
+Qed.
+
+Definition complete_mask (m: int) := Int.zero_ext (Int.size m) Int.mone.
+
+Lemma iagree_eqmod:
+ forall x y m,
+ iagree x y (complete_mask m) ->
+ Int.eqmod (two_p (Int.size m)) (Int.unsigned x) (Int.unsigned y).
+Proof.
+ intros. set (p := nat_of_Z (Int.size m)).
+ generalize (Int.size_range m); intros RANGE.
+ assert (EQ: Int.size m = Z_of_nat p). { symmetry; apply nat_of_Z_eq. omega. }
+ rewrite EQ; rewrite <- two_power_nat_two_p.
+ apply Int.eqmod_same_bits. intros. apply H. omega.
+ unfold complete_mask. rewrite Int.bits_zero_ext by omega.
+ rewrite zlt_true by omega. rewrite Int.bits_mone by omega. auto.
+Qed.
+
+Lemma complete_mask_idem:
+ forall m, complete_mask (complete_mask m) = complete_mask m.
+Proof.
+ unfold complete_mask; intros. destruct (Int.eq_dec m Int.zero).
++ subst m; reflexivity.
++ assert (Int.unsigned m <> 0).
+ { red; intros; elim n. rewrite <- (Int.repr_unsigned m). rewrite H; auto. }
+ assert (0 < Int.size m).
+ { apply Int.Zsize_pos'. generalize (Int.unsigned_range m); omega. }
+ generalize (Int.size_range m); intros.
+ f_equal. apply Int.bits_size_4. tauto.
+ rewrite Int.bits_zero_ext by omega. rewrite zlt_true by omega.
+ apply Int.bits_mone; omega.
+ intros. rewrite Int.bits_zero_ext by omega. apply zlt_false; omega.
+Qed.
+
+(** ** Abstract operations over value needs. *)
+
+Ltac InvAgree :=
+ simpl vagree in *;
+ repeat (
+ auto || exact Logic.I ||
+ match goal with
+ | [ H: False |- _ ] => contradiction
+ | [ H: match ?v with Vundef => _ | Vint _ => _ | Vlong _ => _ | Vfloat _ => _ | Vptr _ _ => _ end |- _ ] => destruct v
+ end).
+
+(** And immediate, or immediate *)
+
+Definition andimm (x: nval) (n: int) :=
+ match x with
+ | Nothing | Fsingle => Nothing
+ | I m => I (Int.and m n)
+ | All => I n
+ end.
+
+Lemma andimm_sound:
+ forall v w x n,
+ vagree v w (andimm x n) ->
+ vagree (Val.and v (Vint n)) (Val.and w (Vint n)) x.
+Proof.
+ unfold andimm; intros; destruct x; simpl in *; unfold Val.and.
+- auto.
+- InvAgree. apply iagree_and; auto.
+- destruct v; destruct w; tauto.
+- InvAgree. rewrite iagree_and_eq in H. rewrite H; auto.
+Qed.
+
+Definition orimm (x: nval) (n: int) :=
+ match x with
+ | Nothing | Fsingle => Nothing
+ | I m => I (Int.and m (Int.not n))
+ | _ => I (Int.not n)
+ end.
+
+Lemma orimm_sound:
+ forall v w x n,
+ vagree v w (orimm x n) ->
+ vagree (Val.or v (Vint n)) (Val.or w (Vint n)) x.
+Proof.
+ unfold orimm; intros; destruct x; simpl in *.
+- auto.
+- unfold Val.or; InvAgree. apply iagree_or; auto.
+- destruct v; destruct w; tauto.
+- InvAgree. simpl. apply Val.lessdef_same. f_equal. apply iagree_mone.
+ apply iagree_or. rewrite Int.and_commut. rewrite Int.and_mone. auto.
+Qed.
+
+(** Bitwise operations: and, or, xor, not *)
+
+Definition bitwise (x: nval) :=
+ match x with
+ | Fsingle => Nothing
+ | _ => x
+ end.
+
+Remark bitwise_idem: forall nv, bitwise (bitwise nv) = bitwise nv.
+Proof. destruct nv; auto. Qed.
+
+Lemma vagree_bitwise_binop:
+ forall f,
+ (forall p1 p2 q1 q2 m,
+ iagree p1 q1 m -> iagree p2 q2 m -> iagree (f p1 p2) (f q1 q2) m) ->
+ forall v1 w1 v2 w2 x,
+ vagree v1 w1 (bitwise x) -> vagree v2 w2 (bitwise x) ->
+ vagree (match v1, v2 with Vint i1, Vint i2 => Vint(f i1 i2) | _, _ => Vundef end)
+ (match w1, w2 with Vint i1, Vint i2 => Vint(f i1 i2) | _, _ => Vundef end)
+ x.
+Proof.
+ unfold bitwise; intros. destruct x; simpl in *.
+- auto.
+- InvAgree.
+- destruct v1; auto. destruct v2; auto.
+- inv H0; auto. inv H1; auto. destruct w1; auto.
+Qed.
+
+Lemma and_sound:
+ forall v1 w1 v2 w2 x,
+ vagree v1 w1 (bitwise x) -> vagree v2 w2 (bitwise x) ->
+ vagree (Val.and v1 v2) (Val.and w1 w2) x.
+Proof (vagree_bitwise_binop Int.and (iagree_bitwise_binop andb Int.and Int.bits_and)).
+
+Lemma or_sound:
+ forall v1 w1 v2 w2 x,
+ vagree v1 w1 (bitwise x) -> vagree v2 w2 (bitwise x) ->
+ vagree (Val.or v1 v2) (Val.or w1 w2) x.
+Proof (vagree_bitwise_binop Int.or (iagree_bitwise_binop orb Int.or Int.bits_or)).
+
+Lemma xor_sound:
+ forall v1 w1 v2 w2 x,
+ vagree v1 w1 (bitwise x) -> vagree v2 w2 (bitwise x) ->
+ vagree (Val.xor v1 v2) (Val.xor w1 w2) x.
+Proof (vagree_bitwise_binop Int.xor (iagree_bitwise_binop xorb Int.xor Int.bits_xor)).
+
+Lemma notint_sound:
+ forall v w x,
+ vagree v w (bitwise x) -> vagree (Val.notint v) (Val.notint w) x.
+Proof.
+ intros. rewrite ! Val.not_xor. apply xor_sound; auto with na.
+Qed.
+
+(** Shifts and rotates *)
+
+Definition shlimm (x: nval) (n: int) :=
+ match x with
+ | Nothing | Fsingle => Nothing
+ | I m => I (Int.shru m n)
+ | All => I (Int.shru Int.mone n)
+ end.
+
+Lemma shlimm_sound:
+ forall v w x n,
+ vagree v w (shlimm x n) ->
+ vagree (Val.shl v (Vint n)) (Val.shl w (Vint n)) x.
+Proof.
+ unfold shlimm; intros. unfold Val.shl.
+ destruct (Int.ltu n Int.iwordsize).
+ destruct x; simpl in *.
+- auto.
+- InvAgree. apply iagree_shl; auto.
+- destruct v; destruct w; auto.
+- InvAgree. apply Val.lessdef_same. f_equal. apply iagree_mone. apply iagree_shl; auto.
+- destruct v; auto with na.
+Qed.
+
+Definition shruimm (x: nval) (n: int) :=
+ match x with
+ | Nothing | Fsingle => Nothing
+ | I m => I (Int.shl m n)
+ | All => I (Int.shl Int.mone n)
+ end.
+
+Lemma shruimm_sound:
+ forall v w x n,
+ vagree v w (shruimm x n) ->
+ vagree (Val.shru v (Vint n)) (Val.shru w (Vint n)) x.
+Proof.
+ unfold shruimm; intros. unfold Val.shru.
+ destruct (Int.ltu n Int.iwordsize).
+ destruct x; simpl in *.
+- auto.
+- InvAgree. apply iagree_shru; auto.
+- destruct v; destruct w; auto.
+- InvAgree. apply Val.lessdef_same. f_equal. apply iagree_mone. apply iagree_shru; auto.
+- destruct v; auto with na.
+Qed.
+
+Definition shrimm (x: nval) (n: int) :=
+ match x with
+ | Nothing | Fsingle => Nothing
+ | I m => I (let m' := Int.shl m n in
+ if Int.eq_dec (Int.shru m' n) m
+ then m'
+ else Int.or m' (Int.repr Int.min_signed))
+ | All => I (Int.or (Int.shl Int.mone n) (Int.repr Int.min_signed))
+ end.
+
+Lemma shrimm_sound:
+ forall v w x n,
+ vagree v w (shrimm x n) ->
+ vagree (Val.shr v (Vint n)) (Val.shr w (Vint n)) x.
+Proof.
+ unfold shrimm; intros. unfold Val.shr.
+ destruct (Int.ltu n Int.iwordsize).
+ destruct x; simpl in *.
+- auto.
+- InvAgree.
+ destruct (Int.eq_dec (Int.shru (Int.shl m n) n) m).
+ apply iagree_shr_1; auto.
+ apply iagree_shr; auto.
+- destruct v; destruct w; auto.
+- InvAgree. apply Val.lessdef_same. f_equal. apply iagree_mone. apply iagree_shr. auto.
+- destruct v; auto with na.
+Qed.
+
+Definition rolm (x: nval) (amount mask: int) :=
+ match x with
+ | Nothing | Fsingle => Nothing
+ | I m => I (Int.ror (Int.and m mask) amount)
+ | _ => I (Int.ror mask amount)
+ end.
+
+Lemma rolm_sound:
+ forall v w x amount mask,
+ vagree v w (rolm x amount mask) ->
+ vagree (Val.rolm v amount mask) (Val.rolm w amount mask) x.
+Proof.
+ unfold rolm; intros; destruct x; simpl in *.
+- auto.
+- unfold Val.rolm; InvAgree. unfold Int.rolm.
+ apply iagree_and. apply iagree_rol. auto.
+- unfold Val.rolm; destruct v, w; auto.
+- unfold Val.rolm; InvAgree. apply Val.lessdef_same. f_equal. apply iagree_mone.
+ unfold Int.rolm. apply iagree_and. apply iagree_rol. rewrite Int.and_commut.
+ rewrite Int.and_mone. auto.
+Qed.
+
+Definition ror (x: nval) (amount: int) :=
+ match x with
+ | Nothing | Fsingle => Nothing
+ | I m => I (Int.rol m amount)
+ | All => All
+ end.
+
+Lemma ror_sound:
+ forall v w x n,
+ vagree v w (ror x n) ->
+ vagree (Val.ror v (Vint n)) (Val.ror w (Vint n)) x.
+Proof.
+ unfold ror; intros. unfold Val.ror.
+ destruct (Int.ltu n Int.iwordsize).
+ destruct x; simpl in *.
+- auto.
+- InvAgree. apply iagree_ror; auto.
+- destruct v, w; auto.
+- inv H; auto.
+- destruct v; auto with na.
+Qed.
+
+(** Modular arithmetic operations: add, mul.
+ (But not subtraction because of the pointer - pointer case. *)
+
+Definition modarith (x: nval) :=
+ match x with
+ | Nothing | Fsingle => Nothing
+ | I m => I (complete_mask m)
+ | All => All
+ end.
+
+Lemma add_sound:
+ forall v1 w1 v2 w2 x,
+ vagree v1 w1 (modarith x) -> vagree v2 w2 (modarith x) ->
+ vagree (Val.add v1 v2) (Val.add w1 w2) x.
+Proof.
+ unfold modarith; intros. destruct x; simpl in *.
+- auto.
+- unfold Val.add; InvAgree. apply eqmod_iagree. apply Int.eqmod_add; apply iagree_eqmod; auto.
+- unfold Val.add; destruct v1, w1; auto; destruct v2, w2; auto.
+- inv H; auto. inv H0; auto. destruct w1; auto.
+Qed.
+
+Remark modarith_idem: forall nv, modarith (modarith nv) = modarith nv.
+Proof.
+ destruct nv; simpl; auto. f_equal; apply complete_mask_idem.
+Qed.
+
+Lemma add_sound_2:
+ forall v1 w1 v2 w2 x,
+ vagree v1 w1 (modarith x) -> vagree v2 w2 (modarith x) ->
+ vagree (Val.add v1 v2) (Val.add w1 w2) (modarith x).
+Proof.
+ intros. apply add_sound; rewrite modarith_idem; auto.
+Qed.
+
+Lemma mul_sound:
+ forall v1 w1 v2 w2 x,
+ vagree v1 w1 (modarith x) -> vagree v2 w2 (modarith x) ->
+ vagree (Val.mul v1 v2) (Val.mul w1 w2) x.
+Proof.
+ unfold mul, add; intros. destruct x; simpl in *.
+- auto.
+- unfold Val.mul; InvAgree. apply eqmod_iagree. apply Int.eqmod_mult; apply iagree_eqmod; auto.
+- unfold Val.mul; destruct v1, w1; auto; destruct v2, w2; auto.
+- inv H; auto. inv H0; auto. destruct w1; auto.
+Qed.
+
+Lemma mul_sound_2:
+ forall v1 w1 v2 w2 x,
+ vagree v1 w1 (modarith x) -> vagree v2 w2 (modarith x) ->
+ vagree (Val.mul v1 v2) (Val.mul w1 w2) (modarith x).
+Proof.
+ intros. apply mul_sound; rewrite modarith_idem; auto.
+Qed.
+
+(** Conversions: zero extension, sign extension, single-of-float *)
+
+Definition zero_ext (n: Z) (x: nval) :=
+ match x with
+ | Nothing | Fsingle => Nothing
+ | I m => I (Int.zero_ext n m)
+ | All => I (Int.zero_ext n Int.mone)
+ end.
+
+Lemma zero_ext_sound:
+ forall v w x n,
+ vagree v w (zero_ext n x) ->
+ 0 <= n ->
+ vagree (Val.zero_ext n v) (Val.zero_ext n w) x.
+Proof.
+ unfold zero_ext; intros.
+ destruct x; simpl in *.
+- auto.
+- unfold Val.zero_ext; InvAgree.
+ red; intros. autorewrite with ints; try omega.
+ destruct (zlt i1 n); auto. apply H; auto.
+ autorewrite with ints; try omega. rewrite zlt_true; auto.
+- unfold Val.zero_ext; destruct v; destruct w; auto.
+- unfold Val.zero_ext; InvAgree; auto. apply Val.lessdef_same. f_equal.
+ Int.bit_solve; try omega. destruct (zlt i1 n); auto. apply H; auto.
+ autorewrite with ints; try omega. apply zlt_true; auto.
+Qed.
+
+Definition sign_ext (n: Z) (x: nval) :=
+ match x with
+ | Nothing | Fsingle => Nothing
+ | I m => I (Int.or (Int.zero_ext n m) (Int.shl Int.one (Int.repr (n - 1))))
+ | All => I (Int.zero_ext n Int.mone)
+ end.
+
+Lemma sign_ext_sound:
+ forall v w x n,
+ vagree v w (sign_ext n x) ->
+ 0 < n < Int.zwordsize ->
+ vagree (Val.sign_ext n v) (Val.sign_ext n w) x.
+Proof.
+ unfold sign_ext; intros. destruct x; simpl in *.
+- auto.
+- unfold Val.sign_ext; InvAgree.
+ red; intros. autorewrite with ints; try omega.
+ set (j := if zlt i1 n then i1 else n - 1).
+ assert (0 <= j < Int.zwordsize).
+ { unfold j; destruct (zlt i1 n); omega. }
+ apply H; auto.
+ autorewrite with ints; try omega. apply orb_true_intro.
+ unfold j; destruct (zlt i1 n).
+ left. rewrite zlt_true; auto.
+ right. rewrite Int.unsigned_repr. rewrite zlt_false by omega.
+ replace (n - 1 - (n - 1)) with 0 by omega. reflexivity.
+ generalize Int.wordsize_max_unsigned; omega.
+- unfold Val.sign_ext; destruct v; destruct w; auto.
+- unfold Val.sign_ext; InvAgree; auto. apply Val.lessdef_same. f_equal.
+ Int.bit_solve; try omega.
+ set (j := if zlt i1 n then i1 else n - 1).
+ assert (0 <= j < Int.zwordsize).
+ { unfold j; destruct (zlt i1 n); omega. }
+ apply H; auto. rewrite Int.bits_zero_ext; try omega.
+ rewrite zlt_true. apply Int.bits_mone; auto.
+ unfold j. destruct (zlt i1 n); omega.
+Qed.
+
+Definition singleoffloat (x: nval) :=
+ match x with
+ | Nothing | I _ => Nothing
+ | Fsingle | All => Fsingle
+ end.
+
+Lemma singleoffloat_sound:
+ forall v w x,
+ vagree v w (singleoffloat x) ->
+ vagree (Val.singleoffloat v) (Val.singleoffloat w) x.
+Proof.
+ unfold singleoffloat; intros. destruct x; simpl in *.
+- auto.
+- unfold Val.singleoffloat; destruct v, w; auto.
+- unfold Val.singleoffloat; InvAgree. congruence.
+- unfold Val.singleoffloat; InvAgree; auto. rewrite H; auto.
+Qed.
+
+(** The needs of a memory store concerning the value being stored. *)
+
+Definition store_argument (chunk: memory_chunk) :=
+ match chunk with
+ | Mint8signed | Mint8unsigned => I (Int.repr 255)
+ | Mint16signed | Mint16unsigned => I (Int.repr 65535)
+ | Mfloat32 => Fsingle
+ | _ => All
+ end.
+
+Lemma store_argument_sound:
+ forall chunk v w,
+ vagree v w (store_argument chunk) ->
+ list_forall2 memval_lessdef (encode_val chunk v) (encode_val chunk w).
+Proof.
+ intros.
+ assert (UNDEF: list_forall2 memval_lessdef
+ (list_repeat (size_chunk_nat chunk) Undef)
+ (encode_val chunk w)).
+ {
+ rewrite <- (encode_val_length chunk w).
+ apply repeat_Undef_inject_any.
+ }
+ assert (SAME: forall vl1 vl2,
+ vl1 = vl2 ->
+ list_forall2 memval_lessdef vl1 vl2).
+ {
+ intros. subst vl2. revert vl1. induction vl1; constructor; auto.
+ apply memval_lessdef_refl.
+ }
+
+ intros. unfold store_argument in H; destruct chunk.
+- InvAgree. apply SAME. simpl; f_equal. apply encode_int_8_mod.
+ change 8 with (Int.size (Int.repr 255)). apply iagree_eqmod; auto.
+- InvAgree. apply SAME. simpl; f_equal. apply encode_int_8_mod.
+ change 8 with (Int.size (Int.repr 255)). apply iagree_eqmod; auto.
+- InvAgree. apply SAME. simpl; f_equal. apply encode_int_16_mod.
+ change 16 with (Int.size (Int.repr 65535)). apply iagree_eqmod; auto.
+- InvAgree. apply SAME. simpl; f_equal. apply encode_int_16_mod.
+ change 16 with (Int.size (Int.repr 65535)). apply iagree_eqmod; auto.
+- apply encode_val_inject. rewrite val_inject_id; auto.
+- apply encode_val_inject. rewrite val_inject_id; auto.
+- InvAgree. apply SAME. simpl.
+ rewrite <- (Float.bits_of_singleoffloat f).
+ rewrite <- (Float.bits_of_singleoffloat f0).
+ congruence.
+- apply encode_val_inject. rewrite val_inject_id; auto.
+- apply encode_val_inject. rewrite val_inject_id; auto.
+Qed.
+
+Lemma store_argument_load_result:
+ forall chunk v w,
+ vagree v w (store_argument chunk) ->
+ Val.lessdef (Val.load_result chunk v) (Val.load_result chunk w).
+Proof.
+ unfold store_argument; intros; destruct chunk;
+ auto using Val.load_result_lessdef; InvAgree; simpl.
+- apply sign_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 8).
+ auto. compute; auto.
+- apply zero_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 8).
+ auto. omega.
+- apply sign_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 16).
+ auto. compute; auto.
+- apply zero_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 16).
+ auto. omega.
+- apply singleoffloat_sound with (v := Vfloat f) (w := Vfloat f0) (x := All).
+ auto.
+Qed.
+
+(** The needs of a comparison *)
+
+Definition maskzero (n: int) := I n.
+
+Lemma maskzero_sound:
+ forall v w n b,
+ vagree v w (maskzero n) ->
+ Val.maskzero_bool v n = Some b ->
+ Val.maskzero_bool w n = Some b.
+Proof.
+ unfold maskzero; intros.
+ unfold Val.maskzero_bool; InvAgree; try discriminate.
+ inv H0. rewrite iagree_and_eq in H. rewrite H. auto.
+Qed.
+
+(** The default abstraction: if the result is unused, the arguments are
+ unused; otherwise, the arguments are needed in full. *)
+
+Definition default (x: nval) :=
+ match x with
+ | Nothing => Nothing
+ | _ => All
+ end.
+
+Section DEFAULT.
+
+Variable ge: genv.
+Variable sp: block.
+Variables m1 m2: mem.
+Hypothesis PERM: forall b ofs k p, Mem.perm m1 b ofs k p -> Mem.perm m2 b ofs k p.
+
+Let valid_pointer_inj:
+ forall b1 ofs b2 delta,
+ inject_id b1 = Some(b2, delta) ->
+ Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true ->
+ Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true.
+Proof.
+ unfold inject_id; intros. inv H. rewrite Int.add_zero.
+ rewrite Mem.valid_pointer_nonempty_perm in *. eauto.
+Qed.
+
+Let weak_valid_pointer_inj:
+ forall b1 ofs b2 delta,
+ inject_id b1 = Some(b2, delta) ->
+ Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true ->
+ Mem.weak_valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true.
+Proof.
+ unfold inject_id; intros. inv H. rewrite Int.add_zero.
+ rewrite Mem.weak_valid_pointer_spec in *.
+ rewrite ! Mem.valid_pointer_nonempty_perm in *.
+ destruct H0; [left|right]; eauto.
+Qed.
+
+Let weak_valid_pointer_no_overflow:
+ forall b1 ofs b2 delta,
+ inject_id b1 = Some(b2, delta) ->
+ Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true ->
+ 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned.
+Proof.
+ unfold inject_id; intros. inv H. rewrite Zplus_0_r. apply Int.unsigned_range_2.
+Qed.
+
+Let valid_different_pointers_inj:
+ forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
+ b1 <> b2 ->
+ Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true ->
+ Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true ->
+ inject_id b1 = Some (b1', delta1) ->
+ inject_id b2 = Some (b2', delta2) ->
+ b1' <> b2' \/
+ Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)).
+Proof.
+ unfold inject_id; intros. left; congruence.
+Qed.
+
+Lemma default_needs_of_condition_sound:
+ forall cond args1 b args2,
+ eval_condition cond args1 m1 = Some b ->
+ vagree_list args1 args2 All ->
+ eval_condition cond args2 m2 = Some b.
+Proof.
+ intros. apply eval_condition_inj with (f := inject_id) (m1 := m1) (vl1 := args1); auto.
+ apply val_list_inject_lessdef. apply lessdef_vagree_list. auto.
+Qed.
+
+Lemma default_needs_of_operation_sound:
+ forall op args1 v1 args2 nv,
+ eval_operation ge (Vptr sp Int.zero) op args1 m1 = Some v1 ->
+ vagree_list args1 args2 (default nv) ->
+ nv <> Nothing ->
+ exists v2,
+ eval_operation ge (Vptr sp Int.zero) op args2 m2 = Some v2
+ /\ vagree v1 v2 nv.
+Proof.
+ intros. assert (default nv = All) by (destruct nv; simpl; congruence).
+ rewrite H2 in H0.
+ exploit (@eval_operation_inj _ _ ge inject_id).
+ intros. apply val_inject_lessdef. auto.
+ eassumption. auto. auto. auto.
+ apply val_inject_lessdef. instantiate (1 := Vptr sp Int.zero). instantiate (1 := Vptr sp Int.zero). auto.
+ apply val_list_inject_lessdef. apply lessdef_vagree_list. eauto.
+ eauto.
+ intros (v2 & A & B). exists v2; split; auto.
+ apply vagree_lessdef. apply val_inject_lessdef. auto.
+Qed.
+
+End DEFAULT.
+
+(** ** Detecting operations that are redundant and can be turned into a move *)
+
+Definition andimm_redundant (x: nval) (n: int) :=
+ match x with
+ | Nothing => true
+ | I m => Int.eq_dec (Int.and m (Int.not n)) Int.zero
+ | _ => false
+ end.
+
+Lemma andimm_redundant_sound:
+ forall v w x n,
+ andimm_redundant x n = true ->
+ vagree v w (andimm x n) ->
+ vagree (Val.and v (Vint n)) w x.
+Proof.
+ unfold andimm_redundant; intros. destruct x; try discriminate.
+- simpl; auto.
+- InvBooleans. simpl in *; unfold Val.and; InvAgree.
+ red; intros. exploit (eq_same_bits i1); eauto.
+ autorewrite with ints; auto. rewrite H2; simpl; intros.
+ destruct (Int.testbit n i1) eqn:N; try discriminate.
+ rewrite andb_true_r. apply H0; auto. autorewrite with ints; auto.
+ rewrite H2, N; auto.
+Qed.
+
+Definition orimm_redundant (x: nval) (n: int) :=
+ match x with
+ | Nothing => true
+ | I m => Int.eq_dec (Int.and m n) Int.zero
+ | _ => false
+ end.
+
+Lemma orimm_redundant_sound:
+ forall v w x n,
+ orimm_redundant x n = true ->
+ vagree v w (orimm x n) ->
+ vagree (Val.or v (Vint n)) w x.
+Proof.
+ unfold orimm_redundant; intros. destruct x; try discriminate.
+- auto.
+- InvBooleans. simpl in *; unfold Val.or; InvAgree.
+ apply iagree_not'. rewrite Int.not_or_and_not.
+ apply (andimm_redundant_sound (Vint (Int.not i)) (Vint (Int.not i0)) (I m) (Int.not n)).
+ simpl. rewrite Int.not_involutive. apply proj_sumbool_is_true. auto.
+ simpl. apply iagree_not; auto.
+Qed.
+
+Definition rolm_redundant (x: nval) (amount mask: int) :=
+ Int.eq_dec amount Int.zero && andimm_redundant x mask.
+
+Lemma rolm_redundant_sound:
+ forall v w x amount mask,
+ rolm_redundant x amount mask = true ->
+ vagree v w (rolm x amount mask) ->
+ vagree (Val.rolm v amount mask) w x.
+Proof.
+ unfold rolm_redundant; intros; InvBooleans. subst amount. rewrite Val.rolm_zero.
+ apply andimm_redundant_sound; auto.
+ assert (forall n, Int.ror n Int.zero = n).
+ { intros. rewrite Int.ror_rol_neg by apply int_wordsize_divides_modulus.
+ rewrite Int.neg_zero. apply Int.rol_zero. }
+ unfold rolm, andimm in *. destruct x; auto.
+ rewrite H in H0. auto.
+ rewrite H in H0. auto.
+Qed.
+
+Definition zero_ext_redundant (n: Z) (x: nval) :=
+ match x with
+ | Nothing => true
+ | I m => Int.eq_dec (Int.zero_ext n m) m
+ | _ => false
+ end.
+
+Lemma zero_ext_redundant_sound:
+ forall v w x n,
+ zero_ext_redundant n x = true ->
+ vagree v w (zero_ext n x) ->
+ 0 <= n ->
+ vagree (Val.zero_ext n v) w x.
+Proof.
+ unfold zero_ext_redundant; intros. destruct x; try discriminate.
+- auto.
+- simpl in *; InvAgree. simpl. InvBooleans. rewrite <- H.
+ red; intros; autorewrite with ints; try omega.
+ destruct (zlt i1 n). apply H0; auto.
+ rewrite Int.bits_zero_ext in H3 by omega. rewrite zlt_false in H3 by auto. discriminate.
+Qed.
+
+Definition sign_ext_redundant (n: Z) (x: nval) :=
+ match x with
+ | Nothing => true
+ | I m => Int.eq_dec (Int.zero_ext n m) m
+ | _ => false
+ end.
+
+Lemma sign_ext_redundant_sound:
+ forall v w x n,
+ sign_ext_redundant n x = true ->
+ vagree v w (sign_ext n x) ->
+ 0 < n ->
+ vagree (Val.sign_ext n v) w x.
+Proof.
+ unfold sign_ext_redundant; intros. destruct x; try discriminate.
+- auto.
+- simpl in *; InvAgree. simpl. InvBooleans. rewrite <- H.
+ red; intros; autorewrite with ints; try omega.
+ destruct (zlt i1 n). apply H0; auto.
+ rewrite Int.bits_or; auto. rewrite H3; auto.
+ rewrite Int.bits_zero_ext in H3 by omega. rewrite zlt_false in H3 by auto. discriminate.
+Qed.
+
+Definition singleoffloat_redundant (x: nval) :=
+ match x with
+ | Nothing => true
+ | Fsingle => true
+ | _ => false
+ end.
+
+Lemma singleoffloat_redundant_sound:
+ forall v w x,
+ singleoffloat_redundant x = true ->
+ vagree v w (singleoffloat x) ->
+ vagree (Val.singleoffloat v) w x.
+Proof.
+ unfold singleoffloat; intros. destruct x; try discriminate.
+- auto.
+- simpl in *; InvAgree. simpl. rewrite Float.singleoffloat_idem; auto.
+Qed.
+
+(** * Neededness for register environments *)
+
+Module NVal <: SEMILATTICE.
+
+ Definition t := nval.
+ 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).
+ Definition beq (x y: t) : bool := proj_sumbool (eq_nval x y).
+ Lemma beq_correct: forall x y, beq x y = true -> eq x y.
+ Proof. unfold beq; intros. InvBooleans. auto. Qed.
+ Definition ge := nge.
+ Lemma ge_refl: forall x y, eq x y -> ge x y.
+ Proof. unfold eq, ge; intros. subst y. apply nge_refl. Qed.
+ Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
+ Proof. unfold ge; intros. eapply nge_trans; eauto. Qed.
+ Definition bot : t := Nothing.
+ Lemma ge_bot: forall x, ge x bot.
+ Proof. intros. constructor. Qed.
+ Definition lub := nlub.
+ Lemma ge_lub_left: forall x y, ge (lub x y) x.
+ Proof nge_lub_l.
+ Lemma ge_lub_right: forall x y, ge (lub x y) y.
+ Proof nge_lub_r.
+End NVal.
+
+Module NE := LPMap1(NVal).
+
+Definition nenv := NE.t.
+
+Definition nreg (ne: nenv) (r: reg) := NE.get r ne.
+
+Definition eagree (e1 e2: regset) (ne: nenv) : Prop :=
+ forall r, vagree e1#r e2#r (NE.get r ne).
+
+Lemma nreg_agree:
+ forall rs1 rs2 ne r, eagree rs1 rs2 ne -> vagree rs1#r rs2#r (nreg ne r).
+Proof.
+ intros. apply H.
+Qed.
+
+Hint Resolve nreg_agree: na.
+
+Lemma eagree_ge:
+ forall e1 e2 ne ne',
+ eagree e1 e2 ne -> NE.ge ne ne' -> eagree e1 e2 ne'.
+Proof.
+ intros; red; intros. apply nge_agree with (NE.get r ne); auto. apply H0.
+Qed.
+
+Lemma eagree_bot:
+ forall e1 e2, eagree e1 e2 NE.bot.
+Proof.
+ intros; red; intros. rewrite NE.get_bot. exact Logic.I.
+Qed.
+
+Lemma eagree_same:
+ forall e ne, eagree e e ne.
+Proof.
+ intros; red; intros. apply vagree_same.
+Qed.
+
+Lemma eagree_update_1:
+ forall e1 e2 ne v1 v2 nv r,
+ eagree e1 e2 ne -> vagree v1 v2 nv -> eagree (e1#r <- v1) (e2#r <- v2) (NE.set r nv ne).
+Proof.
+ intros; red; intros. rewrite NE.gsspec. rewrite ! PMap.gsspec.
+ destruct (peq r0 r); auto.
+Qed.
+
+Lemma eagree_update:
+ forall e1 e2 ne v1 v2 r,
+ vagree v1 v2 (nreg ne r) ->
+ eagree e1 e2 (NE.set r Nothing ne) ->
+ eagree (e1#r <- v1) (e2#r <- v2) ne.
+Proof.
+ intros; red; intros. specialize (H0 r0). rewrite NE.gsspec in H0.
+ rewrite ! PMap.gsspec. destruct (peq r0 r).
+ subst r0. auto.
+ auto.
+Qed.
+
+Lemma eagree_update_dead:
+ forall e1 e2 ne v1 r,
+ nreg ne r = Nothing ->
+ eagree e1 e2 ne -> eagree (e1#r <- v1) e2 ne.
+Proof.
+ intros; red; intros. rewrite PMap.gsspec.
+ destruct (peq r0 r); auto. subst. unfold nreg in H. rewrite H. red; auto.
+Qed.
+
+(** * Neededness for memory locations *)
+
+Inductive nmem : Type :=
+ | NMemDead
+ | NMem (stk: ISet.t) (gl: PTree.t ISet.t).
+
+(** Interpretation of [nmem]:
+- [NMemDead]: all memory locations are unused (dead). Acts as bottom.
+- [NMem stk gl]: all memory locations are used, except:
+ - the stack locations whose offset is in the interval [stk]
+ - the global locations whose offset is in the corresponding entry of [gl].
+*)
+
+Section LOCATIONS.
+
+Variable ge: genv.
+Variable sp: block.
+
+Inductive nlive: nmem -> block -> Z -> Prop :=
+ | nlive_intro: forall stk gl b ofs
+ (STK: b = sp -> ~ISet.In ofs stk)
+ (GL: forall id iv,
+ Genv.find_symbol ge id = Some b ->
+ gl!id = Some iv ->
+ ~ISet.In ofs iv),
+ nlive (NMem stk gl) b ofs.
+
+(** All locations are live *)
+
+Definition nmem_all := NMem ISet.empty (PTree.empty _).
+
+Lemma nlive_all: forall b ofs, nlive nmem_all b ofs.
+Proof.
+ intros; constructor; intros.
+ apply ISet.In_empty.
+ rewrite PTree.gempty in H0; discriminate.
+Qed.
+
+(** Add a range of live locations to [nm]. The range starts at
+ the abstract pointer [p] and has length [sz]. *)
+
+Definition nmem_add (nm: nmem) (p: aptr) (sz: Z) : nmem :=
+ match nm with
+ | NMemDead => nmem_all (**r very conservative, should never happen *)
+ | NMem stk gl =>
+ match p with
+ | Gl id ofs =>
+ match gl!id with
+ | Some iv => NMem stk (PTree.set id (ISet.remove (Int.unsigned ofs) (Int.unsigned ofs + sz) iv) gl)
+ | None => nm
+ end
+ | Glo id =>
+ NMem stk (PTree.remove id gl)
+ | Stk ofs =>
+ NMem (ISet.remove (Int.unsigned ofs) (Int.unsigned ofs + sz) stk) gl
+ | Stack =>
+ NMem ISet.empty gl
+ | _ => nmem_all
+ end
+ end.
+
+Lemma nlive_add:
+ forall bc b ofs p nm sz i,
+ genv_match bc ge ->
+ bc sp = BCstack ->
+ pmatch bc b ofs p ->
+ Int.unsigned ofs <= i < Int.unsigned ofs + sz ->
+ nlive (nmem_add nm p sz) b i.
+Proof.
+ intros. unfold nmem_add. destruct nm. apply nlive_all.
+ inv H1; try (apply nlive_all).
+ - (* Gl id ofs *)
+ assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto).
+ destruct gl!id as [iv|] eqn:NG.
+ + constructor; simpl; intros.
+ congruence.
+ assert (id0 = id) by (eapply Genv.genv_vars_inj; eauto). subst id0.
+ rewrite PTree.gss in H5. inv H5. rewrite ISet.In_remove.
+ intros [A B]. elim A; auto.
+ + constructor; simpl; intros.
+ congruence.
+ assert (id0 = id) by (eapply Genv.genv_vars_inj; eauto). subst id0.
+ congruence.
+ - (* Glo id *)
+ assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto).
+ constructor; simpl; intros.
+ congruence.
+ assert (id0 = id) by (eapply Genv.genv_vars_inj; eauto). subst id0.
+ rewrite PTree.grs in H5. congruence.
+ - (* Stk ofs *)
+ constructor; simpl; intros.
+ rewrite ISet.In_remove. intros [A B]. elim A; auto.
+ assert (bc b = BCglob id) by (eapply H; eauto). congruence.
+ - (* Stack *)
+ constructor; simpl; intros.
+ apply ISet.In_empty.
+ assert (bc b = BCglob id) by (eapply H; eauto). congruence.
+Qed.
+
+Lemma incl_nmem_add:
+ forall nm b i p sz,
+ nlive nm b i -> nlive (nmem_add nm p sz) b i.
+Proof.
+ intros. inversion H; subst. unfold nmem_add; destruct p; try (apply nlive_all).
+- (* Gl id ofs *)
+ destruct gl!id as [iv|] eqn:NG.
+ + split; simpl; intros. auto.
+ rewrite PTree.gsspec in H1. destruct (peq id0 id); eauto. inv H1.
+ rewrite ISet.In_remove. intros [P Q]. eelim GL; eauto.
+ + auto.
+- (* Glo id *)
+ split; simpl; intros. auto.
+ rewrite PTree.grspec in H1. destruct (PTree.elt_eq id0 id). congruence. eauto.
+- (* Stk ofs *)
+ split; simpl; intros.
+ rewrite ISet.In_remove. intros [P Q]. eelim STK; eauto.
+ eauto.
+- (* Stack *)
+ split; simpl; intros.
+ apply ISet.In_empty.
+ eauto.
+Qed.
+
+(** Remove a range of locations from [nm], marking these locations as dead.
+ The range starts at the abstract pointer [p] and has length [sz]. *)
+
+Definition nmem_remove (nm: nmem) (p: aptr) (sz: Z) : nmem :=
+ match nm with
+ | NMemDead => NMemDead
+ | NMem stk gl =>
+ match p with
+ | Gl id ofs =>
+ let iv' :=
+ match gl!id with
+ | Some iv => ISet.add (Int.unsigned ofs) (Int.unsigned ofs + sz) iv
+ | None => ISet.interval (Int.unsigned ofs) (Int.unsigned ofs + sz)
+ end in
+ NMem stk (PTree.set id iv' gl)
+ | Stk ofs =>
+ NMem (ISet.add (Int.unsigned ofs) (Int.unsigned ofs + sz) stk) gl
+ | _ => nm
+ end
+ end.
+
+Lemma nlive_remove:
+ forall bc b ofs p nm sz b' i,
+ genv_match bc ge ->
+ bc sp = BCstack ->
+ pmatch bc b ofs p ->
+ nlive nm b' i ->
+ b' <> b \/ i < Int.unsigned ofs \/ Int.unsigned ofs + sz <= i ->
+ nlive (nmem_remove nm p sz) b' i.
+Proof.
+ intros. inversion H2; subst. unfold nmem_remove; inv H1; auto.
+- (* Gl id ofs *)
+ set (iv' := match gl!id with
+ | Some iv =>
+ ISet.add (Int.unsigned ofs) (Int.unsigned ofs + sz) iv
+ | None =>
+ ISet.interval (Int.unsigned ofs)
+ (Int.unsigned ofs + sz)
+ end).
+ assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto).
+ split; simpl; auto; intros.
+ rewrite PTree.gsspec in H6. destruct (peq id0 id).
++ inv H6. destruct H3. congruence. destruct gl!id as [iv0|] eqn:NG.
+ rewrite ISet.In_add. intros [P|P]. omega. eelim GL; eauto.
+ rewrite ISet.In_interval. omega.
++ eauto.
+- (* Stk ofs *)
+ split; simpl; auto; intros. destruct H3.
+ elim H3. subst b'. eapply bc_stack; eauto.
+ rewrite ISet.In_add. intros [P|P]. omega. eapply STK; eauto.
+Qed.
+
+(** Test (conservatively) whether some locations in the range delimited
+ by [p] and [sz] can be live in [nm]. *)
+
+Definition nmem_contains (nm: nmem) (p: aptr) (sz: Z) :=
+ match nm with
+ | NMemDead => false
+ | NMem stk gl =>
+ match p with
+ | Gl id ofs =>
+ match gl!id with
+ | Some iv => negb (ISet.contains (Int.unsigned ofs) (Int.unsigned ofs + sz) iv)
+ | None => true
+ end
+ | Stk ofs =>
+ negb (ISet.contains (Int.unsigned ofs) (Int.unsigned ofs + sz) stk)
+ | _ => true (**r conservative answer *)
+ end
+ end.
+
+Lemma nlive_contains:
+ forall bc b ofs p nm sz i,
+ genv_match bc ge ->
+ bc sp = BCstack ->
+ pmatch bc b ofs p ->
+ nmem_contains nm p sz = false ->
+ Int.unsigned ofs <= i < Int.unsigned ofs + sz ->
+ ~(nlive nm b i).
+Proof.
+ unfold nmem_contains; intros. red; intros L; inv L.
+ inv H1; try discriminate.
+- (* Gl id ofs *)
+ assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto).
+ destruct gl!id as [iv|] eqn:HG; inv H2.
+ destruct (ISet.contains (Int.unsigned ofs) (Int.unsigned ofs + sz) iv) eqn:IC; try discriminate.
+ rewrite ISet.contains_spec in IC. eelim GL; eauto.
+- (* Stk ofs *)
+ destruct (ISet.contains (Int.unsigned ofs) (Int.unsigned ofs + sz) stk) eqn:IC; try discriminate.
+ rewrite ISet.contains_spec in IC. eelim STK; eauto. eapply bc_stack; eauto.
+Qed.
+
+(** Kill all stack locations between 0 and [sz], and mark everything else
+ as live. This reflects the effect of freeing the stack block at
+ a [Ireturn] or [Itailcall] instruction. *)
+
+Definition nmem_dead_stack (sz: Z) :=
+ NMem (ISet.interval 0 sz) (PTree.empty _).
+
+Lemma nlive_dead_stack:
+ forall sz b' i, b' <> sp \/ ~(0 <= i < sz) -> nlive (nmem_dead_stack sz) b' i.
+Proof.
+ intros; constructor; simpl; intros.
+- rewrite ISet.In_interval. intuition.
+- rewrite PTree.gempty in H1; discriminate.
+Qed.
+
+(** Least upper bound *)
+
+Definition nmem_lub (nm1 nm2: nmem) : nmem :=
+ match nm1, nm2 with
+ | NMemDead, _ => nm2
+ | _, NMemDead => nm1
+ | NMem stk1 gl1, NMem stk2 gl2 =>
+ NMem (ISet.inter stk1 stk2)
+ (PTree.combine
+ (fun o1 o2 =>
+ match o1, o2 with
+ | Some iv1, Some iv2 => Some(ISet.inter iv1 iv2)
+ | _, _ => None
+ end)
+ gl1 gl2)
+ end.
+
+Lemma nlive_lub_l:
+ forall nm1 nm2 b i, nlive nm1 b i -> nlive (nmem_lub nm1 nm2) b i.
+Proof.
+ intros. inversion H; subst. destruct nm2; simpl. auto.
+ constructor; simpl; intros.
+- rewrite ISet.In_inter. intros [P Q]. eelim STK; eauto.
+- rewrite PTree.gcombine in H1 by auto.
+ destruct gl!id as [iv1|] eqn:NG1; try discriminate;
+ destruct gl0!id as [iv2|] eqn:NG2; inv H1.
+ rewrite ISet.In_inter. intros [P Q]. eelim GL; eauto.
+Qed.
+
+Lemma nlive_lub_r:
+ forall nm1 nm2 b i, nlive nm2 b i -> nlive (nmem_lub nm1 nm2) b i.
+Proof.
+ intros. inversion H; subst. destruct nm1; simpl. auto.
+ constructor; simpl; intros.
+- rewrite ISet.In_inter. intros [P Q]. eelim STK; eauto.
+- rewrite PTree.gcombine in H1 by auto.
+ destruct gl0!id as [iv1|] eqn:NG1; try discriminate;
+ destruct gl!id as [iv2|] eqn:NG2; inv H1.
+ rewrite ISet.In_inter. intros [P Q]. eelim GL; eauto.
+Qed.
+
+(** Boolean-valued equality test *)
+
+Definition nmem_beq (nm1 nm2: nmem) : bool :=
+ match nm1, nm2 with
+ | NMemDead, NMemDead => true
+ | NMem stk1 gl1, NMem stk2 gl2 => ISet.beq stk1 stk2 && PTree.beq ISet.beq gl1 gl2
+ | _, _ => false
+ end.
+
+Lemma nmem_beq_sound:
+ forall nm1 nm2 b ofs,
+ nmem_beq nm1 nm2 = true ->
+ (nlive nm1 b ofs <-> nlive nm2 b ofs).
+Proof.
+ unfold nmem_beq; intros.
+ destruct nm1 as [ | stk1 gl1]; destruct nm2 as [ | stk2 gl2]; try discriminate.
+- split; intros L; inv L.
+- InvBooleans. rewrite ISet.beq_spec in H0. rewrite PTree.beq_correct in H1.
+ split; intros L; inv L; constructor; intros.
++ rewrite <- H0. eauto.
++ specialize (H1 id). rewrite H2 in H1. destruct gl1!id as [iv1|] eqn: NG; try contradiction.
+ rewrite ISet.beq_spec in H1. rewrite <- H1. eauto.
++ rewrite H0. eauto.
++ specialize (H1 id). rewrite H2 in H1. destruct gl2!id as [iv2|] eqn: NG; try contradiction.
+ rewrite ISet.beq_spec in H1. rewrite H1. eauto.
+Qed.
+
+End LOCATIONS.
+
+
+(** * The lattice for dataflow analysis *)
+
+Module NA <: SEMILATTICE.
+
+ Definition t := (nenv * nmem)%type.
+
+ Definition eq (x y: t) :=
+ NE.eq (fst x) (fst y) /\
+ (forall ge sp b ofs, nlive ge sp (snd x) b ofs <-> nlive ge sp (snd y) b ofs).
+
+ Lemma eq_refl: forall x, eq x x.
+ Proof.
+ unfold eq; destruct x; simpl; split. apply NE.eq_refl. tauto.
+ Qed.
+ Lemma eq_sym: forall x y, eq x y -> eq y x.
+ Proof.
+ unfold eq; destruct x, y; simpl. intros [A B].
+ split. apply NE.eq_sym; auto.
+ intros. rewrite B. tauto.
+ Qed.
+ Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
+ Proof.
+ unfold eq; destruct x, y, z; simpl. intros [A B] [C D]; split.
+ eapply NE.eq_trans; eauto.
+ intros. rewrite B; auto.
+ Qed.
+
+ Definition beq (x y: t) : bool :=
+ NE.beq (fst x) (fst y) && nmem_beq (snd x) (snd y).
+
+ Lemma beq_correct: forall x y, beq x y = true -> eq x y.
+ Proof.
+ unfold beq, eq; destruct x, y; simpl; intros. InvBooleans. split.
+ apply NE.beq_correct; auto.
+ intros. apply nmem_beq_sound; auto.
+ Qed.
+
+ Definition ge (x y: t) : Prop :=
+ NE.ge (fst x) (fst y) /\
+ (forall ge sp b ofs, nlive ge sp (snd y) b ofs -> nlive ge sp (snd x) b ofs).
+
+ Lemma ge_refl: forall x y, eq x y -> ge x y.
+ Proof.
+ unfold eq, ge; destruct x, y; simpl. intros [A B]; split.
+ apply NE.ge_refl; auto.
+ intros. apply B; auto.
+ Qed.
+ Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
+ Proof.
+ unfold ge; destruct x, y, z; simpl. intros [A B] [C D]; split.
+ eapply NE.ge_trans; eauto.
+ auto.
+ Qed.
+
+ Definition bot : t := (NE.bot, NMemDead).
+
+ Lemma ge_bot: forall x, ge x bot.
+ Proof.
+ unfold ge, bot; destruct x; simpl. split.
+ apply NE.ge_bot.
+ intros. inv H.
+ Qed.
+
+ Definition lub (x y: t) : t :=
+ (NE.lub (fst x) (fst y), nmem_lub (snd x) (snd y)).
+
+ Lemma ge_lub_left: forall x y, ge (lub x y) x.
+ Proof.
+ unfold ge; destruct x, y; simpl; split.
+ apply NE.ge_lub_left.
+ intros; apply nlive_lub_l; auto.
+ Qed.
+ Lemma ge_lub_right: forall x y, ge (lub x y) y.
+ Proof.
+ unfold ge; destruct x, y; simpl; split.
+ apply NE.ge_lub_right.
+ intros; apply nlive_lub_r; auto.
+ Qed.
+
+End NA.
+
diff --git a/backend/PrintRTL.ml b/backend/PrintRTL.ml
index 429199e..137f65b 100644
--- a/backend/PrintRTL.ml
+++ b/backend/PrintRTL.ml
@@ -133,3 +133,6 @@ let print_constprop = print_if destination_constprop
let destination_cse : string option ref = ref None
let print_cse = print_if destination_cse
+let destination_deadcode : string option ref = ref None
+let print_deadcode = print_if destination_deadcode
+
diff --git a/backend/Regalloc.ml b/backend/Regalloc.ml
index 8a3c05e..5c68602 100644
--- a/backend/Regalloc.ml
+++ b/backend/Regalloc.ml
@@ -278,7 +278,7 @@ end
module Liveness_Solver = Backward_Dataflow_Solver(VSetLat)(NodeSetBackward)
let liveness_analysis f =
- match Liveness_Solver.fixpoint f.fn_code successors_block (transfer_live f) [] with
+ match Liveness_Solver.fixpoint f.fn_code successors_block (transfer_live f) with
| None -> assert false
| Some lv -> lv
diff --git a/backend/Splitting.ml b/backend/Splitting.ml
index b238cef..3530ba9 100644
--- a/backend/Splitting.ml
+++ b/backend/Splitting.ml
@@ -128,7 +128,7 @@ let transfer f pc after =
(* The live range analysis *)
-let analysis f = Solver.fixpoint f.fn_code successors_instr (transfer f) []
+let analysis f = Solver.fixpoint f.fn_code successors_instr (transfer f)
(* Produce renamed registers for each instruction. *)
diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v
new file mode 100644
index 0000000..396d8d4
--- /dev/null
+++ b/backend/ValueAnalysis.v
@@ -0,0 +1,1812 @@
+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 Import Events.
+Require Import Lattice.
+Require Import Kildall.
+Require Import Registers.
+Require Import Op.
+Require Import RTL.
+Require Import ValueDomain.
+Require Import ValueAOp.
+Require Import Liveness.
+
+(** * The dataflow analysis *)
+
+Definition areg (ae: aenv) (r: reg) : aval := AE.get r ae.
+
+Definition aregs (ae: aenv) (rl: list reg) : list aval := List.map (areg ae) rl.
+
+Definition mafter_public_call : amem := mtop.
+
+Definition mafter_private_call (am_before: amem) : amem :=
+ {| am_stack := am_before.(am_stack);
+ am_glob := PTree.empty _;
+ am_nonstack := Nonstack;
+ am_top := plub (ab_summary (am_stack am_before)) Nonstack |}.
+
+Definition transfer_call (ae: aenv) (am: amem) (args: list reg) (res: reg) :=
+ if pincl am.(am_nonstack) Nonstack
+ && forallb (fun r => vpincl (areg ae r) Nonstack) args
+ then
+ VA.State (AE.set res (Ifptr Nonstack) ae) (mafter_private_call am)
+ else
+ VA.State (AE.set res Vtop ae) mafter_public_call.
+
+Inductive builtin_kind : Type :=
+ | Builtin_vload (chunk: memory_chunk) (aaddr: aval)
+ | Builtin_vstore (chunk: memory_chunk) (aaddr av: aval)
+ | Builtin_memcpy (sz al: Z) (adst asrc: aval)
+ | Builtin_annot
+ | Builtin_annot_val (av: aval)
+ | Builtin_default.
+
+Definition classify_builtin (ef: external_function) (args: list reg) (ae: aenv) :=
+ match ef, args with
+ | EF_vload chunk, a1::nil => Builtin_vload chunk (areg ae a1)
+ | EF_vload_global chunk id ofs, nil => Builtin_vload chunk (Ptr (Gl id ofs))
+ | EF_vstore chunk, a1::a2::nil => Builtin_vstore chunk (areg ae a1) (areg ae a2)
+ | EF_vstore_global chunk id ofs, a1::nil => Builtin_vstore chunk (Ptr (Gl id ofs)) (areg ae a1)
+ | EF_memcpy sz al, a1::a2::nil => Builtin_memcpy sz al (areg ae a1) (areg ae a2)
+ | EF_annot _ _, _ => Builtin_annot
+ | EF_annot_val _ _, a1::nil => Builtin_annot_val (areg ae a1)
+ | _, _ => Builtin_default
+ end.
+
+Definition transfer_builtin (ae: aenv) (am: amem) (rm: romem) (ef: external_function) (args: list reg) (res: reg) :=
+ match classify_builtin ef args ae with
+ | Builtin_vload chunk aaddr =>
+ let a :=
+ if strict
+ then vlub (loadv chunk rm am aaddr) (vnormalize chunk (Ifptr Glob))
+ else vnormalize chunk Vtop in
+ VA.State (AE.set res a ae) am
+ | Builtin_vstore chunk aaddr av =>
+ let am' := storev chunk am aaddr av in
+ VA.State (AE.set res itop ae) (mlub am am')
+ | Builtin_memcpy sz al adst asrc =>
+ let p := loadbytes am rm (aptr_of_aval asrc) in
+ let am' := storebytes am (aptr_of_aval adst) sz p in
+ VA.State (AE.set res itop ae) am'
+ | Builtin_annot =>
+ VA.State (AE.set res itop ae) am
+ | Builtin_annot_val av =>
+ VA.State (AE.set res av ae) am
+ | Builtin_default =>
+ transfer_call ae am args res
+ end.
+
+Definition transfer (f: function) (rm: romem) (pc: node) (ae: aenv) (am: amem) : VA.t :=
+ match f.(fn_code)!pc with
+ | None =>
+ VA.Bot
+ | Some(Inop s) =>
+ VA.State ae am
+ | Some(Iop op args res s) =>
+ let a := eval_static_operation op (aregs ae args) in
+ VA.State (AE.set res a ae) am
+ | Some(Iload chunk addr args dst s) =>
+ let a := loadv chunk rm am (eval_static_addressing addr (aregs ae args)) in
+ VA.State (AE.set dst a ae) am
+ | Some(Istore chunk addr args src s) =>
+ let am' := storev chunk am (eval_static_addressing addr (aregs ae args)) (areg ae src) in
+ VA.State ae am'
+ | Some(Icall sig ros args res s) =>
+ transfer_call ae am args res
+ | Some(Itailcall sig ros args) =>
+ VA.Bot
+ | Some(Ibuiltin ef args res s) =>
+ transfer_builtin ae am rm ef args res
+ | Some(Icond cond args s1 s2) =>
+ VA.State ae am
+ | Some(Ijumptable arg tbl) =>
+ VA.State ae am
+ | Some(Ireturn arg) =>
+ VA.Bot
+ end.
+
+Definition transfer' (f: function) (lastuses: PTree.t (list reg)) (rm: romem)
+ (pc: node) (before: VA.t) : VA.t :=
+ match before with
+ | VA.Bot => VA.Bot
+ | VA.State ae am =>
+ match transfer f rm pc ae am with
+ | VA.Bot => VA.Bot
+ | VA.State ae' am' =>
+ let ae'' :=
+ match lastuses!pc with
+ | None => ae'
+ | Some regs => eforget regs ae'
+ end in
+ VA.State ae'' am'
+ end
+ end.
+
+Module DS := Dataflow_Solver(VA)(NodeSetForward).
+
+Definition mfunction_entry :=
+ {| am_stack := ablock_init Pbot;
+ am_glob := PTree.empty _;
+ am_nonstack := Nonstack;
+ am_top := Nonstack |}.
+
+Definition analyze (rm: romem) (f: function): PMap.t VA.t :=
+ let lu := Liveness.last_uses f in
+ let entry := VA.State (einit_regs f.(fn_params)) mfunction_entry in
+ match DS.fixpoint f.(fn_code) successors_instr (transfer' f lu rm)
+ f.(fn_entrypoint) entry with
+ | None => PMap.init (VA.State AE.top mtop)
+ | Some res => res
+ end.
+
+(** Constructing the approximation of read-only globals *)
+
+Definition store_init_data (ab: ablock) (p: Z) (id: init_data) : ablock :=
+ match id with
+ | Init_int8 n => ablock_store Mint8unsigned ab p (I n)
+ | Init_int16 n => ablock_store Mint16unsigned ab p (I n)
+ | Init_int32 n => ablock_store Mint32 ab p (I n)
+ | Init_int64 n => ablock_store Mint64 ab p (L n)
+ | Init_float32 n => ablock_store Mfloat32 ab p
+ (if propagate_float_constants tt then F n else ftop)
+ | Init_float64 n => ablock_store Mfloat64 ab p
+ (if propagate_float_constants tt then F n else ftop)
+ | Init_addrof symb ofs => ablock_store Mint32 ab p (Ptr (Gl symb ofs))
+ | Init_space n => ab
+ end.
+
+Fixpoint store_init_data_list (ab: ablock) (p: Z) (idl: list init_data)
+ {struct idl}: ablock :=
+ match idl with
+ | nil => ab
+ | id :: idl' => store_init_data_list (store_init_data ab p id) (p + Genv.init_data_size id) idl'
+ end.
+
+Definition alloc_global (rm: romem) (idg: ident * globdef fundef unit): romem :=
+ match idg with
+ | (id, Gfun f) =>
+ PTree.remove id rm
+ | (id, Gvar v) =>
+ if v.(gvar_readonly) && negb v.(gvar_volatile)
+ then PTree.set id (store_init_data_list (ablock_init Pbot) 0 v.(gvar_init)) rm
+ else PTree.remove id rm
+ end.
+
+Definition romem_for_program (p: program) : romem :=
+ List.fold_left alloc_global p.(prog_defs) (PTree.empty _).
+
+(** * Soundness proof *)
+
+(** Properties of the dataflow solution. *)
+
+Lemma analyze_entrypoint:
+ forall rm f vl m bc,
+ (forall v, In v vl -> vmatch bc v (Ifptr Nonstack)) ->
+ mmatch bc m mfunction_entry ->
+ exists ae am,
+ (analyze rm f)!!(fn_entrypoint f) = VA.State ae am
+ /\ ematch bc (init_regs vl (fn_params f)) ae
+ /\ mmatch bc m am.
+Proof.
+ intros.
+ unfold analyze.
+ set (lu := Liveness.last_uses f).
+ set (entry := VA.State (einit_regs f.(fn_params)) mfunction_entry).
+ destruct (DS.fixpoint (fn_code f) successors_instr (transfer' f lu rm)
+ (fn_entrypoint f) entry) as [res|] eqn:FIX.
+- assert (A: VA.ge res!!(fn_entrypoint f) entry) by (eapply DS.fixpoint_entry; eauto).
+ destruct (res!!(fn_entrypoint f)) as [ | ae am ]; simpl in A. contradiction.
+ destruct A as [A1 A2].
+ exists ae, am.
+ split. auto.
+ split. eapply ematch_ge; eauto. apply ematch_init; auto.
+ auto.
+- exists AE.top, mtop.
+ split. apply PMap.gi.
+ split. apply ematch_ge with (einit_regs (fn_params f)).
+ apply ematch_init; auto. apply AE.ge_top.
+ eapply mmatch_top'; eauto.
+Qed.
+
+Lemma analyze_successor:
+ forall f n ae am instr s rm ae' am',
+ (analyze rm f)!!n = VA.State ae am ->
+ f.(fn_code)!n = Some instr ->
+ In s (successors_instr instr) ->
+ transfer f rm n ae am = VA.State ae' am' ->
+ VA.ge (analyze rm f)!!s (transfer f rm n ae am).
+Proof.
+ unfold analyze; intros.
+ set (lu := Liveness.last_uses f) in *.
+ set (entry := VA.State (einit_regs f.(fn_params)) mfunction_entry) in *.
+ destruct (DS.fixpoint (fn_code f) successors_instr (transfer' f lu rm)
+ (fn_entrypoint f) entry) as [res|] eqn:FIX.
+- assert (A: VA.ge res!!s (transfer' f lu rm n res#n)).
+ { eapply DS.fixpoint_solution; eauto with coqlib.
+ intros. unfold transfer'. simpl. auto. }
+ rewrite H in A. unfold transfer' in A. rewrite H2 in A. rewrite H2.
+ destruct lu!n.
+ eapply VA.ge_trans. eauto. split; auto. apply eforget_ge.
+ auto.
+- rewrite H2. rewrite PMap.gi. split; intros. apply AE.ge_top. eapply mmatch_top'; eauto.
+Qed.
+
+Lemma analyze_succ:
+ forall e m rm f n ae am instr s ae' am' bc,
+ (analyze rm f)!!n = VA.State ae am ->
+ f.(fn_code)!n = Some instr ->
+ In s (successors_instr instr) ->
+ transfer f rm n ae am = VA.State ae' am' ->
+ ematch bc e ae' ->
+ mmatch bc m am' ->
+ exists ae'' am'',
+ (analyze rm f)!!s = VA.State ae'' am''
+ /\ ematch bc e ae''
+ /\ mmatch bc m am''.
+Proof.
+ intros. exploit analyze_successor; eauto. rewrite H2.
+ destruct (analyze rm f)#s as [ | ae'' am'']; simpl; try tauto. intros [A B].
+ exists ae'', am''.
+ split. auto.
+ split. eapply ematch_ge; eauto. eauto.
+Qed.
+
+(** Classification of builtin functions *)
+
+Lemma classify_builtin_sound:
+ forall bc e ae ef (ge: genv) args m t res m',
+ ematch bc e ae ->
+ genv_match bc ge ->
+ external_call ef ge e##args m t res m' ->
+ match classify_builtin ef args ae with
+ | Builtin_vload chunk aaddr =>
+ exists addr,
+ volatile_load_sem chunk ge (addr::nil) m t res m' /\ vmatch bc addr aaddr
+ | Builtin_vstore chunk aaddr av =>
+ exists addr v,
+ volatile_store_sem chunk ge (addr::v::nil) m t res m'
+ /\ vmatch bc addr aaddr /\ vmatch bc v av
+ | Builtin_memcpy sz al adst asrc =>
+ exists dst, exists src,
+ extcall_memcpy_sem sz al ge (dst::src::nil) m t res m'
+ /\ vmatch bc dst adst /\ vmatch bc src asrc
+ | Builtin_annot => m' = m /\ res = Vundef
+ | Builtin_annot_val av => m' = m /\ vmatch bc res av
+ | Builtin_default => True
+ end.
+Proof.
+ intros. unfold classify_builtin; destruct ef; auto.
+- (* vload *)
+ destruct args; auto. destruct args; auto.
+ exists (e#p); split; eauto.
+- (* vstore *)
+ destruct args; auto. destruct args; auto. destruct args; auto.
+ exists (e#p), (e#p0); eauto.
+- (* vload global *)
+ destruct args; auto. simpl in H1.
+ rewrite volatile_load_global_charact in H1. destruct H1 as (b & A & B).
+ exists (Vptr b ofs); split; auto. constructor. constructor. eapply H0; eauto.
+- (* vstore global *)
+ destruct args; auto. destruct args; auto. simpl in H1.
+ rewrite volatile_store_global_charact in H1. destruct H1 as (b & A & B).
+ exists (Vptr b ofs), (e#p); split; auto. split; eauto. constructor. constructor. eapply H0; eauto.
+- (* memcpy *)
+ destruct args; auto. destruct args; auto. destruct args; auto.
+ exists (e#p), (e#p0); eauto.
+- (* annot *)
+ simpl in H1. inv H1. auto.
+- (* annot val *)
+ destruct args; auto. destruct args; auto.
+ simpl in H1. inv H1. eauto.
+Qed.
+
+(** ** Constructing block classifications *)
+
+Definition bc_nostack (bc: block_classification) : Prop :=
+ forall b, bc b <> BCstack.
+
+Section NOSTACK.
+
+Variable bc: block_classification.
+Hypothesis NOSTACK: bc_nostack bc.
+
+Lemma pmatch_no_stack: forall b ofs p, pmatch bc b ofs p -> pmatch bc b ofs Nonstack.
+Proof.
+ intros. inv H; constructor; congruence.
+Qed.
+
+Lemma vmatch_no_stack: forall v x, vmatch bc v x -> vmatch bc v (Ifptr Nonstack).
+Proof.
+ induction 1; constructor; auto; eapply pmatch_no_stack; eauto.
+Qed.
+
+Lemma smatch_no_stack: forall m b p, smatch bc m b p -> smatch bc m b Nonstack.
+Proof.
+ intros. destruct H as [A B]. split; intros.
+ eapply vmatch_no_stack; eauto.
+ eapply pmatch_no_stack; eauto.
+Qed.
+
+Lemma mmatch_no_stack: forall m am astk,
+ mmatch bc m am -> mmatch bc m {| am_stack := astk; am_glob := PTree.empty _; am_nonstack := Nonstack; am_top := Nonstack |}.
+Proof.
+ intros. destruct H. constructor; simpl; intros.
+- elim (NOSTACK b); auto.
+- rewrite PTree.gempty in H0; discriminate.
+- eapply smatch_no_stack; eauto.
+- eapply smatch_no_stack; eauto.
+- auto.
+Qed.
+
+End NOSTACK.
+
+(** ** Construction 1: allocating the stack frame at function entry *)
+
+Ltac splitall := repeat (match goal with |- _ /\ _ => split end).
+
+Theorem allocate_stack:
+ forall m sz m' sp bc ge rm am,
+ Mem.alloc m 0 sz = (m', sp) ->
+ genv_match bc ge ->
+ romatch bc m rm ->
+ mmatch bc m am ->
+ bc_nostack bc ->
+ exists bc',
+ bc_incr bc bc'
+ /\ bc' sp = BCstack
+ /\ genv_match bc' ge
+ /\ romatch bc' m' rm
+ /\ mmatch bc' m' mfunction_entry
+ /\ (forall b, Plt b sp -> bc' b = bc b)
+ /\ (forall v x, vmatch bc v x -> vmatch bc' v (Ifptr Nonstack)).
+Proof.
+ intros until am; intros ALLOC GENV RO MM NOSTACK.
+ exploit Mem.nextblock_alloc; eauto. intros NB.
+ exploit Mem.alloc_result; eauto. intros SP.
+ assert (SPINVALID: bc sp = BCinvalid).
+ { rewrite SP. eapply bc_below_invalid. apply Plt_strict. eapply mmatch_below; eauto. }
+(* Part 1: constructing bc' *)
+ set (f := fun b => if eq_block b sp then BCstack else bc b).
+ assert (F_stack: forall b1 b2, f b1 = BCstack -> f b2 = BCstack -> b1 = b2).
+ {
+ assert (forall b, f b = BCstack -> b = sp).
+ { unfold f; intros. destruct (eq_block b sp); auto. eelim NOSTACK; eauto. }
+ intros. transitivity sp; auto. symmetry; auto.
+ }
+ assert (F_glob: forall b1 b2 id, f b1 = BCglob id -> f b2 = BCglob id -> b1 = b2).
+ {
+ assert (forall b id, f b = BCglob id -> bc b = BCglob id).
+ { unfold f; intros. destruct (eq_block b sp). congruence. auto. }
+ intros. eapply (bc_glob bc); eauto.
+ }
+ set (bc' := BC f F_stack F_glob). unfold f in bc'.
+ assert (BC'EQ: forall b, bc b <> BCinvalid -> bc' b = bc b).
+ { intros; simpl. apply dec_eq_false. congruence. }
+ assert (INCR: bc_incr bc bc').
+ { red; simpl; intros. apply BC'EQ; auto. }
+(* Part 2: invariance properties *)
+ assert (SM: forall b p, bc b <> BCinvalid -> smatch bc m b p -> smatch bc' m' b Nonstack).
+ {
+ intros.
+ apply smatch_incr with bc; auto.
+ apply smatch_inv with m.
+ apply smatch_no_stack with p; auto.
+ intros. eapply Mem.loadbytes_alloc_unchanged; eauto. eapply mmatch_below; eauto.
+ }
+ assert (SMSTACK: smatch bc' m' sp Pbot).
+ {
+ split; intros.
+ exploit Mem.load_alloc_same; eauto. intros EQ. subst v. constructor.
+ exploit Mem.loadbytes_alloc_same; eauto with coqlib. congruence.
+ }
+(* Conclusions *)
+ exists bc'; splitall.
+- (* incr *)
+ assumption.
+- (* sp is BCstack *)
+ simpl; apply dec_eq_true.
+- (* genv match *)
+ eapply genv_match_exten; eauto.
+ simpl; intros. destruct (eq_block b sp); intuition congruence.
+ simpl; intros. destruct (eq_block b sp); congruence.
+- (* romatch *)
+ apply romatch_exten with bc.
+ eapply romatch_alloc; eauto. eapply mmatch_below; eauto.
+ simpl; intros. destruct (eq_block b sp); intuition.
+- (* mmatch *)
+ constructor; simpl; intros.
+ + (* stack *)
+ apply ablock_init_sound. destruct (eq_block b sp).
+ subst b. apply SMSTACK.
+ elim (NOSTACK b); auto.
+ + (* globals *)
+ rewrite PTree.gempty in H0; discriminate.
+ + (* nonstack *)
+ destruct (eq_block b sp). congruence. eapply SM; auto. eapply mmatch_nonstack; eauto.
+ + (* top *)
+ destruct (eq_block b sp).
+ subst b. apply smatch_ge with Pbot. apply SMSTACK. constructor.
+ eapply SM; auto. eapply mmatch_top; eauto.
+ + (* below *)
+ red; simpl; intros. rewrite NB. destruct (eq_block b sp).
+ subst b; rewrite SP; xomega.
+ exploit mmatch_below; eauto. xomega.
+- (* unchanged *)
+ simpl; intros. apply dec_eq_false. apply Plt_ne. auto.
+- (* values *)
+ intros. apply vmatch_incr with bc; auto. eapply vmatch_no_stack; eauto.
+Qed.
+
+(** Construction 2: turn the stack into an "other" block, at public calls or function returns *)
+
+Theorem anonymize_stack:
+ forall m sp bc ge rm am,
+ genv_match bc ge ->
+ romatch bc m rm ->
+ mmatch bc m am ->
+ bc sp = BCstack ->
+ exists bc',
+ bc_nostack bc'
+ /\ bc' sp = BCother
+ /\ (forall b, b <> sp -> bc' b = bc b)
+ /\ (forall v x, vmatch bc v x -> vmatch bc' v Vtop)
+ /\ genv_match bc' ge
+ /\ romatch bc' m rm
+ /\ mmatch bc' m mtop.
+Proof.
+ intros until am; intros GENV RO MM SP.
+(* Part 1: constructing bc' *)
+ set (f := fun b => if eq_block b sp then BCother else bc b).
+ assert (F_stack: forall b1 b2, f b1 = BCstack -> f b2 = BCstack -> b1 = b2).
+ {
+ unfold f; intros.
+ destruct (eq_block b1 sp); try discriminate.
+ destruct (eq_block b2 sp); try discriminate.
+ eapply bc_stack; eauto.
+ }
+ assert (F_glob: forall b1 b2 id, f b1 = BCglob id -> f b2 = BCglob id -> b1 = b2).
+ {
+ unfold f; intros.
+ destruct (eq_block b1 sp); try discriminate.
+ destruct (eq_block b2 sp); try discriminate.
+ eapply bc_glob; eauto.
+ }
+ set (bc' := BC f F_stack F_glob). unfold f in bc'.
+
+(* Part 2: matching wrt bc' *)
+ assert (PM: forall b ofs p, pmatch bc b ofs p -> pmatch bc' b ofs Ptop).
+ {
+ intros. assert (pmatch bc b ofs Ptop) by (eapply pmatch_top'; eauto).
+ inv H0. constructor; simpl. destruct (eq_block b sp); congruence.
+ }
+ assert (VM: forall v x, vmatch bc v x -> vmatch bc' v Vtop).
+ {
+ induction 1; constructor; eauto.
+ }
+ assert (SM: forall b p, smatch bc m b p -> smatch bc' m b Ptop).
+ {
+ intros. destruct H as [S1 S2]. split; intros.
+ eapply VM. eapply S1; eauto.
+ eapply PM. eapply S2; eauto.
+ }
+(* Conclusions *)
+ exists bc'; splitall.
+- (* nostack *)
+ red; simpl; intros. destruct (eq_block b sp). congruence.
+ red; intros. elim n. eapply bc_stack; eauto.
+- (* bc' sp is BCother *)
+ simpl; apply dec_eq_true.
+- (* other blocks *)
+ intros; simpl; apply dec_eq_false; auto.
+- (* values *)
+ auto.
+- (* genv *)
+ apply genv_match_exten with bc; auto.
+ simpl; intros. destruct (eq_block b sp); intuition congruence.
+ simpl; intros. destruct (eq_block b sp); auto.
+- (* romatch *)
+ apply romatch_exten with bc; auto.
+ simpl; intros. destruct (eq_block b sp); intuition.
+- (* mmatch top *)
+ constructor; simpl; intros.
+ + destruct (eq_block b sp). congruence. elim n. eapply bc_stack; eauto.
+ + rewrite PTree.gempty in H0; discriminate.
+ + destruct (eq_block b sp).
+ subst b. eapply SM. eapply mmatch_stack; eauto.
+ eapply SM. eapply mmatch_nonstack; eauto.
+ + destruct (eq_block b sp).
+ subst b. eapply SM. eapply mmatch_stack; eauto.
+ eapply SM. eapply mmatch_top; eauto.
+ + red; simpl; intros. destruct (eq_block b sp).
+ subst b. eapply mmatch_below; eauto. congruence.
+ eapply mmatch_below; eauto.
+Qed.
+
+(** Construction 3: turn the stack into an invalid block, at private calls *)
+
+Theorem hide_stack:
+ forall m sp bc ge rm am,
+ genv_match bc ge ->
+ romatch bc m rm ->
+ mmatch bc m am ->
+ bc sp = BCstack ->
+ pge Nonstack am.(am_nonstack) ->
+ exists bc',
+ bc_nostack bc'
+ /\ bc' sp = BCinvalid
+ /\ (forall b, b <> sp -> bc' b = bc b)
+ /\ (forall v x, vge (Ifptr Nonstack) x -> vmatch bc v x -> vmatch bc' v Vtop)
+ /\ genv_match bc' ge
+ /\ romatch bc' m rm
+ /\ mmatch bc' m mtop.
+Proof.
+ intros until am; intros GENV RO MM SP NOLEAK.
+(* Part 1: constructing bc' *)
+ set (f := fun b => if eq_block b sp then BCinvalid else bc b).
+ assert (F_stack: forall b1 b2, f b1 = BCstack -> f b2 = BCstack -> b1 = b2).
+ {
+ unfold f; intros.
+ destruct (eq_block b1 sp); try discriminate.
+ destruct (eq_block b2 sp); try discriminate.
+ eapply bc_stack; eauto.
+ }
+ assert (F_glob: forall b1 b2 id, f b1 = BCglob id -> f b2 = BCglob id -> b1 = b2).
+ {
+ unfold f; intros.
+ destruct (eq_block b1 sp); try discriminate.
+ destruct (eq_block b2 sp); try discriminate.
+ eapply bc_glob; eauto.
+ }
+ set (bc' := BC f F_stack F_glob). unfold f in bc'.
+
+(* Part 2: matching wrt bc' *)
+ assert (PM: forall b ofs p, pge Nonstack p -> pmatch bc b ofs p -> pmatch bc' b ofs Ptop).
+ {
+ intros. assert (pmatch bc b ofs Nonstack) by (eapply pmatch_ge; eauto).
+ inv H1. constructor; simpl; destruct (eq_block b sp); congruence.
+ }
+ assert (VM: forall v x, vge (Ifptr Nonstack) x -> vmatch bc v x -> vmatch bc' v Vtop).
+ {
+ intros. apply vmatch_ifptr; intros. subst v.
+ inv H0; inv H; eapply PM; eauto.
+ }
+ assert (SM: forall b p, pge Nonstack p -> smatch bc m b p -> smatch bc' m b Ptop).
+ {
+ intros. destruct H0 as [S1 S2]. split; intros.
+ eapply VM with (x := Ifptr p). constructor; auto. eapply S1; eauto.
+ eapply PM. eauto. eapply S2; eauto.
+ }
+(* Conclusions *)
+ exists bc'; splitall.
+- (* nostack *)
+ red; simpl; intros. destruct (eq_block b sp). congruence.
+ red; intros. elim n. eapply bc_stack; eauto.
+- (* bc' sp is BCinvalid *)
+ simpl; apply dec_eq_true.
+- (* other blocks *)
+ intros; simpl; apply dec_eq_false; auto.
+- (* values *)
+ auto.
+- (* genv *)
+ apply genv_match_exten with bc; auto.
+ simpl; intros. destruct (eq_block b sp); intuition congruence.
+ simpl; intros. destruct (eq_block b sp); congruence.
+- (* romatch *)
+ apply romatch_exten with bc; auto.
+ simpl; intros. destruct (eq_block b sp); intuition.
+- (* mmatch top *)
+ constructor; simpl; intros.
+ + destruct (eq_block b sp). congruence. elim n. eapply bc_stack; eauto.
+ + rewrite PTree.gempty in H0; discriminate.
+ + destruct (eq_block b sp). congruence.
+ eapply SM. eauto. eapply mmatch_nonstack; eauto.
+ + destruct (eq_block b sp). congruence.
+ eapply SM. eauto. eapply mmatch_nonstack; eauto.
+ red; intros; elim n. eapply bc_stack; eauto.
+ + red; simpl; intros. destruct (eq_block b sp). congruence.
+ eapply mmatch_below; eauto.
+Qed.
+
+(** Construction 4: restore the stack after a public call *)
+
+Theorem return_from_public_call:
+ forall (caller callee: block_classification) bound sp ge e ae v m rm,
+ bc_below caller bound ->
+ callee sp = BCother ->
+ caller sp = BCstack ->
+ (forall b, Plt b bound -> b <> sp -> caller b = callee b) ->
+ genv_match caller ge ->
+ ematch caller e ae ->
+ Ple bound (Mem.nextblock m) ->
+ vmatch callee v Vtop ->
+ romatch callee m rm ->
+ mmatch callee m mtop ->
+ genv_match callee ge ->
+ bc_nostack callee ->
+ exists bc,
+ vmatch bc v Vtop
+ /\ ematch bc e ae
+ /\ romatch bc m rm
+ /\ mmatch bc m mafter_public_call
+ /\ genv_match bc ge
+ /\ bc sp = BCstack
+ /\ (forall b, Plt b sp -> bc b = caller b).
+Proof.
+ intros until rm; intros BELOW SP1 SP2 SAME GE1 EM BOUND RESM RM MM GE2 NOSTACK.
+(* Constructing bc *)
+ set (f := fun b => if eq_block b sp then BCstack else callee b).
+ assert (F_stack: forall b1 b2, f b1 = BCstack -> f b2 = BCstack -> b1 = b2).
+ {
+ assert (forall b, f b = BCstack -> b = sp).
+ { unfold f; intros. destruct (eq_block b sp); auto. eelim NOSTACK; eauto. }
+ intros. transitivity sp; auto. symmetry; auto.
+ }
+ assert (F_glob: forall b1 b2 id, f b1 = BCglob id -> f b2 = BCglob id -> b1 = b2).
+ {
+ assert (forall b id, f b = BCglob id -> callee b = BCglob id).
+ { unfold f; intros. destruct (eq_block b sp). congruence. auto. }
+ intros. eapply (bc_glob callee); eauto.
+ }
+ set (bc := BC f F_stack F_glob). unfold f in bc.
+ assert (INCR: bc_incr caller bc).
+ {
+ red; simpl; intros. destruct (eq_block b sp). congruence.
+ symmetry; apply SAME; auto.
+ }
+(* Invariance properties *)
+ assert (PM: forall b ofs p, pmatch callee b ofs p -> pmatch bc b ofs Ptop).
+ {
+ intros. assert (pmatch callee b ofs Ptop) by (eapply pmatch_top'; eauto).
+ inv H0. constructor; simpl. destruct (eq_block b sp); congruence.
+ }
+ assert (VM: forall v x, vmatch callee v x -> vmatch bc v Vtop).
+ {
+ intros. assert (vmatch callee v0 Vtop) by (eapply vmatch_top; eauto).
+ inv H0; constructor; eauto.
+ }
+ assert (SM: forall b p, smatch callee m b p -> smatch bc m b Ptop).
+ {
+ intros. destruct H; split; intros. eapply VM; eauto. eapply PM; eauto.
+ }
+(* Conclusions *)
+ exists bc; splitall.
+- (* result value *)
+ eapply VM; eauto.
+- (* environment *)
+ eapply ematch_incr; eauto.
+- (* romem *)
+ apply romatch_exten with callee; auto.
+ intros; simpl. destruct (eq_block b sp); intuition.
+- (* mmatch *)
+ constructor; simpl; intros.
+ + (* stack *)
+ apply ablock_init_sound. destruct (eq_block b sp).
+ subst b. eapply SM. eapply mmatch_nonstack; eauto. congruence.
+ elim (NOSTACK b); auto.
+ + (* globals *)
+ rewrite PTree.gempty in H0; discriminate.
+ + (* nonstack *)
+ destruct (eq_block b sp). congruence. eapply SM; auto. eapply mmatch_nonstack; eauto.
+ + (* top *)
+ eapply SM. eapply mmatch_top; eauto.
+ destruct (eq_block b sp); congruence.
+ + (* below *)
+ red; simpl; intros. destruct (eq_block b sp).
+ subst b. eapply mmatch_below; eauto. congruence.
+ eapply mmatch_below; eauto.
+- (* genv *)
+ eapply genv_match_exten with caller; eauto.
+ simpl; intros. destruct (eq_block b sp). intuition congruence.
+ split; intros. rewrite SAME in H by eauto with va. auto.
+ apply <- (proj1 GE2) in H. apply (proj1 GE1) in H. auto.
+ simpl; intros. destruct (eq_block b sp). congruence.
+ rewrite <- SAME; eauto with va.
+- (* sp *)
+ simpl. apply dec_eq_true.
+- (* unchanged *)
+ simpl; intros. destruct (eq_block b sp). congruence.
+ symmetry. apply SAME; auto. eapply Plt_trans. eauto. apply BELOW. congruence.
+Qed.
+
+(** Construction 5: restore the stack after a private call *)
+
+Theorem return_from_private_call:
+ forall (caller callee: block_classification) bound sp ge e ae v m rm am,
+ bc_below caller bound ->
+ callee sp = BCinvalid ->
+ caller sp = BCstack ->
+ (forall b, Plt b bound -> b <> sp -> caller b = callee b) ->
+ genv_match caller ge ->
+ ematch caller e ae ->
+ bmatch caller m sp am.(am_stack) ->
+ Ple bound (Mem.nextblock m) ->
+ vmatch callee v Vtop ->
+ romatch callee m rm ->
+ mmatch callee m mtop ->
+ genv_match callee ge ->
+ bc_nostack callee ->
+ exists bc,
+ vmatch bc v (Ifptr Nonstack)
+ /\ ematch bc e ae
+ /\ romatch bc m rm
+ /\ mmatch bc m (mafter_private_call am)
+ /\ genv_match bc ge
+ /\ bc sp = BCstack
+ /\ (forall b, Plt b sp -> bc b = caller b).
+Proof.
+ intros until am; intros BELOW SP1 SP2 SAME GE1 EM CONTENTS BOUND RESM RM MM GE2 NOSTACK.
+(* Constructing bc *)
+ set (f := fun b => if eq_block b sp then BCstack else callee b).
+ assert (F_stack: forall b1 b2, f b1 = BCstack -> f b2 = BCstack -> b1 = b2).
+ {
+ assert (forall b, f b = BCstack -> b = sp).
+ { unfold f; intros. destruct (eq_block b sp); auto. eelim NOSTACK; eauto. }
+ intros. transitivity sp; auto. symmetry; auto.
+ }
+ assert (F_glob: forall b1 b2 id, f b1 = BCglob id -> f b2 = BCglob id -> b1 = b2).
+ {
+ assert (forall b id, f b = BCglob id -> callee b = BCglob id).
+ { unfold f; intros. destruct (eq_block b sp). congruence. auto. }
+ intros. eapply (bc_glob callee); eauto.
+ }
+ set (bc := BC f F_stack F_glob). unfold f in bc.
+ assert (INCR1: bc_incr caller bc).
+ {
+ red; simpl; intros. destruct (eq_block b sp). congruence.
+ symmetry; apply SAME; auto.
+ }
+ assert (INCR2: bc_incr callee bc).
+ {
+ red; simpl; intros. destruct (eq_block b sp). congruence. auto.
+ }
+
+(* Invariance properties *)
+ assert (PM: forall b ofs p, pmatch callee b ofs p -> pmatch bc b ofs Nonstack).
+ {
+ intros. assert (pmatch callee b ofs Ptop) by (eapply pmatch_top'; eauto).
+ inv H0. constructor; simpl; destruct (eq_block b sp); congruence.
+ }
+ assert (VM: forall v x, vmatch callee v x -> vmatch bc v (Ifptr Nonstack)).
+ {
+ intros. assert (vmatch callee v0 Vtop) by (eapply vmatch_top; eauto).
+ inv H0; constructor; eauto.
+ }
+ assert (SM: forall b p, smatch callee m b p -> smatch bc m b Nonstack).
+ {
+ intros. destruct H; split; intros. eapply VM; eauto. eapply PM; eauto.
+ }
+ assert (BSTK: bmatch bc m sp (am_stack am)).
+ {
+ apply bmatch_incr with caller; eauto.
+ }
+(* Conclusions *)
+ exists bc; splitall.
+- (* result value *)
+ eapply VM; eauto.
+- (* environment *)
+ eapply ematch_incr; eauto.
+- (* romem *)
+ apply romatch_exten with callee; auto.
+ intros; simpl. destruct (eq_block b sp); intuition.
+- (* mmatch *)
+ constructor; simpl; intros.
+ + (* stack *)
+ destruct (eq_block b sp).
+ subst b. exact BSTK.
+ elim (NOSTACK b); auto.
+ + (* globals *)
+ rewrite PTree.gempty in H0; discriminate.
+ + (* nonstack *)
+ destruct (eq_block b sp). congruence. eapply SM; auto. eapply mmatch_nonstack; eauto.
+ + (* top *)
+ destruct (eq_block b sp).
+ subst. apply smatch_ge with (ab_summary (am_stack am)). apply BSTK. apply pge_lub_l.
+ apply smatch_ge with Nonstack. eapply SM. eapply mmatch_top; eauto. apply pge_lub_r.
+ + (* below *)
+ red; simpl; intros. destruct (eq_block b sp).
+ subst b. apply Plt_le_trans with bound. apply BELOW. congruence. auto.
+ eapply mmatch_below; eauto.
+- (* genv *)
+ eapply genv_match_exten; eauto.
+ simpl; intros. destruct (eq_block b sp); intuition congruence.
+ simpl; intros. destruct (eq_block b sp); congruence.
+- (* sp *)
+ simpl. apply dec_eq_true.
+- (* unchanged *)
+ simpl; intros. destruct (eq_block b sp). congruence.
+ symmetry. apply SAME; auto. eapply Plt_trans. eauto. apply BELOW. congruence.
+Qed.
+
+(** Construction 6: external call *)
+
+Theorem external_call_match:
+ forall ef (ge: genv) vargs m t vres m' bc rm am,
+ external_call ef ge vargs m t vres m' ->
+ genv_match bc ge ->
+ (forall v, In v vargs -> vmatch bc v Vtop) ->
+ romatch bc m rm ->
+ mmatch bc m am ->
+ bc_nostack bc ->
+ exists bc',
+ bc_incr bc bc'
+ /\ (forall b, Plt b (Mem.nextblock m) -> bc' b = bc b)
+ /\ vmatch bc' vres Vtop
+ /\ genv_match bc' ge
+ /\ romatch bc' m' rm
+ /\ mmatch bc' m' mtop
+ /\ bc_nostack bc'
+ /\ (forall b ofs n, Mem.valid_block m b -> bc b = BCinvalid -> Mem.loadbytes m' b ofs n = Mem.loadbytes m b ofs n).
+Proof.
+ intros until am; intros EC GENV ARGS RO MM NOSTACK.
+ (* Part 1: using ec_mem_inject *)
+ exploit (@external_call_mem_inject ef _ _ ge vargs m t vres m' (inj_of_bc bc) m vargs).
+ apply inj_of_bc_preserves_globals; auto.
+ exact EC.
+ eapply mmatch_inj; eauto. eapply mmatch_below; eauto.
+ revert ARGS. generalize vargs.
+ induction vargs0; simpl; intros; constructor.
+ eapply vmatch_inj; eauto. auto.
+ intros (j' & vres' & m'' & EC' & IRES & IMEM & UNCH1 & UNCH2 & IINCR & ISEP).
+ assert (JBELOW: forall b, Plt b (Mem.nextblock m) -> j' b = inj_of_bc bc b).
+ {
+ intros. destruct (inj_of_bc bc b) as [[b' delta] | ] eqn:EQ.
+ eapply IINCR; eauto.
+ destruct (j' b) as [[b'' delta'] | ] eqn:EQ'; auto.
+ exploit ISEP; eauto. tauto.
+ }
+ (* Part 2: constructing bc' from j' *)
+ set (f := fun b => if plt b (Mem.nextblock m)
+ then bc b
+ else match j' b with None => BCinvalid | Some _ => BCother end).
+ assert (F_stack: forall b1 b2, f b1 = BCstack -> f b2 = BCstack -> b1 = b2).
+ {
+ assert (forall b, f b = BCstack -> bc b = BCstack).
+ { unfold f; intros. destruct (plt b (Mem.nextblock m)); auto. destruct (j' b); discriminate. }
+ intros. apply (bc_stack bc); auto.
+ }
+ assert (F_glob: forall b1 b2 id, f b1 = BCglob id -> f b2 = BCglob id -> b1 = b2).
+ {
+ assert (forall b id, f b = BCglob id -> bc b = BCglob id).
+ { unfold f; intros. destruct (plt b (Mem.nextblock m)); auto. destruct (j' b); discriminate. }
+ intros. eapply (bc_glob bc); eauto.
+ }
+ set (bc' := BC f F_stack F_glob). unfold f in bc'.
+ assert (INCR: bc_incr bc bc').
+ {
+ red; simpl; intros. apply pred_dec_true. eapply mmatch_below; eauto.
+ }
+ assert (BC'INV: forall b, bc' b <> BCinvalid -> exists b' delta, j' b = Some(b', delta)).
+ {
+ simpl; intros. destruct (plt b (Mem.nextblock m)).
+ exists b, 0. rewrite JBELOW by auto. apply inj_of_bc_valid; auto.
+ destruct (j' b) as [[b' delta] | ].
+ exists b', delta; auto.
+ congruence.
+ }
+
+ (* Part 3: injection wrt j' implies matching with top wrt bc' *)
+ assert (PMTOP: forall b b' delta ofs, j' b = Some (b', delta) -> pmatch bc' b ofs Ptop).
+ {
+ intros. constructor. simpl; unfold f.
+ destruct (plt b (Mem.nextblock m)).
+ rewrite JBELOW in H by auto. eapply inj_of_bc_inv; eauto.
+ rewrite H; congruence.
+ }
+ assert (VMTOP: forall v v', val_inject j' v v' -> vmatch bc' v Vtop).
+ {
+ intros. inv H; constructor. eapply PMTOP; eauto.
+ }
+ assert (SMTOP: forall b, bc' b <> BCinvalid -> smatch bc' m' b Ptop).
+ {
+ intros; split; intros.
+ - exploit BC'INV; eauto. intros (b' & delta & J').
+ exploit Mem.load_inject. eexact IMEM. eauto. eauto. intros (v' & A & B).
+ eapply VMTOP; eauto.
+ - exploit BC'INV; eauto. intros (b'' & delta & J').
+ exploit Mem.loadbytes_inject. eexact IMEM. eauto. eauto. intros (bytes & A & B).
+ inv B. inv H3. eapply PMTOP; eauto.
+ }
+ (* Conclusions *)
+ exists bc'; splitall.
+- (* incr *)
+ exact INCR.
+- (* unchanged *)
+ simpl; intros. apply pred_dec_true; auto.
+- (* vmatch res *)
+ eapply VMTOP; eauto.
+- (* genv match *)
+ apply genv_match_exten with bc; auto.
+ simpl; intros; split; intros.
+ rewrite pred_dec_true by (eapply mmatch_below; eauto with va). auto.
+ destruct (plt b (Mem.nextblock m)). auto. destruct (j' b); congruence.
+ simpl; intros. rewrite pred_dec_true by (eapply mmatch_below; eauto with va). auto.
+- (* romatch m' *)
+ red; simpl; intros. destruct (plt b (Mem.nextblock m)).
+ exploit RO; eauto. intros (R & P & Q).
+ split; auto.
+ split. apply bmatch_incr with bc; auto. apply bmatch_inv with m; auto.
+ intros. eapply Mem.loadbytes_unchanged_on_1. eapply external_call_readonly; eauto.
+ auto. intros; red. apply Q.
+ intros; red; intros; elim (Q ofs).
+ eapply external_call_max_perm with (m2 := m'); eauto.
+ destruct (j' b); congruence.
+- (* mmatch top *)
+ constructor; simpl; intros.
+ + apply ablock_init_sound. apply SMTOP. simpl; congruence.
+ + rewrite PTree.gempty in H0; discriminate.
+ + apply SMTOP; auto.
+ + apply SMTOP; auto.
+ + red; simpl; intros. destruct (plt b (Mem.nextblock m)).
+ eapply Plt_le_trans. eauto. eapply external_call_nextblock; eauto.
+ destruct (j' b) as [[bx deltax] | ] eqn:J'.
+ eapply Mem.valid_block_inject_1; eauto.
+ congruence.
+- (* nostack *)
+ red; simpl; intros. destruct (plt b (Mem.nextblock m)).
+ apply NOSTACK; auto.
+ destruct (j' b); congruence.
+- (* unmapped blocks are invariant *)
+ intros. eapply Mem.loadbytes_unchanged_on_1; auto.
+ apply UNCH1; auto. intros; red. unfold inj_of_bc; rewrite H0; auto.
+Qed.
+
+(** ** Semantic invariant *)
+
+Section SOUNDNESS.
+
+Variable prog: program.
+
+Let ge : genv := Genv.globalenv prog.
+
+Let rm := romem_for_program prog.
+
+Inductive sound_stack: block_classification -> list stackframe -> mem -> block -> Prop :=
+ | sound_stack_nil: forall bc m bound,
+ sound_stack bc nil m bound
+ | sound_stack_public_call:
+ forall (bc: block_classification) res f sp pc e stk m bound bc' bound' ae
+ (STK: sound_stack bc' stk m sp)
+ (INCR: Ple bound' bound)
+ (BELOW: bc_below bc' bound')
+ (SP: bc sp = BCother)
+ (SP': bc' sp = BCstack)
+ (SAME: forall b, Plt b bound' -> b <> sp -> bc b = bc' b)
+ (GE: genv_match bc' ge)
+ (AN: VA.ge (analyze rm f)!!pc (VA.State (AE.set res Vtop ae) mafter_public_call))
+ (EM: ematch bc' e ae),
+ sound_stack bc (Stackframe res f (Vptr sp Int.zero) pc e :: stk) m bound
+ | sound_stack_private_call:
+ forall (bc: block_classification) res f sp pc e stk m bound bc' bound' ae am
+ (STK: sound_stack bc' stk m sp)
+ (INCR: Ple bound' bound)
+ (BELOW: bc_below bc' bound')
+ (SP: bc sp = BCinvalid)
+ (SP': bc' sp = BCstack)
+ (SAME: forall b, Plt b bound' -> b <> sp -> bc b = bc' b)
+ (GE: genv_match bc' ge)
+ (AN: VA.ge (analyze rm f)!!pc (VA.State (AE.set res (Ifptr Nonstack) ae) (mafter_private_call am)))
+ (EM: ematch bc' e ae)
+ (CONTENTS: bmatch bc' m sp am.(am_stack)),
+ sound_stack bc (Stackframe res f (Vptr sp Int.zero) pc e :: stk) m bound.
+
+Inductive sound_state: state -> Prop :=
+ | sound_regular_state:
+ forall s f sp pc e m ae am bc
+ (STK: sound_stack bc s m sp)
+ (AN: (analyze rm f)!!pc = VA.State ae am)
+ (EM: ematch bc e ae)
+ (RO: romatch bc m rm)
+ (MM: mmatch bc m am)
+ (GE: genv_match bc ge)
+ (SP: bc sp = BCstack),
+ sound_state (State s f (Vptr sp Int.zero) pc e m)
+ | sound_call_state:
+ forall s fd args m bc
+ (STK: sound_stack bc s m (Mem.nextblock m))
+ (ARGS: forall v, In v args -> vmatch bc v Vtop)
+ (RO: romatch bc m rm)
+ (MM: mmatch bc m mtop)
+ (GE: genv_match bc ge)
+ (NOSTK: bc_nostack bc),
+ sound_state (Callstate s fd args m)
+ | sound_return_state:
+ forall s v m bc
+ (STK: sound_stack bc s m (Mem.nextblock m))
+ (RES: vmatch bc v Vtop)
+ (RO: romatch bc m rm)
+ (MM: mmatch bc m mtop)
+ (GE: genv_match bc ge)
+ (NOSTK: bc_nostack bc),
+ sound_state (Returnstate s v m).
+
+(** Properties of the [sound_stack] invariant on call stacks. *)
+
+Lemma sound_stack_ext:
+ forall m' bc stk m bound,
+ sound_stack bc stk m bound ->
+ (forall b ofs n bytes,
+ Plt b bound -> bc b = BCinvalid -> n >= 0 ->
+ Mem.loadbytes m' b ofs n = Some bytes ->
+ Mem.loadbytes m b ofs n = Some bytes) ->
+ sound_stack bc stk m' bound.
+Proof.
+ induction 1; intros INV.
+- constructor.
+- assert (Plt sp bound') by eauto with va.
+ eapply sound_stack_public_call; eauto. apply IHsound_stack; intros.
+ apply INV. xomega. rewrite SAME; auto. xomega. auto. auto.
+- assert (Plt sp bound') by eauto with va.
+ eapply sound_stack_private_call; eauto. apply IHsound_stack; intros.
+ apply INV. xomega. rewrite SAME; auto. xomega. auto. auto.
+ apply bmatch_ext with m; auto. intros. apply INV. xomega. auto. auto. auto.
+Qed.
+
+Lemma sound_stack_inv:
+ forall m' bc stk m bound,
+ sound_stack bc stk m bound ->
+ (forall b ofs n, Plt b bound -> bc b = BCinvalid -> n >= 0 -> Mem.loadbytes m' b ofs n = Mem.loadbytes m b ofs n) ->
+ sound_stack bc stk m' bound.
+Proof.
+ intros. eapply sound_stack_ext; eauto. intros. rewrite <- H0; auto.
+Qed.
+
+Lemma sound_stack_storev:
+ forall chunk m addr v m' bc aaddr stk bound,
+ Mem.storev chunk m addr v = Some m' ->
+ vmatch bc addr aaddr ->
+ sound_stack bc stk m bound ->
+ sound_stack bc stk m' bound.
+Proof.
+ intros. apply sound_stack_inv with m; auto.
+ destruct addr; simpl in H; try discriminate.
+ assert (A: pmatch bc b i Ptop).
+ { inv H0; eapply pmatch_top'; eauto. }
+ inv A.
+ intros. eapply Mem.loadbytes_store_other; eauto. left; congruence.
+Qed.
+
+Lemma sound_stack_storebytes:
+ forall m b ofs bytes m' bc aaddr stk bound,
+ Mem.storebytes m b (Int.unsigned ofs) bytes = Some m' ->
+ vmatch bc (Vptr b ofs) aaddr ->
+ sound_stack bc stk m bound ->
+ sound_stack bc stk m' bound.
+Proof.
+ intros. apply sound_stack_inv with m; auto.
+ assert (A: pmatch bc b ofs Ptop).
+ { inv H0; eapply pmatch_top'; eauto. }
+ inv A.
+ intros. eapply Mem.loadbytes_storebytes_other; eauto. left; congruence.
+Qed.
+
+Lemma sound_stack_free:
+ forall m b lo hi m' bc stk bound,
+ Mem.free m b lo hi = Some m' ->
+ sound_stack bc stk m bound ->
+ sound_stack bc stk m' bound.
+Proof.
+ intros. eapply sound_stack_ext; eauto. intros.
+ eapply Mem.loadbytes_free_2; eauto.
+Qed.
+
+Lemma sound_stack_new_bound:
+ forall bc stk m bound bound',
+ sound_stack bc stk m bound ->
+ Ple bound bound' ->
+ sound_stack bc stk m bound'.
+Proof.
+ intros. inv H.
+- constructor.
+- eapply sound_stack_public_call with (bound' := bound'0); eauto. xomega.
+- eapply sound_stack_private_call with (bound' := bound'0); eauto. xomega.
+Qed.
+
+Lemma sound_stack_exten:
+ forall bc stk m bound (bc1: block_classification),
+ sound_stack bc stk m bound ->
+ (forall b, Plt b bound -> bc1 b = bc b) ->
+ sound_stack bc1 stk m bound.
+Proof.
+ intros. inv H.
+- constructor.
+- assert (Plt sp bound') by eauto with va.
+ eapply sound_stack_public_call; eauto.
+ rewrite H0; auto. xomega.
+ intros. rewrite H0; auto. xomega.
+- assert (Plt sp bound') by eauto with va.
+ eapply sound_stack_private_call; eauto.
+ rewrite H0; auto. xomega.
+ intros. rewrite H0; auto. xomega.
+Qed.
+
+(** ** Preservation of the semantic invariant by one step of execution *)
+
+Lemma sound_succ_state:
+ forall bc pc ae am instr ae' am' s f sp pc' e' m',
+ (analyze rm f)!!pc = VA.State ae am ->
+ f.(fn_code)!pc = Some instr ->
+ In pc' (successors_instr instr) ->
+ transfer f rm pc ae am = VA.State ae' am' ->
+ ematch bc e' ae' ->
+ mmatch bc m' am' ->
+ romatch bc m' rm ->
+ genv_match bc ge ->
+ bc sp = BCstack ->
+ sound_stack bc s m' sp ->
+ sound_state (State s f (Vptr sp Int.zero) pc' e' m').
+Proof.
+ intros. exploit analyze_succ; eauto. intros (ae'' & am'' & AN & EM & MM).
+ econstructor; eauto.
+Qed.
+
+Lemma areg_sound:
+ forall bc e ae r, ematch bc e ae -> vmatch bc (e#r) (areg ae r).
+Proof.
+ intros. apply H.
+Qed.
+
+Lemma aregs_sound:
+ forall bc e ae rl, ematch bc e ae -> list_forall2 (vmatch bc) (e##rl) (aregs ae rl).
+Proof.
+ induction rl; simpl; intros. constructor. constructor; auto. apply areg_sound; auto.
+Qed.
+
+Hint Resolve areg_sound aregs_sound: va.
+
+Theorem sound_step:
+ forall st t st', RTL.step ge st t st' -> sound_state st -> sound_state st'.
+Proof.
+ induction 1; intros SOUND; inv SOUND.
+
+- (* nop *)
+ eapply sound_succ_state; eauto. simpl; auto.
+ unfold transfer; rewrite H. auto.
+
+- (* op *)
+ eapply sound_succ_state; eauto. simpl; auto.
+ unfold transfer; rewrite H. eauto.
+ apply ematch_update; auto. eapply eval_static_operation_sound; eauto with va.
+
+- (* load *)
+ eapply sound_succ_state; eauto. simpl; auto.
+ unfold transfer; rewrite H. eauto.
+ apply ematch_update; auto. eapply loadv_sound; eauto with va.
+ eapply eval_static_addressing_sound; eauto with va.
+
+- (* store *)
+ exploit eval_static_addressing_sound; eauto with va. intros VMADDR.
+ eapply sound_succ_state; eauto. simpl; auto.
+ unfold transfer; rewrite H. eauto.
+ eapply storev_sound; eauto.
+ destruct a; simpl in H1; try discriminate. eapply romatch_store; eauto.
+ eapply sound_stack_storev; eauto.
+
+- (* call *)
+ assert (TR: transfer f rm pc ae am = transfer_call ae am args res).
+ { unfold transfer; rewrite H; auto. }
+ unfold transfer_call in TR.
+ destruct (pincl (am_nonstack am) Nonstack &&
+ forallb (fun r : reg => vpincl (areg ae r) Nonstack) args) eqn:NOLEAK.
++ (* private call *)
+ InvBooleans.
+ exploit analyze_successor; eauto. simpl; eauto. rewrite TR. intros SUCC.
+ exploit hide_stack; eauto. apply pincl_ge; auto.
+ intros (bc' & A & B & C & D & E & F & G).
+ apply sound_call_state with bc'; auto.
+ * eapply sound_stack_private_call with (bound' := Mem.nextblock m) (bc' := bc); eauto.
+ apply Ple_refl.
+ eapply mmatch_below; eauto.
+ eapply mmatch_stack; eauto.
+ * intros. exploit list_in_map_inv; eauto. intros (r & P & Q). subst v.
+ apply D with (areg ae r).
+ rewrite forallb_forall in H2. apply vpincl_ge. apply H2; auto. auto with va.
++ (* public call *)
+ exploit analyze_successor; eauto. simpl; eauto. rewrite TR. intros SUCC.
+ exploit anonymize_stack; eauto. intros (bc' & A & B & C & D & E & F & G).
+ apply sound_call_state with bc'; auto.
+ * eapply sound_stack_public_call with (bound' := Mem.nextblock m) (bc' := bc); eauto.
+ apply Ple_refl.
+ eapply mmatch_below; eauto.
+ * intros. exploit list_in_map_inv; eauto. intros (r & P & Q). subst v.
+ apply D with (areg ae r). auto with va.
+
+- (* tailcall *)
+ exploit anonymize_stack; eauto. intros (bc' & A & B & C & D & E & F & G).
+ apply sound_call_state with bc'; auto.
+ erewrite Mem.nextblock_free by eauto.
+ apply sound_stack_new_bound with stk.
+ apply sound_stack_exten with bc.
+ eapply sound_stack_free; eauto.
+ intros. apply C. apply Plt_ne; auto.
+ apply Plt_Ple. eapply mmatch_below; eauto. congruence.
+ intros. exploit list_in_map_inv; eauto. intros (r & P & Q). subst v.
+ apply D with (areg ae r). auto with va.
+ eapply romatch_free; eauto.
+ eapply mmatch_free; eauto.
+
+- (* builtin *)
+ assert (SPVALID: Plt sp0 (Mem.nextblock m)) by (eapply mmatch_below; eauto with va).
+ assert (TR: transfer f rm pc ae am = transfer_builtin ae am rm ef args res).
+ { unfold transfer; rewrite H; auto. }
+ unfold transfer_builtin in TR.
+ exploit classify_builtin_sound; eauto. destruct (classify_builtin ef args ae).
++ (* volatile load *)
+ intros (addr & VLOAD & VADDR). inv VLOAD.
+ eapply sound_succ_state; eauto. simpl; auto.
+ apply ematch_update; auto.
+ inv H2.
+ * (* true volatile access *)
+ assert (V: vmatch bc v0 (Ifptr Glob)).
+ { inv H4; constructor. econstructor. eapply GE; eauto. }
+ destruct strict. apply vmatch_lub_r. apply vnormalize_sound. auto.
+ apply vnormalize_sound. eapply vmatch_ge; eauto. constructor. constructor.
+ * (* normal memory access *)
+ exploit loadv_sound; eauto. simpl; eauto. intros V.
+ destruct strict.
+ apply vmatch_lub_l. auto.
+ eapply vnormalize_cast; eauto. eapply vmatch_top; eauto.
++ (* volatile store *)
+ intros (addr & src & VSTORE & VADDR & VSRC). inv VSTORE. inv H7.
+ * (* true volatile access *)
+ eapply sound_succ_state; eauto. simpl; auto.
+ apply ematch_update; auto. constructor.
+ apply mmatch_lub_l; auto.
+ * (* normal memory access *)
+ eapply sound_succ_state; eauto. simpl; auto.
+ apply ematch_update; auto. constructor.
+ apply mmatch_lub_r. eapply storev_sound; eauto. auto.
+ eapply romatch_store; eauto.
+ eapply sound_stack_storev; eauto. simpl; eauto.
++ (* memcpy *)
+ intros (dst & src & MEMCPY & VDST & VSRC). inv MEMCPY.
+ eapply sound_succ_state; eauto. simpl; auto.
+ apply ematch_update; auto. constructor.
+ eapply storebytes_sound; eauto.
+ apply match_aptr_of_aval; auto.
+ eapply Mem.loadbytes_length; eauto.
+ intros. eapply loadbytes_sound; eauto. apply match_aptr_of_aval; auto.
+ eapply romatch_storebytes; eauto.
+ exploit Mem.loadbytes_length; eauto.
+ intros. exploit (nat_of_Z_eq sz). omega. rewrite <- H1; intros.
+ destruct bytes. simpl in H2. omegaContradiction. congruence.
+ eapply sound_stack_storebytes; eauto.
++ (* annot *)
+ intros (A & B); subst.
+ eapply sound_succ_state; eauto. simpl; auto.
+ apply ematch_update; auto. constructor.
++ (* annot val *)
+ intros (A & B); subst.
+ eapply sound_succ_state; eauto. simpl; auto.
+ apply ematch_update; auto.
++ (* general case *)
+ intros _.
+ unfold transfer_call in TR.
+ destruct (pincl (am_nonstack am) Nonstack &&
+ forallb (fun r : reg => vpincl (areg ae r) Nonstack) args) eqn:NOLEAK.
+* (* private builtin call *)
+ InvBooleans. rewrite forallb_forall in H2.
+ exploit hide_stack; eauto. apply pincl_ge; auto.
+ intros (bc1 & A & B & C & D & E & F & G).
+ exploit external_call_match; eauto.
+ intros. exploit list_in_map_inv; eauto. intros (r & P & Q). subst v0.
+ eapply D; eauto with va. apply vpincl_ge. apply H2; auto.
+ intros (bc2 & J & K & L & M & N & O & P & Q).
+ exploit (return_from_private_call bc bc2); eauto.
+ eapply mmatch_below; eauto.
+ rewrite K; auto.
+ intros. rewrite K; auto. rewrite C; auto.
+ apply bmatch_inv with m. eapply mmatch_stack; eauto.
+ intros. apply Q; auto.
+ eapply external_call_nextblock; eauto.
+ intros (bc3 & U & V & W & X & Y & Z & AA).
+ eapply sound_succ_state with (bc := bc3); eauto. simpl; auto.
+ apply ematch_update; auto.
+ apply sound_stack_exten with bc.
+ apply sound_stack_inv with m. auto.
+ intros. apply Q. red. eapply Plt_trans; eauto.
+ rewrite C; auto.
+ exact AA.
+* (* public builtin call *)
+ exploit anonymize_stack; eauto.
+ intros (bc1 & A & B & C & D & E & F & G).
+ exploit external_call_match; eauto.
+ intros. exploit list_in_map_inv; eauto. intros (r & P & Q). subst v0. eapply D; eauto with va.
+ intros (bc2 & J & K & L & M & N & O & P & Q).
+ exploit (return_from_public_call bc bc2); eauto.
+ eapply mmatch_below; eauto.
+ rewrite K; auto.
+ intros. rewrite K; auto. rewrite C; auto.
+ eapply external_call_nextblock; eauto.
+ intros (bc3 & U & V & W & X & Y & Z & AA).
+ eapply sound_succ_state with (bc := bc3); eauto. simpl; auto.
+ apply ematch_update; auto.
+ apply sound_stack_exten with bc.
+ apply sound_stack_inv with m. auto.
+ intros. apply Q. red. eapply Plt_trans; eauto.
+ rewrite C; auto.
+ exact AA.
+
+- (* cond *)
+ eapply sound_succ_state; eauto.
+ simpl. destruct b; auto.
+ unfold transfer; rewrite H; auto.
+
+- (* jumptable *)
+ eapply sound_succ_state; eauto.
+ simpl. eapply list_nth_z_in; eauto.
+ unfold transfer; rewrite H; auto.
+
+- (* return *)
+ exploit anonymize_stack; eauto. intros (bc' & A & B & C & D & E & F & G).
+ apply sound_return_state with bc'; auto.
+ erewrite Mem.nextblock_free by eauto.
+ apply sound_stack_new_bound with stk.
+ apply sound_stack_exten with bc.
+ eapply sound_stack_free; eauto.
+ intros. apply C. apply Plt_ne; auto.
+ apply Plt_Ple. eapply mmatch_below; eauto with va.
+ destruct or; simpl. eapply D; eauto. constructor.
+ eapply romatch_free; eauto.
+ eapply mmatch_free; eauto.
+
+- (* internal function *)
+ exploit allocate_stack; eauto.
+ intros (bc' & A & B & C & D & E & F & G).
+ exploit (analyze_entrypoint rm f args m' bc'); eauto.
+ intros (ae & am & AN & EM & MM').
+ econstructor; eauto.
+ erewrite Mem.alloc_result by eauto.
+ apply sound_stack_exten with bc; auto.
+ apply sound_stack_inv with m; auto.
+ intros. eapply Mem.loadbytes_alloc_unchanged; eauto.
+ intros. apply F. erewrite Mem.alloc_result by eauto. auto.
+
+- (* external function *)
+ exploit external_call_match; eauto with va.
+ intros (bc' & A & B & C & D & E & F & G & K).
+ econstructor; eauto.
+ apply sound_stack_new_bound with (Mem.nextblock m).
+ apply sound_stack_exten with bc; auto.
+ apply sound_stack_inv with m; auto.
+ eapply external_call_nextblock; eauto.
+
+- (* return *)
+ inv STK.
+ + (* from public call *)
+ exploit return_from_public_call; eauto.
+ intros; rewrite SAME; auto.
+ intros (bc1 & A & B & C & D & E & F & G).
+ destruct (analyze rm f)#pc as [ |ae' am'] eqn:EQ; simpl in AN; try contradiction. destruct AN as [A1 A2].
+ eapply sound_regular_state with (bc := bc1); eauto.
+ apply sound_stack_exten with bc'; auto.
+ eapply ematch_ge; eauto. apply ematch_update. auto. auto.
+ + (* from private call *)
+ exploit return_from_private_call; eauto.
+ intros; rewrite SAME; auto.
+ intros (bc1 & A & B & C & D & E & F & G).
+ destruct (analyze rm f)#pc as [ |ae' am'] eqn:EQ; simpl in AN; try contradiction. destruct AN as [A1 A2].
+ eapply sound_regular_state with (bc := bc1); eauto.
+ apply sound_stack_exten with bc'; auto.
+ eapply ematch_ge; eauto. apply ematch_update. auto. auto.
+Qed.
+
+End SOUNDNESS.
+
+(** ** Soundness of the initial memory abstraction *)
+
+Section INITIAL.
+
+Variable prog: program.
+
+Let ge := Genv.globalenv prog.
+
+Lemma initial_block_classification:
+ forall m,
+ Genv.init_mem prog = Some m ->
+ exists bc,
+ genv_match bc ge
+ /\ bc_below bc (Mem.nextblock m)
+ /\ bc_nostack bc
+ /\ (forall b id, bc b = BCglob id -> Genv.find_symbol ge id = Some b)
+ /\ (forall b, Mem.valid_block m b -> bc b <> BCinvalid).
+Proof.
+ intros.
+ set (f := fun b =>
+ if plt b (Genv.genv_next ge) then
+ match Genv.invert_symbol ge b with None => BCother | Some id => BCglob id end
+ else
+ BCinvalid).
+ assert (F_glob: forall b1 b2 id, f b1 = BCglob id -> f b2 = BCglob id -> b1 = b2).
+ {
+ unfold f; intros.
+ destruct (plt b1 (Genv.genv_next ge)); try discriminate.
+ destruct (Genv.invert_symbol ge b1) as [id1|] eqn:I1; inv H0.
+ destruct (plt b2 (Genv.genv_next ge)); try discriminate.
+ destruct (Genv.invert_symbol ge b2) as [id2|] eqn:I2; inv H1.
+ exploit Genv.invert_find_symbol. eexact I1.
+ exploit Genv.invert_find_symbol. eexact I2.
+ congruence.
+ }
+ assert (F_stack: forall b1 b2, f b1 = BCstack -> f b2 = BCstack -> b1 = b2).
+ {
+ unfold f; intros.
+ destruct (plt b1 (Genv.genv_next ge)); try discriminate.
+ destruct (Genv.invert_symbol ge b1); discriminate.
+ }
+ set (bc := BC f F_stack F_glob). unfold f in bc.
+ exists bc; splitall.
+- split; simpl; intros.
+ + split; intros.
+ * rewrite pred_dec_true by (eapply Genv.genv_symb_range; eauto).
+ erewrite Genv.find_invert_symbol; eauto.
+ * apply Genv.invert_find_symbol.
+ destruct (plt b (Genv.genv_next ge)); try discriminate.
+ destruct (Genv.invert_symbol ge b); congruence.
+ + rewrite ! pred_dec_true by assumption.
+ destruct (Genv.invert_symbol); split; congruence.
+- red; simpl; intros. destruct (plt b (Genv.genv_next ge)); try congruence.
+ erewrite <- Genv.init_mem_genv_next by eauto. auto.
+- red; simpl; intros.
+ destruct (plt b (Genv.genv_next ge)).
+ destruct (Genv.invert_symbol ge b); congruence.
+ congruence.
+- simpl; intros. destruct (plt b (Genv.genv_next ge)); try discriminate.
+ destruct (Genv.invert_symbol ge b) as [id' | ] eqn:IS; inv H0.
+ apply Genv.invert_find_symbol; auto.
+- intros; simpl. unfold ge; erewrite Genv.init_mem_genv_next by eauto.
+ rewrite pred_dec_true by assumption.
+ destruct (Genv.invert_symbol (Genv.globalenv prog) b); congruence.
+Qed.
+
+Section INIT.
+
+Variable bc: block_classification.
+Hypothesis GMATCH: genv_match bc ge.
+
+Lemma store_init_data_summary:
+ forall ab p id,
+ pge Glob (ab_summary ab) ->
+ pge Glob (ab_summary (store_init_data ab p id)).
+Proof.
+ intros.
+ assert (DFL: forall chunk av,
+ vge (Ifptr Glob) av ->
+ pge Glob (ab_summary (ablock_store chunk ab p av))).
+ {
+ intros. simpl. unfold vplub; destruct av; auto.
+ inv H0. apply plub_least; auto.
+ inv H0. apply plub_least; auto.
+ }
+ destruct id; auto.
+ simpl. destruct (propagate_float_constants tt); auto.
+ simpl. destruct (propagate_float_constants tt); auto.
+ apply DFL. constructor. constructor.
+Qed.
+
+Lemma store_init_data_list_summary:
+ forall idl ab p,
+ pge Glob (ab_summary ab) ->
+ pge Glob (ab_summary (store_init_data_list ab p idl)).
+Proof.
+ induction idl; simpl; intros. auto. apply IHidl. apply store_init_data_summary; auto.
+Qed.
+
+Lemma store_init_data_sound:
+ forall m b p id m' ab,
+ Genv.store_init_data ge m b p id = Some m' ->
+ bmatch bc m b ab ->
+ bmatch bc m' b (store_init_data ab p id).
+Proof.
+ intros. destruct id; try (eapply ablock_store_sound; eauto; constructor).
+ simpl. destruct (propagate_float_constants tt); eapply ablock_store_sound; eauto; constructor.
+ simpl. destruct (propagate_float_constants tt); eapply ablock_store_sound; eauto; constructor.
+ simpl in H. inv H. auto.
+ simpl in H. destruct (Genv.find_symbol ge i) as [b'|] eqn:FS; try discriminate.
+ eapply ablock_store_sound; eauto. constructor. constructor. apply GMATCH; auto.
+Qed.
+
+Lemma store_init_data_list_sound:
+ forall idl m b p m' ab,
+ Genv.store_init_data_list ge m b p idl = Some m' ->
+ bmatch bc m b ab ->
+ bmatch bc m' b (store_init_data_list ab p idl).
+Proof.
+ induction idl; simpl; intros.
+- inv H; auto.
+- destruct (Genv.store_init_data ge m b p a) as [m1|] eqn:SI; try discriminate.
+ eapply IHidl; eauto. eapply store_init_data_sound; eauto.
+Qed.
+
+Lemma store_init_data_other:
+ forall m b p id m' ab b',
+ Genv.store_init_data ge m b p id = Some m' ->
+ b' <> b ->
+ bmatch bc m b' ab ->
+ bmatch bc m' b' ab.
+Proof.
+ intros. eapply bmatch_inv; eauto.
+ intros. destruct id; try (eapply Mem.loadbytes_store_other; eauto; fail); simpl in H.
+ inv H; auto.
+ destruct (Genv.find_symbol ge i); try discriminate.
+ eapply Mem.loadbytes_store_other; eauto.
+Qed.
+
+Lemma store_init_data_list_other:
+ forall b b' ab idl m p m',
+ Genv.store_init_data_list ge m b p idl = Some m' ->
+ b' <> b ->
+ bmatch bc m b' ab ->
+ bmatch bc m' b' ab.
+Proof.
+ induction idl; simpl; intros.
+ inv H; auto.
+ destruct (Genv.store_init_data ge m b p a) as [m1|] eqn:SI; try discriminate.
+ eapply IHidl; eauto. eapply store_init_data_other; eauto.
+Qed.
+
+Lemma store_zeros_same:
+ forall p m b pos n m',
+ store_zeros m b pos n = Some m' ->
+ smatch bc m b p ->
+ smatch bc m' b p.
+Proof.
+ intros until n. functional induction (store_zeros m b pos n); intros.
+- inv H. auto.
+- eapply IHo; eauto. change p with (vplub (I Int.zero) p).
+ eapply smatch_store; eauto. constructor.
+- discriminate.
+Qed.
+
+Lemma store_zeros_other:
+ forall b' ab m b p n m',
+ store_zeros m b p n = Some m' ->
+ b' <> b ->
+ bmatch bc m b' ab ->
+ bmatch bc m' b' ab.
+Proof.
+ intros until n. functional induction (store_zeros m b p n); intros.
+- inv H. auto.
+- eapply IHo; eauto. eapply bmatch_inv; eauto.
+ intros. eapply Mem.loadbytes_store_other; eauto.
+- discriminate.
+Qed.
+
+Definition initial_mem_match (bc: block_classification) (m: mem) (g: genv) :=
+ forall b v,
+ Genv.find_var_info g b = Some v ->
+ v.(gvar_volatile) = false -> v.(gvar_readonly) = true ->
+ bmatch bc m b (store_init_data_list (ablock_init Pbot) 0 v.(gvar_init)).
+
+Lemma alloc_global_match:
+ forall m g idg m',
+ Genv.genv_next g = Mem.nextblock m ->
+ initial_mem_match bc m g ->
+ Genv.alloc_global ge m idg = Some m' ->
+ initial_mem_match bc m' (Genv.add_global g idg).
+Proof.
+ intros; red; intros. destruct idg as [id [fd | gv]]; simpl in *.
+- destruct (Mem.alloc m 0 1) as [m1 b1] eqn:ALLOC.
+ unfold Genv.find_var_info, Genv.add_global in H2; simpl in H2.
+ assert (Plt b (Mem.nextblock m)).
+ { rewrite <- H. eapply Genv.genv_vars_range; eauto. }
+ assert (b <> b1).
+ { apply Plt_ne. erewrite Mem.alloc_result by eauto. auto. }
+ apply bmatch_inv with m.
+ eapply H0; eauto.
+ intros. transitivity (Mem.loadbytes m1 b ofs n).
+ eapply Mem.loadbytes_drop; eauto.
+ eapply Mem.loadbytes_alloc_unchanged; eauto.
+- set (sz := Genv.init_data_list_size (gvar_init gv)) in *.
+ destruct (Mem.alloc m 0 sz) as [m1 b1] eqn:ALLOC.
+ destruct (store_zeros m1 b1 0 sz) as [m2 | ] eqn:STZ; try discriminate.
+ destruct (Genv.store_init_data_list ge m2 b1 0 (gvar_init gv)) as [m3 | ] eqn:SIDL; try discriminate.
+ unfold Genv.find_var_info, Genv.add_global in H2; simpl in H2.
+ rewrite PTree.gsspec in H2. destruct (peq b (Genv.genv_next g)).
++ inversion H2; clear H2; subst v.
+ assert (b = b1). { erewrite Mem.alloc_result by eauto. congruence. }
+ clear e. subst b.
+ apply bmatch_inv with m3.
+ eapply store_init_data_list_sound; eauto.
+ apply ablock_init_sound.
+ eapply store_zeros_same; eauto.
+ split; intros.
+ exploit Mem.load_alloc_same; eauto. intros EQ; subst v; constructor.
+ exploit Mem.loadbytes_alloc_same; eauto with coqlib. congruence.
+ intros. eapply Mem.loadbytes_drop; eauto.
+ right; right; right. unfold Genv.perm_globvar. rewrite H3, H4. constructor.
++ assert (Plt b (Mem.nextblock m)).
+ { rewrite <- H. eapply Genv.genv_vars_range; eauto. }
+ assert (b <> b1).
+ { apply Plt_ne. erewrite Mem.alloc_result by eauto. auto. }
+ apply bmatch_inv with m3.
+ eapply store_init_data_list_other; eauto.
+ eapply store_zeros_other; eauto.
+ apply bmatch_inv with m.
+ eapply H0; eauto.
+ intros. eapply Mem.loadbytes_alloc_unchanged; eauto.
+ intros. eapply Mem.loadbytes_drop; eauto.
+Qed.
+
+Lemma alloc_globals_match:
+ forall gl m g m',
+ Genv.genv_next g = Mem.nextblock m ->
+ initial_mem_match bc m g ->
+ Genv.alloc_globals ge m gl = Some m' ->
+ initial_mem_match bc m' (Genv.add_globals g gl).
+Proof.
+ induction gl; simpl; intros.
+- inv H1; auto.
+- destruct (Genv.alloc_global ge m a) as [m1|] eqn:AG; try discriminate.
+ eapply IHgl; eauto.
+ erewrite Genv.alloc_global_nextblock; eauto. simpl. congruence.
+ eapply alloc_global_match; eauto.
+Qed.
+
+Definition romem_consistent (g: genv) (rm: romem) :=
+ forall id b ab,
+ Genv.find_symbol g id = Some b -> rm!id = Some ab ->
+ exists v,
+ Genv.find_var_info g b = Some v
+ /\ v.(gvar_readonly) = true
+ /\ v.(gvar_volatile) = false
+ /\ ab = store_init_data_list (ablock_init Pbot) 0 v.(gvar_init).
+
+Lemma alloc_global_consistent:
+ forall g rm idg,
+ romem_consistent g rm ->
+ romem_consistent (Genv.add_global g idg) (alloc_global rm idg).
+Proof.
+ intros; red; intros. destruct idg as [id1 [fd1 | v1]];
+ unfold Genv.add_global, Genv.find_symbol, Genv.find_var_info, alloc_global in *; simpl in *.
+- rewrite PTree.gsspec in H0. rewrite PTree.grspec in H1. unfold PTree.elt_eq in *.
+ destruct (peq id id1). congruence. eapply H; eauto.
+- rewrite PTree.gsspec in H0. destruct (peq id id1).
++ inv H0. rewrite PTree.gss.
+ destruct (gvar_readonly v1 && negb (gvar_volatile v1)) eqn:RO.
+ InvBooleans. rewrite negb_true_iff in H2.
+ rewrite PTree.gss in H1.
+ exists v1. intuition congruence.
+ rewrite PTree.grs in H1. discriminate.
++ rewrite PTree.gso. eapply H; eauto.
+ destruct (gvar_readonly v1 && negb (gvar_volatile v1)).
+ rewrite PTree.gso in H1; auto.
+ rewrite PTree.gro in H1; auto.
+ apply Plt_ne. eapply Genv.genv_symb_range; eauto.
+Qed.
+
+Lemma alloc_globals_consistent:
+ forall gl g rm,
+ romem_consistent g rm ->
+ romem_consistent (Genv.add_globals g gl) (List.fold_left alloc_global gl rm).
+Proof.
+ induction gl; simpl; intros. auto. apply IHgl. apply alloc_global_consistent; auto.
+Qed.
+
+End INIT.
+
+Theorem initial_mem_matches:
+ forall m,
+ Genv.init_mem prog = Some m ->
+ exists bc,
+ genv_match bc ge
+ /\ bc_below bc (Mem.nextblock m)
+ /\ bc_nostack bc
+ /\ romatch bc m (romem_for_program prog)
+ /\ (forall b, Mem.valid_block m b -> bc b <> BCinvalid).
+Proof.
+ intros.
+ exploit initial_block_classification; eauto. intros (bc & GE & BELOW & NOSTACK & INV & VALID).
+ exists bc; splitall; auto.
+ assert (A: initial_mem_match bc m ge).
+ {
+ apply alloc_globals_match with (m := Mem.empty); auto.
+ red. unfold Genv.find_var_info; simpl. intros. rewrite PTree.gempty in H0; discriminate.
+ }
+ assert (B: romem_consistent ge (romem_for_program prog)).
+ {
+ apply alloc_globals_consistent.
+ red; intros. rewrite PTree.gempty in H1; discriminate.
+ }
+ red; intros.
+ exploit B; eauto. intros (v & FV & RO & NVOL & EQ).
+ split. subst ab. apply store_init_data_list_summary. constructor.
+ split. subst ab. eapply A; eauto.
+ unfold ge in FV; exploit Genv.init_mem_characterization; eauto.
+ intros (P & Q & R).
+ intros; red; intros. exploit Q; eauto. intros [U V].
+ unfold Genv.perm_globvar in V; rewrite RO, NVOL in V. inv V.
+Qed.
+
+End INITIAL.
+
+Require Import Axioms.
+
+Theorem sound_initial:
+ forall prog st, initial_state prog st -> sound_state prog st.
+Proof.
+ destruct 1.
+ exploit initial_mem_matches; eauto. intros (bc & GE & BELOW & NOSTACK & RM & VALID).
+ apply sound_call_state with bc.
+- constructor.
+- simpl; tauto.
+- exact RM.
+- apply mmatch_inj_top with m0.
+ replace (inj_of_bc bc) with (Mem.flat_inj (Mem.nextblock m0)).
+ eapply Genv.initmem_inject; eauto.
+ symmetry; apply extensionality; unfold Mem.flat_inj; intros x.
+ destruct (plt x (Mem.nextblock m0)).
+ apply inj_of_bc_valid; auto.
+ unfold inj_of_bc. erewrite bc_below_invalid; eauto.
+- exact GE.
+- exact NOSTACK.
+Qed.
+
+Hint Resolve areg_sound aregs_sound: va.
+
+(** * Interface with other optimizations *)
+
+Definition avalue (a: VA.t) (r: reg) : aval :=
+ match a with
+ | VA.Bot => Vbot
+ | VA.State ae am => AE.get r ae
+ end.
+
+Lemma avalue_sound:
+ forall prog s f sp pc e m r,
+ sound_state prog (State s f (Vptr sp Int.zero) pc e m) ->
+ exists bc,
+ vmatch bc e#r (avalue (analyze (romem_for_program prog) f)!!pc r)
+ /\ genv_match bc (Genv.globalenv prog)
+ /\ bc sp = BCstack.
+Proof.
+ intros. inv H. exists bc; split; auto. rewrite AN. apply EM.
+Qed.
+
+Definition aaddr (a: VA.t) (r: reg) : aptr :=
+ match a with
+ | VA.Bot => Pbot
+ | VA.State ae am => aptr_of_aval (AE.get r ae)
+ end.
+
+Lemma aaddr_sound:
+ forall prog s f sp pc e m r b ofs,
+ sound_state prog (State s f (Vptr sp Int.zero) pc e m) ->
+ e#r = Vptr b ofs ->
+ exists bc,
+ pmatch bc b ofs (aaddr (analyze (romem_for_program prog) f)!!pc r)
+ /\ genv_match bc (Genv.globalenv prog)
+ /\ bc sp = BCstack.
+Proof.
+ intros. inv H. exists bc; split; auto.
+ unfold aaddr; rewrite AN. apply match_aptr_of_aval. rewrite <- H0. apply EM.
+Qed.
+
+Definition aaddressing (a: VA.t) (addr: addressing) (args: list reg) : aptr :=
+ match a with
+ | VA.Bot => Pbot
+ | VA.State ae am => aptr_of_aval (eval_static_addressing addr (aregs ae args))
+ end.
+
+Lemma aaddressing_sound:
+ forall prog s f sp pc e m addr args b ofs,
+ sound_state prog (State s f (Vptr sp Int.zero) pc e m) ->
+ eval_addressing (Genv.globalenv prog) (Vptr sp Int.zero) addr e##args = Some (Vptr b ofs) ->
+ exists bc,
+ pmatch bc b ofs (aaddressing (analyze (romem_for_program prog) f)!!pc addr args)
+ /\ genv_match bc (Genv.globalenv prog)
+ /\ bc sp = BCstack.
+Proof.
+ intros. inv H. exists bc; split; auto.
+ unfold aaddressing. rewrite AN. apply match_aptr_of_aval.
+ eapply eval_static_addressing_sound; eauto with va.
+Qed.
+
+
+
+
+
diff --git a/backend/ValueDomain.v b/backend/ValueDomain.v
new file mode 100644
index 0000000..2c728d3
--- /dev/null
+++ b/backend/ValueDomain.v
@@ -0,0 +1,3692 @@
+Require Import Coqlib.
+Require Import Zwf.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Events.
+Require Import Lattice.
+Require Import Kildall.
+Require Import Registers.
+Require Import RTL.
+
+Parameter strict: bool.
+Parameter propagate_float_constants: unit -> bool.
+Parameter generate_float_constants : unit -> bool.
+
+Inductive block_class : Type :=
+ | BCinvalid
+ | BCglob (id: ident)
+ | BCstack
+ | BCother.
+
+Definition block_class_eq: forall (x y: block_class), {x=y} + {x<>y}.
+Proof. decide equality. apply peq. Defined.
+
+Record block_classification : Type := BC {
+ bc_img :> block -> block_class;
+ bc_stack: forall b1 b2, bc_img b1 = BCstack -> bc_img b2 = BCstack -> b1 = b2;
+ bc_glob: forall b1 b2 id, bc_img b1 = BCglob id -> bc_img b2 = BCglob id -> b1 = b2
+}.
+
+Definition bc_below (bc: block_classification) (bound: block) : Prop :=
+ forall b, bc b <> BCinvalid -> Plt b bound.
+
+Lemma bc_below_invalid:
+ forall b bc bound, ~Plt b bound -> bc_below bc bound -> bc b = BCinvalid.
+Proof.
+ intros. destruct (block_class_eq (bc b) BCinvalid); auto.
+ elim H. apply H0; auto.
+Qed.
+
+Hint Extern 2 (_ = _) => congruence : va.
+Hint Extern 2 (_ <> _) => congruence : va.
+Hint Extern 2 (_ < _) => xomega : va.
+Hint Extern 2 (_ <= _) => xomega : va.
+Hint Extern 2 (_ > _) => xomega : va.
+Hint Extern 2 (_ >= _) => xomega : va.
+
+Section MATCH.
+
+Variable bc: block_classification.
+
+(** * Abstracting the result of conditions (type [option bool]) *)
+
+Inductive abool := Bnone | Just (b: bool) | Maybe (b: bool) | Btop.
+
+Inductive cmatch: option bool -> abool -> Prop :=
+ | cmatch_none: cmatch None Bnone
+ | cmatch_just: forall b, cmatch (Some b) (Just b)
+ | cmatch_maybe_none: forall b, cmatch None (Maybe b)
+ | cmatch_maybe_some: forall b, cmatch (Some b) (Maybe b)
+ | cmatch_top: forall ob, cmatch ob Btop.
+
+Hint Constructors cmatch : va.
+
+Definition club (x y: abool) : abool :=
+ match x, y with
+ | Bnone, Bnone => Bnone
+ | Bnone, (Just b | Maybe b) => Maybe b
+ | (Just b | Maybe b), Bnone => Maybe b
+ | Just b1, Just b2 => if eqb b1 b2 then x else Btop
+ | Maybe b1, Maybe b2 => if eqb b1 b2 then x else Btop
+ | Maybe b1, Just b2 => if eqb b1 b2 then x else Btop
+ | Just b1, Maybe b2 => if eqb b1 b2 then y else Btop
+ | _, _ => Btop
+ end.
+
+Lemma cmatch_lub_l:
+ forall ob x y, cmatch ob x -> cmatch ob (club x y).
+Proof.
+ intros. unfold club; inv H; destruct y; try constructor;
+ destruct (eqb b b0) eqn:EQ; try constructor.
+ replace b0 with b by (apply eqb_prop; auto). constructor.
+Qed.
+
+Lemma cmatch_lub_r:
+ forall ob x y, cmatch ob y -> cmatch ob (club x y).
+Proof.
+ intros. unfold club; inv H; destruct x; try constructor;
+ destruct (eqb b0 b) eqn:EQ; try constructor.
+ replace b with b0 by (apply eqb_prop; auto). constructor.
+ replace b with b0 by (apply eqb_prop; auto). constructor.
+ replace b with b0 by (apply eqb_prop; auto). constructor.
+Qed.
+
+Definition cnot (x: abool) : abool :=
+ match x with
+ | Just b => Just (negb b)
+ | Maybe b => Maybe (negb b)
+ | _ => x
+ end.
+
+Lemma cnot_sound:
+ forall ob x, cmatch ob x -> cmatch (option_map negb ob) (cnot x).
+Proof.
+ destruct 1; constructor.
+Qed.
+
+(** * Abstracting pointers *)
+
+Inductive aptr : Type :=
+ | Pbot
+ | Gl (id: ident) (ofs: int)
+ | Glo (id: ident)
+ | Glob
+ | Stk (ofs: int)
+ | Stack
+ | Nonstack
+ | Ptop.
+
+Definition eq_aptr: forall (p1 p2: aptr), {p1=p2} + {p1<>p2}.
+Proof.
+ intros. generalize ident_eq, Int.eq_dec; intros. decide equality.
+Defined.
+
+Inductive pmatch (b: block) (ofs: int): aptr -> Prop :=
+ | pmatch_gl: forall id,
+ bc b = BCglob id ->
+ pmatch b ofs (Gl id ofs)
+ | pmatch_glo: forall id,
+ bc b = BCglob id ->
+ pmatch b ofs (Glo id)
+ | pmatch_glob: forall id,
+ bc b = BCglob id ->
+ pmatch b ofs Glob
+ | pmatch_stk:
+ bc b = BCstack ->
+ pmatch b ofs (Stk ofs)
+ | pmatch_stack:
+ bc b = BCstack ->
+ pmatch b ofs Stack
+ | pmatch_nonstack:
+ bc b <> BCstack -> bc b <> BCinvalid ->
+ pmatch b ofs Nonstack
+ | pmatch_top:
+ bc b <> BCinvalid ->
+ pmatch b ofs Ptop.
+
+Hint Constructors pmatch: va.
+
+Inductive pge: aptr -> aptr -> Prop :=
+ | pge_top: forall p, pge Ptop p
+ | pge_bot: forall p, pge p Pbot
+ | pge_refl: forall p, pge p p
+ | pge_glo_gl: forall id ofs, pge (Glo id) (Gl id ofs)
+ | pge_glob_gl: forall id ofs, pge Glob (Gl id ofs)
+ | pge_glob_glo: forall id, pge Glob (Glo id)
+ | pge_ns_gl: forall id ofs, pge Nonstack (Gl id ofs)
+ | pge_ns_glo: forall id, pge Nonstack (Glo id)
+ | pge_ns_glob: pge Nonstack Glob
+ | pge_stack_stk: forall ofs, pge Stack (Stk ofs).
+
+Hint Constructors pge: va.
+
+Lemma pge_trans:
+ forall p q, pge p q -> forall r, pge q r -> pge p r.
+Proof.
+ induction 1; intros r PM; inv PM; auto with va.
+Qed.
+
+Lemma pmatch_ge:
+ forall b ofs p q, pge p q -> pmatch b ofs q -> pmatch b ofs p.
+Proof.
+ induction 1; intros PM; inv PM; eauto with va.
+Qed.
+
+Lemma pmatch_top': forall b ofs p, pmatch b ofs p -> pmatch b ofs Ptop.
+Proof.
+ intros. apply pmatch_ge with p; auto with va.
+Qed.
+
+Definition plub (p q: aptr) : aptr :=
+ match p, q with
+ | Pbot, _ => q
+ | _, Pbot => p
+ | Gl id1 ofs1, Gl id2 ofs2 =>
+ if ident_eq id1 id2 then if Int.eq_dec ofs1 ofs2 then p else Glo id1 else Glob
+ | Gl id1 ofs1, Glo id2 =>
+ if ident_eq id1 id2 then q else Glob
+ | Glo id1, Gl id2 ofs2 =>
+ if ident_eq id1 id2 then p else Glob
+ | Glo id1, Glo id2 =>
+ if ident_eq id1 id2 then p else Glob
+ | (Gl _ _ | Glo _ | Glob), Glob => Glob
+ | Glob, (Gl _ _ | Glo _) => Glob
+ | (Gl _ _ | Glo _ | Glob | Nonstack), Nonstack =>
+ Nonstack
+ | Nonstack, (Gl _ _ | Glo _ | Glob) =>
+ Nonstack
+ | Stk ofs1, Stk ofs2 =>
+ if Int.eq_dec ofs1 ofs2 then p else Stack
+ | (Stk _ | Stack), Stack =>
+ Stack
+ | Stack, Stk _ =>
+ Stack
+ | _, _ => Ptop
+ end.
+
+Lemma plub_comm:
+ forall p q, plub p q = plub q p.
+Proof.
+ intros; unfold plub; destruct p; destruct q; auto.
+ destruct (ident_eq id id0). subst id0.
+ rewrite dec_eq_true.
+ destruct (Int.eq_dec ofs ofs0). subst ofs0. rewrite dec_eq_true. auto.
+ rewrite dec_eq_false by auto. auto.
+ rewrite dec_eq_false by auto. auto.
+ destruct (ident_eq id id0). subst id0.
+ rewrite dec_eq_true; auto.
+ rewrite dec_eq_false; auto.
+ destruct (ident_eq id id0). subst id0.
+ rewrite dec_eq_true; auto.
+ rewrite dec_eq_false; auto.
+ destruct (ident_eq id id0). subst id0.
+ rewrite dec_eq_true; auto.
+ rewrite dec_eq_false; auto.
+ destruct (Int.eq_dec ofs ofs0). subst ofs0. rewrite dec_eq_true; auto.
+ rewrite dec_eq_false; auto.
+Qed.
+
+Lemma pge_lub_l:
+ forall p q, pge (plub p q) p.
+Proof.
+ unfold plub; destruct p, q; auto with va.
+- destruct (ident_eq id id0).
+ destruct (Int.eq_dec ofs ofs0); subst; constructor.
+ constructor.
+- destruct (ident_eq id id0); subst; constructor.
+- destruct (ident_eq id id0); subst; constructor.
+- destruct (ident_eq id id0); subst; constructor.
+- destruct (Int.eq_dec ofs ofs0); subst; constructor.
+Qed.
+
+Lemma pge_lub_r:
+ forall p q, pge (plub p q) q.
+Proof.
+ intros. rewrite plub_comm. apply pge_lub_l.
+Qed.
+
+Lemma pmatch_lub_l:
+ forall b ofs p q, pmatch b ofs p -> pmatch b ofs (plub p q).
+Proof.
+ intros. eapply pmatch_ge; eauto. apply pge_lub_l.
+Qed.
+
+Lemma pmatch_lub_r:
+ forall b ofs p q, pmatch b ofs q -> pmatch b ofs (plub p q).
+Proof.
+ intros. eapply pmatch_ge; eauto. apply pge_lub_r.
+Qed.
+
+Lemma plub_least:
+ forall r p q, pge r p -> pge r q -> pge r (plub p q).
+Proof.
+ intros. inv H; inv H0; simpl; try constructor.
+- destruct p; constructor.
+- unfold plub; destruct q; repeat rewrite dec_eq_true; constructor.
+- rewrite dec_eq_true; constructor.
+- rewrite dec_eq_true; constructor.
+- rewrite dec_eq_true. destruct (Int.eq_dec ofs ofs0); constructor.
+- destruct (ident_eq id id0). destruct (Int.eq_dec ofs ofs0); constructor. constructor.
+- destruct (ident_eq id id0); constructor.
+- destruct (ident_eq id id0); constructor.
+- destruct (ident_eq id id0); constructor.
+- destruct (ident_eq id id0). destruct (Int.eq_dec ofs ofs0); constructor. constructor.
+- destruct (ident_eq id id0); constructor.
+- destruct (ident_eq id id0); constructor.
+- destruct (ident_eq id id0); constructor.
+- destruct (Int.eq_dec ofs ofs0); constructor.
+Qed.
+
+Definition pincl (p q: aptr) : bool :=
+ match p, q with
+ | Pbot, _ => true
+ | Gl id1 ofs1, Gl id2 ofs2 => peq id1 id2 && Int.eq_dec ofs1 ofs2
+ | Gl id1 ofs1, Glo id2 => peq id1 id2
+ | Glo id1, Glo id2 => peq id1 id2
+ | (Gl _ _ | Glo _ | Glob), Glob => true
+ | (Gl _ _ | Glo _ | Glob | Nonstack), Nonstack => true
+ | Stk ofs1, Stk ofs2 => Int.eq_dec ofs1 ofs2
+ | Stk ofs1, Stack => true
+ | _, Ptop => true
+ | _, _ => false
+ end.
+
+Lemma pincl_ge: forall p q, pincl p q = true -> pge q p.
+Proof.
+ unfold pincl; destruct p, q; intros; try discriminate; auto with va;
+ InvBooleans; subst; auto with va.
+Qed.
+
+Lemma pincl_sound:
+ forall b ofs p q,
+ pincl p q = true -> pmatch b ofs p -> pmatch b ofs q.
+Proof.
+ intros. eapply pmatch_ge; eauto. apply pincl_ge; auto.
+Qed.
+
+Definition padd (p: aptr) (n: int) : aptr :=
+ match p with
+ | Gl id ofs => Gl id (Int.add ofs n)
+ | Stk ofs => Stk (Int.add ofs n)
+ | _ => p
+ end.
+
+Lemma padd_sound:
+ forall b ofs p delta,
+ pmatch b ofs p ->
+ pmatch b (Int.add ofs delta) (padd p delta).
+Proof.
+ intros. inv H; simpl padd; eauto with va.
+Qed.
+
+Definition psub (p: aptr) (n: int) : aptr :=
+ match p with
+ | Gl id ofs => Gl id (Int.sub ofs n)
+ | Stk ofs => Stk (Int.sub ofs n)
+ | _ => p
+ end.
+
+Lemma psub_sound:
+ forall b ofs p delta,
+ pmatch b ofs p ->
+ pmatch b (Int.sub ofs delta) (psub p delta).
+Proof.
+ intros. inv H; simpl psub; eauto with va.
+Qed.
+
+Definition poffset (p: aptr) : aptr :=
+ match p with
+ | Gl id ofs => Glo id
+ | Stk ofs => Stack
+ | _ => p
+ end.
+
+Lemma poffset_sound:
+ forall b ofs1 ofs2 p,
+ pmatch b ofs1 p ->
+ pmatch b ofs2 (poffset p).
+Proof.
+ intros. inv H; simpl poffset; eauto with va.
+Qed.
+
+Definition psub2 (p q: aptr) : option int :=
+ match p, q with
+ | Gl id1 ofs1, Gl id2 ofs2 =>
+ if peq id1 id2 then Some (Int.sub ofs1 ofs2) else None
+ | Stk ofs1, Stk ofs2 =>
+ Some (Int.sub ofs1 ofs2)
+ | _, _ =>
+ None
+ end.
+
+Lemma psub2_sound:
+ forall b1 ofs1 p1 b2 ofs2 p2 delta,
+ psub2 p1 p2 = Some delta ->
+ pmatch b1 ofs1 p1 ->
+ pmatch b2 ofs2 p2 ->
+ b1 = b2 /\ delta = Int.sub ofs1 ofs2.
+Proof.
+ intros. destruct p1; try discriminate; destruct p2; try discriminate; simpl in H.
+- destruct (peq id id0); inv H. inv H0; inv H1.
+ split. eapply bc_glob; eauto. reflexivity.
+- inv H; inv H0; inv H1. split. eapply bc_stack; eauto. reflexivity.
+Qed.
+
+Definition cmp_different_blocks (c: comparison) : abool :=
+ match c with
+ | Ceq => Maybe false
+ | Cne => Maybe true
+ | _ => Bnone
+ end.
+
+Lemma cmp_different_blocks_none:
+ forall c, cmatch None (cmp_different_blocks c).
+Proof.
+ intros; destruct c; constructor.
+Qed.
+
+Lemma cmp_different_blocks_sound:
+ forall c, cmatch (Val.cmp_different_blocks c) (cmp_different_blocks c).
+Proof.
+ intros; destruct c; constructor.
+Qed.
+
+Definition pcmp (c: comparison) (p1 p2: aptr) : abool :=
+ match p1, p2 with
+ | Pbot, _ | _, Pbot => Bnone
+ | Gl id1 ofs1, Gl id2 ofs2 =>
+ if peq id1 id2 then Maybe (Int.cmpu c ofs1 ofs2)
+ else cmp_different_blocks c
+ | Gl id1 ofs1, Glo id2 =>
+ if peq id1 id2 then Btop else cmp_different_blocks c
+ | Glo id1, Gl id2 ofs2 =>
+ if peq id1 id2 then Btop else cmp_different_blocks c
+ | Glo id1, Glo id2 =>
+ if peq id1 id2 then Btop else cmp_different_blocks c
+ | Stk ofs1, Stk ofs2 => Maybe (Int.cmpu c ofs1 ofs2)
+ | (Gl _ _ | Glo _ | Glob | Nonstack), (Stk _ | Stack) => cmp_different_blocks c
+ | (Stk _ | Stack), (Gl _ _ | Glo _ | Glob | Nonstack) => cmp_different_blocks c
+ | _, _ => Btop
+ end.
+
+Lemma pcmp_sound:
+ forall valid c b1 ofs1 p1 b2 ofs2 p2,
+ pmatch b1 ofs1 p1 -> pmatch b2 ofs2 p2 ->
+ cmatch (Val.cmpu_bool valid c (Vptr b1 ofs1) (Vptr b2 ofs2)) (pcmp c p1 p2).
+Proof.
+ intros.
+ assert (DIFF: b1 <> b2 ->
+ cmatch (Val.cmpu_bool valid c (Vptr b1 ofs1) (Vptr b2 ofs2))
+ (cmp_different_blocks c)).
+ {
+ intros. simpl. rewrite dec_eq_false by assumption.
+ destruct (valid b1 (Int.unsigned ofs1) && valid b2 (Int.unsigned ofs2)); simpl.
+ apply cmp_different_blocks_sound.
+ apply cmp_different_blocks_none.
+ }
+ assert (SAME: b1 = b2 ->
+ cmatch (Val.cmpu_bool valid c (Vptr b1 ofs1) (Vptr b2 ofs2))
+ (Maybe (Int.cmpu c ofs1 ofs2))).
+ {
+ intros. subst b2. simpl. rewrite dec_eq_true.
+ destruct ((valid b1 (Int.unsigned ofs1) || valid b1 (Int.unsigned ofs1 - 1)) &&
+ (valid b1 (Int.unsigned ofs2) || valid b1 (Int.unsigned ofs2 - 1))); simpl.
+ constructor.
+ constructor.
+ }
+ unfold pcmp; inv H; inv H0; (apply cmatch_top || (apply DIFF; congruence) || idtac).
+ - destruct (peq id id0). subst id0. apply SAME. eapply bc_glob; eauto.
+ auto with va.
+ - destruct (peq id id0); auto with va.
+ - destruct (peq id id0); auto with va.
+ - destruct (peq id id0); auto with va.
+ - apply SAME. eapply bc_stack; eauto.
+Qed.
+
+Lemma pcmp_none:
+ forall c p1 p2, cmatch None (pcmp c p1 p2).
+Proof.
+ intros.
+ unfold pcmp; destruct p1; try constructor; destruct p2;
+ try (destruct (peq id id0)); try constructor; try (apply cmp_different_blocks_none).
+Qed.
+
+Definition pdisjoint (p1: aptr) (sz1: Z) (p2: aptr) (sz2: Z) : bool :=
+ match p1, p2 with
+ | Pbot, _ => true
+ | _, Pbot => true
+ | Gl id1 ofs1, Gl id2 ofs2 =>
+ if peq id1 id2
+ then zle (Int.unsigned ofs1 + sz1) (Int.unsigned ofs2)
+ || zle (Int.unsigned ofs2 + sz2) (Int.unsigned ofs1)
+ else true
+ | Gl id1 ofs1, Glo id2 => negb(peq id1 id2)
+ | Glo id1, Gl id2 ofs2 => negb(peq id1 id2)
+ | Glo id1, Glo id2 => negb(peq id1 id2)
+ | Stk ofs1, Stk ofs2 =>
+ zle (Int.unsigned ofs1 + sz1) (Int.unsigned ofs2)
+ || zle (Int.unsigned ofs2 + sz2) (Int.unsigned ofs1)
+ | (Gl _ _ | Glo _ | Glob | Nonstack), (Stk _ | Stack) => true
+ | (Stk _ | Stack), (Gl _ _ | Glo _ | Glob | Nonstack) => true
+ | _, _ => false
+ end.
+
+Lemma pdisjoint_sound:
+ forall sz1 b1 ofs1 p1 sz2 b2 ofs2 p2,
+ pdisjoint p1 sz1 p2 sz2 = true ->
+ pmatch b1 ofs1 p1 -> pmatch b2 ofs2 p2 ->
+ b1 <> b2 \/ Int.unsigned ofs1 + sz1 <= Int.unsigned ofs2 \/ Int.unsigned ofs2 + sz2 <= Int.unsigned ofs1.
+Proof.
+ intros. inv H0; inv H1; simpl in H; try discriminate; try (left; congruence).
+- destruct (peq id id0). subst id0. destruct (orb_true_elim _ _ H); InvBooleans; auto.
+ left; congruence.
+- destruct (peq id id0); try discriminate. left; congruence.
+- destruct (peq id id0); try discriminate. left; congruence.
+- destruct (peq id id0); try discriminate. left; congruence.
+- destruct (orb_true_elim _ _ H); InvBooleans; auto.
+Qed.
+
+(** * Abstracting values *)
+
+Inductive aval : Type :=
+ | Vbot
+ | I (n: int)
+ | Uns (n: Z)
+ | Sgn (n: Z)
+ | L (n: int64)
+ | F (f: float)
+ | Fsingle
+ | Ptr (p: aptr)
+ | Ifptr (p: aptr).
+
+Definition eq_aval: forall (v1 v2: aval), {v1=v2} + {v1<>v2}.
+Proof.
+ intros. generalize zeq Int.eq_dec Int64.eq_dec Float.eq_dec eq_aptr; intros.
+ decide equality.
+Defined.
+
+Definition Vtop := Ifptr Ptop.
+Definition itop := Ifptr Pbot.
+Definition ftop := Ifptr Pbot.
+Definition ltop := Ifptr Pbot.
+
+Definition is_uns (n: Z) (i: int) : Prop :=
+ forall m, 0 <= m < Int.zwordsize -> m >= n -> Int.testbit i m = false.
+Definition is_sgn (n: Z) (i: int) : Prop :=
+ forall m, 0 <= m < Int.zwordsize -> m >= n - 1 -> Int.testbit i m = Int.testbit i (Int.zwordsize - 1).
+
+Inductive vmatch : val -> aval -> Prop :=
+ | vmatch_i: forall i, vmatch (Vint i) (I i)
+ | vmatch_Uns: forall i n, 0 <= n -> is_uns n i -> vmatch (Vint i) (Uns n)
+ | vmatch_Uns_undef: forall n, vmatch Vundef (Uns n)
+ | vmatch_Sgn: forall i n, 0 < n -> is_sgn n i -> vmatch (Vint i) (Sgn n)
+ | vmatch_Sgn_undef: forall n, vmatch Vundef (Sgn n)
+ | vmatch_l: forall i, vmatch (Vlong i) (L i)
+ | vmatch_f: forall f, vmatch (Vfloat f) (F f)
+ | vmatch_single: forall f, Float.is_single f -> vmatch (Vfloat f) Fsingle
+ | vmatch_single_undef: vmatch Vundef Fsingle
+ | vmatch_ptr: forall b ofs p, pmatch b ofs p -> vmatch (Vptr b ofs) (Ptr p)
+ | vmatch_ptr_undef: forall p, vmatch Vundef (Ptr p)
+ | vmatch_ifptr_undef: forall p, vmatch Vundef (Ifptr p)
+ | vmatch_ifptr_i: forall i p, vmatch (Vint i) (Ifptr p)
+ | vmatch_ifptr_l: forall i p, vmatch (Vlong i) (Ifptr p)
+ | vmatch_ifptr_f: forall f p, vmatch (Vfloat f) (Ifptr p)
+ | vmatch_ifptr_p: forall b ofs p, pmatch b ofs p -> vmatch (Vptr b ofs) (Ifptr p).
+
+Lemma vmatch_ifptr:
+ forall v p,
+ (forall b ofs, v = Vptr b ofs -> pmatch b ofs p) ->
+ vmatch v (Ifptr p).
+Proof.
+ intros. destruct v; constructor; auto.
+Qed.
+
+Lemma vmatch_top: forall v x, vmatch v x -> vmatch v Vtop.
+Proof.
+ intros. apply vmatch_ifptr. intros. subst v. inv H; eapply pmatch_top'; eauto.
+Qed.
+
+Lemma vmatch_itop: forall i, vmatch (Vint i) itop.
+Proof. intros; constructor. Qed.
+
+Lemma vmatch_undef_itop: vmatch Vundef itop.
+Proof. constructor. Qed.
+
+Lemma vmatch_ftop: forall f, vmatch (Vfloat f) ftop.
+Proof. intros; constructor. Qed.
+
+Lemma vmatch_undef_ftop: vmatch Vundef ftop.
+Proof. constructor. Qed.
+
+Hint Constructors vmatch : va.
+Hint Resolve vmatch_itop vmatch_undef_itop vmatch_ftop vmatch_undef_ftop : va.
+
+(* Some properties about [is_uns] and [is_sgn]. *)
+
+Lemma is_uns_mon: forall n1 n2 i, is_uns n1 i -> n1 <= n2 -> is_uns n2 i.
+Proof.
+ intros; red; intros. apply H; omega.
+Qed.
+
+Lemma is_sgn_mon: forall n1 n2 i, is_sgn n1 i -> n1 <= n2 -> is_sgn n2 i.
+Proof.
+ intros; red; intros. apply H; omega.
+Qed.
+
+Lemma is_uns_sgn: forall n1 n2 i, is_uns n1 i -> n1 < n2 -> is_sgn n2 i.
+Proof.
+ intros; red; intros. rewrite ! H by omega. auto.
+Qed.
+
+Definition usize := Int.size.
+
+Definition ssize (i: int) := Int.size (if Int.lt i Int.zero then Int.not i else i) + 1.
+
+Lemma is_uns_usize:
+ forall i, is_uns (usize i) i.
+Proof.
+ unfold usize; intros; red; intros.
+ apply Int.bits_size_2. omega.
+Qed.
+
+Lemma is_sgn_ssize:
+ forall i, is_sgn (ssize i) i.
+Proof.
+ unfold ssize; intros; red; intros.
+ destruct (Int.lt i Int.zero) eqn:LT.
+- rewrite <- (negb_involutive (Int.testbit i m)).
+ rewrite <- (negb_involutive (Int.testbit i (Int.zwordsize - 1))).
+ f_equal.
+ generalize (Int.size_range (Int.not i)); intros RANGE.
+ rewrite <- ! Int.bits_not by omega.
+ rewrite ! Int.bits_size_2 by omega.
+ auto.
+- rewrite ! Int.bits_size_2 by omega.
+ auto.
+Qed.
+
+Lemma is_uns_zero_ext:
+ forall n i, is_uns n i <-> Int.zero_ext n i = i.
+Proof.
+ intros; split; intros.
+ Int.bit_solve. destruct (zlt i0 n); auto. symmetry; apply H; auto. omega.
+ rewrite <- H. red; intros. rewrite Int.bits_zero_ext by omega. rewrite zlt_false by omega. auto.
+Qed.
+
+Lemma is_sgn_sign_ext:
+ forall n i, 0 < n -> (is_sgn n i <-> Int.sign_ext n i = i).
+Proof.
+ intros; split; intros.
+ Int.bit_solve. destruct (zlt i0 n); auto.
+ transitivity (Int.testbit i (Int.zwordsize - 1)).
+ apply H0; omega. symmetry; apply H0; omega.
+ rewrite <- H0. red; intros. rewrite ! Int.bits_sign_ext by omega.
+ f_equal. transitivity (n-1). destruct (zlt m n); omega.
+ destruct (zlt (Int.zwordsize - 1) n); omega.
+Qed.
+
+Lemma is_zero_ext_uns:
+ forall i n m,
+ is_uns m i \/ n <= m -> is_uns m (Int.zero_ext n i).
+Proof.
+ intros. red; intros. rewrite Int.bits_zero_ext by omega.
+ destruct (zlt m0 n); auto. destruct H. apply H; omega. omegaContradiction.
+Qed.
+
+Lemma is_zero_ext_sgn:
+ forall i n m,
+ n < m ->
+ is_sgn m (Int.zero_ext n i).
+Proof.
+ intros. red; intros. rewrite ! Int.bits_zero_ext by omega.
+ transitivity false. apply zlt_false; omega.
+ symmetry; apply zlt_false; omega.
+Qed.
+
+Lemma is_sign_ext_uns:
+ forall i n m,
+ 0 <= m < n ->
+ is_uns m i ->
+ is_uns m (Int.sign_ext n i).
+Proof.
+ intros; red; intros. rewrite Int.bits_sign_ext by omega.
+ apply H0. destruct (zlt m0 n); omega. destruct (zlt m0 n); omega.
+Qed.
+
+Lemma is_sign_ext_sgn:
+ forall i n m,
+ 0 < n -> 0 < m ->
+ is_sgn m i \/ n <= m -> is_sgn m (Int.sign_ext n i).
+Proof.
+ intros. apply is_sgn_sign_ext; auto.
+ destruct (zlt m n). destruct H1. apply is_sgn_sign_ext in H1; auto.
+ rewrite <- H1. rewrite (Int.sign_ext_widen i) by omega. apply Int.sign_ext_idem; auto.
+ omegaContradiction.
+ apply Int.sign_ext_widen; omega.
+Qed.
+
+Hint Resolve is_uns_mon is_sgn_mon is_uns_sgn is_uns_usize is_sgn_ssize : va.
+
+(** Smart constructors for [Uns] and [Sgn]. *)
+
+Definition uns (n: Z) : aval :=
+ if zle n 1 then Uns 1
+ else if zle n 7 then Uns 7
+ else if zle n 8 then Uns 8
+ else if zle n 15 then Uns 15
+ else if zle n 16 then Uns 16
+ else itop.
+
+Definition sgn (n: Z) : aval :=
+ if zle n 8 then Sgn 8 else if zle n 16 then Sgn 16 else itop.
+
+Lemma vmatch_uns':
+ forall i n, is_uns (Zmax 0 n) i -> vmatch (Vint i) (uns n).
+Proof.
+ intros.
+ assert (A: forall n', n' >= 0 -> n' >= n -> is_uns n' i) by (eauto with va).
+ unfold uns.
+ destruct (zle n 1). auto with va.
+ destruct (zle n 7). auto with va.
+ destruct (zle n 8). auto with va.
+ destruct (zle n 15). auto with va.
+ destruct (zle n 16). auto with va.
+ auto with va.
+Qed.
+
+Lemma vmatch_uns:
+ forall i n, is_uns n i -> vmatch (Vint i) (uns n).
+Proof.
+ intros. apply vmatch_uns'. eauto with va.
+Qed.
+
+Lemma vmatch_uns_undef: forall n, vmatch Vundef (uns n).
+Proof.
+ intros. unfold uns.
+ destruct (zle n 1). auto with va.
+ destruct (zle n 7). auto with va.
+ destruct (zle n 8). auto with va.
+ destruct (zle n 15). auto with va.
+ destruct (zle n 16); auto with va.
+Qed.
+
+Lemma vmatch_sgn':
+ forall i n, is_sgn (Zmax 1 n) i -> vmatch (Vint i) (sgn n).
+Proof.
+ intros.
+ assert (A: forall n', n' >= 1 -> n' >= n -> is_sgn n' i) by (eauto with va).
+ unfold sgn.
+ destruct (zle n 8). auto with va.
+ destruct (zle n 16); auto with va.
+Qed.
+
+Lemma vmatch_sgn:
+ forall i n, is_sgn n i -> vmatch (Vint i) (sgn n).
+Proof.
+ intros. apply vmatch_sgn'. eauto with va.
+Qed.
+
+Lemma vmatch_sgn_undef: forall n, vmatch Vundef (sgn n).
+Proof.
+ intros. unfold sgn.
+ destruct (zle n 8). auto with va.
+ destruct (zle n 16); auto with va.
+Qed.
+
+Hint Resolve vmatch_uns vmatch_uns_undef vmatch_sgn vmatch_sgn_undef : va.
+
+(** Ordering *)
+
+Inductive vge: aval -> aval -> Prop :=
+ | vge_bot: forall v, vge v Vbot
+ | vge_i: forall i, vge (I i) (I i)
+ | vge_l: forall i, vge (L i) (L i)
+ | vge_f: forall f, vge (F f) (F f)
+ | vge_uns_i: forall n i, 0 <= n -> is_uns n i -> vge (Uns n) (I i)
+ | vge_uns_uns: forall n1 n2, n1 >= n2 -> vge (Uns n1) (Uns n2)
+ | vge_sgn_i: forall n i, 0 < n -> is_sgn n i -> vge (Sgn n) (I i)
+ | vge_sgn_sgn: forall n1 n2, n1 >= n2 -> vge (Sgn n1) (Sgn n2)
+ | vge_sgn_uns: forall n1 n2, n1 > n2 -> vge (Sgn n1) (Uns n2)
+ | vge_single_f: forall f, Float.is_single f -> vge Fsingle (F f)
+ | vge_single: vge Fsingle Fsingle
+ | vge_p_p: forall p q, pge p q -> vge (Ptr p) (Ptr q)
+ | vge_ip_p: forall p q, pge p q -> vge (Ifptr p) (Ptr q)
+ | vge_ip_ip: forall p q, pge p q -> vge (Ifptr p) (Ifptr q)
+ | vge_ip_i: forall p i, vge (Ifptr p) (I i)
+ | vge_ip_l: forall p i, vge (Ifptr p) (L i)
+ | vge_ip_f: forall p f, vge (Ifptr p) (F f)
+ | vge_ip_uns: forall p n, vge (Ifptr p) (Uns n)
+ | vge_ip_sgn: forall p n, vge (Ifptr p) (Sgn n)
+ | vge_ip_single: forall p, vge (Ifptr p) Fsingle.
+
+Hint Constructors vge : va.
+
+Lemma vge_top: forall v, vge Vtop v.
+Proof.
+ destruct v; constructor; constructor.
+Qed.
+
+Hint Resolve vge_top : va.
+
+Lemma vge_refl: forall v, vge v v.
+Proof.
+ destruct v; auto with va.
+Qed.
+
+Lemma vge_trans: forall u v, vge u v -> forall w, vge v w -> vge u w.
+Proof.
+ induction 1; intros w V; inv V; eauto with va; constructor; eapply pge_trans; eauto.
+Qed.
+
+Lemma vmatch_ge:
+ forall v x y, vge x y -> vmatch v y -> vmatch v x.
+Proof.
+ induction 1; intros V; inv V; eauto with va; constructor; eapply pmatch_ge; eauto.
+Qed.
+
+(** Least upper bound *)
+
+Definition vlub (v w: aval) : aval :=
+ match v, w with
+ | Vbot, _ => w
+ | _, Vbot => v
+ | I i1, I i2 =>
+ if Int.eq i1 i2 then v else
+ if Int.lt i1 Int.zero || Int.lt i2 Int.zero
+ then sgn (Z.max (ssize i1) (ssize i2))
+ else uns (Z.max (usize i1) (usize i2))
+ | I i, Uns n | Uns n, I i =>
+ if Int.lt i Int.zero
+ then sgn (Z.max (ssize i) (n + 1))
+ else uns (Z.max (usize i) n)
+ | I i, Sgn n | Sgn n, I i =>
+ sgn (Z.max (ssize i) n)
+ | I i, (Ptr p | Ifptr p) | (Ptr p | Ifptr p), I i =>
+ if strict || Int.eq i Int.zero then Ifptr p else Vtop
+ | Uns n1, Uns n2 => Uns (Z.max n1 n2)
+ | Uns n1, Sgn n2 => sgn (Z.max (n1 + 1) n2)
+ | Sgn n1, Uns n2 => sgn (Z.max n1 (n2 + 1))
+ | Sgn n1, Sgn n2 => sgn (Z.max n1 n2)
+ | F f1, F f2 =>
+ if Float.eq_dec f1 f2 then v else
+ if Float.is_single_dec f1 && Float.is_single_dec f2 then Fsingle else ftop
+ | F f, Fsingle | Fsingle, F f =>
+ if Float.is_single_dec f then Fsingle else ftop
+ | Fsingle, Fsingle =>
+ Fsingle
+ | L i1, L i2 =>
+ if Int64.eq i1 i2 then v else ltop
+ | Ptr p1, Ptr p2 => Ptr(plub p1 p2)
+ | Ptr p1, Ifptr p2 => Ifptr(plub p1 p2)
+ | Ifptr p1, Ptr p2 => Ifptr(plub p1 p2)
+ | Ifptr p1, Ifptr p2 => Ifptr(plub p1 p2)
+ | _, (Ptr p | Ifptr p) | (Ptr p | Ifptr p), _ => if strict then Ifptr p else Vtop
+ | _, _ => Vtop
+ end.
+
+Lemma vlub_comm:
+ forall v w, vlub v w = vlub w v.
+Proof.
+ intros. unfold vlub; destruct v; destruct w; auto.
+- rewrite Int.eq_sym. predSpec Int.eq Int.eq_spec n0 n.
+ congruence.
+ rewrite orb_comm.
+ destruct (Int.lt n0 Int.zero || Int.lt n Int.zero); f_equal; apply Z.max_comm.
+- f_equal; apply Z.max_comm.
+- f_equal; apply Z.max_comm.
+- f_equal; apply Z.max_comm.
+- f_equal; apply Z.max_comm.
+- rewrite Int64.eq_sym. predSpec Int64.eq Int64.eq_spec n0 n; congruence.
+- rewrite dec_eq_sym. destruct (Float.eq_dec f0 f). congruence.
+ rewrite andb_comm. auto.
+- f_equal; apply plub_comm.
+- f_equal; apply plub_comm.
+- f_equal; apply plub_comm.
+- f_equal; apply plub_comm.
+Qed.
+
+Lemma vge_uns_uns': forall n, vge (uns n) (Uns n).
+Proof.
+ unfold uns, itop; intros.
+ destruct (zle n 1). auto with va.
+ destruct (zle n 7). auto with va.
+ destruct (zle n 8). auto with va.
+ destruct (zle n 15). auto with va.
+ destruct (zle n 16); auto with va.
+Qed.
+
+Lemma vge_uns_i': forall n i, 0 <= n -> is_uns n i -> vge (uns n) (I i).
+Proof.
+ intros. apply vge_trans with (Uns n). apply vge_uns_uns'. auto with va.
+Qed.
+
+Lemma vge_sgn_sgn': forall n, vge (sgn n) (Sgn n).
+Proof.
+ unfold sgn, itop; intros.
+ destruct (zle n 8). auto with va.
+ destruct (zle n 16); auto with va.
+Qed.
+
+Lemma vge_sgn_i': forall n i, 0 < n -> is_sgn n i -> vge (sgn n) (I i).
+Proof.
+ intros. apply vge_trans with (Sgn n). apply vge_sgn_sgn'. auto with va.
+Qed.
+
+Hint Resolve vge_uns_uns' vge_uns_i' vge_sgn_sgn' vge_sgn_i' : va.
+
+Lemma usize_pos: forall n, 0 <= usize n.
+Proof.
+ unfold usize; intros. generalize (Int.size_range n); omega.
+Qed.
+
+Lemma ssize_pos: forall n, 0 < ssize n.
+Proof.
+ unfold ssize; intros.
+ generalize (Int.size_range (if Int.lt n Int.zero then Int.not n else n)); omega.
+Qed.
+
+Lemma vge_lub_l:
+ forall x y, vge (vlub x y) x.
+Proof.
+ assert (IFSTRICT: forall (cond: bool) x y, vge x y -> vge (if cond then x else Vtop ) y).
+ { destruct cond; auto with va. }
+ unfold vlub; destruct x, y; eauto with va.
+- predSpec Int.eq Int.eq_spec n n0. auto with va.
+ destruct (Int.lt n Int.zero || Int.lt n0 Int.zero).
+ apply vge_sgn_i'. generalize (ssize_pos n); xomega. eauto with va.
+ apply vge_uns_i'. generalize (usize_pos n); xomega. eauto with va.
+- destruct (Int.lt n Int.zero).
+ apply vge_sgn_i'. generalize (ssize_pos n); xomega. eauto with va.
+ apply vge_uns_i'. generalize (usize_pos n); xomega. eauto with va.
+- apply vge_sgn_i'. generalize (ssize_pos n); xomega. eauto with va.
+- destruct (Int.lt n0 Int.zero).
+ eapply vge_trans. apply vge_sgn_sgn'.
+ apply vge_trans with (Sgn (n + 1)); eauto with va.
+ eapply vge_trans. apply vge_uns_uns'. eauto with va.
+- eapply vge_trans. apply vge_sgn_sgn'.
+ apply vge_trans with (Sgn (n + 1)); eauto with va.
+- eapply vge_trans. apply vge_sgn_sgn'. eauto with va.
+- eapply vge_trans. apply vge_sgn_sgn'. eauto with va.
+- eapply vge_trans. apply vge_sgn_sgn'. eauto with va.
+- destruct (Int64.eq n n0); constructor.
+- destruct (Float.eq_dec f f0). constructor.
+ destruct (Float.is_single_dec f && Float.is_single_dec f0) eqn:FS.
+ InvBooleans. auto with va.
+ constructor.
+- destruct (Float.is_single_dec f); constructor; auto.
+- destruct (Float.is_single_dec f); constructor; auto.
+- constructor; apply pge_lub_l; auto.
+- constructor; apply pge_lub_l; auto.
+- constructor; apply pge_lub_l; auto.
+- constructor; apply pge_lub_l; auto.
+Qed.
+
+Lemma vge_lub_r:
+ forall x y, vge (vlub x y) y.
+Proof.
+ intros. rewrite vlub_comm. apply vge_lub_l.
+Qed.
+
+Lemma vmatch_lub_l:
+ forall v x y, vmatch v x -> vmatch v (vlub x y).
+Proof.
+ intros. eapply vmatch_ge; eauto. apply vge_lub_l.
+Qed.
+
+Lemma vmatch_lub_r:
+ forall v x y, vmatch v y -> vmatch v (vlub x y).
+Proof.
+ intros. rewrite vlub_comm. apply vmatch_lub_l; auto.
+Qed.
+
+Definition aptr_of_aval (v: aval) : aptr :=
+ match v with
+ | Ptr p => p
+ | Ifptr p => p
+ | _ => Pbot
+ end.
+
+Lemma match_aptr_of_aval:
+ forall b ofs av,
+ vmatch (Vptr b ofs) av <-> pmatch b ofs (aptr_of_aval av).
+Proof.
+ unfold aptr_of_aval; intros; split; intros.
+- inv H; auto.
+- destruct av; ((constructor; assumption) || inv H).
+Qed.
+
+Definition vplub (v: aval) (p: aptr) : aptr :=
+ match v with
+ | Ptr q => plub q p
+ | Ifptr q => plub q p
+ | _ => p
+ end.
+
+Lemma vmatch_vplub_l:
+ forall v x p, vmatch v x -> vmatch v (Ifptr (vplub x p)).
+Proof.
+ intros. unfold vplub; inv H; auto with va; constructor; eapply pmatch_lub_l; eauto.
+Qed.
+
+Lemma pmatch_vplub:
+ forall b ofs x p, pmatch b ofs p -> pmatch b ofs (vplub x p).
+Proof.
+ intros.
+ assert (DFL: pmatch b ofs (if strict then p else Ptop)).
+ { destruct strict; auto. eapply pmatch_top'; eauto. }
+ unfold vplub; destruct x; auto; apply pmatch_lub_r; auto.
+Qed.
+
+Lemma vmatch_vplub_r:
+ forall v x p, vmatch v (Ifptr p) -> vmatch v (Ifptr (vplub x p)).
+Proof.
+ intros. apply vmatch_ifptr; intros; subst v. inv H. apply pmatch_vplub; auto.
+Qed.
+
+(** Inclusion *)
+
+Definition vpincl (v: aval) (p: aptr) : bool :=
+ match v with
+ | Ptr q => pincl q p
+ | Ifptr q => pincl q p
+ | _ => true
+ end.
+
+Lemma vpincl_ge:
+ forall x p, vpincl x p = true -> vge (Ifptr p) x.
+Proof.
+ unfold vpincl; intros. destruct x; constructor; apply pincl_ge; auto.
+Qed.
+
+Lemma vpincl_sound:
+ forall v x p, vpincl x p = true -> vmatch v x -> vmatch v (Ifptr p).
+Proof.
+ intros. apply vmatch_ge with x; auto. apply vpincl_ge; auto.
+Qed.
+
+Definition vincl (v w: aval) : bool :=
+ match v, w with
+ | Vbot, _ => true
+ | I i, I j => Int.eq_dec i j
+ | I i, Uns n => Int.eq_dec (Int.zero_ext n i) i && zle 0 n
+ | I i, Sgn n => Int.eq_dec (Int.sign_ext n i) i && zlt 0 n
+ | Uns n, Uns m => zle n m
+ | Uns n, Sgn m => zlt n m
+ | Sgn n, Sgn m => zle n m
+ | L i, L j => Int64.eq_dec i j
+ | F i, F j => Float.eq_dec i j
+ | F i, Fsingle => Float.is_single_dec i
+ | Fsingle, Fsingle => true
+ | Ptr p, Ptr q => pincl p q
+ | Ptr p, Ifptr q => pincl p q
+ | Ifptr p, Ifptr q => pincl p q
+ | _, Ifptr _ => true
+ | _, _ => false
+ end.
+
+Lemma vincl_ge: forall v w, vincl v w = true -> vge w v.
+Proof.
+ unfold vincl; destruct v; destruct w; intros; try discriminate; auto with va.
+ InvBooleans. subst; auto with va.
+ InvBooleans. constructor; auto. rewrite is_uns_zero_ext; auto.
+ InvBooleans. constructor; auto. rewrite is_sgn_sign_ext; auto.
+ InvBooleans. constructor; auto with va.
+ InvBooleans. constructor; auto with va.
+ InvBooleans. constructor; auto with va.
+ InvBooleans. subst; auto with va.
+ InvBooleans. subst; auto with va.
+ InvBooleans. auto with va.
+ constructor; apply pincl_ge; auto.
+ constructor; apply pincl_ge; auto.
+ constructor; apply pincl_ge; auto.
+Qed.
+
+(** Loading constants *)
+
+Definition genv_match (ge: genv) : Prop :=
+ (forall id b, Genv.find_symbol ge id = Some b <-> bc b = BCglob id)
+/\(forall b, Plt b (Genv.genv_next ge) -> bc b <> BCinvalid /\ bc b <> BCstack).
+
+Definition symbol_address (ge: genv) (id: ident) (ofs: int) : val :=
+ match Genv.find_symbol ge id with Some b => Vptr b ofs | None => Vundef end.
+
+Lemma symbol_address_sound:
+ forall ge id ofs,
+ genv_match ge ->
+ vmatch (symbol_address ge id ofs) (Ptr (Gl id ofs)).
+Proof.
+ intros. unfold symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:F.
+ constructor. constructor. apply H; auto.
+ constructor.
+Qed.
+
+Lemma vmatch_ptr_gl:
+ forall ge v id ofs,
+ genv_match ge ->
+ vmatch v (Ptr (Gl id ofs)) ->
+ Val.lessdef v (symbol_address ge id ofs).
+Proof.
+ intros. unfold symbol_address. inv H0.
+- inv H3. replace (Genv.find_symbol ge id) with (Some b). constructor.
+ symmetry. apply H; auto.
+- constructor.
+Qed.
+
+Lemma vmatch_ptr_stk:
+ forall v ofs sp,
+ vmatch v (Ptr(Stk ofs)) ->
+ bc sp = BCstack ->
+ Val.lessdef v (Vptr sp ofs).
+Proof.
+ intros. inv H.
+- inv H3. replace b with sp by (eapply bc_stack; eauto). constructor.
+- constructor.
+Qed.
+
+(** Generic operations that just do constant propagation. *)
+
+Definition unop_int (sem: int -> int) (x: aval) :=
+ match x with I n => I (sem n) | _ => itop end.
+
+Lemma unop_int_sound:
+ forall sem v x,
+ vmatch v x ->
+ vmatch (match v with Vint i => Vint(sem i) | _ => Vundef end) (unop_int sem x).
+Proof.
+ intros. unfold unop_int; inv H; auto with va.
+Qed.
+
+Definition binop_int (sem: int -> int -> int) (x y: aval) :=
+ match x, y with I n, I m => I (sem n m) | _, _ => itop end.
+
+Lemma binop_int_sound:
+ forall sem v x w y,
+ vmatch v x -> vmatch w y ->
+ vmatch (match v, w with Vint i, Vint j => Vint(sem i j) | _, _ => Vundef end) (binop_int sem x y).
+Proof.
+ intros. unfold binop_int; inv H; auto with va; inv H0; auto with va.
+Qed.
+
+Definition unop_float (sem: float -> float) (x: aval) :=
+ match x with F n => F (sem n) | _ => ftop end.
+
+Lemma unop_float_sound:
+ forall sem v x,
+ vmatch v x ->
+ vmatch (match v with Vfloat i => Vfloat(sem i) | _ => Vundef end) (unop_float sem x).
+Proof.
+ intros. unfold unop_float; inv H; auto with va.
+Qed.
+
+Definition binop_float (sem: float -> float -> float) (x y: aval) :=
+ match x, y with F n, F m => F (sem n m) | _, _ => ftop end.
+
+Lemma binop_float_sound:
+ forall sem v x w y,
+ vmatch v x -> vmatch w y ->
+ vmatch (match v, w with Vfloat i, Vfloat j => Vfloat(sem i j) | _, _ => Vundef end) (binop_float sem x y).
+Proof.
+ intros. unfold binop_float; inv H; auto with va; inv H0; auto with va.
+Qed.
+
+(** Logical operations *)
+
+Definition shl (v w: aval) :=
+ match w with
+ | I amount =>
+ if Int.ltu amount Int.iwordsize then
+ match v with
+ | I i => I (Int.shl i amount)
+ | Uns n => uns (n + Int.unsigned amount)
+ | Sgn n => sgn (n + Int.unsigned amount)
+ | _ => itop
+ end
+ else itop
+ | _ => itop
+ end.
+
+Lemma shl_sound:
+ forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.shl v w) (shl x y).
+Proof.
+ intros.
+ assert (DEFAULT: vmatch (Val.shl v w) itop).
+ {
+ destruct v; destruct w; simpl; try constructor.
+ destruct (Int.ltu i0 Int.iwordsize); constructor.
+ }
+ destruct y; auto. simpl. inv H0. unfold Val.shl.
+ destruct (Int.ltu n Int.iwordsize) eqn:LTU; auto.
+ exploit Int.ltu_inv; eauto. intros RANGE.
+ inv H; auto with va.
+- apply vmatch_uns'. red; intros. rewrite Int.bits_shl by omega.
+ destruct (zlt m (Int.unsigned n)). auto. apply H1; xomega.
+- apply vmatch_sgn'. red; intros. zify.
+ rewrite ! Int.bits_shl by omega.
+ rewrite ! zlt_false by omega.
+ rewrite H1 by omega. symmetry. rewrite H1 by omega. auto.
+- destruct v; constructor.
+Qed.
+
+Definition shru (v w: aval) :=
+ match w with
+ | I amount =>
+ if Int.ltu amount Int.iwordsize then
+ match v with
+ | I i => I (Int.shru i amount)
+ | Uns n => uns (n - Int.unsigned amount)
+ | _ => uns (Int.zwordsize - Int.unsigned amount)
+ end
+ else itop
+ | _ => itop
+ end.
+
+Lemma shru_sound:
+ forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.shru v w) (shru x y).
+Proof.
+ intros.
+ assert (DEFAULT: vmatch (Val.shru v w) itop).
+ {
+ destruct v; destruct w; simpl; try constructor.
+ destruct (Int.ltu i0 Int.iwordsize); constructor.
+ }
+ destruct y; auto. inv H0. unfold shru, Val.shru.
+ destruct (Int.ltu n Int.iwordsize) eqn:LTU; auto.
+ exploit Int.ltu_inv; eauto. intros RANGE. change (Int.unsigned Int.iwordsize) with Int.zwordsize in RANGE.
+ assert (DEFAULT2: forall i, vmatch (Vint (Int.shru i n)) (uns (Int.zwordsize - Int.unsigned n))).
+ {
+ intros. apply vmatch_uns. red; intros.
+ rewrite Int.bits_shru by omega. apply zlt_false. omega.
+ }
+ inv H; auto with va.
+- apply vmatch_uns'. red; intros. zify.
+ rewrite Int.bits_shru by omega.
+ destruct (zlt (m + Int.unsigned n) Int.zwordsize); auto.
+ apply H1; omega.
+- destruct v; constructor.
+Qed.
+
+Definition shr (v w: aval) :=
+ match w with
+ | I amount =>
+ if Int.ltu amount Int.iwordsize then
+ match v with
+ | I i => I (Int.shr i amount)
+ | Uns n => sgn (n + 1 - Int.unsigned amount)
+ | Sgn n => sgn (n - Int.unsigned amount)
+ | _ => sgn (Int.zwordsize - Int.unsigned amount)
+ end
+ else itop
+ | _ => itop
+ end.
+
+Lemma shr_sound:
+ forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.shr v w) (shr x y).
+Proof.
+ intros.
+ assert (DEFAULT: vmatch (Val.shr v w) itop).
+ {
+ destruct v; destruct w; simpl; try constructor.
+ destruct (Int.ltu i0 Int.iwordsize); constructor.
+ }
+ destruct y; auto. inv H0. unfold shr, Val.shr.
+ destruct (Int.ltu n Int.iwordsize) eqn:LTU; auto.
+ exploit Int.ltu_inv; eauto. intros RANGE. change (Int.unsigned Int.iwordsize) with Int.zwordsize in RANGE.
+ assert (DEFAULT2: forall i, vmatch (Vint (Int.shr i n)) (sgn (Int.zwordsize - Int.unsigned n))).
+ {
+ intros. apply vmatch_sgn. red; intros.
+ rewrite ! Int.bits_shr by omega. f_equal.
+ destruct (zlt (m + Int.unsigned n) Int.zwordsize);
+ destruct (zlt (Int.zwordsize - 1 + Int.unsigned n) Int.zwordsize);
+ omega.
+ }
+ assert (SGN: forall i p, is_sgn p i -> 0 < p -> vmatch (Vint (Int.shr i n)) (sgn (p - Int.unsigned n))).
+ {
+ intros. apply vmatch_sgn'. red; intros. zify.
+ rewrite ! Int.bits_shr by omega.
+ transitivity (Int.testbit i (Int.zwordsize - 1)).
+ destruct (zlt (m + Int.unsigned n) Int.zwordsize).
+ apply H0; omega.
+ auto.
+ symmetry.
+ destruct (zlt (Int.zwordsize - 1 + Int.unsigned n) Int.zwordsize).
+ apply H0; omega.
+ auto.
+ }
+ inv H; eauto with va.
+- destruct v; constructor.
+Qed.
+
+Definition and (v w: aval) :=
+ match v, w with
+ | I i1, I i2 => I (Int.and i1 i2)
+ | I i, Uns n | Uns n, I i => uns (Z.min n (usize i))
+ | I i, _ | _, I i => uns (usize i)
+ | Uns n1, Uns n2 => uns (Z.min n1 n2)
+ | Uns n, _ | _, Uns n => uns n
+ | Sgn n1, Sgn n2 => sgn (Z.max n1 n2)
+ | _, _ => itop
+ end.
+
+Lemma and_sound:
+ forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.and v w) (and x y).
+Proof.
+ assert (UNS_l: forall i j n, is_uns n i -> is_uns n (Int.and i j)).
+ {
+ intros; red; intros. rewrite Int.bits_and by auto. rewrite (H m) by auto.
+ apply andb_false_l.
+ }
+ assert (UNS_r: forall i j n, is_uns n i -> is_uns n (Int.and j i)).
+ {
+ intros. rewrite Int.and_commut. eauto.
+ }
+ assert (UNS: forall i j n m, is_uns n i -> is_uns m j -> is_uns (Z.min n m) (Int.and i j)).
+ {
+ intros. apply Z.min_case; auto.
+ }
+ assert (SGN: forall i j n m, is_sgn n i -> is_sgn m j -> is_sgn (Z.max n m) (Int.and i j)).
+ {
+ intros; red; intros. rewrite ! Int.bits_and by auto with va.
+ rewrite H by auto with va. rewrite H0 by auto with va. auto.
+ }
+ intros. unfold and, Val.and; inv H; eauto with va; inv H0; eauto with va.
+Qed.
+
+Definition or (v w: aval) :=
+ match v, w with
+ | I i1, I i2 => I (Int.or i1 i2)
+ | I i, Uns n | Uns n, I i => uns (Z.max n (usize i))
+ | Uns n1, Uns n2 => uns (Z.max n1 n2)
+ | Sgn n1, Sgn n2 => sgn (Z.max n1 n2)
+ | _, _ => itop
+ end.
+
+Lemma or_sound:
+ forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.or v w) (or x y).
+Proof.
+ assert (UNS: forall i j n m, is_uns n i -> is_uns m j -> is_uns (Z.max n m) (Int.or i j)).
+ {
+ intros; red; intros. rewrite Int.bits_or by auto.
+ rewrite H by xomega. rewrite H0 by xomega. auto.
+ }
+ assert (SGN: forall i j n m, is_sgn n i -> is_sgn m j -> is_sgn (Z.max n m) (Int.or i j)).
+ {
+ intros; red; intros. rewrite ! Int.bits_or by xomega.
+ rewrite H by xomega. rewrite H0 by xomega. auto.
+ }
+ intros. unfold or, Val.or; inv H; eauto with va; inv H0; eauto with va.
+Qed.
+
+Definition xor (v w: aval) :=
+ match v, w with
+ | I i1, I i2 => I (Int.xor i1 i2)
+ | I i, Uns n | Uns n, I i => uns (Z.max n (usize i))
+ | Uns n1, Uns n2 => uns (Z.max n1 n2)
+ | Sgn n1, Sgn n2 => sgn (Z.max n1 n2)
+ | _, _ => itop
+ end.
+
+Lemma xor_sound:
+ forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.xor v w) (xor x y).
+Proof.
+ assert (UNS: forall i j n m, is_uns n i -> is_uns m j -> is_uns (Z.max n m) (Int.xor i j)).
+ {
+ intros; red; intros. rewrite Int.bits_xor by auto.
+ rewrite H by xomega. rewrite H0 by xomega. auto.
+ }
+ assert (SGN: forall i j n m, is_sgn n i -> is_sgn m j -> is_sgn (Z.max n m) (Int.xor i j)).
+ {
+ intros; red; intros. rewrite ! Int.bits_xor by xomega.
+ rewrite H by xomega. rewrite H0 by xomega. auto.
+ }
+ intros. unfold xor, Val.xor; inv H; eauto with va; inv H0; eauto with va.
+Qed.
+
+Definition notint (v: aval) :=
+ match v with
+ | I i => I (Int.not i)
+ | Uns n => sgn (n + 1)
+ | Sgn n => Sgn n
+ | _ => itop
+ end.
+
+Lemma notint_sound:
+ forall v x, vmatch v x -> vmatch (Val.notint v) (notint x).
+Proof.
+ assert (SGN: forall n i, is_sgn n i -> is_sgn n (Int.not i)).
+ {
+ intros; red; intros. rewrite ! Int.bits_not by omega.
+ f_equal. apply H; auto.
+ }
+ intros. unfold Val.notint, notint; inv H; eauto with va.
+Qed.
+
+Definition ror (x y: aval) :=
+ match y, x with
+ | I j, I i => if Int.ltu j Int.iwordsize then I(Int.ror i j) else itop
+ | _, _ => itop
+ end.
+
+Lemma ror_sound:
+ forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.ror v w) (ror x y).
+Proof.
+ intros.
+ assert (DEFAULT: vmatch (Val.ror v w) itop).
+ {
+ destruct v; destruct w; simpl; try constructor.
+ destruct (Int.ltu i0 Int.iwordsize); constructor.
+ }
+ unfold ror; destruct y; auto. inv H0. unfold Val.ror.
+ destruct (Int.ltu n Int.iwordsize) eqn:LTU.
+ inv H; auto with va.
+ inv H; auto with va.
+Qed.
+
+Definition rolm (x: aval) (amount mask: int) :=
+ match x with
+ | I i => I (Int.rolm i amount mask)
+ | _ => uns (usize mask)
+ end.
+
+Lemma rolm_sound:
+ forall v x amount mask,
+ vmatch v x -> vmatch (Val.rolm v amount mask) (rolm x amount mask).
+Proof.
+ intros.
+ assert (UNS: forall i, vmatch (Vint (Int.rolm i amount mask)) (uns (usize mask))).
+ {
+ intros.
+ change (vmatch (Val.and (Vint (Int.rol i amount)) (Vint mask))
+ (and itop (I mask))).
+ apply and_sound; auto with va.
+ }
+ unfold Val.rolm, rolm. inv H; auto with va.
+Qed.
+
+(** Integer arithmetic operations *)
+
+Definition neg := unop_int Int.neg.
+
+Lemma neg_sound:
+ forall v x, vmatch v x -> vmatch (Val.neg v) (neg x).
+Proof (unop_int_sound Int.neg).
+
+Definition add (x y: aval) :=
+ match x, y with
+ | I i, I j => I (Int.add i j)
+ | Ptr p, I i | I i, Ptr p => Ptr (padd p i)
+ | Ptr p, _ | _, Ptr p => Ptr (poffset p)
+ | Ifptr p, I i | I i, Ifptr p => Ifptr (padd p i)
+ | Ifptr p, Ifptr q => Ifptr (plub (poffset p) (poffset q))
+ | Ifptr p, _ | _, Ifptr p => Ifptr (poffset p)
+ | _, _ => Vtop
+ end.
+
+Lemma add_sound:
+ forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.add v w) (add x y).
+Proof.
+ intros. unfold Val.add, add; inv H; inv H0; constructor;
+ ((apply padd_sound; assumption) || (eapply poffset_sound; eassumption) || idtac).
+ apply pmatch_lub_r. eapply poffset_sound; eauto.
+ apply pmatch_lub_l. eapply poffset_sound; eauto.
+Qed.
+
+Definition sub (v w: aval) :=
+ match v, w with
+ | I i1, I i2 => I (Int.sub i1 i2)
+ | Ptr p, I i => Ptr (psub p i)
+(* problem with undefs *)
+(*
+ | Ptr p1, Ptr p2 => match psub2 p1 p2 with Some n => I n | _ => itop end
+*)
+ | Ptr p, _ => Ifptr (poffset p)
+ | Ifptr p, I i => Ifptr (psub p i)
+ | Ifptr p, (Uns _ | Sgn _) => Ifptr (poffset p)
+ | Ifptr p1, Ptr p2 => itop
+ | _, _ => Vtop
+ end.
+
+Lemma sub_sound:
+ forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.sub v w) (sub x y).
+Proof.
+ intros. inv H; inv H0; simpl;
+ try (destruct (eq_block b b0));
+ try (constructor; (apply psub_sound || eapply poffset_sound); eauto).
+ change Vtop with (Ifptr (poffset Ptop)).
+ constructor; eapply poffset_sound. eapply pmatch_top'; eauto.
+Qed.
+
+Definition mul := binop_int Int.mul.
+
+Lemma mul_sound:
+ forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.mul v w) (mul x y).
+Proof (binop_int_sound Int.mul).
+
+Definition mulhs := binop_int Int.mulhs.
+
+Lemma mulhs_sound:
+ forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.mulhs v w) (mulhs x y).
+Proof (binop_int_sound Int.mulhs).
+
+Definition mulhu := binop_int Int.mulhu.
+
+Lemma mulhu_sound:
+ forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.mulhu v w) (mulhu x y).
+Proof (binop_int_sound Int.mulhu).
+
+Definition divs (v w: aval) :=
+ match w, v with
+ | I i2, I i1 =>
+ if Int.eq i2 Int.zero
+ || Int.eq i1 (Int.repr Int.min_signed) && Int.eq i2 Int.mone
+ then if strict then Vbot else itop
+ else I (Int.divs i1 i2)
+ | _, _ => itop
+ end.
+
+Lemma divs_sound:
+ forall v w u x y, vmatch v x -> vmatch w y -> Val.divs v w = Some u -> vmatch u (divs x y).
+Proof.
+ intros. destruct v; destruct w; try discriminate; simpl in H1.
+ destruct (Int.eq i0 Int.zero
+ || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone) eqn:E; inv H1.
+ inv H; inv H0; auto with va. simpl. rewrite E. constructor.
+Qed.
+
+Definition divu (v w: aval) :=
+ match w, v with
+ | I i2, I i1 =>
+ if Int.eq i2 Int.zero
+ then if strict then Vbot else itop
+ else I (Int.divu i1 i2)
+ | _, _ => itop
+ end.
+
+Lemma divu_sound:
+ forall v w u x y, vmatch v x -> vmatch w y -> Val.divu v w = Some u -> vmatch u (divu x y).
+Proof.
+ intros. destruct v; destruct w; try discriminate; simpl in H1.
+ destruct (Int.eq i0 Int.zero) eqn:E; inv H1.
+ inv H; inv H0; auto with va. simpl. rewrite E. constructor.
+Qed.
+
+Definition mods (v w: aval) :=
+ match w, v with
+ | I i2, I i1 =>
+ if Int.eq i2 Int.zero
+ || Int.eq i1 (Int.repr Int.min_signed) && Int.eq i2 Int.mone
+ then if strict then Vbot else itop
+ else I (Int.mods i1 i2)
+ | _, _ => itop
+ end.
+
+Lemma mods_sound:
+ forall v w u x y, vmatch v x -> vmatch w y -> Val.mods v w = Some u -> vmatch u (mods x y).
+Proof.
+ intros. destruct v; destruct w; try discriminate; simpl in H1.
+ destruct (Int.eq i0 Int.zero
+ || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone) eqn:E; inv H1.
+ inv H; inv H0; auto with va. simpl. rewrite E. constructor.
+Qed.
+
+Definition modu (v w: aval) :=
+ match w, v with
+ | I i2, I i1 =>
+ if Int.eq i2 Int.zero
+ then if strict then Vbot else itop
+ else I (Int.modu i1 i2)
+ | I i2, _ => uns (usize i2)
+ | _, _ => itop
+ end.
+
+Lemma modu_sound:
+ forall v w u x y, vmatch v x -> vmatch w y -> Val.modu v w = Some u -> vmatch u (modu x y).
+Proof.
+ assert (UNS: forall i j, j <> Int.zero -> is_uns (usize j) (Int.modu i j)).
+ {
+ intros. apply is_uns_mon with (usize (Int.modu i j)); auto with va.
+ unfold usize, Int.size. apply Int.Zsize_monotone.
+ generalize (Int.unsigned_range_2 j); intros RANGE.
+ assert (Int.unsigned j <> 0).
+ { red; intros; elim H. rewrite <- (Int.repr_unsigned j). rewrite H0. auto. }
+ exploit (Z_mod_lt (Int.unsigned i) (Int.unsigned j)). omega. intros MOD.
+ unfold Int.modu. rewrite Int.unsigned_repr. omega. omega.
+ }
+ intros. destruct v; destruct w; try discriminate; simpl in H1.
+ destruct (Int.eq i0 Int.zero) eqn:Z; inv H1.
+ assert (i0 <> Int.zero) by (generalize (Int.eq_spec i0 Int.zero); rewrite Z; auto).
+ unfold modu. inv H; inv H0; auto with va. rewrite Z. constructor.
+Qed.
+
+Definition shrx (v w: aval) :=
+ match v, w with
+ | I i, I j => if Int.ltu j (Int.repr 31) then I(Int.shrx i j) else itop
+ | _, _ => itop
+ end.
+
+Lemma shrx_sound:
+ forall v w u x y, vmatch v x -> vmatch w y -> Val.shrx v w = Some u -> vmatch u (shrx x y).
+Proof.
+ intros.
+ destruct v; destruct w; try discriminate; simpl in H1.
+ destruct (Int.ltu i0 (Int.repr 31)) eqn:LTU; inv H1.
+ unfold shrx; inv H; auto with va; inv H0; auto with va.
+ rewrite LTU; auto with va.
+Qed.
+
+(** Floating-point arithmetic operations *)
+
+Definition negf := unop_float Float.neg.
+
+Lemma negf_sound:
+ forall v x, vmatch v x -> vmatch (Val.negf v) (negf x).
+Proof (unop_float_sound Float.neg).
+
+Definition absf := unop_float Float.abs.
+
+Lemma absf_sound:
+ forall v x, vmatch v x -> vmatch (Val.absf v) (absf x).
+Proof (unop_float_sound Float.abs).
+
+Definition addf := binop_float Float.add.
+
+Lemma addf_sound:
+ forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.addf v w) (addf x y).
+Proof (binop_float_sound Float.add).
+
+Definition subf := binop_float Float.sub.
+
+Lemma subf_sound:
+ forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.subf v w) (subf x y).
+Proof (binop_float_sound Float.sub).
+
+Definition mulf := binop_float Float.mul.
+
+Lemma mulf_sound:
+ forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.mulf v w) (mulf x y).
+Proof (binop_float_sound Float.mul).
+
+Definition divf := binop_float Float.div.
+
+Lemma divf_sound:
+ forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.divf v w) (divf x y).
+Proof (binop_float_sound Float.div).
+
+(** Conversions *)
+
+Definition zero_ext (nbits: Z) (v: aval) :=
+ match v with
+ | I i => I (Int.zero_ext nbits i)
+ | Uns n => uns (Z.min n nbits)
+ | _ => uns nbits
+ end.
+
+Lemma zero_ext_sound:
+ forall nbits v x, vmatch v x -> vmatch (Val.zero_ext nbits v) (zero_ext nbits x).
+Proof.
+ assert (DFL: forall nbits i, is_uns nbits (Int.zero_ext nbits i)).
+ {
+ intros; red; intros. rewrite Int.bits_zero_ext by omega. apply zlt_false; auto.
+ }
+ intros. inv H; simpl; auto with va. apply vmatch_uns.
+ red; intros. zify.
+ rewrite Int.bits_zero_ext by omega.
+ destruct (zlt m nbits); auto. apply H1; omega.
+Qed.
+
+Definition sign_ext (nbits: Z) (v: aval) :=
+ match v with
+ | I i => I (Int.sign_ext nbits i)
+ | Uns n => if zlt n nbits then Uns n else sgn nbits
+ | Sgn n => sgn (Z.min n nbits)
+ | _ => sgn nbits
+ end.
+
+Lemma sign_ext_sound:
+ forall nbits v x, 0 < nbits -> vmatch v x -> vmatch (Val.sign_ext nbits v) (sign_ext nbits x).
+Proof.
+ assert (DFL: forall nbits i, 0 < nbits -> vmatch (Vint (Int.sign_ext nbits i)) (sgn nbits)).
+ {
+ intros. apply vmatch_sgn. apply is_sign_ext_sgn; auto with va.
+ }
+ intros. inv H0; simpl; auto with va.
+- destruct (zlt n nbits); eauto with va.
+ constructor; auto. eapply is_sign_ext_uns; eauto with va.
+- destruct (zlt n nbits); auto with va.
+- apply vmatch_sgn. apply is_sign_ext_sgn; auto with va.
+ apply Z.min_case; auto with va.
+Qed.
+
+Definition singleoffloat (v: aval) :=
+ match v with
+ | F f => F (Float.singleoffloat f)
+ | _ => Fsingle
+ end.
+
+Lemma singleoffloat_sound:
+ forall v x, vmatch v x -> vmatch (Val.singleoffloat v) (singleoffloat x).
+Proof.
+ intros.
+ assert (DEFAULT: vmatch (Val.singleoffloat v) Fsingle).
+ { destruct v; constructor. apply Float.singleoffloat_is_single. }
+ destruct x; auto. inv H. constructor.
+Qed.
+
+Definition intoffloat (x: aval) :=
+ match x with
+ | F f =>
+ match Float.intoffloat f with
+ | Some i => I i
+ | None => if strict then Vbot else itop
+ end
+ | _ => itop
+ end.
+
+Lemma intoffloat_sound:
+ forall v x w, vmatch v x -> Val.intoffloat v = Some w -> vmatch w (intoffloat x).
+Proof.
+ unfold Val.intoffloat; intros. destruct v; try discriminate.
+ destruct (Float.intoffloat f) as [i|] eqn:E; simpl in H0; inv H0.
+ inv H; simpl; auto with va. rewrite E; constructor.
+Qed.
+
+Definition intuoffloat (x: aval) :=
+ match x with
+ | F f =>
+ match Float.intuoffloat f with
+ | Some i => I i
+ | None => if strict then Vbot else itop
+ end
+ | _ => itop
+ end.
+
+Lemma intuoffloat_sound:
+ forall v x w, vmatch v x -> Val.intuoffloat v = Some w -> vmatch w (intuoffloat x).
+Proof.
+ unfold Val.intuoffloat; intros. destruct v; try discriminate.
+ destruct (Float.intuoffloat f) as [i|] eqn:E; simpl in H0; inv H0.
+ inv H; simpl; auto with va. rewrite E; constructor.
+Qed.
+
+Definition floatofint (x: aval) :=
+ match x with
+ | I i => F(Float.floatofint i)
+ | _ => ftop
+ end.
+
+Lemma floatofint_sound:
+ forall v x w, vmatch v x -> Val.floatofint v = Some w -> vmatch w (floatofint x).
+Proof.
+ unfold Val.floatofint; intros. destruct v; inv H0.
+ inv H; simpl; auto with va.
+Qed.
+
+Definition floatofintu (x: aval) :=
+ match x with
+ | I i => F(Float.floatofintu i)
+ | _ => ftop
+ end.
+
+Lemma floatofintu_sound:
+ forall v x w, vmatch v x -> Val.floatofintu v = Some w -> vmatch w (floatofintu x).
+Proof.
+ unfold Val.floatofintu; intros. destruct v; inv H0.
+ inv H; simpl; auto with va.
+Qed.
+
+Definition floatofwords (x y: aval) :=
+ match x, y with
+ | I i, I j => F(Float.from_words i j)
+ | _, _ => ftop
+ end.
+
+Lemma floatofwords_sound:
+ forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.floatofwords v w) (floatofwords x y).
+Proof.
+ intros. unfold floatofwords, ftop; inv H; simpl; auto with va; inv H0; auto with va.
+Qed.
+
+Definition longofwords (x y: aval) :=
+ match x, y with
+ | I i, I j => L(Int64.ofwords i j)
+ | _, _ => ltop
+ end.
+
+Lemma longofwords_sound:
+ forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.longofwords v w) (longofwords x y).
+Proof.
+ intros. unfold longofwords, ltop; inv H; simpl; auto with va; inv H0; auto with va.
+Qed.
+
+Definition loword (x: aval) :=
+ match x with
+ | L i => I(Int64.loword i)
+ | _ => itop
+ end.
+
+Lemma loword_sound: forall v x, vmatch v x -> vmatch (Val.loword v) (loword x).
+Proof.
+ destruct 1; simpl; auto with va.
+Qed.
+
+Definition hiword (x: aval) :=
+ match x with
+ | L i => I(Int64.hiword i)
+ | _ => itop
+ end.
+
+Lemma hiword_sound: forall v x, vmatch v x -> vmatch (Val.hiword v) (hiword x).
+Proof.
+ destruct 1; simpl; auto with va.
+Qed.
+
+(** Comparisons *)
+
+Definition cmpu_bool (c: comparison) (v w: aval) : abool :=
+ match v, w with
+ | I i1, I i2 => Just (Int.cmpu c i1 i2)
+(* there are cute things to do with Uns/Sgn compared against an integer *)
+ | Ptr _, (I _ | Uns _ | Sgn _) => cmp_different_blocks c
+ | (I _ | Uns _ | Sgn _), Ptr _ => cmp_different_blocks c
+ | Ptr p1, Ptr p2 => pcmp c p1 p2
+ | Ptr p1, Ifptr p2 => club (pcmp c p1 p2) (cmp_different_blocks c)
+ | Ifptr p1, Ptr p2 => club (pcmp c p1 p2) (cmp_different_blocks c)
+ | _, _ => Btop
+ end.
+
+Lemma cmpu_bool_sound:
+ forall valid c v w x y, vmatch v x -> vmatch w y -> cmatch (Val.cmpu_bool valid c v w) (cmpu_bool c x y).
+Proof.
+ intros.
+ assert (IP: forall i b ofs,
+ cmatch (Val.cmpu_bool valid c (Vint i) (Vptr b ofs)) (cmp_different_blocks c)).
+ {
+ intros. simpl. destruct (Int.eq i Int.zero). apply cmp_different_blocks_sound. apply cmp_different_blocks_none.
+ }
+ assert (PI: forall i b ofs,
+ cmatch (Val.cmpu_bool valid c (Vptr b ofs) (Vint i)) (cmp_different_blocks c)).
+ {
+ intros. simpl. destruct (Int.eq i Int.zero). apply cmp_different_blocks_sound. apply cmp_different_blocks_none.
+ }
+ unfold cmpu_bool; inv H; inv H0;
+ auto using cmatch_top, cmp_different_blocks_none, pcmp_none,
+ cmatch_lub_l, cmatch_lub_r, pcmp_sound.
+- constructor.
+Qed.
+
+Definition cmp_bool (c: comparison) (v w: aval) : abool :=
+ match v, w with
+ | I i1, I i2 => Just (Int.cmp c i1 i2)
+ | _, _ => Btop
+ end.
+
+Lemma cmp_bool_sound:
+ forall c v w x y, vmatch v x -> vmatch w y -> cmatch (Val.cmp_bool c v w) (cmp_bool c x y).
+Proof.
+ intros. inv H; try constructor; inv H0; constructor.
+Qed.
+
+Definition cmpf_bool (c: comparison) (v w: aval) : abool :=
+ match v, w with
+ | F f1, F f2 => Just (Float.cmp c f1 f2)
+ | _, _ => Btop
+ end.
+
+Lemma cmpf_bool_sound:
+ forall c v w x y, vmatch v x -> vmatch w y -> cmatch (Val.cmpf_bool c v w) (cmpf_bool c x y).
+Proof.
+ intros. inv H; try constructor; inv H0; constructor.
+Qed.
+
+Definition maskzero (x: aval) (mask: int) : abool :=
+ match x with
+ | I i => Just (Int.eq (Int.and i mask) Int.zero)
+ | Uns n => if Int.eq (Int.zero_ext n mask) Int.zero then Maybe true else Btop
+ | _ => Btop
+ end.
+
+Lemma maskzero_sound:
+ forall mask v x,
+ vmatch v x ->
+ cmatch (Val.maskzero_bool v mask) (maskzero x mask).
+Proof.
+ intros. inv H; simpl; auto with va.
+ predSpec Int.eq Int.eq_spec (Int.zero_ext n mask) Int.zero; auto with va.
+ replace (Int.and i mask) with Int.zero.
+ rewrite Int.eq_true. constructor.
+ rewrite is_uns_zero_ext in H1. rewrite Int.zero_ext_and in * by auto.
+ rewrite <- H1. rewrite Int.and_assoc. rewrite Int.and_commut in H. rewrite H.
+ rewrite Int.and_zero; auto.
+ destruct (Int.eq (Int.zero_ext n mask) Int.zero); constructor.
+Qed.
+
+Definition of_optbool (ab: abool) : aval :=
+ match ab with
+ | Just b => I (if b then Int.one else Int.zero)
+ | _ => Uns 1
+ end.
+
+Lemma of_optbool_sound:
+ forall ob ab, cmatch ob ab -> vmatch (Val.of_optbool ob) (of_optbool ab).
+Proof.
+ intros.
+ assert (DEFAULT: vmatch (Val.of_optbool ob) (Uns 1)).
+ {
+ destruct ob; simpl; auto with va.
+ destruct b; constructor; try omega.
+ change 1 with (usize Int.one). apply is_uns_usize.
+ red; intros. apply Int.bits_zero.
+ }
+ inv H; auto. simpl. destruct b; constructor.
+Qed.
+
+Definition resolve_branch (ab: abool) : option bool :=
+ match ab with
+ | Just b => Some b
+ | Maybe b => Some b
+ | _ => None
+ end.
+
+Lemma resolve_branch_sound:
+ forall b ab b',
+ cmatch (Some b) ab -> resolve_branch ab = Some b' -> b' = b.
+Proof.
+ intros. inv H; simpl in H0; congruence.
+Qed.
+
+(** Normalization at load time *)
+
+Definition vnormalize (chunk: memory_chunk) (v: aval) :=
+ match chunk, v with
+ | _, Vbot => Vbot
+ | Mint8signed, I i => I (Int.sign_ext 8 i)
+ | Mint8signed, Uns n => if zlt n 8 then Uns n else Sgn 8
+ | Mint8signed, Sgn n => Sgn (Z.min n 8)
+ | Mint8signed, _ => Sgn 8
+ | Mint8unsigned, I i => I (Int.zero_ext 8 i)
+ | Mint8unsigned, Uns n => Uns (Z.min n 8)
+ | Mint8unsigned, _ => Uns 8
+ | Mint16signed, I i => I (Int.sign_ext 16 i)
+ | Mint16signed, Uns n => if zlt n 16 then Uns n else Sgn 16
+ | Mint16signed, Sgn n => Sgn (Z.min n 16)
+ | Mint16signed, _ => Sgn 16
+ | Mint16unsigned, I i => I (Int.zero_ext 16 i)
+ | Mint16unsigned, Uns n => Uns (Z.min n 16)
+ | Mint16unsigned, _ => Uns 16
+ | Mint32, (I _ | Ptr _ | Ifptr _) => v
+ | Mint64, L _ => v
+ | Mfloat32, F f => F (Float.singleoffloat f)
+ | Mfloat32, _ => Fsingle
+ | (Mfloat64 | Mfloat64al32), F f => v
+ | _, _ => Ifptr Pbot
+ end.
+
+Lemma vnormalize_sound:
+ forall chunk v x, vmatch v x -> vmatch (Val.load_result chunk v) (vnormalize chunk x).
+Proof.
+ unfold Val.load_result, vnormalize; induction 1; destruct chunk; auto with va.
+- destruct (zlt n 8); constructor; auto with va.
+ apply is_sign_ext_uns; auto.
+ apply is_sign_ext_sgn; auto with va.
+- constructor. xomega. apply is_zero_ext_uns. apply Z.min_case; auto with va.
+- destruct (zlt n 16); constructor; auto with va.
+ apply is_sign_ext_uns; auto.
+ apply is_sign_ext_sgn; auto with va.
+- constructor. xomega. apply is_zero_ext_uns. apply Z.min_case; auto with va.
+- destruct (zlt n 8); auto with va.
+- destruct (zlt n 16); auto with va.
+- constructor. xomega. apply is_sign_ext_sgn; auto with va. apply Z.min_case; auto with va.
+- constructor. omega. apply is_zero_ext_uns; auto with va.
+- constructor. xomega. apply is_sign_ext_sgn; auto with va. apply Z.min_case; auto with va.
+- constructor. omega. apply is_zero_ext_uns; auto with va.
+- constructor. apply Float.singleoffloat_is_single.
+- constructor. omega. apply is_sign_ext_sgn; auto with va.
+- constructor. omega. apply is_zero_ext_uns; auto with va.
+- constructor. omega. apply is_sign_ext_sgn; auto with va.
+- constructor. omega. apply is_zero_ext_uns; auto with va.
+- constructor. apply Float.singleoffloat_is_single.
+Qed.
+
+Lemma vnormalize_cast:
+ forall chunk m b ofs v p,
+ Mem.load chunk m b ofs = Some v ->
+ vmatch v (Ifptr p) ->
+ vmatch v (vnormalize chunk (Ifptr p)).
+Proof.
+ intros. exploit Mem.load_cast; eauto. exploit Mem.load_type; eauto.
+ destruct chunk; simpl; intros.
+- (* int8signed *)
+ rewrite H2. destruct v; simpl; constructor. omega. apply is_sign_ext_sgn; auto with va.
+- (* int8unsigned *)
+ rewrite H2. destruct v; simpl; constructor. omega. apply is_zero_ext_uns; auto with va.
+- (* int16signed *)
+ rewrite H2. destruct v; simpl; constructor. omega. apply is_sign_ext_sgn; auto with va.
+- (* int16unsigned *)
+ rewrite H2. destruct v; simpl; constructor. omega. apply is_zero_ext_uns; auto with va.
+- (* int32 *)
+ auto.
+- (* int64 *)
+ destruct v; try contradiction; constructor.
+- (* float32 *)
+ rewrite H2. destruct v; simpl; constructor. apply Float.singleoffloat_is_single.
+- (* float64 *)
+ destruct v; try contradiction; constructor.
+- (* float64 *)
+ destruct v; try contradiction; constructor.
+Qed.
+
+Lemma vnormalize_monotone:
+ forall chunk x y,
+ vge x y -> vge (vnormalize chunk x) (vnormalize chunk y).
+Proof.
+ induction 1; destruct chunk; simpl; auto with va.
+- destruct (zlt n 8); constructor; auto with va.
+ apply is_sign_ext_uns; auto with va.
+ apply is_sign_ext_sgn; auto with va.
+- constructor; auto with va. apply is_zero_ext_uns; auto with va.
+ apply Z.min_case; auto with va.
+- destruct (zlt n 16); constructor; auto with va.
+ apply is_sign_ext_uns; auto with va.
+ apply is_sign_ext_sgn; auto with va.
+- constructor; auto with va. apply is_zero_ext_uns; auto with va.
+ apply Z.min_case; auto with va.
+- destruct (zlt n1 8). rewrite zlt_true by omega. auto with va.
+ destruct (zlt n2 8); auto with va.
+- destruct (zlt n1 16). rewrite zlt_true by omega. auto with va.
+ destruct (zlt n2 16); auto with va.
+- constructor; auto with va. apply is_sign_ext_sgn; auto with va.
+ apply Z.min_case; auto with va.
+- constructor; auto with va. apply is_zero_ext_uns; auto with va.
+- constructor; auto with va. apply is_sign_ext_sgn; auto with va.
+ apply Z.min_case; auto with va.
+- constructor; auto with va. apply is_zero_ext_uns; auto with va.
+- destruct (zlt n2 8); constructor; auto with va.
+- destruct (zlt n2 16); constructor; auto with va.
+- constructor. apply Float.singleoffloat_is_single.
+- constructor; auto with va. apply is_sign_ext_sgn; auto with va.
+- constructor; auto with va. apply is_zero_ext_uns; auto with va.
+- constructor; auto with va. apply is_sign_ext_sgn; auto with va.
+- constructor; auto with va. apply is_zero_ext_uns; auto with va.
+- constructor. apply Float.singleoffloat_is_single.
+- destruct (zlt n 8); constructor; auto with va.
+- destruct (zlt n 16); constructor; auto with va.
+Qed.
+
+(** Abstracting memory blocks *)
+
+Inductive acontent : Type :=
+ | ACany
+ | ACval (chunk: memory_chunk) (av: aval).
+
+Definition eq_acontent : forall (c1 c2: acontent), {c1=c2} + {c1<>c2}.
+Proof.
+ intros. generalize chunk_eq eq_aval. decide equality.
+Defined.
+
+Record ablock : Type := ABlock {
+ ab_contents: ZMap.t acontent;
+ ab_summary: aptr;
+ ab_default: fst ab_contents = ACany
+}.
+
+Local Notation "a ## b" := (ZMap.get b a) (at level 1).
+
+Definition ablock_init (p: aptr) : ablock :=
+ {| ab_contents := ZMap.init ACany; ab_summary := p; ab_default := refl_equal _ |}.
+
+Definition chunk_compat (chunk chunk': memory_chunk) : bool :=
+ match chunk, chunk' with
+ | (Mint8signed | Mint8unsigned), (Mint8signed | Mint8unsigned) => true
+ | (Mint16signed | Mint16unsigned), (Mint16signed | Mint16unsigned) => true
+ | Mint32, Mint32 => true
+ | Mfloat32, Mfloat32 => true
+ | Mint64, Mint64 => true
+ | (Mfloat64 | Mfloat64al32), Mfloat64 => true
+ | Mfloat64al32, Mfloat64al32 => true
+ | _, _ => false
+ end.
+
+Definition ablock_load (chunk: memory_chunk) (ab: ablock) (i: Z) : aval :=
+ match ab.(ab_contents)##i with
+ | ACany => vnormalize chunk (Ifptr ab.(ab_summary))
+ | ACval chunk' av =>
+ if chunk_compat chunk chunk'
+ then vnormalize chunk av
+ else vnormalize chunk (Ifptr ab.(ab_summary))
+ end.
+
+Definition ablock_load_anywhere (chunk: memory_chunk) (ab: ablock) : aval :=
+ vnormalize chunk (Ifptr ab.(ab_summary)).
+
+Function inval_after (lo: Z) (hi: Z) (c: ZMap.t acontent) { wf (Zwf lo) hi } : ZMap.t acontent :=
+ if zle lo hi
+ then inval_after lo (hi - 1) (ZMap.set hi ACany c)
+ else c.
+Proof.
+ intros; red; omega.
+ apply Zwf_well_founded.
+Qed.
+
+Definition inval_if (hi: Z) (lo: Z) (c: ZMap.t acontent) :=
+ match c##lo with
+ | ACany => c
+ | ACval chunk av => if zle (lo + size_chunk chunk) hi then c else ZMap.set lo ACany c
+ end.
+
+Function inval_before (hi: Z) (lo: Z) (c: ZMap.t acontent) { wf (Zwf_up hi) lo } : ZMap.t acontent :=
+ if zlt lo hi
+ then inval_before hi (lo + 1) (inval_if hi lo c)
+ else c.
+Proof.
+ intros; red; omega.
+ apply Zwf_up_well_founded.
+Qed.
+
+Remark fst_inval_after: forall lo hi c, fst (inval_after lo hi c) = fst c.
+Proof.
+ intros. functional induction (inval_after lo hi c); auto.
+Qed.
+
+Remark fst_inval_before: forall hi lo c, fst (inval_before hi lo c) = fst c.
+Proof.
+ intros. functional induction (inval_before hi lo c); auto.
+ rewrite IHt. unfold inval_if. destruct c##lo; auto.
+ destruct (zle (lo + size_chunk chunk) hi); auto.
+Qed.
+
+Program Definition ablock_store (chunk: memory_chunk) (ab: ablock) (i: Z) (av: aval) : ablock :=
+ {| ab_contents :=
+ ZMap.set i (ACval chunk av)
+ (inval_before i (i - 7)
+ (inval_after (i + 1) (i + size_chunk chunk - 1) ab.(ab_contents)));
+ ab_summary :=
+ vplub av ab.(ab_summary);
+ ab_default := _ |}.
+Next Obligation.
+ rewrite fst_inval_before, fst_inval_after. apply ab_default.
+Qed.
+
+Definition ablock_store_anywhere (chunk: memory_chunk) (ab: ablock) (av: aval) : ablock :=
+ ablock_init (vplub av ab.(ab_summary)).
+
+Definition ablock_loadbytes (ab: ablock) : aptr := ab.(ab_summary).
+
+Program Definition ablock_storebytes (ab: ablock) (p: aptr) (ofs: Z) (sz: Z) :=
+ {| ab_contents :=
+ inval_before ofs (ofs - 7)
+ (inval_after ofs (ofs + sz - 1) ab.(ab_contents));
+ ab_summary :=
+ plub p ab.(ab_summary);
+ ab_default := _ |}.
+Next Obligation.
+ rewrite fst_inval_before, fst_inval_after. apply ab_default.
+Qed.
+
+Definition ablock_storebytes_anywhere (ab: ablock) (p: aptr) :=
+ ablock_init (plub p ab.(ab_summary)).
+
+Definition smatch (m: mem) (b: block) (p: aptr) : Prop :=
+ (forall chunk ofs v, Mem.load chunk m b ofs = Some v -> vmatch v (Ifptr p))
+/\(forall ofs b' ofs' i, Mem.loadbytes m b ofs 1 = Some (Pointer b' ofs' i :: nil) -> pmatch b' ofs' p).
+
+Remark loadbytes_load_ext:
+ forall b m m',
+ (forall ofs n bytes, Mem.loadbytes m' b ofs n = Some bytes -> n >= 0 -> Mem.loadbytes m b ofs n = Some bytes) ->
+ forall chunk ofs v, Mem.load chunk m' b ofs = Some v -> Mem.load chunk m b ofs = Some v.
+Proof.
+ intros. exploit Mem.load_loadbytes; eauto. intros [bytes [A B]].
+ exploit Mem.load_valid_access; eauto. intros [C D].
+ subst v. apply Mem.loadbytes_load; auto. apply H; auto. generalize (size_chunk_pos chunk); omega.
+Qed.
+
+Lemma smatch_ext:
+ forall m b p m',
+ smatch m b p ->
+ (forall ofs n bytes, Mem.loadbytes m' b ofs n = Some bytes -> n >= 0 -> Mem.loadbytes m b ofs n = Some bytes) ->
+ smatch m' b p.
+Proof.
+ intros. destruct H. split; intros.
+ eapply H; eauto. eapply loadbytes_load_ext; eauto.
+ eapply H1; eauto. apply H0; eauto. omega.
+Qed.
+
+Lemma smatch_inv:
+ forall m b p m',
+ smatch m b p ->
+ (forall ofs n, n >= 0 -> Mem.loadbytes m' b ofs n = Mem.loadbytes m b ofs n) ->
+ smatch m' b p.
+Proof.
+ intros. eapply smatch_ext; eauto.
+ intros. rewrite <- H0; eauto.
+Qed.
+
+Lemma smatch_ge:
+ forall m b p q, smatch m b p -> pge q p -> smatch m b q.
+Proof.
+ intros. destruct H as [A B]. split; intros.
+ apply vmatch_ge with (Ifptr p); eauto with va.
+ apply pmatch_ge with p; eauto with va.
+Qed.
+
+Lemma In_loadbytes:
+ forall m b byte n ofs bytes,
+ Mem.loadbytes m b ofs n = Some bytes ->
+ In byte bytes ->
+ exists ofs', ofs <= ofs' < ofs + n /\ Mem.loadbytes m b ofs' 1 = Some(byte :: nil).
+Proof.
+ intros until n. pattern n.
+ apply well_founded_ind with (R := Zwf 0).
+- apply Zwf_well_founded.
+- intros sz REC ofs bytes LOAD IN.
+ destruct (zle sz 0).
+ + rewrite (Mem.loadbytes_empty m b ofs sz) in LOAD by auto.
+ inv LOAD. contradiction.
+ + exploit (Mem.loadbytes_split m b ofs 1 (sz - 1) bytes).
+ replace (1 + (sz - 1)) with sz by omega. auto.
+ omega.
+ omega.
+ intros (bytes1 & bytes2 & LOAD1 & LOAD2 & CONCAT).
+ subst bytes.
+ exploit Mem.loadbytes_length. eexact LOAD1. change (nat_of_Z 1) with 1%nat. intros LENGTH1.
+ rewrite in_app_iff in IN. destruct IN.
+ * destruct bytes1; try discriminate. destruct bytes1; try discriminate.
+ simpl in H. destruct H; try contradiction. subst m0.
+ exists ofs; split. omega. auto.
+ * exploit (REC (sz - 1)). red; omega. eexact LOAD2. auto.
+ intros (ofs' & A & B).
+ exists ofs'; split. omega. auto.
+Qed.
+
+Lemma smatch_loadbytes:
+ forall m b p b' ofs' i n ofs bytes,
+ Mem.loadbytes m b ofs n = Some bytes ->
+ smatch m b p ->
+ In (Pointer b' ofs' i) bytes ->
+ pmatch b' ofs' p.
+Proof.
+ intros. exploit In_loadbytes; eauto. intros (ofs1 & A & B).
+ eapply H0; eauto.
+Qed.
+
+Lemma loadbytes_provenance:
+ forall m b ofs' byte n ofs bytes,
+ Mem.loadbytes m b ofs n = Some bytes ->
+ Mem.loadbytes m b ofs' 1 = Some (byte :: nil) ->
+ ofs <= ofs' < ofs + n ->
+ In byte bytes.
+Proof.
+ intros until n. pattern n.
+ apply well_founded_ind with (R := Zwf 0).
+- apply Zwf_well_founded.
+- intros sz REC ofs bytes LOAD LOAD1 IN.
+ exploit (Mem.loadbytes_split m b ofs 1 (sz - 1) bytes).
+ replace (1 + (sz - 1)) with sz by omega. auto.
+ omega.
+ omega.
+ intros (bytes1 & bytes2 & LOAD3 & LOAD4 & CONCAT). subst bytes. rewrite in_app_iff.
+ destruct (zeq ofs ofs').
++ subst ofs'. rewrite LOAD1 in LOAD3; inv LOAD3. left; simpl; auto.
++ right. eapply (REC (sz - 1)). red; omega. eexact LOAD4. auto. omega.
+Qed.
+
+Lemma storebytes_provenance:
+ forall m b ofs bytes m' b' ofs' b'' ofs'' i,
+ Mem.storebytes m b ofs bytes = Some m' ->
+ Mem.loadbytes m' b' ofs' 1 = Some (Pointer b'' ofs'' i :: nil) ->
+ In (Pointer b'' ofs'' i) bytes
+ \/ Mem.loadbytes m b' ofs' 1 = Some (Pointer b'' ofs'' i :: nil).
+Proof.
+ intros.
+ assert (EITHER:
+ (b' <> b \/ ofs' + 1 <= ofs \/ ofs + Z.of_nat (length bytes) <= ofs')
+ \/ (b' = b /\ ofs <= ofs' < ofs + Z.of_nat (length bytes))).
+ {
+ destruct (eq_block b' b); auto.
+ destruct (zle (ofs' + 1) ofs); auto.
+ destruct (zle (ofs + Z.of_nat (length bytes)) ofs'); auto.
+ right. split. auto. omega.
+ }
+ destruct EITHER as [A | (A & B)].
+- right. rewrite <- H0. symmetry. eapply Mem.loadbytes_storebytes_other; eauto. omega.
+- subst b'. left.
+ eapply loadbytes_provenance; eauto.
+ eapply Mem.loadbytes_storebytes_same; eauto.
+Qed.
+
+Lemma store_provenance:
+ forall chunk m b ofs v m' b' ofs' b'' ofs'' i,
+ Mem.store chunk m b ofs v = Some m' ->
+ Mem.loadbytes m' b' ofs' 1 = Some (Pointer b'' ofs'' i :: nil) ->
+ v = Vptr b'' ofs'' /\ chunk = Mint32
+ \/ Mem.loadbytes m b' ofs' 1 = Some (Pointer b'' ofs'' i :: nil).
+Proof.
+ intros. exploit storebytes_provenance; eauto. eapply Mem.store_storebytes; eauto.
+ intros [A|A]; auto. left.
+ assert (IN_ENC_BYTES: forall bl, ~In (Pointer b'' ofs'' i) (inj_bytes bl)).
+ {
+ induction bl; simpl. tauto. red; intros; elim IHbl. destruct H1. congruence. auto.
+ }
+ assert (IN_REP_UNDEF: forall n, ~In (Pointer b'' ofs'' i) (list_repeat n Undef)).
+ {
+ intros; red; intros. exploit in_list_repeat; eauto. congruence.
+ }
+ unfold encode_val in A; destruct chunk, v;
+ try (eelim IN_ENC_BYTES; eassumption);
+ try (eelim IN_REP_UNDEF; eassumption).
+ simpl in A. split; auto. intuition congruence.
+Qed.
+
+Lemma smatch_store:
+ forall chunk m b ofs v m' b' p av,
+ Mem.store chunk m b ofs v = Some m' ->
+ smatch m b' p ->
+ vmatch v av ->
+ smatch m' b' (vplub av p).
+Proof.
+ intros. destruct H0 as [A B]. split.
+- intros chunk' ofs' v' LOAD. destruct v'; auto with va.
+ exploit Mem.load_pointer_store; eauto.
+ intros [(P & Q & R & S & T) | DISJ].
++ subst. apply vmatch_vplub_l. auto.
++ apply vmatch_vplub_r. apply A with (chunk := chunk') (ofs := ofs').
+ rewrite <- LOAD. symmetry. eapply Mem.load_store_other; eauto.
+- intros. exploit store_provenance; eauto. intros [[P Q] | P].
++ subst.
+ assert (V: vmatch (Vptr b'0 ofs') (Ifptr (vplub av p))).
+ {
+ apply vmatch_vplub_l. auto.
+ }
+ inv V; auto.
++ apply pmatch_vplub. eapply B; eauto.
+Qed.
+
+Lemma smatch_storebytes:
+ forall m b ofs bytes m' b' p p',
+ Mem.storebytes m b ofs bytes = Some m' ->
+ smatch m b' p ->
+ (forall b' ofs' i, In (Pointer b' ofs' i) bytes -> pmatch b' ofs' p') ->
+ smatch m' b' (plub p' p).
+Proof.
+ intros. destruct H0 as [A B]. split.
+- intros. apply vmatch_ifptr. intros bx ofsx EQ; subst v.
+ exploit Mem.load_loadbytes; eauto. intros (bytes' & P & Q).
+ exploit decode_val_pointer_inv; eauto. intros [U V].
+ subst chunk bytes'.
+ exploit In_loadbytes; eauto.
+ instantiate (1 := Pointer bx ofsx 3%nat). simpl; auto.
+ intros (ofs' & X & Y).
+ exploit storebytes_provenance; eauto. intros [Z | Z].
+ apply pmatch_lub_l. eauto.
+ apply pmatch_lub_r. eauto.
+- intros. exploit storebytes_provenance; eauto. intros [Z | Z].
+ apply pmatch_lub_l. eauto.
+ apply pmatch_lub_r. eauto.
+Qed.
+
+Definition bmatch (m: mem) (b: block) (ab: ablock) : Prop :=
+ smatch m b ab.(ab_summary) /\
+ forall chunk ofs v, Mem.load chunk m b ofs = Some v -> vmatch v (ablock_load chunk ab ofs).
+
+Lemma bmatch_ext:
+ forall m b ab m',
+ bmatch m b ab ->
+ (forall ofs n bytes, Mem.loadbytes m' b ofs n = Some bytes -> n >= 0 -> Mem.loadbytes m b ofs n = Some bytes) ->
+ bmatch m' b ab.
+Proof.
+ intros. destruct H as [A B]. split; intros.
+ apply smatch_ext with m; auto.
+ eapply B; eauto. eapply loadbytes_load_ext; eauto.
+Qed.
+
+Lemma bmatch_inv:
+ forall m b ab m',
+ bmatch m b ab ->
+ (forall ofs n, n >= 0 -> Mem.loadbytes m' b ofs n = Mem.loadbytes m b ofs n) ->
+ bmatch m' b ab.
+Proof.
+ intros. eapply bmatch_ext; eauto.
+ intros. rewrite <- H0; eauto.
+Qed.
+
+Lemma ablock_load_sound:
+ forall chunk m b ofs v ab,
+ Mem.load chunk m b ofs = Some v ->
+ bmatch m b ab ->
+ vmatch v (ablock_load chunk ab ofs).
+Proof.
+ intros. destruct H0. eauto.
+Qed.
+
+Lemma ablock_load_anywhere_sound:
+ forall chunk m b ofs v ab,
+ Mem.load chunk m b ofs = Some v ->
+ bmatch m b ab ->
+ vmatch v (ablock_load_anywhere chunk ab).
+Proof.
+ intros. destruct H0. destruct H0. unfold ablock_load_anywhere.
+ eapply vnormalize_cast; eauto.
+Qed.
+
+Lemma ablock_init_sound:
+ forall m b p, smatch m b p -> bmatch m b (ablock_init p).
+Proof.
+ intros; split; auto; intros.
+ unfold ablock_load, ablock_init; simpl. rewrite ZMap.gi.
+ eapply vnormalize_cast; eauto. eapply H; eauto.
+Qed.
+
+Lemma ablock_store_anywhere_sound:
+ forall chunk m b ofs v m' b' ab av,
+ Mem.store chunk m b ofs v = Some m' ->
+ bmatch m b' ab ->
+ vmatch v av ->
+ bmatch m' b' (ablock_store_anywhere chunk ab av).
+Proof.
+ intros. destruct H0 as [A B]. unfold ablock_store_anywhere.
+ apply ablock_init_sound. eapply smatch_store; eauto.
+Qed.
+
+Remark inval_after_outside:
+ forall i lo hi c, i < lo \/ i > hi -> (inval_after lo hi c)##i = c##i.
+Proof.
+ intros until c. functional induction (inval_after lo hi c); intros.
+ rewrite IHt by omega. apply ZMap.gso. unfold ZIndexed.t; omega.
+ auto.
+Qed.
+
+Remark inval_after_contents:
+ forall chunk av i lo hi c,
+ (inval_after lo hi c)##i = ACval chunk av ->
+ c##i = ACval chunk av /\ (i < lo \/ i > hi).
+Proof.
+ intros until c. functional induction (inval_after lo hi c); intros.
+ destruct (zeq i hi).
+ subst i. rewrite inval_after_outside in H by omega. rewrite ZMap.gss in H. discriminate.
+ exploit IHt; eauto. intros [A B]. rewrite ZMap.gso in A by auto. split. auto. omega.
+ split. auto. omega.
+Qed.
+
+Remark inval_before_outside:
+ forall i hi lo c, i < lo \/ i >= hi -> (inval_before hi lo c)##i = c##i.
+Proof.
+ intros until c. functional induction (inval_before hi lo c); intros.
+ rewrite IHt by omega. unfold inval_if. destruct (c##lo); auto.
+ destruct (zle (lo + size_chunk chunk) hi); auto.
+ apply ZMap.gso. unfold ZIndexed.t; omega.
+ auto.
+Qed.
+
+Remark inval_before_contents_1:
+ forall i chunk av lo hi c,
+ lo <= i < hi -> (inval_before hi lo c)##i = ACval chunk av ->
+ c##i = ACval chunk av /\ i + size_chunk chunk <= hi.
+Proof.
+ intros until c. functional induction (inval_before hi lo c); intros.
+- destruct (zeq lo i).
++ subst i. rewrite inval_before_outside in H0 by omega.
+ unfold inval_if in H0. destruct (c##lo) eqn:C. congruence.
+ destruct (zle (lo + size_chunk chunk0) hi).
+ rewrite C in H0; inv H0. auto.
+ rewrite ZMap.gss in H0. congruence.
++ exploit IHt. omega. auto. intros [A B]; split; auto.
+ unfold inval_if in A. destruct (c##lo) eqn:C. auto.
+ destruct (zle (lo + size_chunk chunk0) hi); auto.
+ rewrite ZMap.gso in A; auto.
+- omegaContradiction.
+Qed.
+
+Lemma max_size_chunk: forall chunk, size_chunk chunk <= 8.
+Proof.
+ destruct chunk; simpl; omega.
+Qed.
+
+Remark inval_before_contents:
+ forall i c chunk' av' j,
+ (inval_before i (i - 7) c)##j = ACval chunk' av' ->
+ c##j = ACval chunk' av' /\ (j + size_chunk chunk' <= i \/ i <= j).
+Proof.
+ intros. destruct (zlt j (i - 7)).
+ rewrite inval_before_outside in H by omega.
+ split. auto. left. generalize (max_size_chunk chunk'); omega.
+ destruct (zlt j i).
+ exploit inval_before_contents_1; eauto. omega. tauto.
+ rewrite inval_before_outside in H by omega.
+ split. auto. omega.
+Qed.
+
+Lemma ablock_store_contents:
+ forall chunk ab i av j chunk' av',
+ (ablock_store chunk ab i av).(ab_contents)##j = ACval chunk' av' ->
+ (i = j /\ chunk' = chunk /\ av' = av)
+ \/ (ab.(ab_contents)##j = ACval chunk' av'
+ /\ (j + size_chunk chunk' <= i \/ i + size_chunk chunk <= j)).
+Proof.
+ unfold ablock_store; simpl; intros.
+ destruct (zeq i j).
+ subst j. rewrite ZMap.gss in H. inv H; auto.
+ right. rewrite ZMap.gso in H by auto.
+ exploit inval_before_contents; eauto. intros [A B].
+ exploit inval_after_contents; eauto. intros [C D].
+ split. auto. omega.
+Qed.
+
+Lemma chunk_compat_true:
+ forall c c',
+ chunk_compat c c' = true ->
+ size_chunk c = size_chunk c' /\ align_chunk c <= align_chunk c' /\ type_of_chunk c = type_of_chunk c'.
+Proof.
+ destruct c, c'; intros; try discriminate; simpl; auto with va.
+Qed.
+
+Lemma ablock_store_sound:
+ forall chunk m b ofs v m' ab av,
+ Mem.store chunk m b ofs v = Some m' ->
+ bmatch m b ab ->
+ vmatch v av ->
+ bmatch m' b (ablock_store chunk ab ofs av).
+Proof.
+ intros until av; intros STORE BIN VIN. destruct BIN as [BIN1 BIN2]. split.
+ eapply smatch_store; eauto.
+ intros chunk' ofs' v' LOAD.
+ assert (SUMMARY: vmatch v' (vnormalize chunk' (Ifptr (vplub av ab.(ab_summary))))).
+ { exploit smatch_store; eauto. intros [A B]. eapply vnormalize_cast; eauto. }
+ unfold ablock_load.
+ destruct ((ab_contents (ablock_store chunk ab ofs av)) ## ofs') as [ | chunk1 av1] eqn:C.
+ apply SUMMARY.
+ destruct (chunk_compat chunk' chunk1) eqn:COMPAT; auto.
+ exploit chunk_compat_true; eauto. intros (U & V & W).
+ exploit ablock_store_contents; eauto. intros [(P & Q & R) | (P & Q)].
+- (* same offset and compatible chunks *)
+ subst.
+ assert (v' = Val.load_result chunk' v).
+ { exploit Mem.load_store_similar_2; eauto. congruence. }
+ subst v'. apply vnormalize_sound; auto.
+- (* disjoint load/store *)
+ assert (Mem.load chunk' m b ofs' = Some v').
+ { rewrite <- LOAD. symmetry. eapply Mem.load_store_other; eauto.
+ rewrite U. auto. }
+ exploit BIN2; eauto. unfold ablock_load. rewrite P. rewrite COMPAT. auto.
+Qed.
+
+Lemma ablock_loadbytes_sound:
+ forall m b ab b' ofs' i n ofs bytes,
+ Mem.loadbytes m b ofs n = Some bytes ->
+ bmatch m b ab ->
+ In (Pointer b' ofs' i) bytes ->
+ pmatch b' ofs' (ablock_loadbytes ab).
+Proof.
+ intros. destruct H0. eapply smatch_loadbytes; eauto.
+Qed.
+
+Lemma ablock_storebytes_anywhere_sound:
+ forall m b ofs bytes p m' b' ab,
+ Mem.storebytes m b ofs bytes = Some m' ->
+ (forall b' ofs' i, In (Pointer b' ofs' i) bytes -> pmatch b' ofs' p) ->
+ bmatch m b' ab ->
+ bmatch m' b' (ablock_storebytes_anywhere ab p).
+Proof.
+ intros. destruct H1 as [A B]. apply ablock_init_sound.
+ eapply smatch_storebytes; eauto.
+Qed.
+
+Lemma ablock_storebytes_contents:
+ forall ab p i sz j chunk' av',
+ (ablock_storebytes ab p i sz).(ab_contents)##j = ACval chunk' av' ->
+ ab.(ab_contents)##j = ACval chunk' av'
+ /\ (j + size_chunk chunk' <= i \/ i + Zmax sz 0 <= j).
+Proof.
+ unfold ablock_storebytes; simpl; intros.
+ exploit inval_before_contents; eauto. clear H. intros [A B].
+ exploit inval_after_contents; eauto. clear A. intros [C D].
+ split. auto. xomega.
+Qed.
+
+Lemma ablock_storebytes_sound:
+ forall m b ofs bytes m' p ab sz,
+ Mem.storebytes m b ofs bytes = Some m' ->
+ length bytes = nat_of_Z sz ->
+ (forall b' ofs' i, In (Pointer b' ofs' i) bytes -> pmatch b' ofs' p) ->
+ bmatch m b ab ->
+ bmatch m' b (ablock_storebytes ab p ofs sz).
+Proof.
+ intros until sz; intros STORE LENGTH CONTENTS BM. destruct BM as [BM1 BM2]. split.
+ eapply smatch_storebytes; eauto.
+ intros chunk' ofs' v' LOAD'.
+ assert (SUMMARY: vmatch v' (vnormalize chunk' (Ifptr (plub p ab.(ab_summary))))).
+ { exploit smatch_storebytes; eauto. intros [A B]. eapply vnormalize_cast; eauto. }
+ unfold ablock_load.
+ destruct (ab_contents (ablock_storebytes ab p ofs sz))##ofs' eqn:C.
+ exact SUMMARY.
+ destruct (chunk_compat chunk' chunk) eqn:COMPAT; auto.
+ exploit chunk_compat_true; eauto. intros (U & V & W).
+ exploit ablock_storebytes_contents; eauto. intros [A B].
+ assert (Mem.load chunk' m b ofs' = Some v').
+ { rewrite <- LOAD'; symmetry. eapply Mem.load_storebytes_other; eauto.
+ rewrite U. rewrite LENGTH. rewrite nat_of_Z_max. right; omega. }
+ exploit BM2; eauto. unfold ablock_load. rewrite A. rewrite COMPAT. auto.
+Qed.
+
+(** Boolean equality *)
+
+Definition bbeq (ab1 ab2: ablock) : bool :=
+ eq_aptr ab1.(ab_summary) ab2.(ab_summary) &&
+ PTree.beq (fun c1 c2 => proj_sumbool (eq_acontent c1 c2))
+ (snd ab1.(ab_contents)) (snd ab2.(ab_contents)).
+
+Lemma bbeq_load:
+ forall ab1 ab2,
+ bbeq ab1 ab2 = true ->
+ ab1.(ab_summary) = ab2.(ab_summary)
+ /\ (forall chunk i, ablock_load chunk ab1 i = ablock_load chunk ab2 i).
+Proof.
+ unfold bbeq; intros. InvBooleans. split.
+- unfold ablock_load_anywhere; intros; congruence.
+- rewrite PTree.beq_correct in H1.
+ assert (A: forall i, ZMap.get i (ab_contents ab1) = ZMap.get i (ab_contents ab2)).
+ {
+ intros. unfold ZMap.get, PMap.get. set (j := ZIndexed.index i).
+ specialize (H1 j).
+ destruct (snd (ab_contents ab1))!j; destruct (snd (ab_contents ab2))!j; try contradiction.
+ InvBooleans; auto.
+ rewrite ! ab_default. auto.
+ }
+ intros. unfold ablock_load. rewrite A, H.
+ destruct (ab_contents ab2)##i; auto.
+Qed.
+
+Lemma bbeq_sound:
+ forall ab1 ab2,
+ bbeq ab1 ab2 = true ->
+ forall m b, bmatch m b ab1 <-> bmatch m b ab2.
+Proof.
+ intros. exploit bbeq_load; eauto. intros [A B].
+ unfold bmatch. rewrite A. intuition. rewrite <- B; eauto. rewrite B; eauto.
+Qed.
+
+(** Least upper bound *)
+
+Definition combine_acontents_opt (c1 c2: option acontent) : option acontent :=
+ match c1, c2 with
+ | Some (ACval chunk1 v1), Some (ACval chunk2 v2) =>
+ if chunk_eq chunk1 chunk2 then Some(ACval chunk1 (vlub v1 v2)) else None
+ | _, _ =>
+ None
+ end.
+
+Definition combine_contentmaps (m1 m2: ZMap.t acontent) : ZMap.t acontent :=
+ (ACany, PTree.combine combine_acontents_opt (snd m1) (snd m2)).
+
+Definition blub (ab1 ab2: ablock) : ablock :=
+ {| ab_contents := combine_contentmaps ab1.(ab_contents) ab2.(ab_contents);
+ ab_summary := plub ab1.(ab_summary) ab2.(ab_summary);
+ ab_default := refl_equal _ |}.
+
+Definition combine_acontents (c1 c2: acontent) : acontent :=
+ match c1, c2 with
+ | ACval chunk1 v1, ACval chunk2 v2 =>
+ if chunk_eq chunk1 chunk2 then ACval chunk1 (vlub v1 v2) else ACany
+ | _, _ => ACany
+ end.
+
+Lemma get_combine_contentmaps:
+ forall m1 m2 i,
+ fst m1 = ACany -> fst m2 = ACany ->
+ ZMap.get i (combine_contentmaps m1 m2) = combine_acontents (ZMap.get i m1) (ZMap.get i m2).
+Proof.
+ intros. destruct m1 as [dfl1 pt1]. destruct m2 as [dfl2 pt2]; simpl in *.
+ subst dfl1 dfl2. unfold combine_contentmaps, ZMap.get, PMap.get, fst, snd.
+ set (j := ZIndexed.index i).
+ rewrite PTree.gcombine by auto.
+ destruct (pt1!j) as [[]|]; destruct (pt2!j) as [[]|]; simpl; auto.
+ destruct (chunk_eq chunk chunk0); auto.
+Qed.
+
+Lemma smatch_lub_l:
+ forall m b p q, smatch m b p -> smatch m b (plub p q).
+Proof.
+ intros. destruct H as [A B]. split; intros.
+ change (vmatch v (vlub (Ifptr p) (Ifptr q))). apply vmatch_lub_l. eapply A; eauto.
+ apply pmatch_lub_l. eapply B; eauto.
+Qed.
+
+Lemma smatch_lub_r:
+ forall m b p q, smatch m b q -> smatch m b (plub p q).
+Proof.
+ intros. destruct H as [A B]. split; intros.
+ change (vmatch v (vlub (Ifptr p) (Ifptr q))). apply vmatch_lub_r. eapply A; eauto.
+ apply pmatch_lub_r. eapply B; eauto.
+Qed.
+
+Lemma bmatch_lub_l:
+ forall m b x y, bmatch m b x -> bmatch m b (blub x y).
+Proof.
+ intros. destruct H as [BM1 BM2]. split; unfold blub; simpl.
+- apply smatch_lub_l; auto.
+- intros.
+ assert (SUMMARY: vmatch v (vnormalize chunk (Ifptr (plub (ab_summary x) (ab_summary y))))
+).
+ { exploit smatch_lub_l; eauto. instantiate (1 := ab_summary y).
+ intros [SUMM _]. eapply vnormalize_cast; eauto. }
+ exploit BM2; eauto.
+ unfold ablock_load; simpl. rewrite get_combine_contentmaps by (apply ab_default).
+ unfold combine_acontents; destruct (ab_contents x)##ofs, (ab_contents y)##ofs; auto.
+ destruct (chunk_eq chunk0 chunk1); auto. subst chunk0.
+ destruct (chunk_compat chunk chunk1); auto.
+ intros. eapply vmatch_ge; eauto. apply vnormalize_monotone. apply vge_lub_l.
+Qed.
+
+Lemma bmatch_lub_r:
+ forall m b x y, bmatch m b y -> bmatch m b (blub x y).
+Proof.
+ intros. destruct H as [BM1 BM2]. split; unfold blub; simpl.
+- apply smatch_lub_r; auto.
+- intros.
+ assert (SUMMARY: vmatch v (vnormalize chunk (Ifptr (plub (ab_summary x) (ab_summary y))))
+).
+ { exploit smatch_lub_r; eauto. instantiate (1 := ab_summary x).
+ intros [SUMM _]. eapply vnormalize_cast; eauto. }
+ exploit BM2; eauto.
+ unfold ablock_load; simpl. rewrite get_combine_contentmaps by (apply ab_default).
+ unfold combine_acontents; destruct (ab_contents x)##ofs, (ab_contents y)##ofs; auto.
+ destruct (chunk_eq chunk0 chunk1); auto. subst chunk0.
+ destruct (chunk_compat chunk chunk1); auto.
+ intros. eapply vmatch_ge; eauto. apply vnormalize_monotone. apply vge_lub_r.
+Qed.
+
+(** * Abstracting read-only global variables *)
+
+Definition romem := PTree.t ablock.
+
+Definition romatch (m: mem) (rm: romem) : Prop :=
+ forall b id ab,
+ bc b = BCglob id ->
+ rm!id = Some ab ->
+ pge Glob ab.(ab_summary)
+ /\ bmatch m b ab
+ /\ forall ofs, ~Mem.perm m b ofs Max Writable.
+
+Lemma romatch_store:
+ forall chunk m b ofs v m' rm,
+ Mem.store chunk m b ofs v = Some m' ->
+ romatch m rm ->
+ romatch m' rm.
+Proof.
+ intros; red; intros. exploit H0; eauto. intros (A & B & C). split; auto. split.
+- exploit Mem.store_valid_access_3; eauto. intros [P _].
+ apply bmatch_inv with m; auto.
++ intros. eapply Mem.loadbytes_store_other; eauto.
+ left. red; intros; subst b0. elim (C ofs). apply Mem.perm_cur_max.
+ apply P. generalize (size_chunk_pos chunk); omega.
+- intros; red; intros; elim (C ofs0). eauto with mem.
+Qed.
+
+Lemma romatch_storebytes:
+ forall m b ofs bytes m' rm,
+ Mem.storebytes m b ofs bytes = Some m' ->
+ bytes <> nil ->
+ romatch m rm ->
+ romatch m' rm.
+Proof.
+ intros; red; intros. exploit H1; eauto. intros (A & B & C). split; auto. split.
+- apply bmatch_inv with m; auto.
+ intros. eapply Mem.loadbytes_storebytes_other; eauto.
+ left. red; intros; subst b0. elim (C ofs). apply Mem.perm_cur_max.
+ eapply Mem.storebytes_range_perm; eauto.
+ destruct bytes. congruence. simpl length. rewrite inj_S. omega.
+- intros; red; intros; elim (C ofs0). eauto with mem.
+Qed.
+
+Lemma romatch_ext:
+ forall m rm m',
+ romatch m rm ->
+ (forall b id ofs n bytes, bc b = BCglob id -> Mem.loadbytes m' b ofs n = Some bytes -> Mem.loadbytes m b ofs n = Some bytes) ->
+ (forall b id ofs p, bc b = BCglob id -> Mem.perm m' b ofs Max p -> Mem.perm m b ofs Max p) ->
+ romatch m' rm.
+Proof.
+ intros; red; intros. exploit H; eauto. intros (A & B & C).
+ split. auto.
+ split. apply bmatch_ext with m; auto. intros. eapply H0; eauto.
+ intros; red; intros. elim (C ofs). eapply H1; eauto.
+Qed.
+
+Lemma romatch_free:
+ forall m b lo hi m' rm,
+ Mem.free m b lo hi = Some m' ->
+ romatch m rm ->
+ romatch m' rm.
+Proof.
+ intros. apply romatch_ext with m; auto.
+ intros. eapply Mem.loadbytes_free_2; eauto.
+ intros. eauto with mem.
+Qed.
+
+Lemma romatch_alloc:
+ forall m b lo hi m' rm,
+ Mem.alloc m lo hi = (m', b) ->
+ bc_below bc (Mem.nextblock m) ->
+ romatch m rm ->
+ romatch m' rm.
+Proof.
+ intros. apply romatch_ext with m; auto.
+ intros. rewrite <- H3; symmetry. eapply Mem.loadbytes_alloc_unchanged; eauto.
+ apply H0. congruence.
+ intros. eapply Mem.perm_alloc_4; eauto. apply Mem.valid_not_valid_diff with m; eauto with mem.
+ apply H0. congruence.
+Qed.
+
+(** * Abstracting memory states *)
+
+Record amem : Type := AMem {
+ am_stack: ablock;
+ am_glob: PTree.t ablock;
+ am_nonstack: aptr;
+ am_top: aptr
+}.
+
+Record mmatch (m: mem) (am: amem) : Prop := mk_mem_match {
+ mmatch_stack: forall b,
+ bc b = BCstack ->
+ bmatch m b am.(am_stack);
+ mmatch_glob: forall id ab b,
+ bc b = BCglob id ->
+ am.(am_glob)!id = Some ab ->
+ bmatch m b ab;
+ mmatch_nonstack: forall b,
+ bc b <> BCstack -> bc b <> BCinvalid ->
+ smatch m b am.(am_nonstack);
+ mmatch_top: forall b,
+ bc b <> BCinvalid ->
+ smatch m b am.(am_top);
+ mmatch_below:
+ bc_below bc (Mem.nextblock m)
+}.
+
+Definition minit (p: aptr) :=
+ {| am_stack := ablock_init p;
+ am_glob := PTree.empty _;
+ am_nonstack := p;
+ am_top := p |}.
+
+Definition mbot := minit Pbot.
+Definition mtop := minit Ptop.
+
+Definition load (chunk: memory_chunk) (rm: romem) (m: amem) (p: aptr) : aval :=
+ match p with
+ | Pbot => if strict then Vbot else Vtop
+ | Gl id ofs =>
+ match rm!id with
+ | Some ab => ablock_load chunk ab (Int.unsigned ofs)
+ | None =>
+ match m.(am_glob)!id with
+ | Some ab => ablock_load chunk ab (Int.unsigned ofs)
+ | None => vnormalize chunk (Ifptr m.(am_nonstack))
+ end
+ end
+ | Glo id =>
+ match rm!id with
+ | Some ab => ablock_load_anywhere chunk ab
+ | None =>
+ match m.(am_glob)!id with
+ | Some ab => ablock_load_anywhere chunk ab
+ | None => vnormalize chunk (Ifptr m.(am_nonstack))
+ end
+ end
+ | Stk ofs => ablock_load chunk m.(am_stack) (Int.unsigned ofs)
+ | Stack => ablock_load_anywhere chunk m.(am_stack)
+ | Glob | Nonstack => vnormalize chunk (Ifptr m.(am_nonstack))
+ | Ptop => vnormalize chunk (Ifptr m.(am_top))
+ end.
+
+Definition loadv (chunk: memory_chunk) (rm: romem) (m: amem) (addr: aval) : aval :=
+ load chunk rm m (aptr_of_aval addr).
+
+Definition store (chunk: memory_chunk) (m: amem) (p: aptr) (av: aval) : amem :=
+ {| am_stack :=
+ match p with
+ | Stk ofs => ablock_store chunk m.(am_stack) (Int.unsigned ofs) av
+ | Stack | Ptop => ablock_store_anywhere chunk m.(am_stack) av
+ | _ => m.(am_stack)
+ end;
+ am_glob :=
+ match p with
+ | Gl id ofs =>
+ let ab := match m.(am_glob)!id with Some ab => ab | None => ablock_init m.(am_nonstack) end in
+ PTree.set id (ablock_store chunk ab (Int.unsigned ofs) av) m.(am_glob)
+ | Glo id =>
+ let ab := match m.(am_glob)!id with Some ab => ab | None => ablock_init m.(am_nonstack) end in
+ PTree.set id (ablock_store_anywhere chunk ab av) m.(am_glob)
+ | Glob | Nonstack | Ptop => PTree.empty _
+ | _ => m.(am_glob)
+ end;
+ am_nonstack :=
+ match p with
+ | Gl _ _ | Glo _ | Glob | Nonstack | Ptop => vplub av m.(am_nonstack)
+ | _ => m.(am_nonstack)
+ end;
+ am_top := vplub av m.(am_top)
+ |}.
+
+Definition storev (chunk: memory_chunk) (m: amem) (addr: aval) (v: aval): amem :=
+ store chunk m (aptr_of_aval addr) v.
+
+Definition loadbytes (m: amem) (rm: romem) (p: aptr) : aptr :=
+ match p with
+ | Pbot => if strict then Pbot else Ptop
+ | Gl id _ | Glo id =>
+ match rm!id with
+ | Some ab => ablock_loadbytes ab
+ | None =>
+ match m.(am_glob)!id with
+ | Some ab => ablock_loadbytes ab
+ | None => m.(am_nonstack)
+ end
+ end
+ | Stk _ | Stack => ablock_loadbytes m.(am_stack)
+ | Glob | Nonstack => m.(am_nonstack)
+ | Ptop => m.(am_top)
+ end.
+
+Definition storebytes (m: amem) (dst: aptr) (sz: Z) (p: aptr) : amem :=
+ {| am_stack :=
+ match dst with
+ | Stk ofs => ablock_storebytes m.(am_stack) p (Int.unsigned ofs) sz
+ | Stack | Ptop => ablock_storebytes_anywhere m.(am_stack) p
+ | _ => m.(am_stack)
+ end;
+ am_glob :=
+ match dst with
+ | Gl id ofs =>
+ let ab := match m.(am_glob)!id with Some ab => ab | None => ablock_init m.(am_nonstack) end in
+ PTree.set id (ablock_storebytes ab p (Int.unsigned ofs) sz) m.(am_glob)
+ | Glo id =>
+ let ab := match m.(am_glob)!id with Some ab => ab | None => ablock_init m.(am_nonstack) end in
+ PTree.set id (ablock_storebytes_anywhere ab p) m.(am_glob)
+ | Glob | Nonstack | Ptop => PTree.empty _
+ | _ => m.(am_glob)
+ end;
+ am_nonstack :=
+ match dst with
+ | Gl _ _ | Glo _ | Glob | Nonstack | Ptop => plub p m.(am_nonstack)
+ | _ => m.(am_nonstack)
+ end;
+ am_top := plub p m.(am_top)
+ |}.
+
+Theorem load_sound:
+ forall chunk m b ofs v rm am p,
+ Mem.load chunk m b (Int.unsigned ofs) = Some v ->
+ romatch m rm ->
+ mmatch m am ->
+ pmatch b ofs p ->
+ vmatch v (load chunk rm am p).
+Proof.
+ intros. unfold load. inv H2.
+- (* Gl id ofs *)
+ destruct (rm!id) as [ab|] eqn:RM.
+ eapply ablock_load_sound; eauto. eapply H0; eauto.
+ destruct (am_glob am)!id as [ab|] eqn:AM.
+ eapply ablock_load_sound; eauto. eapply mmatch_glob; eauto.
+ eapply vnormalize_cast; eauto. eapply mmatch_nonstack; eauto; congruence.
+- (* Glo id *)
+ destruct (rm!id) as [ab|] eqn:RM.
+ eapply ablock_load_anywhere_sound; eauto. eapply H0; eauto.
+ destruct (am_glob am)!id as [ab|] eqn:AM.
+ eapply ablock_load_anywhere_sound; eauto. eapply mmatch_glob; eauto.
+ eapply vnormalize_cast; eauto. eapply mmatch_nonstack; eauto; congruence.
+- (* Glob *)
+ eapply vnormalize_cast; eauto. eapply mmatch_nonstack; eauto. congruence. congruence.
+- (* Stk ofs *)
+ eapply ablock_load_sound; eauto. eapply mmatch_stack; eauto.
+- (* Stack *)
+ eapply ablock_load_anywhere_sound; eauto. eapply mmatch_stack; eauto.
+- (* Nonstack *)
+ eapply vnormalize_cast; eauto. eapply mmatch_nonstack; eauto.
+- (* Top *)
+ eapply vnormalize_cast; eauto. eapply mmatch_top; eauto.
+Qed.
+
+Theorem loadv_sound:
+ forall chunk m addr v rm am aaddr,
+ Mem.loadv chunk m addr = Some v ->
+ romatch m rm ->
+ mmatch m am ->
+ vmatch addr aaddr ->
+ vmatch v (loadv chunk rm am aaddr).
+Proof.
+ intros. destruct addr; simpl in H; try discriminate.
+ eapply load_sound; eauto. apply match_aptr_of_aval; auto.
+Qed.
+
+Theorem store_sound:
+ forall chunk m b ofs v m' am p av,
+ Mem.store chunk m b (Int.unsigned ofs) v = Some m' ->
+ mmatch m am ->
+ pmatch b ofs p ->
+ vmatch v av ->
+ mmatch m' (store chunk am p av).
+Proof.
+ intros until av; intros STORE MM PM VM.
+ unfold store; constructor; simpl; intros.
+- (* Stack *)
+ assert (DFL: bc b <> BCstack -> bmatch m' b0 (am_stack am)).
+ { intros. apply bmatch_inv with m. eapply mmatch_stack; eauto.
+ intros. eapply Mem.loadbytes_store_other; eauto. left; congruence. }
+ inv PM; try (apply DFL; congruence).
+ + assert (b0 = b) by (eapply bc_stack; eauto). subst b0.
+ eapply ablock_store_sound; eauto. eapply mmatch_stack; eauto.
+ + assert (b0 = b) by (eapply bc_stack; eauto). subst b0.
+ eapply ablock_store_anywhere_sound; eauto. eapply mmatch_stack; eauto.
+ + eapply ablock_store_anywhere_sound; eauto. eapply mmatch_stack; eauto.
+
+- (* Globals *)
+ rename b0 into b'.
+ assert (DFL: bc b <> BCglob id -> (am_glob am)!id = Some ab ->
+ bmatch m' b' ab).
+ { intros. apply bmatch_inv with m. eapply mmatch_glob; eauto.
+ intros. eapply Mem.loadbytes_store_other; eauto. left; congruence. }
+ inv PM.
+ + rewrite PTree.gsspec in H0. destruct (peq id id0).
+ subst id0; inv H0.
+ assert (b' = b) by (eapply bc_glob; eauto). subst b'.
+ eapply ablock_store_sound; eauto.
+ destruct (am_glob am)!id as [ab0|] eqn:GL.
+ eapply mmatch_glob; eauto.
+ apply ablock_init_sound. eapply mmatch_nonstack; eauto; congruence.
+ eapply DFL; eauto. congruence.
+ + rewrite PTree.gsspec in H0. destruct (peq id id0).
+ subst id0; inv H0.
+ assert (b' = b) by (eapply bc_glob; eauto). subst b'.
+ eapply ablock_store_anywhere_sound; eauto.
+ destruct (am_glob am)!id as [ab0|] eqn:GL.
+ eapply mmatch_glob; eauto.
+ apply ablock_init_sound. eapply mmatch_nonstack; eauto; congruence.
+ eapply DFL; eauto. congruence.
+ + rewrite PTree.gempty in H0; congruence.
+ + eapply DFL; eauto. congruence.
+ + eapply DFL; eauto. congruence.
+ + rewrite PTree.gempty in H0; congruence.
+ + rewrite PTree.gempty in H0; congruence.
+
+- (* Nonstack *)
+ assert (DFL: smatch m' b0 (vplub av (am_nonstack am))).
+ { eapply smatch_store; eauto. eapply mmatch_nonstack; eauto. }
+ assert (STK: bc b = BCstack -> smatch m' b0 (am_nonstack am)).
+ { intros. apply smatch_inv with m. eapply mmatch_nonstack; eauto; congruence.
+ intros. eapply Mem.loadbytes_store_other; eauto. left. congruence.
+ }
+ inv PM; (apply DFL || apply STK; congruence).
+
+- (* Top *)
+ eapply smatch_store; eauto. eapply mmatch_top; eauto.
+
+- (* Below *)
+ erewrite Mem.nextblock_store by eauto. eapply mmatch_below; eauto.
+Qed.
+
+Theorem storev_sound:
+ forall chunk m addr v m' am aaddr av,
+ Mem.storev chunk m addr v = Some m' ->
+ mmatch m am ->
+ vmatch addr aaddr ->
+ vmatch v av ->
+ mmatch m' (storev chunk am aaddr av).
+Proof.
+ intros. destruct addr; simpl in H; try discriminate.
+ eapply store_sound; eauto. apply match_aptr_of_aval; auto.
+Qed.
+
+Theorem loadbytes_sound:
+ forall m b ofs sz bytes am rm p,
+ Mem.loadbytes m b (Int.unsigned ofs) sz = Some bytes ->
+ romatch m rm ->
+ mmatch m am ->
+ pmatch b ofs p ->
+ forall b' ofs' i, In (Pointer b' ofs' i) bytes -> pmatch b' ofs' (loadbytes am rm p).
+Proof.
+ intros. unfold loadbytes; inv H2.
+- (* Gl id ofs *)
+ destruct (rm!id) as [ab|] eqn:RM.
+ exploit H0; eauto. intros (A & B & C). eapply ablock_loadbytes_sound; eauto.
+ destruct (am_glob am)!id as [ab|] eqn:GL.
+ eapply ablock_loadbytes_sound; eauto. eapply mmatch_glob; eauto.
+ eapply smatch_loadbytes; eauto. eapply mmatch_nonstack; eauto with va.
+- (* Glo id *)
+ destruct (rm!id) as [ab|] eqn:RM.
+ exploit H0; eauto. intros (A & B & C). eapply ablock_loadbytes_sound; eauto.
+ destruct (am_glob am)!id as [ab|] eqn:GL.
+ eapply ablock_loadbytes_sound; eauto. eapply mmatch_glob; eauto.
+ eapply smatch_loadbytes; eauto. eapply mmatch_nonstack; eauto with va.
+- (* Glob *)
+ eapply smatch_loadbytes; eauto. eapply mmatch_nonstack; eauto with va.
+- (* Stk ofs *)
+ eapply ablock_loadbytes_sound; eauto. eapply mmatch_stack; eauto.
+- (* Stack *)
+ eapply ablock_loadbytes_sound; eauto. eapply mmatch_stack; eauto.
+- (* Nonstack *)
+ eapply smatch_loadbytes; eauto. eapply mmatch_nonstack; eauto with va.
+- (* Top *)
+ eapply smatch_loadbytes; eauto. eapply mmatch_top; eauto with va.
+Qed.
+
+Theorem storebytes_sound:
+ forall m b ofs bytes m' am p sz q,
+ Mem.storebytes m b (Int.unsigned ofs) bytes = Some m' ->
+ mmatch m am ->
+ pmatch b ofs p ->
+ length bytes = nat_of_Z sz ->
+ (forall b' ofs' i, In (Pointer b' ofs' i) bytes -> pmatch b' ofs' q) ->
+ mmatch m' (storebytes am p sz q).
+Proof.
+ intros until q; intros STORE MM PM LENGTH BYTES.
+ unfold storebytes; constructor; simpl; intros.
+- (* Stack *)
+ assert (DFL: bc b <> BCstack -> bmatch m' b0 (am_stack am)).
+ { intros. apply bmatch_inv with m. eapply mmatch_stack; eauto.
+ intros. eapply Mem.loadbytes_storebytes_other; eauto. left; congruence. }
+ inv PM; try (apply DFL; congruence).
+ + assert (b0 = b) by (eapply bc_stack; eauto). subst b0.
+ eapply ablock_storebytes_sound; eauto. eapply mmatch_stack; eauto.
+ + assert (b0 = b) by (eapply bc_stack; eauto). subst b0.
+ eapply ablock_storebytes_anywhere_sound; eauto. eapply mmatch_stack; eauto.
+ + eapply ablock_storebytes_anywhere_sound; eauto. eapply mmatch_stack; eauto.
+
+- (* Globals *)
+ rename b0 into b'.
+ assert (DFL: bc b <> BCglob id -> (am_glob am)!id = Some ab ->
+ bmatch m' b' ab).
+ { intros. apply bmatch_inv with m. eapply mmatch_glob; eauto.
+ intros. eapply Mem.loadbytes_storebytes_other; eauto. left; congruence. }
+ inv PM.
+ + rewrite PTree.gsspec in H0. destruct (peq id id0).
+ subst id0; inv H0.
+ assert (b' = b) by (eapply bc_glob; eauto). subst b'.
+ eapply ablock_storebytes_sound; eauto.
+ destruct (am_glob am)!id as [ab0|] eqn:GL.
+ eapply mmatch_glob; eauto.
+ apply ablock_init_sound. eapply mmatch_nonstack; eauto; congruence.
+ eapply DFL; eauto. congruence.
+ + rewrite PTree.gsspec in H0. destruct (peq id id0).
+ subst id0; inv H0.
+ assert (b' = b) by (eapply bc_glob; eauto). subst b'.
+ eapply ablock_storebytes_anywhere_sound; eauto.
+ destruct (am_glob am)!id as [ab0|] eqn:GL.
+ eapply mmatch_glob; eauto.
+ apply ablock_init_sound. eapply mmatch_nonstack; eauto; congruence.
+ eapply DFL; eauto. congruence.
+ + rewrite PTree.gempty in H0; congruence.
+ + eapply DFL; eauto. congruence.
+ + eapply DFL; eauto. congruence.
+ + rewrite PTree.gempty in H0; congruence.
+ + rewrite PTree.gempty in H0; congruence.
+
+- (* Nonstack *)
+ assert (DFL: smatch m' b0 (plub q (am_nonstack am))).
+ { eapply smatch_storebytes; eauto. eapply mmatch_nonstack; eauto. }
+ assert (STK: bc b = BCstack -> smatch m' b0 (am_nonstack am)).
+ { intros. apply smatch_inv with m. eapply mmatch_nonstack; eauto; congruence.
+ intros. eapply Mem.loadbytes_storebytes_other; eauto. left. congruence.
+ }
+ inv PM; (apply DFL || apply STK; congruence).
+
+- (* Top *)
+ eapply smatch_storebytes; eauto. eapply mmatch_top; eauto.
+
+- (* Below *)
+ erewrite Mem.nextblock_storebytes by eauto. eapply mmatch_below; eauto.
+Qed.
+
+Lemma mmatch_ext:
+ forall m am m',
+ mmatch m am ->
+ (forall b ofs n bytes, bc b <> BCinvalid -> n >= 0 -> Mem.loadbytes m' b ofs n = Some bytes -> Mem.loadbytes m b ofs n = Some bytes) ->
+ Ple (Mem.nextblock m) (Mem.nextblock m') ->
+ mmatch m' am.
+Proof.
+ intros. inv H. constructor; intros.
+- apply bmatch_ext with m; auto with va.
+- apply bmatch_ext with m; eauto with va.
+- apply smatch_ext with m; auto with va.
+- apply smatch_ext with m; auto with va.
+- red; intros. exploit mmatch_below0; eauto. xomega.
+Qed.
+
+Lemma mmatch_free:
+ forall m b lo hi m' am,
+ Mem.free m b lo hi = Some m' ->
+ mmatch m am ->
+ mmatch m' am.
+Proof.
+ intros. apply mmatch_ext with m; auto.
+ intros. eapply Mem.loadbytes_free_2; eauto.
+ erewrite <- Mem.nextblock_free by eauto. xomega.
+Qed.
+
+Lemma mmatch_top':
+ forall m am, mmatch m am -> mmatch m mtop.
+Proof.
+ intros. constructor; simpl; intros.
+- apply ablock_init_sound. apply smatch_ge with (ab_summary (am_stack am)).
+ eapply mmatch_stack; eauto. constructor.
+- rewrite PTree.gempty in H1; discriminate.
+- eapply smatch_ge. eapply mmatch_nonstack; eauto. constructor.
+- eapply smatch_ge. eapply mmatch_top; eauto. constructor.
+- eapply mmatch_below; eauto.
+Qed.
+
+(** Boolean equality *)
+
+Definition mbeq (m1 m2: amem) : bool :=
+ eq_aptr m1.(am_top) m2.(am_top)
+ && eq_aptr m1.(am_nonstack) m2.(am_nonstack)
+ && bbeq m1.(am_stack) m2.(am_stack)
+ && PTree.beq bbeq m1.(am_glob) m2.(am_glob).
+
+Lemma mbeq_sound:
+ forall m1 m2, mbeq m1 m2 = true -> forall m, mmatch m m1 <-> mmatch m m2.
+Proof.
+ unfold mbeq; intros. InvBooleans. rewrite PTree.beq_correct in H1.
+ split; intros M; inv M; constructor; intros.
+- erewrite <- bbeq_sound; eauto.
+- specialize (H1 id). rewrite H4 in H1. destruct (am_glob m1)!id eqn:G; try contradiction.
+ erewrite <- bbeq_sound; eauto.
+- rewrite <- H; eauto.
+- rewrite <- H0; eauto.
+- auto.
+- erewrite bbeq_sound; eauto.
+- specialize (H1 id). rewrite H4 in H1. destruct (am_glob m2)!id eqn:G; try contradiction.
+ erewrite bbeq_sound; eauto.
+- rewrite H; eauto.
+- rewrite H0; eauto.
+- auto.
+Qed.
+
+(** Least upper bound *)
+
+Definition combine_ablock (ob1 ob2: option ablock) : option ablock :=
+ match ob1, ob2 with
+ | Some b1, Some b2 => Some (blub b1 b2)
+ | _, _ => None
+ end.
+
+Definition mlub (m1 m2: amem) : amem :=
+{| am_stack := blub m1.(am_stack) m2.(am_stack);
+ am_glob := PTree.combine combine_ablock m1.(am_glob) m2.(am_glob);
+ am_nonstack := plub m1.(am_nonstack) m2.(am_nonstack);
+ am_top := plub m1.(am_top) m2.(am_top) |}.
+
+Lemma mmatch_lub_l:
+ forall m x y, mmatch m x -> mmatch m (mlub x y).
+Proof.
+ intros. inv H. constructor; simpl; intros.
+- apply bmatch_lub_l; auto.
+- rewrite PTree.gcombine in H0 by auto. unfold combine_ablock in H0.
+ destruct (am_glob x)!id as [b1|] eqn:G1;
+ destruct (am_glob y)!id as [b2|] eqn:G2;
+ inv H0.
+ apply bmatch_lub_l; eauto.
+- apply smatch_lub_l; auto.
+- apply smatch_lub_l; auto.
+- auto.
+Qed.
+
+Lemma mmatch_lub_r:
+ forall m x y, mmatch m y -> mmatch m (mlub x y).
+Proof.
+ intros. inv H. constructor; simpl; intros.
+- apply bmatch_lub_r; auto.
+- rewrite PTree.gcombine in H0 by auto. unfold combine_ablock in H0.
+ destruct (am_glob x)!id as [b1|] eqn:G1;
+ destruct (am_glob y)!id as [b2|] eqn:G2;
+ inv H0.
+ apply bmatch_lub_r; eauto.
+- apply smatch_lub_r; auto.
+- apply smatch_lub_r; auto.
+- auto.
+Qed.
+
+End MATCH.
+
+(** * Monotonicity properties when the block classification changes. *)
+
+Lemma genv_match_exten:
+ forall ge (bc1 bc2: block_classification),
+ genv_match bc1 ge ->
+ (forall b id, bc1 b = BCglob id <-> bc2 b = BCglob id) ->
+ (forall b, bc1 b = BCother -> bc2 b = BCother) ->
+ genv_match bc2 ge.
+Proof.
+ intros. destruct H as [A B]. split; intros.
+- rewrite <- H0. eauto.
+- exploit B; eauto. destruct (bc1 b) eqn:BC1.
+ + intuition congruence.
+ + rewrite H0 in BC1. intuition congruence.
+ + intuition congruence.
+ + erewrite H1 by eauto. intuition congruence.
+Qed.
+
+Lemma romatch_exten:
+ forall (bc1 bc2: block_classification) m rm,
+ romatch bc1 m rm ->
+ (forall b id, bc2 b = BCglob id <-> bc1 b = BCglob id) ->
+ romatch bc2 m rm.
+Proof.
+ intros; red; intros. rewrite H0 in H1. exploit H; eauto. intros (A & B & C).
+ split; auto. split; auto.
+ assert (PM: forall b ofs p, pmatch bc1 b ofs p -> pmatch bc1 b ofs (ab_summary ab) -> pmatch bc2 b ofs p).
+ {
+ intros.
+ assert (pmatch bc1 b0 ofs Glob) by (eapply pmatch_ge; eauto).
+ inv H5.
+ assert (bc2 b0 = BCglob id0) by (rewrite H0; auto).
+ inv H3; econstructor; eauto with va.
+ }
+ assert (VM: forall v x, vmatch bc1 v x -> vmatch bc1 v (Ifptr (ab_summary ab)) -> vmatch bc2 v x).
+ {
+ intros. inv H3; constructor; auto; inv H4; eapply PM; eauto.
+ }
+ destruct B as [[B1 B2] B3]. split. split.
+- intros. apply VM; eauto.
+- intros. apply PM; eauto.
+- intros. apply VM; eauto.
+Qed.
+
+Definition bc_incr (bc1 bc2: block_classification) : Prop :=
+ forall b, bc1 b <> BCinvalid -> bc2 b = bc1 b.
+
+Section MATCH_INCR.
+
+Variables bc1 bc2: block_classification.
+Hypothesis INCR: bc_incr bc1 bc2.
+
+Lemma pmatch_incr: forall b ofs p, pmatch bc1 b ofs p -> pmatch bc2 b ofs p.
+Proof.
+ induction 1;
+ assert (bc2 b = bc1 b) by (apply INCR; congruence);
+ econstructor; eauto with va. rewrite H0; eauto.
+Qed.
+
+Lemma vmatch_incr: forall v x, vmatch bc1 v x -> vmatch bc2 v x.
+Proof.
+ induction 1; constructor; auto; apply pmatch_incr; auto.
+Qed.
+
+Lemma smatch_incr: forall m b p, smatch bc1 m b p -> smatch bc2 m b p.
+Proof.
+ intros. destruct H as [A B]. split; intros.
+ apply vmatch_incr; eauto.
+ apply pmatch_incr; eauto.
+Qed.
+
+Lemma bmatch_incr: forall m b ab, bmatch bc1 m b ab -> bmatch bc2 m b ab.
+Proof.
+ intros. destruct H as [B1 B2]. split.
+ apply smatch_incr; auto.
+ intros. apply vmatch_incr; eauto.
+Qed.
+
+End MATCH_INCR.
+
+(** * Matching and memory injections. *)
+
+Definition inj_of_bc (bc: block_classification) : meminj :=
+ fun b => match bc b with BCinvalid => None | _ => Some(b, 0) end.
+
+Lemma inj_of_bc_valid:
+ forall (bc: block_classification) b, bc b <> BCinvalid -> inj_of_bc bc b = Some(b, 0).
+Proof.
+ intros. unfold inj_of_bc. destruct (bc b); congruence.
+Qed.
+
+Lemma inj_of_bc_inv:
+ forall (bc: block_classification) b b' delta,
+ inj_of_bc bc b = Some(b', delta) -> bc b <> BCinvalid /\ b' = b /\ delta = 0.
+Proof.
+ unfold inj_of_bc; intros. destruct (bc b); intuition congruence.
+Qed.
+
+Lemma pmatch_inj:
+ forall bc b ofs p, pmatch bc b ofs p -> inj_of_bc bc b = Some(b, 0).
+Proof.
+ intros. apply inj_of_bc_valid. inv H; congruence.
+Qed.
+
+Lemma vmatch_inj:
+ forall bc v x, vmatch bc v x -> val_inject (inj_of_bc bc) v v.
+Proof.
+ induction 1; econstructor.
+ eapply pmatch_inj; eauto. rewrite Int.add_zero; auto.
+ eapply pmatch_inj; eauto. rewrite Int.add_zero; auto.
+Qed.
+
+Lemma vmatch_list_inj:
+ forall bc vl xl, list_forall2 (vmatch bc) vl xl -> val_list_inject (inj_of_bc bc) vl vl.
+Proof.
+ induction 1; constructor. eapply vmatch_inj; eauto. auto.
+Qed.
+
+Lemma mmatch_inj:
+ forall bc m am, mmatch bc m am -> bc_below bc (Mem.nextblock m) -> Mem.inject (inj_of_bc bc) m m.
+Proof.
+ intros. constructor. constructor.
+- (* perms *)
+ intros. exploit inj_of_bc_inv; eauto. intros (A & B & C); subst.
+ rewrite Zplus_0_r. auto.
+- (* alignment *)
+ intros. exploit inj_of_bc_inv; eauto. intros (A & B & C); subst.
+ apply Zdivide_0.
+- (* contents *)
+ intros. exploit inj_of_bc_inv; eauto. intros (A & B & C); subst.
+ rewrite Zplus_0_r.
+ set (mv := ZMap.get ofs (Mem.mem_contents m)#b1).
+ assert (Mem.loadbytes m b1 ofs 1 = Some (mv :: nil)).
+ {
+ Local Transparent Mem.loadbytes.
+ unfold Mem.loadbytes. rewrite pred_dec_true. reflexivity.
+ red; intros. replace ofs0 with ofs by omega. auto.
+ }
+ destruct mv; econstructor.
+ apply inj_of_bc_valid.
+ assert (PM: pmatch bc b i Ptop).
+ { exploit mmatch_top; eauto. intros [P Q].
+ eapply pmatch_top'. eapply Q; eauto. }
+ inv PM; auto.
+ rewrite Int.add_zero; auto.
+- (* free blocks *)
+ intros. unfold inj_of_bc. erewrite bc_below_invalid; eauto.
+- (* mapped blocks *)
+ intros. exploit inj_of_bc_inv; eauto. intros (A & B & C); subst.
+ apply H0; auto.
+- (* overlap *)
+ red; intros.
+ exploit inj_of_bc_inv. eexact H2. intros (A1 & B & C); subst.
+ exploit inj_of_bc_inv. eexact H3. intros (A2 & B & C); subst.
+ auto.
+- (* overflow *)
+ intros. exploit inj_of_bc_inv; eauto. intros (A & B & C); subst.
+ rewrite Zplus_0_r. split. omega. apply Int.unsigned_range_2.
+Qed.
+
+Lemma inj_of_bc_preserves_globals:
+ forall bc ge, genv_match bc ge -> meminj_preserves_globals ge (inj_of_bc bc).
+Proof.
+ intros. destruct H as [A B].
+ split. intros. apply inj_of_bc_valid. rewrite A in H. congruence.
+ split. intros. apply inj_of_bc_valid. apply B. eapply Genv.genv_vars_range; eauto.
+ intros. exploit inj_of_bc_inv; eauto. intros (P & Q & R). auto.
+Qed.
+
+Lemma pmatch_inj_top:
+ forall bc b b' delta ofs, inj_of_bc bc b = Some(b', delta) -> pmatch bc b ofs Ptop.
+Proof.
+ intros. exploit inj_of_bc_inv; eauto. intros (A & B & C). constructor; auto.
+Qed.
+
+Lemma vmatch_inj_top:
+ forall bc v v', val_inject (inj_of_bc bc) v v' -> vmatch bc v Vtop.
+Proof.
+ intros. inv H; constructor. eapply pmatch_inj_top; eauto.
+Qed.
+
+Lemma mmatch_inj_top:
+ forall bc m m', Mem.inject (inj_of_bc bc) m m' -> mmatch bc m mtop.
+Proof.
+ intros.
+ assert (SM: forall b, bc b <> BCinvalid -> smatch bc m b Ptop).
+ {
+ intros; split; intros.
+ - exploit Mem.load_inject. eauto. eauto. apply inj_of_bc_valid; auto.
+ intros (v' & A & B). eapply vmatch_inj_top; eauto.
+ - exploit Mem.loadbytes_inject. eauto. eauto. apply inj_of_bc_valid; auto.
+ intros (bytes' & A & B). inv B. inv H4. eapply pmatch_inj_top; eauto.
+ }
+ constructor; simpl; intros.
+ - apply ablock_init_sound. apply SM. congruence.
+ - rewrite PTree.gempty in H1; discriminate.
+ - apply SM; auto.
+ - apply SM; auto.
+ - red; intros. eapply Mem.valid_block_inject_1. eapply inj_of_bc_valid; eauto. eauto.
+Qed.
+
+(** * Abstracting RTL register environments *)
+
+Module AVal <: SEMILATTICE_WITH_TOP.
+
+ Definition t := aval.
+ 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).
+ Definition beq (x y: t) : bool := proj_sumbool (eq_aval x y).
+ Lemma beq_correct: forall x y, beq x y = true -> eq x y.
+ Proof. unfold beq; intros. InvBooleans. auto. Qed.
+ Definition ge := vge.
+ Lemma ge_refl: forall x y, eq x y -> ge x y.
+ Proof. unfold eq, ge; intros. subst y. apply vge_refl. Qed.
+ Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
+ Proof. unfold ge; intros. eapply vge_trans; eauto. Qed.
+ Definition bot : t := Vbot.
+ Lemma ge_bot: forall x, ge x bot.
+ Proof. intros. constructor. Qed.
+ Definition top : t := Vtop.
+ Lemma ge_top: forall x, ge top x.
+ Proof. intros. apply vge_top. Qed.
+ Definition lub := vlub.
+ Lemma ge_lub_left: forall x y, ge (lub x y) x.
+ Proof vge_lub_l.
+ Lemma ge_lub_right: forall x y, ge (lub x y) y.
+ Proof vge_lub_r.
+End AVal.
+
+Module AE := LPMap(AVal).
+
+Definition aenv := AE.t.
+
+Section MATCHENV.
+
+Variable bc: block_classification.
+
+Definition ematch (e: regset) (ae: aenv) : Prop :=
+ forall r, vmatch bc e#r (AE.get r ae).
+
+Lemma ematch_ge:
+ forall e ae1 ae2,
+ ematch e ae1 -> AE.ge ae2 ae1 -> ematch e ae2.
+Proof.
+ intros; red; intros. apply vmatch_ge with (AE.get r ae1); auto. apply H0.
+Qed.
+
+Lemma ematch_update:
+ forall e ae v av r,
+ ematch e ae -> vmatch bc v av -> ematch (e#r <- v) (AE.set r av ae).
+Proof.
+ intros; red; intros. rewrite AE.gsspec. rewrite PMap.gsspec.
+ destruct (peq r0 r); auto.
+ red; intros. specialize (H xH). subst ae. simpl in H. inv H.
+ unfold AVal.eq; red; intros. subst av. inv H0.
+Qed.
+
+Fixpoint einit_regs (rl: list reg) : aenv :=
+ match rl with
+ | r1 :: rs => AE.set r1 (Ifptr Nonstack) (einit_regs rs)
+ | nil => AE.top
+ end.
+
+Lemma ematch_init:
+ forall rl vl,
+ (forall v, In v vl -> vmatch bc v (Ifptr Nonstack)) ->
+ ematch (init_regs vl rl) (einit_regs rl).
+Proof.
+ induction rl; simpl; intros.
+- red; intros. rewrite Regmap.gi. simpl AE.get. rewrite PTree.gempty.
+ constructor.
+- destruct vl as [ | v1 vs ].
+ + assert (ematch (init_regs nil rl) (einit_regs rl)).
+ { apply IHrl. simpl; tauto. }
+ replace (init_regs nil rl) with (Regmap.init Vundef) in H0 by (destruct rl; auto).
+ red; intros. rewrite AE.gsspec. destruct (peq r a).
+ rewrite Regmap.gi. constructor.
+ apply H0.
+ red; intros EQ; rewrite EQ in H0. specialize (H0 xH). simpl in H0. inv H0.
+ unfold AVal.eq, AVal.bot. congruence.
+ + assert (ematch (init_regs vs rl) (einit_regs rl)).
+ { apply IHrl. eauto with coqlib. }
+ red; intros. rewrite Regmap.gsspec. rewrite AE.gsspec. destruct (peq r a).
+ auto with coqlib.
+ apply H0.
+ red; intros EQ; rewrite EQ in H0. specialize (H0 xH). simpl in H0. inv H0.
+ unfold AVal.eq, AVal.bot. congruence.
+Qed.
+
+Fixpoint eforget (rl: list reg) (ae: aenv) {struct rl} : aenv :=
+ match rl with
+ | nil => ae
+ | r1 :: rs => eforget rs (AE.set r1 Vtop ae)
+ end.
+
+Lemma eforget_ge:
+ forall rl ae, AE.ge (eforget rl ae) ae.
+Proof.
+ unfold AE.ge; intros. revert rl ae; induction rl; intros; simpl.
+ apply AVal.ge_refl. apply AVal.eq_refl.
+ destruct ae. unfold AE.get at 2. apply AVal.ge_bot.
+ eapply AVal.ge_trans. apply IHrl. rewrite AE.gsspec.
+ destruct (peq p a). apply AVal.ge_top. apply AVal.ge_refl. apply AVal.eq_refl.
+ congruence.
+ unfold AVal.eq, Vtop, AVal.bot. congruence.
+Qed.
+
+Lemma ematch_forget:
+ forall e rl ae, ematch e ae -> ematch e (eforget rl ae).
+Proof.
+ intros. eapply ematch_ge; eauto. apply eforget_ge.
+Qed.
+
+End MATCHENV.
+
+Lemma ematch_incr:
+ forall bc bc' e ae, ematch bc e ae -> bc_incr bc bc' -> ematch bc' e ae.
+Proof.
+ intros; red; intros. apply vmatch_incr with bc; auto.
+Qed.
+
+(** * Lattice for dataflow analysis *)
+
+Module VA <: SEMILATTICE.
+
+ Inductive t' := Bot | State (ae: aenv) (am: amem).
+ Definition t := t'.
+
+ Definition eq (x y: t) :=
+ match x, y with
+ | Bot, Bot => True
+ | State ae1 am1, State ae2 am2 =>
+ AE.eq ae1 ae2 /\ forall bc m, mmatch bc m am1 <-> mmatch bc m am2
+ | _, _ => False
+ end.
+
+ Lemma eq_refl: forall x, eq x x.
+ Proof.
+ destruct x; simpl. auto. split. apply AE.eq_refl. tauto.
+ Qed.
+ Lemma eq_sym: forall x y, eq x y -> eq y x.
+ Proof.
+ destruct x, y; simpl; auto. intros [A B].
+ split. apply AE.eq_sym; auto. intros. rewrite B. tauto.
+ Qed.
+ Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
+ Proof.
+ destruct x, y, z; simpl; try tauto. intros [A B] [C D]; split.
+ eapply AE.eq_trans; eauto.
+ intros. rewrite B; auto.
+ Qed.
+
+ Definition beq (x y: t) : bool :=
+ match x, y with
+ | Bot, Bot => true
+ | State ae1 am1, State ae2 am2 => AE.beq ae1 ae2 && mbeq am1 am2
+ | _, _ => false
+ end.
+
+ Lemma beq_correct: forall x y, beq x y = true -> eq x y.
+ Proof.
+ destruct x, y; simpl; intros.
+ auto.
+ congruence.
+ congruence.
+ InvBooleans; split.
+ apply AE.beq_correct; auto.
+ intros. apply mbeq_sound; auto.
+ Qed.
+
+ Definition ge (x y: t) : Prop :=
+ match x, y with
+ | _, Bot => True
+ | Bot, _ => False
+ | State ae1 am1, State ae2 am2 => AE.ge ae1 ae2 /\ forall bc m, mmatch bc m am2 -> mmatch bc m am1
+ end.
+
+ Lemma ge_refl: forall x y, eq x y -> ge x y.
+ Proof.
+ destruct x, y; simpl; try tauto. intros [A B]; split.
+ apply AE.ge_refl; auto.
+ intros. rewrite B; auto.
+ Qed.
+ Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
+ Proof.
+ destruct x, y, z; simpl; try tauto. intros [A B] [C D]; split.
+ eapply AE.ge_trans; eauto.
+ eauto.
+ Qed.
+
+ Definition bot : t := Bot.
+ Lemma ge_bot: forall x, ge x bot.
+ Proof.
+ destruct x; simpl; auto.
+ Qed.
+
+ Definition lub (x y: t) : t :=
+ match x, y with
+ | Bot, _ => y
+ | _, Bot => x
+ | State ae1 am1, State ae2 am2 => State (AE.lub ae1 ae2) (mlub am1 am2)
+ end.
+
+ Lemma ge_lub_left: forall x y, ge (lub x y) x.
+ Proof.
+ destruct x, y.
+ apply ge_refl; apply eq_refl.
+ simpl. auto.
+ apply ge_refl; apply eq_refl.
+ simpl. split. apply AE.ge_lub_left. intros; apply mmatch_lub_l; auto.
+ Qed.
+ Lemma ge_lub_right: forall x y, ge (lub x y) y.
+ Proof.
+ destruct x, y.
+ apply ge_refl; apply eq_refl.
+ apply ge_refl; apply eq_refl.
+ simpl. auto.
+ simpl. split. apply AE.ge_lub_right. intros; apply mmatch_lub_r; auto.
+ Qed.
+
+End VA.
+
+Hint Constructors cmatch : va.
+Hint Constructors pmatch: va.
+Hint Constructors vmatch : va.
+Hint Resolve cnot_sound symbol_address_sound
+ shl_sound shru_sound shr_sound
+ and_sound or_sound xor_sound notint_sound
+ ror_sound rolm_sound
+ neg_sound add_sound sub_sound
+ mul_sound mulhs_sound mulhu_sound
+ divs_sound divu_sound mods_sound modu_sound shrx_sound
+ negf_sound absf_sound
+ addf_sound subf_sound mulf_sound divf_sound
+ zero_ext_sound sign_ext_sound singleoffloat_sound
+ intoffloat_sound intuoffloat_sound floatofint_sound floatofintu_sound
+ longofwords_sound loword_sound hiword_sound
+ cmpu_bool_sound cmp_bool_sound cmpf_bool_sound maskzero_sound : va.
diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v
index 36a62a8..79dd26f 100644
--- a/cfrontend/Cexec.v
+++ b/cfrontend/Cexec.v
@@ -205,7 +205,7 @@ Definition do_volatile_store (w: world) (chunk: memory_chunk) (m: mem) (b: block
: option (world * trace * mem) :=
if block_is_volatile ge b then
do id <- Genv.invert_symbol ge b;
- do ev <- eventval_of_val v (type_of_chunk chunk);
+ do ev <- eventval_of_val (Val.load_result chunk v) (type_of_chunk chunk);
do w' <- nextworld_vstore w chunk id ofs ev;
Some(w', Event_vstore chunk id ofs ev :: nil, m)
else
diff --git a/cfrontend/Cminorgen.v b/cfrontend/Cminorgen.v
index 419ffff..3b902c5 100644
--- a/cfrontend/Cminorgen.v
+++ b/cfrontend/Cminorgen.v
@@ -55,220 +55,50 @@ Local Open Scope error_monad_scope.
Definition compilenv := PTree.t Z.
-(** * Helper functions for code generation *)
-
-(** When the translation of an expression is stored in memory,
- 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. *)
-
-Function uncast_int (m: int) (e: expr) {struct e} : expr :=
- match e with
- | Eunop (Ocast8unsigned|Ocast8signed) e1 =>
- if Int.eq (Int.and (Int.repr 255) m) m then uncast_int m e1 else e
- | Eunop (Ocast16unsigned|Ocast16signed) e1 =>
- if Int.eq (Int.and (Int.repr 65535) m) m then uncast_int m e1 else e
- | Ebinop Oand e1 (Econst (Ointconst n)) =>
- if Int.eq (Int.and n m) m then uncast_int m e1 else e
- | Ebinop Oshru e1 (Econst (Ointconst n)) =>
- if Int.eq (Int.shru (Int.shl m n) n) m
- then Ebinop Oshru (uncast_int (Int.shl m n) e1) (Econst (Ointconst n))
- else e
- | Ebinop Oshr e1 (Econst (Ointconst n)) =>
- if Int.eq (Int.shru (Int.shl m n) n) m
- then Ebinop Oshr (uncast_int (Int.shl m n) e1) (Econst (Ointconst n))
- else e
- | _ => e
- end.
-
-Definition uncast_int8 (e: expr) : expr := uncast_int (Int.repr 255) e.
-
-Definition uncast_int16 (e: expr) : expr := uncast_int (Int.repr 65535) e.
-
-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.
-
-Definition make_store (chunk: memory_chunk) (e1 e2: expr): stmt :=
- Sstore chunk e1 (store_arg chunk e2).
-
-Definition make_stackaddr (ofs: Z): expr :=
- Econst (Oaddrstack (Int.repr ofs)).
-
-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 *)
- | Int1 (**r [0] or [1] *)
- | 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
- | Int1, Int1 => true
- | Int7, (Int1 | Int7) => true
- | Int8s, (Int1 | Int7 | Int8s) => true
- | Int8u, (Int1 | Int7 | Int8u) => true
- | Int15, (Int1 | Int7 | Int8u | Int15) => true
- | Int16s, (Int1 | Int7 | Int8s | Int8u | Int15 | Int16s) => true
- | Int16u, (Int1 | Int7 | Int8u | Int15 | Int16u) => true
- | Float32, Float32 => true
- | _, _ => false
- end.
-
-Definition of_int (n: int) :=
- if Int.eq_dec n Int.zero || Int.eq_dec n Int.one then Int1
- else 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
- | Mint64 => Any
- | Mfloat32 => Float32
- | Mfloat64 => Any
- | Mfloat64al32 => Any
- end.
-
-Definition unop (op: unary_operation) (a: approx) :=
- match op with
- | Ocast8unsigned => Int8u
- | Ocast8signed => Int8s
- | Ocast16unsigned => Int16u
- | Ocast16signed => Int16s
- | Osingleoffloat => Float32
- | _ => 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 Int1 a1 || bge Int1 a2 then Int1
- else 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 Int1 a1 && bge Int1 a2 then Int1
- else 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 _ => Int1
- | Ocmpu _ => Int1
- | Ocmpf _ => Int1
- | _ => Any
- end.
-
-End Approx.
-
-(** * Translation of expressions and statements. *)
-
(** Generation of a Cminor expression for taking the address of
a Csharpminor variable. *)
Definition var_addr (cenv: compilenv) (id: ident): expr :=
match PTree.get id cenv with
- | Some ofs => make_stackaddr ofs
- | None => make_globaladdr id
+ | Some ofs => Econst (Oaddrstack (Int.repr ofs))
+ | None => Econst (Oaddrsymbol id Int.zero)
end.
+(** * Translation of expressions and statements. *)
+
(** Translation of constants. *)
-Definition transl_constant (cst: Csharpminor.constant): (constant * approx) :=
+Definition transl_constant (cst: Csharpminor.constant): constant :=
match cst with
| Csharpminor.Ointconst n =>
- (Ointconst n, Approx.of_int n)
+ Ointconst n
| Csharpminor.Ofloatconst n =>
- (Ofloatconst n, Approx.of_float n)
+ Ofloatconst n
| Csharpminor.Olongconst n =>
- (Olongconst n, Any)
+ Olongconst n
end.
-(** 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. *)
+(** Translation of expressions. *)
Fixpoint transl_expr (cenv: compilenv) (e: Csharpminor.expr)
- {struct e}: res (expr * approx) :=
+ {struct e}: res expr :=
match e with
| Csharpminor.Evar id =>
- OK (Evar id, Any)
+ OK (Evar id)
| Csharpminor.Eaddrof id =>
- OK (var_addr cenv id, Any)
+ OK (var_addr cenv id)
| Csharpminor.Econst cst =>
- let (tcst, a) := transl_constant cst in OK (Econst tcst, a)
+ OK (Econst (transl_constant cst))
| Csharpminor.Eunop op e1 =>
- 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)
+ do te1 <- transl_expr cenv e1;
+ OK (Eunop op te1)
| Csharpminor.Ebinop op e1 e2 =>
- do (te1, a1) <- transl_expr cenv e1;
- do (te2, a2) <- transl_expr cenv e2;
- OK (Ebinop op te1 te2, Approx.binop op a1 a2)
+ do te1 <- transl_expr cenv e1;
+ do te2 <- transl_expr cenv e2;
+ OK (Ebinop op te1 te2)
| Csharpminor.Eload chunk e =>
- do (te, a) <- transl_expr cenv e;
- OK (Eload chunk te, Approx.of_chunk chunk)
+ do te <- transl_expr cenv e;
+ OK (Eload chunk te)
end.
Fixpoint transl_exprlist (cenv: compilenv) (el: list Csharpminor.expr)
@@ -277,7 +107,7 @@ Fixpoint transl_exprlist (cenv: compilenv) (el: list Csharpminor.expr)
| nil =>
OK nil
| e1 :: e2 =>
- do (te1, a1) <- transl_expr cenv e1;
+ do te1 <- transl_expr cenv e1;
do te2 <- transl_exprlist cenv e2;
OK (te1 :: te2)
end.
@@ -331,14 +161,14 @@ Fixpoint transl_stmt (cenv: compilenv) (xenv: exit_env) (s: Csharpminor.stmt)
| Csharpminor.Sskip =>
OK Sskip
| Csharpminor.Sset id e =>
- do (te, a) <- transl_expr cenv e;
+ do te <- transl_expr cenv e;
OK (Sassign id te)
| Csharpminor.Sstore chunk e1 e2 =>
- do (te1, a1) <- transl_expr cenv e1;
- do (te2, a2) <- transl_expr cenv e2;
- OK (make_store chunk te1 te2)
+ do te1 <- transl_expr cenv e1;
+ do te2 <- transl_expr cenv e2;
+ OK (Sstore chunk te1 te2)
| Csharpminor.Scall optid sig e el =>
- do (te, a) <- transl_expr cenv e;
+ do te <- transl_expr cenv e;
do tel <- transl_exprlist cenv el;
OK (Scall optid sig te tel)
| Csharpminor.Sbuiltin optid ef el =>
@@ -349,7 +179,7 @@ Fixpoint transl_stmt (cenv: compilenv) (xenv: exit_env) (s: Csharpminor.stmt)
do ts2 <- transl_stmt cenv xenv s2;
OK (Sseq ts1 ts2)
| Csharpminor.Sifthenelse e s1 s2 =>
- do (te, a) <- transl_expr cenv e;
+ do te <- transl_expr cenv e;
do ts1 <- transl_stmt cenv xenv s1;
do ts2 <- transl_stmt cenv xenv s2;
OK (Sifthenelse te ts1 ts2)
@@ -364,12 +194,12 @@ Fixpoint transl_stmt (cenv: compilenv) (xenv: exit_env) (s: Csharpminor.stmt)
| Csharpminor.Sswitch e ls =>
let cases := switch_table ls O in
let default := length cases in
- do (te, a) <- transl_expr cenv e;
+ do te <- transl_expr cenv e;
transl_lblstmt cenv (switch_env ls xenv) ls (Sswitch te cases default)
| Csharpminor.Sreturn None =>
OK (Sreturn None)
| Csharpminor.Sreturn (Some e) =>
- do (te, a) <- transl_expr cenv e;
+ do te <- transl_expr cenv e;
OK (Sreturn (Some te))
| Csharpminor.Slabel lbl s =>
do ts <- transl_stmt cenv xenv s; OK (Slabel lbl ts)
diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v
index 672f804..78ec748 100644
--- a/cfrontend/Cminorgenproof.v
+++ b/cfrontend/Cminorgenproof.v
@@ -1252,226 +1252,6 @@ Proof.
eapply bind_parameters_agree; eauto.
Qed.
-(** * Properties of compile-time approximations of values *)
-
-Definition val_match_approx (a: approx) (v: val) : Prop :=
- match a with
- | Int1 => v = Val.zero_ext 1 v
- | 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 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. omega.
- 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. omega.
- 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. omega.
- assert (D: forall v, v = Val.zero_ext 1 v -> v = Val.zero_ext 8 v).
- intros. rewrite H.
- destruct v; simpl; auto. decEq. symmetry.
- apply Int.zero_ext_widen. omega.
- assert (E: forall v, v = Val.zero_ext 1 v -> v = Val.sign_ext 8 v).
- intros. rewrite H.
- destruct v; simpl; auto. decEq. symmetry.
- apply Int.sign_zero_ext_widen. omega.
- intros.
- unfold Approx.bge in H; destruct a1; try discriminate; destruct a2; simpl in *; try discriminate; intuition.
-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); simpl. subst; auto.
- destruct (Int.eq_dec n Int.one); simpl. subst; auto.
- destruct (Int.eq_dec n (Int.zero_ext 7 n)). simpl.
- split.
- decEq. rewrite e. symmetry. apply Int.zero_ext_widen. omega.
- decEq. rewrite e. symmetry. apply Int.sign_zero_ext_widen. omega.
- 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. omega.
- decEq. rewrite e. symmetry. apply Int.sign_zero_ext_widen. omega.
- 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.
- unfold Approx.of_float; intros.
- destruct (Float.eq_dec f (Float.singleoffloat f)); simpl; auto. congruence.
-Qed.
-
-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.
- intros. exploit Mem.load_cast; eauto.
- destruct chunk; intros; simpl; auto.
-Qed.
-
-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. omega.
- destruct v1; simpl; auto. rewrite Int.sign_ext_idem; auto. omega.
- destruct v1; simpl; auto. rewrite Int.zero_ext_idem; auto. omega.
- destruct v1; simpl; auto. rewrite Int.sign_ext_idem; auto. omega.
- 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.
- assert (R: forall a v, val_match_approx a v -> Approx.bge Int1 a = true ->
- v = Val.zero_ext 1 v).
- intros. apply (val_match_approx_increasing Int1 a v); auto.
-
- intros; unfold Approx.bitwise_and.
- destruct (Approx.bge Int1 a1) eqn:?. simpl. apply Y; eauto. compute; auto.
- destruct (Approx.bge Int1 a2) eqn:?. simpl. apply X; eauto. compute; auto.
- destruct (Approx.bge Int8u a1) eqn:?. simpl. apply Y; eauto. compute; auto.
- destruct (Approx.bge Int8u a2) eqn:?. simpl. apply X; eauto. compute; auto.
- destruct (Approx.bge Int16u a1) eqn:?. simpl. apply Y; eauto. compute; auto.
- destruct (Approx.bge Int16u a2) 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 Int1 a1 && Approx.bge Int1 a2) eqn:?.
- destruct (andb_prop _ _ Heqb).
- simpl. apply X. compute; auto.
- apply (val_match_approx_increasing Int1 a1 v1); auto.
- apply (val_match_approx_increasing Int1 a2 v2); auto.
-
- destruct (Approx.bge Int8u a1 && Approx.bge Int8u a2) eqn:?.
- destruct (andb_prop _ _ Heqb0).
- 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) eqn:?.
- destruct (andb_prop _ _ Heqb1).
- 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 Int1 (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:
@@ -1622,363 +1402,6 @@ Qed.
(** * Correctness of Cminor construction functions *)
-Lemma make_stackaddr_correct:
- forall sp te tm ofs,
- eval_expr tge (Vptr sp Int.zero) te tm
- (make_stackaddr ofs) (Vptr sp (Int.repr ofs)).
-Proof.
- intros; unfold make_stackaddr.
- eapply eval_Econst. simpl. decEq. decEq.
- rewrite Int.add_commut. apply Int.add_zero.
-Qed.
-
-Lemma make_globaladdr_correct:
- forall sp te tm id b,
- Genv.find_symbol tge id = Some b ->
- eval_expr tge (Vptr sp Int.zero) te tm
- (make_globaladdr id) (Vptr b Int.zero).
-Proof.
- intros; unfold make_globaladdr.
- eapply eval_Econst. simpl. rewrite H. auto.
-Qed.
-
-(** Correctness of [make_store]. *)
-
-Inductive val_lessdef_upto (m: int): val -> val -> Prop :=
- | val_lessdef_upto_base:
- forall v1 v2, Val.lessdef v1 v2 -> val_lessdef_upto m v1 v2
- | val_lessdef_upto_int:
- forall n1 n2, Int.and n1 m = Int.and n2 m -> val_lessdef_upto m (Vint n1) (Vint n2).
-
-Hint Resolve val_lessdef_upto_base.
-
-Remark val_lessdef_upto_and:
- forall m v1 v2 p,
- val_lessdef_upto m v1 v2 -> Int.and p m = m ->
- val_lessdef_upto m (Val.and v1 (Vint p)) v2.
-Proof.
- intros. inversion H; clear H.
- inversion H1. destruct v2; simpl; auto.
- apply val_lessdef_upto_int. rewrite Int.and_assoc. congruence.
- simpl. auto.
- simpl. apply val_lessdef_upto_int. rewrite Int.and_assoc. congruence.
-Qed.
-
-Remark val_lessdef_upto_zero_ext:
- forall m v1 v2 p,
- val_lessdef_upto m v1 v2 -> Int.and (Int.repr (two_p p - 1)) m = m -> 0 < p < 32 ->
- val_lessdef_upto m (Val.zero_ext p v1) v2.
-Proof.
- intros. inversion H; clear H.
- inversion H2. destruct v2; simpl; auto.
- apply val_lessdef_upto_int. rewrite Int.zero_ext_and; auto.
- rewrite Int.and_assoc. rewrite H0. auto.
- omega.
- simpl; auto.
- simpl. apply val_lessdef_upto_int. rewrite Int.zero_ext_and; auto.
- rewrite Int.and_assoc. rewrite H0. auto. omega.
-Qed.
-
-Remark val_lessdef_upto_sign_ext:
- forall m v1 v2 p,
- val_lessdef_upto m v1 v2 -> Int.and (Int.repr (two_p p - 1)) m = m -> 0 < p < 32 ->
- val_lessdef_upto m (Val.sign_ext p v1) v2.
-Proof.
- intros.
- assert (A: forall x, Int.and (Int.sign_ext p x) m = Int.and x m).
- intros. transitivity (Int.and (Int.zero_ext p (Int.sign_ext p x)) m).
- rewrite Int.zero_ext_and; auto. rewrite Int.and_assoc. congruence. omega.
- rewrite Int.zero_ext_sign_ext.
- rewrite Int.zero_ext_and; auto. rewrite Int.and_assoc. congruence. omega. omega.
- inversion H; clear H.
- inversion H2. destruct v2; simpl; auto.
- apply val_lessdef_upto_int. auto.
- simpl; auto.
- simpl. apply val_lessdef_upto_int. rewrite A. auto.
-Qed.
-
-Remark val_lessdef_upto_shru:
- forall m v1 v2 p,
- val_lessdef_upto (Int.shl m p) v1 v2 -> Int.shru (Int.shl m p) p = m ->
- val_lessdef_upto m (Val.shru v1 (Vint p)) (Val.shru v2 (Vint p)).
-Proof.
- intros. inversion H; clear H.
- inversion H1; simpl; auto.
- simpl. destruct (Int.ltu p Int.iwordsize); auto. apply val_lessdef_upto_int.
- rewrite <- H0. repeat rewrite Int.and_shru. congruence.
-Qed.
-
-Remark val_lessdef_upto_shr:
- forall m v1 v2 p,
- val_lessdef_upto (Int.shl m p) v1 v2 -> Int.shru (Int.shl m p) p = m ->
- val_lessdef_upto m (Val.shr v1 (Vint p)) (Val.shr v2 (Vint p)).
-Proof.
- intros. inversion H; clear H.
- inversion H1; simpl; auto.
- simpl. destruct (Int.ltu p Int.iwordsize); auto. apply val_lessdef_upto_int.
- repeat rewrite Int.shr_and_shru_and; auto.
- rewrite <- H0. repeat rewrite Int.and_shru. congruence.
-Qed.
-
-Lemma eval_uncast_int:
- forall m sp te tm a x,
- eval_expr tge sp te tm a x ->
- exists v, eval_expr tge sp te tm (uncast_int m a) v /\ val_lessdef_upto m x v.
-Proof.
- assert (EQ: forall p q, Int.eq p q = true -> p = q).
- intros. generalize (Int.eq_spec p q). rewrite H; auto.
- intros until a. functional induction (uncast_int m 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.
- exists x; 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.
- exists x; 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.
- exists x; 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.
- exists x; auto.
- (* and *)
- inv H. simpl in H6; inv H6. inv H5. simpl in H0. inv H0.
- exploit IHe; eauto. intros [v [A B]].
- exists v; split; auto. apply val_lessdef_upto_and; auto.
- exists x; auto.
- (* shru *)
- inv H. simpl in H6; inv H6. inv H5. simpl in H0. inv H0.
- exploit IHe; eauto. intros [v [A B]].
- exists (Val.shru v (Vint n)); split.
- econstructor. eauto. econstructor. simpl; reflexivity. auto.
- apply val_lessdef_upto_shru; auto.
- exists x; auto.
- (* shr *)
- inv H. simpl in H6; inv H6. inv H5. simpl in H0. inv H0.
- exploit IHe; eauto. intros [v [A B]].
- exists (Val.shr v (Vint n)); split.
- econstructor. eauto. econstructor. simpl; reflexivity. auto.
- apply val_lessdef_upto_shr; auto.
- exists x; 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 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 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 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 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 ->
- val_content_inject f chunk v1 v2.
-
-Hint Resolve val_content_inject_base.
-
-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 ->
- exists vb,
- eval_expr tge sp te tm (store_arg chunk a) vb
- /\ val_content_inject f chunk v vb.
-Proof.
- 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_int (Int.repr 255)); 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. omega.
- repeat rewrite Int.zero_ext_and; auto. omega. omega.
- (* int8unsigned *)
- exploit (eval_uncast_int (Int.repr 255)); eauto. intros [v' [A B]].
- exists v'; split; auto.
- inv B; auto. inv H0; auto. constructor.
- repeat rewrite Int.zero_ext_and; auto. omega. omega.
- (* int16signed *)
- exploit (eval_uncast_int (Int.repr 65535)); 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. omega.
- repeat rewrite Int.zero_ext_and; auto. omega. omega.
- (* int16unsigned *)
- exploit (eval_uncast_int (Int.repr 65535)); eauto. intros [v' [A B]].
- exists v'; split; auto.
- inv B; auto. inv H0; auto. constructor.
- repeat rewrite Int.zero_ext_and; auto. omega. omega.
- (* int32 *)
- exists va; auto.
- (* int64 *)
- 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.
- (* float64al32 *)
- 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 ->
- val_inject f a1 a2 ->
- val_content_inject f chunk v1 v2 ->
- exists n2,
- Mem.storev chunk m2 a2 v2 = Some n2 /\ Mem.inject f n1 n2.
-Proof.
- intros.
- assert (forall v1',
- (forall b ofs, Mem.store chunk m1 b ofs v1 = Mem.store chunk m1 b ofs v1') ->
- Mem.storev chunk m1 a1 v1' = Some n1).
- intros. rewrite <- H0. destruct a1; simpl; auto.
- inv H2; eapply Mem.storev_mapped_inject;
- try eapply H; try eapply H1; try apply H3; intros.
- rewrite <- Mem.store_int8_sign_ext. rewrite H4. apply Mem.store_int8_sign_ext.
- auto.
- rewrite <- Mem.store_int8_zero_ext. rewrite H4. apply Mem.store_int8_zero_ext.
- auto.
- rewrite <- Mem.store_int16_sign_ext. rewrite H4. apply Mem.store_int16_sign_ext.
- auto.
- rewrite <- Mem.store_int16_zero_ext. rewrite H4. apply Mem.store_int16_zero_ext.
- auto.
- rewrite <- Mem.store_float32_truncate. rewrite H4. apply Mem.store_float32_truncate.
- auto.
- eauto.
- auto.
-Qed.
-
-Lemma make_store_correct:
- forall f sp te tm addr tvaddr rhs tvrhs chunk m vaddr vrhs m' fn k,
- eval_expr tge sp te tm addr tvaddr ->
- eval_expr tge sp te tm rhs tvrhs ->
- Mem.storev chunk m vaddr vrhs = Some m' ->
- Mem.inject f m tm ->
- val_inject f vaddr tvaddr ->
- val_inject f vrhs tvrhs ->
- exists tm', exists tvrhs',
- step tge (State fn (make_store chunk addr rhs) k sp te tm)
- E0 (State fn Sskip k sp te tm')
- /\ Mem.storev chunk tm tvaddr tvrhs' = Some tm'
- /\ Mem.inject f m' tm'.
-Proof.
- intros. unfold make_store.
- exploit eval_store_arg. eexact H0. eauto.
- intros [tv [EVAL VCINJ]].
- 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_int (Int.repr 255)); eauto. intros [v1 [A B]].
- exists (Val.zero_ext 8 v1); split. econstructor; eauto.
- inv B. apply Val.zero_ext_lessdef; auto. simpl.
- repeat rewrite Int.zero_ext_and; auto.
- change (two_p 8 - 1) with 255. rewrite H0. auto.
- omega. omega.
-(* cast8signed *)
- exploit (eval_uncast_int (Int.repr 255)); eauto. intros [v1 [A B]].
- exists (Val.sign_ext 8 v1); split. econstructor; eauto.
- inv B. apply Val.sign_ext_lessdef; auto. simpl.
- replace (Int.sign_ext 8 n2) with (Int.sign_ext 8 n1). auto.
- apply Int.sign_ext_equal_if_zero_equal; auto. omega.
- repeat rewrite Int.zero_ext_and; auto. omega. omega.
-(* cast16unsigned *)
- exploit (eval_uncast_int (Int.repr 65535)); eauto. intros [v1 [A B]].
- exists (Val.zero_ext 16 v1); split. econstructor; eauto.
- inv B. apply Val.zero_ext_lessdef; auto. simpl.
- repeat rewrite Int.zero_ext_and; auto.
- change (two_p 16 - 1) with 65535. rewrite H0. auto.
- omega. omega.
-(* cast16signed *)
- exploit (eval_uncast_int (Int.repr 65535)); eauto. intros [v1 [A B]].
- exists (Val.sign_ext 16 v1); split. econstructor; eauto.
- inv B. apply Val.sign_ext_lessdef; auto. simpl.
- replace (Int.sign_ext 16 n2) with (Int.sign_ext 16 n1). auto.
- apply Int.sign_ext_equal_if_zero_equal; auto. omega.
- repeat rewrite Int.zero_ext_and; auto. omega. omega.
-(* 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 accessor [var_addr] *)
Lemma var_addr_correct:
@@ -1995,12 +1418,12 @@ Proof.
inv H1; inv H0; try congruence.
(* local *)
exists (Vptr sp (Int.repr ofs)); split.
- eapply make_stackaddr_correct.
+ constructor. simpl. rewrite Int.add_zero_l; auto.
congruence.
(* global *)
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.
+ constructor. simpl. rewrite symbols_preserved. rewrite H2. auto.
econstructor; eauto.
Qed.
@@ -2040,16 +1463,14 @@ 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.
+ eval_constant tge sp (transl_constant cst) = Some tv
+ /\ val_inject f v tv.
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.
- exists (Vlong i); intuition.
+ exists (Vint i); auto.
+ exists (Vfloat f0); auto.
+ exists (Vlong i); auto.
Qed.
Lemma transl_expr_correct:
@@ -2060,46 +1481,34 @@ Lemma transl_expr_correct:
(Mem.nextblock m) (Mem.nextblock tm)),
forall a v,
Csharpminor.eval_expr ge e le m a v ->
- forall ta app
- (TR: transl_expr cenv a = OK (ta, app)),
+ forall ta
+ (TR: transl_expr cenv a = OK ta),
exists tv,
eval_expr tge (Vptr sp Int.zero) te tm ta tv
- /\ val_inject f v tv
- /\ val_match_approx app v.
+ /\ val_inject f v tv.
Proof.
induction 3; intros; simpl in TR; try (monadInv TR).
(* Etempvar *)
inv MATCH. exploit MTMP; eauto. intros [tv [A B]].
- exists tv; split. constructor; auto. split. auto. exact I.
+ exists tv; split. constructor; auto. auto.
(* Eaddrof *)
- exploit var_addr_correct; eauto. intros [tv [A B]].
- exists tv; split. auto. split. auto. red. auto.
+ eapply var_addr_correct; eauto.
(* Econst *)
- 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.
+ exploit transl_constant_correct; eauto. intros [tv [A B]].
+ exists tv; split; eauto. constructor; eauto.
(* Eunop *)
- exploit IHeval_expr; eauto. intros [tv1 [EVAL1 [INJ1 APP1]]].
- unfold Csharpminor.eval_unop in H0.
- destruct (Approx.unop_is_redundant op x0) 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.
+ exploit IHeval_expr; eauto. intros [tv1 [EVAL1 INJ1]].
+ exploit eval_unop_compat; eauto. intros [tv [EVAL INJ]].
+ exists tv; split; auto. econstructor; eauto.
(* Ebinop *)
- exploit IHeval_expr1; eauto. intros [tv1 [EVAL1 [INJ1 APP1]]].
- exploit IHeval_expr2; eauto. intros [tv2 [EVAL2 [INJ2 APP2]]].
+ exploit IHeval_expr1; eauto. intros [tv1 [EVAL1 INJ1]].
+ exploit IHeval_expr2; eauto. intros [tv2 [EVAL2 INJ2]].
exploit eval_binop_compat; eauto. intros [tv [EVAL INJ]].
- exists tv; split. econstructor; eauto. split. auto. eapply approx_of_binop_sound; eauto.
+ exists tv; split. econstructor; eauto. auto.
(* Eload *)
- exploit IHeval_expr; eauto. intros [tv1 [EVAL1 [INJ1 APP1]]].
+ exploit IHeval_expr; eauto. intros [tv1 [EVAL1 INJ1]].
exploit Mem.loadv_inject; eauto. intros [tv [LOAD INJ]].
- exists tv; split. econstructor; eauto. split. auto.
- destruct v1; simpl in H0; try discriminate. eapply approx_of_chunk_sound; eauto.
+ exists tv; split. econstructor; eauto. auto.
Qed.
Lemma transl_exprlist_correct:
@@ -2118,7 +1527,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 APP1]]].
+ exploit transl_expr_correct; eauto. intros [tv1 [EVAL1 VINJ1]].
exploit IHeval_exprlist; eauto. intros [tv2 [EVAL2 VINJ2]].
exists (tv1 :: tv2); split. constructor; auto. constructor; auto.
Qed.
@@ -2517,7 +1926,7 @@ Proof.
(* set *)
monadInv TR.
- exploit transl_expr_correct; eauto. intros [tv [EVAL [VINJ APP]]].
+ exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]].
left; econstructor; split.
apply plus_one. econstructor; eauto.
econstructor; eauto.
@@ -2526,13 +1935,12 @@ Proof.
(* store *)
monadInv TR.
exploit transl_expr_correct. eauto. eauto. eexact H. eauto.
- intros [tv1 [EVAL1 [VINJ1 APP1]]].
+ intros [tv1 [EVAL1 VINJ1]].
exploit transl_expr_correct. eauto. eauto. eexact H0. eauto.
- intros [tv2 [EVAL2 [VINJ2 APP2]]].
- exploit make_store_correct. eexact EVAL1. eexact EVAL2. eauto. eauto. auto. auto.
- intros [tm' [tv' [EXEC [STORE' MINJ']]]].
+ intros [tv2 [EVAL2 VINJ2]].
+ exploit Mem.storev_mapped_inject; eauto. intros [tm' [STORE' MINJ']].
left; econstructor; split.
- apply plus_one. eexact EXEC.
+ apply plus_one. econstructor; eauto.
econstructor; eauto.
inv VINJ1; simpl in H1; try discriminate. unfold Mem.storev in STORE'.
rewrite (Mem.nextblock_store _ _ _ _ _ _ H1).
@@ -2544,7 +1952,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 APP1]]].
+ exploit transl_expr_correct; eauto. intros [tvf [EVAL1 VINJ1]].
assert (tvf = vf).
exploit match_callstack_match_globalenvs; eauto. intros [bnd MG].
eapply val_inject_function_pointer; eauto.
@@ -2596,8 +2004,8 @@ Opaque PTree.set.
(* ifthenelse *)
monadInv TR.
- 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.
+ 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.
apply plus_one. eapply step_ifthenelse; eauto. eapply bool_of_val_inject; eauto.
econstructor; eauto. destruct b; auto.
@@ -2649,7 +2057,7 @@ Opaque PTree.set.
(* switch *)
monadInv TR. left.
- exploit transl_expr_correct; eauto. intros [tv [EVAL [VINJ APP]]].
+ exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]].
inv VINJ.
exploit switch_descent; eauto. intros [k1 [A B]].
exploit switch_ascent; eauto. intros [k2 [C D]].
@@ -2673,7 +2081,7 @@ Opaque PTree.set.
(* return some *)
monadInv TR. left.
- exploit transl_expr_correct; eauto. intros [tv [EVAL [VINJ APP]]].
+ exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]].
exploit match_callstack_freelist; eauto. intros [tm' [A [B C]]].
econstructor; split.
apply plus_one. eapply step_return_1. eauto. eauto.
diff --git a/common/Events.v b/common/Events.v
index 74c672e..24c03dc 100644
--- a/common/Events.v
+++ b/common/Events.v
@@ -557,7 +557,7 @@ Inductive volatile_store (F V: Type) (ge: Genv.t F V):
| volatile_store_vol: forall chunk m b ofs id ev v,
block_is_volatile ge b = true ->
Genv.find_symbol ge id = Some b ->
- eventval_match ge ev (type_of_chunk chunk) v ->
+ eventval_match ge ev (type_of_chunk chunk) (Val.load_result chunk v) ->
volatile_store ge chunk m b ofs v
(Event_vstore chunk id ofs ev :: nil)
m
@@ -585,6 +585,9 @@ Definition extcall_sem : Type :=
Definition loc_out_of_bounds (m: mem) (b: block) (ofs: Z) : Prop :=
~Mem.perm m b ofs Max Nonempty.
+Definition loc_not_writable (m: mem) (b: block) (ofs: Z) : Prop :=
+ ~Mem.perm m b ofs Max Writable.
+
Definition loc_unmapped (f: meminj) (b: block) (ofs: Z): Prop :=
f b = None.
@@ -631,12 +634,9 @@ Record extcall_properties (sem: extcall_sem)
(** External call cannot modify memory unless they have [Max, Writable]
permissions. *)
ec_readonly:
- forall F V (ge: Genv.t F V) vargs m1 t vres m2 chunk b ofs,
+ forall F V (ge: Genv.t F V) vargs m1 t vres m2,
sem F V ge vargs m1 t vres m2 ->
- Mem.valid_block m1 b ->
- (forall ofs', ofs <= ofs' < ofs + size_chunk chunk ->
- ~(Mem.perm m1 b ofs' Max Writable)) ->
- Mem.load chunk m2 b ofs = Mem.load chunk m1 b ofs;
+ Mem.unchanged_on (loc_not_writable m1) m1 m2;
(** External calls must commute with memory extensions, in the
following sense. *)
@@ -777,7 +777,7 @@ Proof.
(* max perms *)
inv H; auto.
(* readonly *)
- inv H; auto.
+ inv H. apply Mem.unchanged_on_refl.
(* mem extends *)
inv H. inv H1. inv H6. inv H4.
exploit volatile_load_extends; eauto. intros [v' [A B]].
@@ -839,7 +839,7 @@ Proof.
(* max perm *)
inv H; auto.
(* readonly *)
- inv H; auto.
+ inv H. apply Mem.unchanged_on_refl.
(* extends *)
inv H. inv H1. exploit volatile_load_extends; eauto. intros [v' [A B]].
exists v'; exists m1'; intuition. econstructor; eauto.
@@ -885,25 +885,16 @@ Proof.
Qed.
Lemma volatile_store_readonly:
- forall F V (ge: Genv.t F V) chunk1 m1 b1 ofs1 v t m2 chunk ofs b,
+ forall F V (ge: Genv.t F V) chunk1 m1 b1 ofs1 v t m2,
volatile_store ge chunk1 m1 b1 ofs1 v t m2 ->
- Mem.valid_block m1 b ->
- (forall ofs', ofs <= ofs' < ofs + size_chunk chunk ->
- ~(Mem.perm m1 b ofs' Max Writable)) ->
- Mem.load chunk m2 b ofs = Mem.load chunk m1 b ofs.
+ Mem.unchanged_on (loc_not_writable m1) m1 m2.
Proof.
intros. inv H.
- auto.
- eapply Mem.load_store_other; eauto.
- destruct (eq_block b b1); auto. subst b1. right.
- apply (Intv.range_disjoint' (ofs, ofs + size_chunk chunk)
- (Int.unsigned ofs1, Int.unsigned ofs1 + size_chunk chunk1)).
- red; intros; red; intros.
- elim (H1 x); auto.
- exploit Mem.store_valid_access_3; eauto. intros [A B].
- apply Mem.perm_cur_max. apply A. auto.
- simpl. generalize (size_chunk_pos chunk); omega.
- simpl. generalize (size_chunk_pos chunk1); omega.
+ apply Mem.unchanged_on_refl.
+ eapply Mem.store_unchanged_on; eauto.
+ exploit Mem.store_valid_access_3; eauto. intros [P Q].
+ intros. unfold loc_not_writable. red; intros. elim H2.
+ apply Mem.perm_cur_max. apply P. auto.
Qed.
Lemma volatile_store_extends:
@@ -917,7 +908,8 @@ Lemma volatile_store_extends:
/\ Mem.unchanged_on (loc_out_of_bounds m1) m1' m2'.
Proof.
intros. inv H.
-- econstructor; split. econstructor; eauto. eapply eventval_match_lessdef; eauto.
+- econstructor; split. econstructor; eauto.
+ eapply eventval_match_lessdef; eauto. apply Val.load_result_lessdef; auto.
auto with mem.
- exploit Mem.store_within_extends; eauto. intros [m2' [A B]].
exists m2'; intuition.
@@ -946,7 +938,8 @@ Proof.
intros. inv H0.
- inv H1. exploit (proj1 H); eauto. intros EQ; rewrite H9 in EQ; inv EQ.
rewrite Int.add_zero. exists m1'. intuition.
- constructor; auto. eapply eventval_match_inject; eauto.
+ constructor; auto.
+ eapply eventval_match_inject; eauto. apply val_load_result_inject; auto.
- assert (Mem.storev chunk m1 (Vptr b ofs) v = Some m2). simpl; auto.
exploit Mem.storev_mapped_inject; eauto. intros [m2' [A B]].
inv H1. exists m2'; intuition.
@@ -1105,10 +1098,7 @@ Proof.
rewrite dec_eq_false. auto.
apply Mem.valid_not_valid_diff with m1; eauto with mem.
(* readonly *)
- inv H. transitivity (Mem.load chunk m' b ofs).
- eapply Mem.load_store_other; eauto.
- left. apply Mem.valid_not_valid_diff with m1; eauto with mem.
- eapply Mem.load_alloc_unchanged; eauto.
+ inv H. eapply UNCHANGED; eauto.
(* mem extends *)
inv H. inv H1. inv H5. inv H7.
exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl.
@@ -1167,18 +1157,10 @@ Proof.
(* perms *)
inv H. eapply Mem.perm_free_3; eauto.
(* readonly *)
- inv H. eapply Mem.load_free; eauto.
- destruct (eq_block b b0); auto.
- subst b0. right; right.
- apply (Intv.range_disjoint'
- (ofs, ofs + size_chunk chunk)
- (Int.unsigned lo - 4, Int.unsigned lo + Int.unsigned sz)).
- red; intros; red; intros.
- elim (H1 x). auto. apply Mem.perm_cur_max.
- apply Mem.perm_implies with Freeable; auto with mem.
- exploit Mem.free_range_perm; eauto.
- simpl. generalize (size_chunk_pos chunk); omega.
- simpl. omega.
+ inv H. eapply Mem.free_unchanged_on; eauto.
+ intros. red; intros. elim H3.
+ apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem.
+ eapply Mem.free_range_perm; eauto.
(* mem extends *)
inv H. inv H1. inv H8. inv H6.
exploit Mem.load_extends; eauto. intros [vsz [A B]]. inv B.
@@ -1271,17 +1253,9 @@ Proof.
(* perms *)
intros. inv H. eapply Mem.perm_storebytes_2; eauto.
(* readonly *)
- intros. inv H. eapply Mem.load_storebytes_other; eauto.
- destruct (eq_block b bdst); auto. subst b. right.
- apply (Intv.range_disjoint'
- (ofs, ofs + size_chunk chunk)
- (Int.unsigned odst, Int.unsigned odst + Z_of_nat (length bytes))).
- red; intros; red; intros. elim (H1 x); auto.
- apply Mem.perm_cur_max.
- eapply Mem.storebytes_range_perm; eauto.
- simpl. generalize (size_chunk_pos chunk); omega.
- simpl. rewrite (Mem.loadbytes_length _ _ _ _ _ H8). rewrite nat_of_Z_eq.
- omega. omega.
+ intros. inv H. eapply Mem.storebytes_unchanged_on; eauto.
+ intros; red; intros. elim H8.
+ apply Mem.perm_cur_max. eapply Mem.storebytes_range_perm; eauto.
(* extensions *)
intros. inv H.
inv H1. inv H13. inv H14. inv H10. inv H11.
@@ -1376,7 +1350,7 @@ Proof.
(* perms *)
inv H; auto.
(* readonly *)
- inv H; auto.
+ inv H. apply Mem.unchanged_on_refl.
(* mem extends *)
inv H.
exists Vundef; exists m1'; intuition.
@@ -1420,7 +1394,7 @@ Proof.
(* perms *)
inv H; auto.
(* readonly *)
- inv H; auto.
+ inv H. apply Mem.unchanged_on_refl.
(* mem extends *)
inv H. inv H1. inv H6.
exists v2; exists m1'; intuition.
diff --git a/common/Memory.v b/common/Memory.v
index af06f6f..1115ed7 100644
--- a/common/Memory.v
+++ b/common/Memory.v
@@ -1866,6 +1866,34 @@ Proof.
eapply load_alloc_same; eauto.
Qed.
+Theorem loadbytes_alloc_unchanged:
+ forall b' ofs n,
+ valid_block m1 b' ->
+ loadbytes m2 b' ofs n = loadbytes m1 b' ofs n.
+Proof.
+ intros. unfold loadbytes.
+ destruct (range_perm_dec m1 b' ofs (ofs + n) Cur Readable).
+ rewrite pred_dec_true.
+ injection ALLOC; intros A B. rewrite <- B; simpl.
+ rewrite PMap.gso. auto. rewrite A. eauto with mem.
+ red; intros. eapply perm_alloc_1; eauto.
+ rewrite pred_dec_false; auto.
+ red; intros; elim n0. red; intros. eapply perm_alloc_4; eauto. eauto with mem.
+Qed.
+
+Theorem loadbytes_alloc_same:
+ forall n ofs bytes byte,
+ loadbytes m2 b ofs n = Some bytes ->
+ In byte bytes -> byte = Undef.
+Proof.
+ unfold loadbytes; intros. destruct (range_perm_dec m2 b ofs (ofs + n) Cur Readable); inv H.
+ revert H0.
+ injection ALLOC; intros A B. rewrite <- A; rewrite <- B; simpl. rewrite PMap.gss.
+ generalize (nat_of_Z n) ofs. induction n0; simpl; intros.
+ contradiction.
+ rewrite ZMap.gi in H0. destruct H0; eauto.
+Qed.
+
End ALLOC.
Local Hint Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem.
@@ -2033,6 +2061,40 @@ Proof.
red; intro; elim n. eapply valid_access_free_1; eauto.
Qed.
+Theorem load_free_2:
+ forall chunk b ofs v,
+ load chunk m2 b ofs = Some v -> load chunk m1 b ofs = Some v.
+Proof.
+ intros. unfold load. rewrite pred_dec_true.
+ rewrite (load_result _ _ _ _ _ H). rewrite free_result; auto.
+ apply valid_access_free_inv_1. eauto with mem.
+Qed.
+
+Theorem loadbytes_free:
+ forall b ofs n,
+ b <> bf \/ lo >= hi \/ ofs + n <= lo \/ hi <= ofs ->
+ loadbytes m2 b ofs n = loadbytes m1 b ofs n.
+Proof.
+ intros. unfold loadbytes.
+ destruct (range_perm_dec m2 b ofs (ofs + n) Cur Readable).
+ rewrite pred_dec_true.
+ rewrite free_result; auto.
+ red; intros. eapply perm_free_3; eauto.
+ rewrite pred_dec_false; auto.
+ red; intros. elim n0; red; intros.
+ eapply perm_free_1; eauto. destruct H; auto. right; omega.
+Qed.
+
+Theorem loadbytes_free_2:
+ forall b ofs n bytes,
+ loadbytes m2 b ofs n = Some bytes -> loadbytes m1 b ofs n = Some bytes.
+Proof.
+ intros. unfold loadbytes in *.
+ destruct (range_perm_dec m2 b ofs (ofs + n) Cur Readable); inv H.
+ rewrite pred_dec_true. rewrite free_result; auto.
+ red; intros. apply perm_free_3; auto.
+Qed.
+
End FREE.
Local Hint Resolve valid_block_free_1 valid_block_free_2
@@ -2164,6 +2226,27 @@ Proof.
red; intros; elim n. eapply valid_access_drop_2; eauto.
Qed.
+Theorem loadbytes_drop:
+ forall b' ofs n,
+ b' <> b \/ ofs + n <= lo \/ hi <= ofs \/ perm_order p Readable ->
+ loadbytes m' b' ofs n = loadbytes m b' ofs n.
+Proof.
+ intros.
+ unfold loadbytes.
+ destruct (range_perm_dec m b' ofs (ofs + n) Cur Readable).
+ rewrite pred_dec_true.
+ unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); inv DROP. simpl. auto.
+ red; intros.
+ destruct (eq_block b' b). subst b'.
+ destruct (zlt ofs0 lo). eapply perm_drop_3; eauto.
+ destruct (zle hi ofs0). eapply perm_drop_3; eauto.
+ apply perm_implies with p. eapply perm_drop_1; eauto. omega. intuition.
+ eapply perm_drop_3; eauto.
+ rewrite pred_dec_false; eauto.
+ red; intros; elim n0; red; intros.
+ eapply perm_drop_4; eauto.
+Qed.
+
End DROP.
(** * Generic injections *)
@@ -4061,6 +4144,26 @@ Proof.
intros. destruct H. apply unchanged_on_perm0; auto.
Qed.
+Lemma loadbytes_unchanged_on_1:
+ forall m m' b ofs n,
+ unchanged_on m m' ->
+ valid_block m b ->
+ (forall i, ofs <= i < ofs + n -> P b i) ->
+ loadbytes m' b ofs n = loadbytes m b ofs n.
+Proof.
+ intros.
+ destruct (zle n 0).
++ erewrite ! loadbytes_empty by assumption. auto.
++ unfold loadbytes. destruct H.
+ destruct (range_perm_dec m b ofs (ofs + n) Cur Readable).
+ rewrite pred_dec_true. f_equal.
+ apply getN_exten. intros. rewrite nat_of_Z_eq in H by omega.
+ apply unchanged_on_contents0; auto.
+ red; intros. apply unchanged_on_perm0; auto.
+ rewrite pred_dec_false. auto.
+ red; intros; elim n0; red; intros. apply <- unchanged_on_perm0; auto.
+Qed.
+
Lemma loadbytes_unchanged_on:
forall m m' b ofs n bytes,
unchanged_on m m' ->
@@ -4071,15 +4174,24 @@ Proof.
intros.
destruct (zle n 0).
+ erewrite loadbytes_empty in * by assumption. auto.
-+ unfold loadbytes in *. destruct H.
- destruct (range_perm_dec m b ofs (ofs + n) Cur Readable); inv H1.
- assert (valid_block m b).
- { eapply perm_valid_block. apply (r ofs). omega. }
- assert (range_perm m' b ofs (ofs + n) Cur Readable).
- { red; intros. apply unchanged_on_perm0; auto. }
- rewrite pred_dec_true by assumption. f_equal.
- apply getN_exten. intros. rewrite nat_of_Z_eq in H2 by omega.
- apply unchanged_on_contents0; auto.
++ rewrite <- H1. apply loadbytes_unchanged_on_1; auto.
+ exploit loadbytes_range_perm; eauto. instantiate (1 := ofs). omega.
+ intros. eauto with mem.
+Qed.
+
+Lemma load_unchanged_on_1:
+ forall m m' chunk b ofs,
+ unchanged_on m m' ->
+ valid_block m b ->
+ (forall i, ofs <= i < ofs + size_chunk chunk -> P b i) ->
+ load chunk m' b ofs = load chunk m b ofs.
+Proof.
+ intros. unfold load. destruct (valid_access_dec m chunk b ofs Readable).
+ destruct v. rewrite pred_dec_true. f_equal. f_equal. apply getN_exten. intros.
+ rewrite <- size_chunk_conv in H4. eapply unchanged_on_contents; eauto.
+ split; auto. red; intros. eapply perm_unchanged_on; eauto.
+ rewrite pred_dec_false. auto.
+ red; intros [A B]; elim n; split; auto. red; intros; eapply perm_unchanged_on_2; eauto.
Qed.
Lemma load_unchanged_on:
@@ -4089,10 +4201,7 @@ Lemma load_unchanged_on:
load chunk m b ofs = Some v ->
load chunk m' b ofs = Some v.
Proof.
- intros.
- exploit load_valid_access; eauto. intros [A B].
- exploit load_loadbytes; eauto. intros [bytes [C D]].
- subst v. apply loadbytes_load; auto. eapply loadbytes_unchanged_on; eauto.
+ intros. rewrite <- H1. eapply load_unchanged_on_1; eauto with mem.
Qed.
Lemma store_unchanged_on:
diff --git a/common/Values.v b/common/Values.v
index b9594fc..99a994b 100644
--- a/common/Values.v
+++ b/common/Values.v
@@ -655,6 +655,12 @@ Definition cmpl (c: comparison) (v1 v2: val): option val :=
Definition cmplu (c: comparison) (v1 v2: val): option val :=
option_map of_bool (cmplu_bool c v1 v2).
+Definition maskzero_bool (v: val) (mask: int): option bool :=
+ match v with
+ | Vint n => Some (Int.eq (Int.and n mask) Int.zero)
+ | _ => None
+ end.
+
End COMPARISONS.
(** [load_result] reflects the effect of storing a value with a given
diff --git a/driver/Clflags.ml b/driver/Clflags.ml
index 4871222..442ca68 100644
--- a/driver/Clflags.ml
+++ b/driver/Clflags.ml
@@ -36,6 +36,7 @@ let option_dtailcall = ref false
let option_dinlining = ref false
let option_dconstprop = ref false
let option_dcse = ref false
+let option_ddeadcode = ref false
let option_dalloc = ref false
let option_dalloctrace = ref false
let option_dmach = ref false
diff --git a/driver/Compiler.v b/driver/Compiler.v
index 5d9e1a7..d088bc9 100644
--- a/driver/Compiler.v
+++ b/driver/Compiler.v
@@ -44,6 +44,7 @@ Require Inlining.
Require Renumber.
Require Constprop.
Require CSE.
+Require Deadcode.
Require Allocation.
Require Tunneling.
Require Linearize.
@@ -62,6 +63,7 @@ Require Inliningproof.
Require Renumberproof.
Require Constpropproof.
Require CSEproof.
+Require Deadcodeproof.
Require Allocproof.
Require Tunnelingproof.
Require Linearizeproof.
@@ -77,6 +79,7 @@ Parameter print_RTL_tailcall: RTL.program -> unit.
Parameter print_RTL_inline: RTL.program -> unit.
Parameter print_RTL_constprop: RTL.program -> unit.
Parameter print_RTL_cse: RTL.program -> unit.
+Parameter print_RTL_deadcode: RTL.program -> unit.
Parameter print_LTL: LTL.program -> unit.
Parameter print_Mach: Mach.program -> unit.
@@ -120,6 +123,8 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program :=
@@ print print_RTL_constprop
@@@ CSE.transf_program
@@ print print_RTL_cse
+ @@@ Deadcode.transf_program
+ @@ print print_RTL_deadcode
@@@ Allocation.transf_program
@@ print print_LTL
@@ Tunneling.tunnel_program
@@ -201,7 +206,8 @@ Proof.
set (p2 := Constprop.transf_program p12) in *.
set (p21 := Renumber.transf_program p2) in *.
destruct (CSE.transf_program p21) as [p3|] eqn:?; simpl in H; try discriminate.
- destruct (Allocation.transf_program p3) as [p4|] eqn:?; simpl in H; try discriminate.
+ destruct (Deadcode.transf_program p3) as [p31|] eqn:?; simpl in H; try discriminate.
+ destruct (Allocation.transf_program p31) as [p4|] eqn:?; simpl in H; try discriminate.
set (p5 := Tunneling.tunnel_program p4) in *.
destruct (Linearize.transf_program p5) as [p6|] eqn:?; simpl in H; try discriminate.
set (p7 := CleanupLabels.transf_program p6) in *.
@@ -212,6 +218,7 @@ Proof.
eapply compose_forward_simulation. apply Constpropproof.transf_program_correct.
eapply compose_forward_simulation. apply Renumberproof.transf_program_correct.
eapply compose_forward_simulation. apply CSEproof.transf_program_correct. eassumption.
+ eapply compose_forward_simulation. apply Deadcodeproof.transf_program_correct. eassumption.
eapply compose_forward_simulation. apply Allocproof.transf_program_correct. eassumption.
eapply compose_forward_simulation. apply Tunnelingproof.transf_program_correct.
eapply compose_forward_simulation. apply Linearizeproof.transf_program_correct. eassumption.
diff --git a/driver/Driver.ml b/driver/Driver.ml
index 5f0ae7e..874f96b 100644
--- a/driver/Driver.ml
+++ b/driver/Driver.ml
@@ -149,6 +149,7 @@ let compile_c_ast sourcename csyntax ofile =
set_dest PrintRTL.destination_inlining option_dinlining ".inlining.rtl";
set_dest PrintRTL.destination_constprop option_dconstprop ".constprop.rtl";
set_dest PrintRTL.destination_cse option_dcse ".cse.rtl";
+ set_dest PrintRTL.destination_deadcode option_ddeadcode ".deadcode.rtl";
set_dest Regalloc.destination_alloctrace option_dalloctrace ".alloctrace";
set_dest PrintLTL.destination option_dalloc ".alloc.ltl";
set_dest PrintMach.destination option_dmach ".mach";
@@ -413,6 +414,7 @@ Tracing options:
-dinlining Save RTL after inlining optimization in <file>.inlining.rtl
-dconstprop Save RTL after constant propagation in <file>.constprop.rtl
-dcse Save RTL after CSE optimization in <file>.cse.rtl
+ -ddeadcode Save RTL after dead code removal in <file>.deadcode.rtl
-dalloc Save LTL after register allocation in <file>.alloc.ltl
-dmach Save generated Mach code in <file>.mach
-dasm Save generated assembly in <file>.s
@@ -460,6 +462,7 @@ let cmdline_actions =
"-dinlining$", Set option_dinlining;
"-dconstprop$", Set option_dconstprop;
"-dcse$", Set option_dcse;
+ "-ddeadcode$", Set option_ddeadcode;
"-dalloc$", Set option_dalloc;
"-dalloctrace$", Set option_dalloctrace;
"-dmach$", Set option_dmach;
diff --git a/extraction/extraction.v b/extraction/extraction.v
index 047a9b4..b1cd8fd 100644
--- a/extraction/extraction.v
+++ b/extraction/extraction.v
@@ -10,6 +10,7 @@
(* *)
(* *********************************************************************)
+Require Coqlib.
Require Wfsimpl.
Require Nan.
Require AST.
@@ -18,8 +19,7 @@ Require Floats.
Require SelectLong.
Require RTLgen.
Require Inlining.
-Require ConstpropOp.
-Require Constprop.
+Require ValueDomain.
Require Tailcall.
Require Allocation.
Require Compiler.
@@ -28,6 +28,9 @@ Require Compiler.
Require Import ExtrOcamlBasic.
Require Import ExtrOcamlString.
+(* Coqlib *)
+Extract Inlined Constant Coqlib.proj_sumbool => "(fun x -> x)".
+
(* Wfsimpl *)
Extraction Inline Wfsimpl.Fix Wfsimpl.Fixm.
@@ -73,10 +76,12 @@ Extraction Inline RTLgen.ret RTLgen.error RTLgen.bind RTLgen.bind2.
Extract Inlined Constant Inlining.should_inline => "Inliningaux.should_inline".
Extraction Inline Inlining.ret Inlining.bind.
-(* Constprop *)
-Extract Constant ConstpropOp.propagate_float_constants =>
+(* ValueDomain *)
+Extract Constant ValueDomain.strict =>
+ "false".
+Extract Constant ValueDomain.propagate_float_constants =>
"fun _ -> !Clflags.option_ffloatconstprop >= 1".
-Extract Constant Constprop.generate_float_constants =>
+Extract Constant ValueDomain.generate_float_constants =>
"fun _ -> !Clflags.option_ffloatconstprop >= 2".
(* Tailcall *)
@@ -101,6 +106,7 @@ Extract Constant Compiler.print_RTL_tailcall => "PrintRTL.print_tailcall".
Extract Constant Compiler.print_RTL_inline => "PrintRTL.print_inlining".
Extract Constant Compiler.print_RTL_constprop => "PrintRTL.print_constprop".
Extract Constant Compiler.print_RTL_cse => "PrintRTL.print_cse".
+Extract Constant Compiler.print_RTL_deadcode => "PrintRTL.print_deadcode".
Extract Constant Compiler.print_LTL => "PrintLTL.print_if".
Extract Constant Compiler.print_Mach => "PrintMach.print_if".
Extract Constant Compiler.print => "fun (f: 'a -> unit) (x: 'a) -> f x; x".
diff --git a/ia32/CombineOp.v b/ia32/CombineOp.v
index 07d5a79..ca54ba1 100644
--- a/ia32/CombineOp.v
+++ b/ia32/CombineOp.v
@@ -17,14 +17,10 @@ Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Op.
-Require SelectOp.
+Require Import CSEdomain.
Definition valnum := positive.
-Inductive rhs : Type :=
- | Op: operation -> list valnum -> rhs
- | Load: memory_chunk -> addressing -> list valnum -> rhs.
-
Section COMBINE.
Variable get: valnum -> option rhs.
@@ -80,7 +76,7 @@ Function combine_addr (addr: addressing) (args: list valnum) : option(addressing
match addr, args with
| Aindexed n, x::nil =>
match get x with
- | Some(Op (Olea a) ys) => Some(SelectOp.offset_addressing a n, ys)
+ | Some(Op (Olea a) ys) => Some(offset_addressing_total a n, ys)
| _ => None
end
| _, _ => None
@@ -93,6 +89,21 @@ Function combine_op (op: operation) (args: list valnum) : option(operation * lis
| Some(addr', args') => Some(Olea addr', args')
| None => None
end
+ | Oandimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oandimm m) ys) => Some(Oandimm (Int.and m n), ys)
+ | _ => None
+ end
+ | Oorimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oorimm m) ys) => Some(Oorimm (Int.or m n), ys)
+ | _ => None
+ end
+ | Oxorimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oxorimm m) ys) => Some(Oxorimm (Int.xor m n), ys)
+ | _ => None
+ end
| Ocmp cond, _ =>
match combine_cond cond args with
| Some(cond', args') => Some(Ocmp cond', args')
diff --git a/ia32/CombineOpproof.v b/ia32/CombineOpproof.v
index d4565bd..1e5b932 100644
--- a/ia32/CombineOpproof.v
+++ b/ia32/CombineOpproof.v
@@ -19,8 +19,8 @@ Require Import Values.
Require Import Memory.
Require Import Op.
Require Import RTL.
+Require Import CSEdomain.
Require Import CombineOp.
-Require Import CSE.
Section COMBINE.
@@ -29,8 +29,20 @@ Variable sp: val.
Variable m: mem.
Variable get: valnum -> option rhs.
Variable valu: valnum -> val.
-Hypothesis get_sound: forall v rhs, get v = Some rhs -> equation_holds valu ge sp m v rhs.
+Hypothesis get_sound: forall v rhs, get v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v).
+Lemma get_op_sound:
+ forall v op vl, get v = Some (Op op vl) -> eval_operation ge sp op (map valu vl) m = Some (valu v).
+Proof.
+ intros. exploit get_sound; eauto. intros REV; inv REV; auto.
+Qed.
+
+Ltac UseGetSound :=
+ match goal with
+ | [ H: get _ = Some _ |- _ ] =>
+ let x := fresh "EQ" in (generalize (get_op_sound _ _ _ H); intros x; simpl in x; FuncInv)
+ end.
+
Lemma combine_compimm_ne_0_sound:
forall x cond args,
combine_compimm_ne_0 get x = Some(cond, args) ->
@@ -39,12 +51,11 @@ Lemma combine_compimm_ne_0_sound:
Proof.
intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ.
(* of cmp *)
- exploit get_sound; eauto. unfold equation_holds. simpl. intro EQ; inv EQ.
+ UseGetSound. rewrite <- H.
destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
(* of and *)
- exploit get_sound; eauto. unfold equation_holds; simpl.
- destruct args; try discriminate. destruct args; try discriminate. simpl.
- intros EQ; inv EQ. destruct (valu v); simpl; auto.
+ UseGetSound. rewrite <- H.
+ destruct v; simpl; auto.
Qed.
Lemma combine_compimm_eq_0_sound:
@@ -55,13 +66,11 @@ Lemma combine_compimm_eq_0_sound:
Proof.
intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ.
(* of cmp *)
- exploit get_sound; eauto. unfold equation_holds. simpl. intro EQ; inv EQ.
+ UseGetSound. rewrite <- H.
rewrite eval_negate_condition.
destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
(* of and *)
- exploit get_sound; eauto. unfold equation_holds; simpl.
- destruct args; try discriminate. destruct args; try discriminate. simpl.
- intros EQ; inv EQ. destruct (valu v); simpl; auto.
+ UseGetSound. rewrite <- H. destruct v; auto.
Qed.
Lemma combine_compimm_eq_1_sound:
@@ -72,7 +81,7 @@ Lemma combine_compimm_eq_1_sound:
Proof.
intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ.
(* of cmp *)
- exploit get_sound; eauto. unfold equation_holds. simpl. intro EQ; inv EQ.
+ UseGetSound. rewrite <- H.
destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
Qed.
@@ -84,7 +93,7 @@ Lemma combine_compimm_ne_1_sound:
Proof.
intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ.
(* of cmp *)
- exploit get_sound; eauto. unfold equation_holds. simpl. intro EQ; inv EQ.
+ UseGetSound. rewrite <- H.
rewrite eval_negate_condition.
destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
Qed.
@@ -119,22 +128,8 @@ Theorem combine_addr_sound:
eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args).
Proof.
intros. functional inversion H; subst.
- exploit get_sound; eauto. unfold equation_holds; simpl; intro EQ.
- assert (forall vl,
- eval_addressing ge sp (SelectOp.offset_addressing a n) vl =
- option_map (fun v => Val.add v (Vint n)) (eval_addressing ge sp a vl)).
- intros. destruct a; simpl; repeat (destruct vl; auto); simpl.
- rewrite Val.add_assoc. auto.
- repeat rewrite Val.add_assoc. auto.
- rewrite Val.add_assoc. auto.
- repeat rewrite Val.add_assoc. auto.
- unfold symbol_address. destruct (Globalenvs.Genv.find_symbol ge i); auto.
- unfold symbol_address. destruct (Globalenvs.Genv.find_symbol ge i); auto.
- repeat rewrite <- (Val.add_commut v). rewrite Val.add_assoc. auto.
- unfold symbol_address. destruct (Globalenvs.Genv.find_symbol ge i0); auto.
- repeat rewrite <- (Val.add_commut (Val.mul v (Vint i))). rewrite Val.add_assoc. auto.
- rewrite Val.add_assoc; auto.
- rewrite H0. rewrite EQ. auto.
+ (* indexed - lea *)
+ UseGetSound. simpl. eapply eval_offset_addressing_total; eauto.
Qed.
Theorem combine_op_sound:
@@ -143,8 +138,14 @@ Theorem combine_op_sound:
eval_operation ge sp op' (map valu args') m = eval_operation ge sp op (map valu args) m.
Proof.
intros. functional inversion H; subst.
-(* lea *)
+(* lea-lea *)
simpl. eapply combine_addr_sound; eauto.
+(* andimm - andimm *)
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.and_assoc. auto.
+(* orimm - orimm *)
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.or_assoc. auto.
+(* xorimm - xorimm *)
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.xor_assoc. auto.
(* cmp *)
simpl. decEq; decEq. eapply combine_cond_sound; eauto.
Qed.
diff --git a/ia32/ConstpropOp.vp b/ia32/ConstpropOp.vp
index 8c3a7fa..396c94c 100644
--- a/ia32/ConstpropOp.vp
+++ b/ia32/ConstpropOp.vp
@@ -10,8 +10,8 @@
(* *)
(* *********************************************************************)
-(** Static analysis and strength reduction for operators
- and conditions. This is the machine-dependent part of [Constprop]. *)
+(** Strength reduction for operators and conditions.
+ This is the machine-dependent part of [Constprop]. *)
Require Import Coqlib.
Require Import AST.
@@ -19,141 +19,7 @@ Require Import Integers.
Require Import Floats.
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. *)
- | L: int64 -> approx (** A know 64-bit integer 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_addressing (addr: addressing) (vl: list approx) :=
- match addr, vl with
- | Aindexed n, I n1::nil => I (Int.add n1 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, 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, 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.
-
-Parameter propagate_float_constants: unit -> bool.
-
-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 => if propagate_float_constants tt then F n else Unknown
- | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n1)
- | Ocast8unsigned, I n1 :: nil => I(Int.zero_ext 8 n1)
- | Ocast16signed, I n1 :: nil => I(Int.sign_ext 16 n1)
- | 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, 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)
- | Omulhs, I n1 :: I n2 :: nil => I(Int.mulhs n1 n2)
- | Omulhu, I n1 :: I n2 :: nil => I(Int.mulhu n1 n2)
- | Odiv, I n1 :: I n2 :: nil =>
- if Int.eq n2 Int.zero then Unknown else
- if Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone 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)
- | Omod, I n1 :: I n2 :: nil =>
- if Int.eq n2 Int.zero then Unknown else
- if Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone then Unknown
- else I(Int.mods n1 n2)
- | Omodu, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.modu 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)
- | Oshl, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shl n1 n2) else Unknown
- | 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.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
- | Oshldimm n, I n1 :: I n2 :: nil =>
- let n' := Int.sub Int.iwordsize n in
- if Int.ltu n Int.iwordsize && Int.ltu n' Int.iwordsize
- then I(Int.or (Int.shl n1 n) (Int.shru n2 n'))
- else Unknown
- | Olea mode, vl => eval_static_addressing mode vl
- | Onegf, F n1 :: nil => F(Float.neg n1)
- | Oabsf, F n1 :: nil => F(Float.abs n1)
- | Oaddf, F n1 :: F n2 :: nil => F(Float.add n1 n2)
- | Osubf, F n1 :: F n2 :: nil => F(Float.sub n1 n2)
- | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2)
- | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2)
- | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1)
- | Ointoffloat, F n1 :: nil => eval_static_intoffloat n1
- | Ofloatofint, I n1 :: nil => if propagate_float_constants tt then F(Float.floatofint n1) else Unknown
- | Omakelong, I n1 :: I n2 :: nil => L(Int64.ofwords n1 n2)
- | Olowlong, L n :: nil => I(Int64.loword n)
- | Ohighlong, L n :: nil => I(Int64.hiword n)
- | Ocmp c, vl => eval_static_condition_val c vl
- | _, _ => Unknown
- end.
+Require Import ValueDomain.
(** * Operator strength reduction *)
@@ -162,12 +28,8 @@ Nondetfunction eval_static_operation (op: operation) (vl: list approx) :=
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.
-
Nondetfunction cond_strength_reduction
- (cond: condition) (args: list reg) (vl: list approx) :=
+ (cond: condition) (args: list reg) (vl: list aval) :=
match cond, args, vl with
| Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
(Ccompimm (swap_comparison c) n1, r2 :: nil)
@@ -182,34 +44,34 @@ Nondetfunction cond_strength_reduction
end.
Nondetfunction addr_strength_reduction
- (addr: addressing) (args: list reg) (vl: list approx) :=
+ (addr: addressing) (args: list reg) (vl: list aval) :=
match addr, args, vl with
- | Aindexed ofs, r1 :: nil, G symb n :: nil =>
+ | Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil =>
(Aglobal symb (Int.add n ofs), nil)
- | Aindexed ofs, r1 :: nil, S n :: nil =>
+ | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil =>
(Ainstack (Int.add n ofs), nil)
- | Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil =>
+ | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil =>
(Aglobal symb (Int.add (Int.add n1 n2) ofs), nil)
- | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: G symb n2 :: nil =>
+ | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Gl symb n2) :: nil =>
(Aglobal symb (Int.add (Int.add n1 n2) ofs), nil)
- | Aindexed2 ofs, r1 :: r2 :: nil, S n1 :: I n2 :: nil =>
+ | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil =>
(Ainstack (Int.add (Int.add n1 n2) ofs), nil)
- | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: S n2 :: nil =>
+ | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Stk n2) :: nil =>
(Ainstack (Int.add (Int.add n1 n2) ofs), nil)
- | Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil =>
+ | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil =>
(Abased symb (Int.add n1 ofs), r2 :: nil)
- | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: G symb n2 :: nil =>
+ | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil =>
(Abased symb (Int.add n2 ofs), r1 :: nil)
| Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
(Aindexed (Int.add n1 ofs), r2 :: nil)
| Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
(Aindexed (Int.add n2 ofs), r1 :: nil)
- | Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil =>
+ | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil =>
(Aglobal symb (Int.add (Int.add n1 (Int.mul n2 sc)) ofs), nil)
- | Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil =>
+ | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil =>
(Abasedscaled sc symb (Int.add n1 ofs), r2 :: nil)
| Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
(Aindexed (Int.add (Int.mul n2 sc) ofs), r1 :: nil)
@@ -255,10 +117,12 @@ Definition make_mulimm (n: int) (r: reg) :=
| None => (Omulimm n, r :: nil)
end.
-Definition make_andimm (n: int) (r: reg) :=
- if Int.eq n Int.zero
- then (Ointconst Int.zero, nil)
+Definition make_andimm (n: int) (r: reg) (a: aval) :=
+ if Int.eq n Int.zero then (Ointconst Int.zero, nil)
else if Int.eq n Int.mone then (Omove, r :: nil)
+ else if match a with Uns m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero
+ | _ => false end
+ then (Omove, r :: nil)
else (Oandimm n, r :: nil).
Definition make_orimm (n: int) (r: reg) :=
@@ -296,17 +160,35 @@ Definition make_mulfimm (n: float) (r r1 r2: reg) :=
then (Oaddf, r :: r :: nil)
else (Omulf, r1 :: r2 :: nil).
+Definition make_cast8signed (r: reg) (a: aval) :=
+ if vincl a (Sgn 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil).
+Definition make_cast8unsigned (r: reg) (a: aval) :=
+ if vincl a (Uns 8) then (Omove, r :: nil) else (Ocast8unsigned, r :: nil).
+Definition make_cast16signed (r: reg) (a: aval) :=
+ if vincl a (Sgn 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil).
+Definition make_cast16unsigned (r: reg) (a: aval) :=
+ if vincl a (Uns 16) then (Omove, r :: nil) else (Ocast16unsigned, r :: nil).
+Definition make_singleoffloat (r: reg) (a: aval) :=
+ if vincl a Fsingle && generate_float_constants tt
+ then (Omove, r :: nil)
+ else (Osingleoffloat, r :: nil).
+
Nondetfunction op_strength_reduction
- (op: operation) (args: list reg) (vl: list approx) :=
+ (op: operation) (args: list reg) (vl: list aval) :=
match op, args, vl with
+ | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1
+ | Ocast8unsigned, r1 :: nil, v1 :: nil => make_cast8unsigned r1 v1
+ | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1
+ | Ocast16unsigned, r1 :: nil, v1 :: nil => make_cast16unsigned r1 v1
| Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1
| Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2
| Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1
| Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2
| Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2
| Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2
- | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2
- | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1
+ | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2
+ | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1
+ | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1
| Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2
| Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1
| Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2
@@ -317,6 +199,7 @@ Nondetfunction op_strength_reduction
| Olea addr, args, vl =>
let (addr', args') := addr_strength_reduction addr args vl in
(Olea addr', args')
+ | Osingleoffloat, r1 :: nil, v1 :: nil => make_singleoffloat r1 v1
| Ocmp c, args, vl =>
let (c', args') := cond_strength_reduction c args vl in
(Ocmp c', args')
@@ -324,5 +207,3 @@ Nondetfunction op_strength_reduction
| Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2
| _, _, _ => (op, args)
end.
-
-End STRENGTH_REDUCTION.
diff --git a/ia32/ConstpropOpproof.v b/ia32/ConstpropOpproof.v
index a4cb402..d9e6068 100644
--- a/ia32/ConstpropOpproof.v
+++ b/ia32/ConstpropOpproof.v
@@ -10,7 +10,7 @@
(* *)
(* *********************************************************************)
-(** Correctness proof for constant propagation (processor-dependent part). *)
+(** Correctness proof for operator strength reduction. *)
Require Import Coqlib.
Require Import Integers.
@@ -22,157 +22,8 @@ Require Import Events.
Require Import Op.
Require Import Registers.
Require Import RTL.
+Require Import ValueDomain.
Require Import ConstpropOp.
-Require Import Constprop.
-
-(** * Correctness of the static analysis *)
-
-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)
- of a register at a program point predicted by the static analysis
- are a superset of the values actually encountered during concrete
- executions. We formalize this correspondence between run-time values and
- compile-time approximations by the following predicate. *)
-
-Definition val_match_approx (a: approx) (v: val) : Prop :=
- match a with
- | Unknown => True
- | I p => v = Vint p
- | F p => v = Vfloat p
- | L p => v = Vlong p
- | G symb ofs => v = symbol_address ge symb ofs
- | S ofs => v = Val.add sp (Vint ofs)
- | Novalue => False
- end.
-
-Inductive val_list_match_approx: list approx -> list val -> Prop :=
- | vlma_nil:
- val_list_match_approx nil nil
- | vlma_cons:
- forall a al v vl,
- val_match_approx a v ->
- val_list_match_approx al vl ->
- val_list_match_approx (a :: al) (v :: vl).
-
-Ltac SimplVMA :=
- match goal with
- | H: (val_match_approx (I _) ?v) |- _ =>
- simpl in H; (try subst v); SimplVMA
- | H: (val_match_approx (F _) ?v) |- _ =>
- simpl in H; (try subst v); SimplVMA
- | H: (val_match_approx (L _) ?v) |- _ =>
- simpl in H; (try subst v); 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.
-
-Ltac InvVLMA :=
- match goal with
- | H: (val_list_match_approx nil ?vl) |- _ =>
- inv H
- | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ =>
- inv H; SimplVMA; InvVLMA
- | _ =>
- idtac
- end.
-
-(** We then show that [eval_static_operation] is a correct abstract
- interpretations of [eval_operation]: if the concrete arguments match
- the given approximations, the concrete results match the
- approximations returned by [eval_static_operation]. *)
-
-Lemma eval_static_condition_correct:
- forall cond al vl m b,
- val_list_match_approx al vl ->
- eval_static_condition cond al = Some b ->
- eval_condition cond vl m = Some b.
-Proof.
- intros until b.
- unfold eval_static_condition.
- case (eval_static_condition_match cond al); intros;
- InvVLMA; simpl; congruence.
-Qed.
-
-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 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 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 al vl m v,
- val_list_match_approx al vl ->
- eval_operation ge sp op vl m = Some v ->
- val_match_approx (eval_static_operation op al) v.
-Proof.
- intros until v.
- unfold eval_static_operation.
- case (eval_static_operation_match op al); intros;
- InvVLMA; simpl in *; FuncInv; try subst v; auto.
- destruct (propagate_float_constants tt); simpl; auto.
- rewrite Int.sub_add_opp. rewrite shift_symbol_address. rewrite Val.sub_add_opp. auto.
- destruct (Int.eq n2 Int.zero). inv H0.
- destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H0; simpl; auto.
- destruct (Int.eq n2 Int.zero); inv H0; simpl; auto.
- destruct (Int.eq n2 Int.zero). inv H0.
- destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); 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.
- destruct (Int.ltu n Int.iwordsize);
- destruct (Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize); simpl; auto.
- eapply eval_static_addressing_correct; eauto.
- unfold eval_static_intoffloat.
- destruct (Float.intoffloat n1) eqn:?; simpl in H0; inv H0.
- simpl; auto.
- destruct (propagate_float_constants tt); 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 *)
(** We now show that strength reduction over operators and addressing
modes preserve semantics: the strength-reduced operations and
@@ -182,130 +33,197 @@ Qed.
Section STRENGTH_REDUCTION.
-Variable app: D.t.
-Variable rs: regset.
+Variable bc: block_classification.
+Variable ge: genv.
+Hypothesis GENV: genv_match bc ge.
+Variable sp: block.
+Hypothesis STACK: bc sp = BCstack.
+Variable ae: AE.t.
+Variable e: regset.
Variable m: mem.
-Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r.
+Hypothesis MATCH: ematch bc e ae.
+
+Lemma match_G:
+ forall r id ofs,
+ AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef e#r (symbol_address ge id ofs).
+Proof.
+ intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH.
+Qed.
+
+Lemma match_S:
+ forall r ofs,
+ AE.get r ae = Ptr(Stk ofs) -> Val.lessdef e#r (Vptr sp ofs).
+Proof.
+ intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH.
+Qed.
Ltac InvApproxRegs :=
match goal with
| [ H: _ :: _ = _ :: _ |- _ ] =>
injection H; clear H; intros; InvApproxRegs
- | [ H: ?v = approx_reg app ?r |- _ ] =>
+ | [ H: ?v = AE.get ?r ae |- _ ] =>
generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs
| _ => idtac
end.
+Ltac SimplVM :=
+ match goal with
+ | [ H: vmatch _ ?v (I ?n) |- _ ] =>
+ let E := fresh in
+ assert (E: v = Vint n) by (inversion H; auto);
+ rewrite E in *; clear H; SimplVM
+ | [ H: vmatch _ ?v (F ?n) |- _ ] =>
+ let E := fresh in
+ assert (E: v = Vfloat n) by (inversion H; auto);
+ rewrite E in *; clear H; SimplVM
+ | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] =>
+ let E := fresh in
+ assert (E: Val.lessdef v (Op.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto);
+ clear H; SimplVM
+ | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] =>
+ let E := fresh in
+ assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto);
+ clear H; SimplVM
+ | _ => idtac
+ end.
+
Lemma cond_strength_reduction_correct:
forall cond args vl,
- vl = approx_regs app args ->
+ vl = map (fun r => AE.get r ae) args ->
let (cond', args') := cond_strength_reduction cond args vl in
- eval_condition cond' rs##args' m = eval_condition cond rs##args m.
+ eval_condition cond' e##args' m = eval_condition cond e##args m.
Proof.
intros until vl. unfold cond_strength_reduction.
- case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVMA.
- rewrite H0. apply Val.swap_cmp_bool.
- rewrite H. auto.
- rewrite H0. apply Val.swap_cmpu_bool.
- rewrite H. auto.
- auto.
+ case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVM.
+- apply Val.swap_cmp_bool.
+- auto.
+- apply Val.swap_cmpu_bool.
+- auto.
+- auto.
+Qed.
+
+Remark shift_symbol_address:
+ forall symb ofs n,
+ Op.symbol_address ge symb (Int.add ofs n) = Val.add (Op.symbol_address ge symb ofs) (Vint n).
+Proof.
+ unfold Op.symbol_address; intros. destruct (Genv.find_symbol ge symb); auto.
Qed.
Lemma addr_strength_reduction_correct:
- forall addr args vl,
- vl = approx_regs app args ->
+ forall addr args vl res,
+ vl = map (fun r => AE.get r ae) args ->
+ eval_addressing ge (Vptr sp Int.zero) addr e##args = Some res ->
let (addr', args') := addr_strength_reduction addr args vl in
- eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args.
+ exists res', eval_addressing ge (Vptr sp Int.zero) addr' e##args' = Some res' /\ Val.lessdef res res'.
Proof.
- 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.
+ intros until res. unfold addr_strength_reduction.
+ destruct (addr_strength_reduction_match addr args vl); simpl;
+ intros VL EA; InvApproxRegs; SimplVM; try (inv EA).
+- rewrite shift_symbol_address. econstructor; split. eauto. apply Val.add_lessdef; auto.
+- econstructor; split; eauto. rewrite Int.add_zero_l.
+ change (Vptr sp (Int.add n ofs)) with (Val.add (Vptr sp n) (Vint ofs)). apply Val.add_lessdef; auto.
+- econstructor; split; eauto. rewrite Int.add_assoc. rewrite shift_symbol_address.
+ rewrite Val.add_assoc. apply Val.add_lessdef; auto.
+- econstructor; split; eauto.
+ fold (Val.add (Vint n1) e#r2). rewrite (Val.add_commut (Vint n1)).
+ rewrite shift_symbol_address. apply Val.add_lessdef; auto.
+ rewrite Int.add_commut. rewrite shift_symbol_address. apply Val.add_lessdef; auto.
+- econstructor; split; eauto. rewrite Int.add_zero_l. rewrite Int.add_assoc.
+ change (Vptr sp (Int.add n1 (Int.add n2 ofs)))
+ with (Val.add (Vptr sp n1) (Vint (Int.add n2 ofs))).
+ rewrite Val.add_assoc. apply Val.add_lessdef; auto.
+- econstructor; split; eauto. rewrite Int.add_zero_l.
+ fold (Val.add (Vint n1) e#r2). rewrite (Int.add_commut n1).
+ change (Vptr sp (Int.add (Int.add n2 n1) ofs))
+ with (Val.add (Val.add (Vint n1) (Vptr sp n2)) (Vint ofs)).
+ apply Val.add_lessdef; auto. apply Val.add_lessdef; auto.
+- econstructor; split; eauto. rewrite shift_symbol_address.
+ rewrite ! Val.add_assoc. apply Val.add_lessdef; auto.
+ rewrite Val.add_commut. apply Val.add_lessdef; auto.
+- econstructor; split; eauto. rewrite shift_symbol_address.
+ rewrite (Val.add_commut e#r1). rewrite ! Val.add_assoc.
+ apply Val.add_lessdef; auto. rewrite Val.add_commut. apply Val.add_lessdef; auto.
+- fold (Val.add (Vint n1) e#r2). econstructor; split; eauto.
+ rewrite (Val.add_commut (Vint n1)). rewrite Val.add_assoc.
+ apply Val.add_lessdef; eauto.
+- econstructor; split; eauto. rewrite ! Val.add_assoc.
+ apply Val.add_lessdef; eauto.
+- econstructor; split; eauto. rewrite Int.add_assoc.
+ rewrite shift_symbol_address. apply Val.add_lessdef; auto.
+- econstructor; split; eauto.
+ rewrite shift_symbol_address. rewrite ! Val.add_assoc. apply Val.add_lessdef; auto.
+ rewrite Val.add_commut; auto.
+- econstructor; split; eauto.
+- econstructor; split; eauto. rewrite shift_symbol_address. auto.
+- econstructor; split; eauto. rewrite shift_symbol_address. rewrite Int.mul_commut; auto.
+- econstructor; eauto.
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.
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.add e#r (Vint n)) v.
Proof.
intros. unfold make_addimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros.
- subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto.
- exists (Val.add rs#r (Vint n)); auto.
+ subst. exists (e#r); split; auto. destruct (e#r); simpl; auto; rewrite Int.add_zero; auto.
+ exists (Val.add e#r (Vint n)); auto.
Qed.
Lemma make_shlimm_correct:
forall n r1,
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.
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.shl e#r1 (Vint n)) v.
Proof.
intros; unfold make_shlimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
- exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shl_zero. auto.
econstructor; split. simpl. eauto. auto.
Qed.
Lemma make_shrimm_correct:
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.
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.shr e#r1 (Vint n)) v.
Proof.
intros; unfold make_shrimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
- exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shr_zero. auto.
econstructor; split; eauto. simpl. auto.
Qed.
Lemma make_shruimm_correct:
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.
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.shru e#r1 (Vint n)) v.
Proof.
intros; unfold make_shruimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
- exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shru_zero. auto.
econstructor; split; eauto. simpl. congruence.
Qed.
Lemma make_mulimm_correct:
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.
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mul e#r1 (Vint n)) v.
Proof.
intros; unfold make_mulimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
- exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto.
+ exists (Vint Int.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_zero; auto.
predSpec Int.eq Int.eq_spec n Int.one; intros. subst.
- exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_one; auto.
destruct (Int.is_power2 n) eqn:?; intros.
- rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). apply make_shlimm_correct; auto.
+ rewrite (Val.mul_pow2 e#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 ->
+ Val.divs e#r1 e#r2 = Some v ->
+ e#r2 = Vint n ->
let (op, args) := make_divimm n r1 r2 in
- exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
+ exists w, eval_operation ge (Vptr sp Int.zero) op e##args m = Some w /\ Val.lessdef v w.
Proof.
intros; unfold make_divimm.
destruct (Int.is_power2 n) eqn:?.
@@ -317,14 +235,14 @@ Qed.
Lemma make_divuimm_correct:
forall n r1 r2 v,
- Val.divu rs#r1 rs#r2 = Some v ->
- rs#r2 = Vint n ->
+ Val.divu e#r1 e#r2 = Some v ->
+ e#r2 = Vint n ->
let (op, args) := make_divuimm n r1 r2 in
- exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
+ exists w, eval_operation ge (Vptr sp Int.zero) op e##args m = Some w /\ Val.lessdef v w.
Proof.
intros; unfold make_divuimm.
destruct (Int.is_power2 n) eqn:?.
- replace v with (Val.shru rs#r1 (Vint i)).
+ replace v with (Val.shru e#r1 (Vint i)).
eapply make_shruimm_correct; eauto.
eapply Val.divu_pow2; eauto. congruence.
exists v; auto.
@@ -332,10 +250,10 @@ Qed.
Lemma make_moduimm_correct:
forall n r1 r2 v,
- Val.modu rs#r1 rs#r2 = Some v ->
- rs#r2 = Vint n ->
+ Val.modu e#r1 e#r2 = Some v ->
+ e#r2 = Vint n ->
let (op, args) := make_moduimm n r1 r2 in
- exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
+ exists w, eval_operation ge (Vptr sp Int.zero) op e##args m = Some w /\ Val.lessdef v w.
Proof.
intros; unfold make_moduimm.
destruct (Int.is_power2 n) eqn:?.
@@ -344,125 +262,216 @@ Proof.
Qed.
Lemma make_andimm_correct:
- forall n r,
- let (op, args) := make_andimm n r in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v.
+ forall n r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_andimm n r x in
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.and e#r (Vint n)) v.
Proof.
intros; unfold make_andimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros.
- subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto.
+ subst n. exists (Vint Int.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_zero; auto.
predSpec Int.eq Int.eq_spec n Int.mone; intros.
- subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_mone; auto.
+ destruct (match x with Uns k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero
+ | _ => false end) eqn:UNS.
+ destruct x; try congruence.
+ exists (e#r); split; auto.
+ inv H; auto. simpl. replace (Int.and i n) with i; auto.
+ generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ.
+ Int.bit_solve. destruct (zlt i0 n0).
+ replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)).
+ rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto.
+ rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto.
+ rewrite Int.bits_not by auto. apply negb_involutive.
+ rewrite H5 by auto. auto.
econstructor; split; eauto. auto.
Qed.
Lemma make_orimm_correct:
forall n r,
let (op, args) := make_orimm n r in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v.
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.or e#r (Vint n)) v.
Proof.
intros; unfold make_orimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros.
- subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_zero; auto.
predSpec Int.eq Int.eq_spec n Int.mone; intros.
- subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto.
+ subst n. exists (Vint Int.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_mone; auto.
econstructor; split; eauto. auto.
Qed.
Lemma make_xorimm_correct:
forall n r,
let (op, args) := make_xorimm n r in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v.
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.xor e#r (Vint n)) v.
Proof.
intros; unfold make_xorimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros.
- subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.xor_zero; auto.
econstructor; split; eauto. auto.
Qed.
Lemma make_mulfimm_correct:
forall n r1 r2,
- rs#r2 = Vfloat n ->
+ e#r2 = Vfloat n ->
let (op, args) := make_mulfimm n r1 r1 r2 in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v.
Proof.
intros; unfold make_mulfimm.
destruct (Float.eq_dec n (Float.floatofint (Int.repr 2))); intros.
simpl. econstructor; split. eauto. rewrite H; subst n.
- destruct (rs#r1); simpl; auto. rewrite Float.mul2_add; auto.
+ destruct (e#r1); simpl; auto. rewrite Float.mul2_add; auto.
simpl. econstructor; split; eauto.
Qed.
Lemma make_mulfimm_correct_2:
forall n r1 r2,
- rs#r1 = Vfloat n ->
+ e#r1 = Vfloat n ->
let (op, args) := make_mulfimm n r2 r1 r2 in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v.
Proof.
intros; unfold make_mulfimm.
destruct (Float.eq_dec n (Float.floatofint (Int.repr 2))); intros.
simpl. econstructor; split. eauto. rewrite H; subst n.
- destruct (rs#r2); simpl; auto. rewrite Float.mul2_add; auto.
+ destruct (e#r2); simpl; auto. rewrite Float.mul2_add; auto.
rewrite Float.mul_commut; auto.
simpl. econstructor; split; eauto.
Qed.
+Lemma make_cast8signed_correct:
+ forall r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_cast8signed r x in
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 8 e#r) v.
+Proof.
+ intros; unfold make_cast8signed. destruct (vincl x (Sgn 8)) eqn:INCL.
+ exists e#r; split; auto.
+ assert (V: vmatch bc e#r (Sgn 8)).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite is_sgn_sign_ext in H3 by auto. rewrite H3; auto.
+ econstructor; split; simpl; eauto.
+Qed.
+
+Lemma make_cast8unsigned_correct:
+ forall r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_cast8unsigned r x in
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext 8 e#r) v.
+Proof.
+ intros; unfold make_cast8unsigned. destruct (vincl x (Uns 8)) eqn:INCL.
+ exists e#r; split; auto.
+ assert (V: vmatch bc e#r (Uns 8)).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite is_uns_zero_ext in H3 by auto. rewrite H3; auto.
+ econstructor; split; simpl; eauto.
+Qed.
+
+Lemma make_cast16signed_correct:
+ forall r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_cast16signed r x in
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 16 e#r) v.
+Proof.
+ intros; unfold make_cast16signed. destruct (vincl x (Sgn 16)) eqn:INCL.
+ exists e#r; split; auto.
+ assert (V: vmatch bc e#r (Sgn 16)).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite is_sgn_sign_ext in H3 by auto. rewrite H3; auto.
+ econstructor; split; simpl; eauto.
+Qed.
+
+Lemma make_cast16unsigned_correct:
+ forall r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_cast16unsigned r x in
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext 16 e#r) v.
+Proof.
+ intros; unfold make_cast16unsigned. destruct (vincl x (Uns 16)) eqn:INCL.
+ exists e#r; split; auto.
+ assert (V: vmatch bc e#r (Uns 16)).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite is_uns_zero_ext in H3 by auto. rewrite H3; auto.
+ econstructor; split; simpl; eauto.
+Qed.
+
+Lemma make_singleoffloat_correct:
+ forall r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_singleoffloat r x in
+ exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.singleoffloat e#r) v.
+Proof.
+ intros; unfold make_singleoffloat.
+ destruct (vincl x Fsingle && generate_float_constants tt) eqn:INCL.
+ InvBooleans. exists e#r; split; auto.
+ assert (V: vmatch bc e#r Fsingle).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite Float.singleoffloat_of_single by auto. auto.
+ econstructor; split; simpl; eauto.
+Qed.
+
Lemma op_strength_reduction_correct:
forall op args vl v,
- vl = approx_regs app args ->
- eval_operation ge sp op rs##args m = Some v ->
+ vl = map (fun r => AE.get r ae) args ->
+ eval_operation ge (Vptr sp Int.zero) op e##args m = Some v ->
let (op', args') := op_strength_reduction op args vl in
- exists w, eval_operation ge sp op' rs##args' m = Some w /\ Val.lessdef v w.
+ exists w, eval_operation ge (Vptr sp Int.zero) op' e##args' m = Some w /\ Val.lessdef v w.
Proof.
intros until v; unfold op_strength_reduction;
case (op_strength_reduction_match op args vl); simpl; intros.
+(* cast8signed *)
+ InvApproxRegs; SimplVM; inv H0. apply make_cast8signed_correct; auto.
+(* cast8unsigned *)
+ InvApproxRegs; SimplVM; inv H0. apply make_cast8unsigned_correct; auto.
+(* cast16signed *)
+ InvApproxRegs; SimplVM; inv H0. apply make_cast16signed_correct; auto.
+(* cast16unsigned *)
+ InvApproxRegs; SimplVM; inv H0. apply make_cast16unsigned_correct; auto.
(* sub *)
- InvApproxRegs. SimplVMA. inv H0; rewrite H. rewrite Val.sub_add_opp. apply make_addimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. rewrite Val.sub_add_opp. apply make_addimm_correct; auto.
(* 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.
+ rewrite Val.mul_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto.
(* divs *)
- assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
+ assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
apply make_divimm_correct; auto.
(* divu *)
- assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
+ assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
apply make_divuimm_correct; auto.
(* modu *)
- assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
+ assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
apply make_moduimm_correct; auto.
(* and *)
- InvApproxRegs. SimplVMA. inv H0; rewrite H1. rewrite Val.and_commut. apply make_andimm_correct; auto.
- InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_andimm_correct; auto.
+ rewrite Val.and_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto.
+ inv H; inv H0. apply make_andimm_correct; auto.
(* or *)
- InvApproxRegs. SimplVMA. inv H0; rewrite H1. rewrite Val.or_commut. apply make_orimm_correct; auto.
- InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_orimm_correct; auto.
+ rewrite Val.or_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto.
(* xor *)
- InvApproxRegs. SimplVMA. inv H0; rewrite H1. rewrite Val.xor_commut. apply make_xorimm_correct; auto.
- InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_xorimm_correct; auto.
+ rewrite Val.xor_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto.
(* shl *)
- InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shlimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_shlimm_correct; auto.
(* shr *)
- InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shrimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_shrimm_correct; auto.
(* shru *)
- InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shruimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_shruimm_correct; auto.
(* lea *)
- generalize (addr_strength_reduction_correct addr args0 vl0 H).
+ exploit addr_strength_reduction_correct; eauto.
destruct (addr_strength_reduction addr args0 vl0) as [addr' args'].
- intro EQ. exists v; split; auto. simpl. congruence.
+ auto.
+(* singleoffloat *)
+ InvApproxRegs; SimplVM; inv H0. apply make_singleoffloat_correct; auto.
(* 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.
(* mulf *)
- inv H0. assert (rs#r2 = Vfloat n2). InvApproxRegs; SimplVMA; auto.
- apply make_mulfimm_correct; auto.
- inv H0. assert (rs#r1 = Vfloat n1). InvApproxRegs; SimplVMA; auto.
- apply make_mulfimm_correct_2; auto.
+ InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2).
+ rewrite <- H2. apply make_mulfimm_correct_2; auto.
(* default *)
exists v; auto.
Qed.
End STRENGTH_REDUCTION.
-
-End ANALYSIS.
-
diff --git a/ia32/NeedOp.v b/ia32/NeedOp.v
new file mode 100644
index 0000000..2853bf1
--- /dev/null
+++ b/ia32/NeedOp.v
@@ -0,0 +1,169 @@
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Op.
+Require Import NeedDomain.
+Require Import RTL.
+
+(** Neededness analysis for IA32 operators *)
+
+Definition needs_of_condition (cond: condition): nval :=
+ match cond with
+ | Cmaskzero n | Cmasknotzero n => maskzero n
+ | _ => All
+ end.
+
+Definition needs_of_addressing (addr: addressing) (nv: nval): nval :=
+ modarith nv.
+
+Definition needs_of_operation (op: operation) (nv: nval): nval :=
+ match op with
+ | Omove => nv
+ | Ointconst n => Nothing
+ | Ofloatconst n => Nothing
+ | Oindirectsymbol id => Nothing
+ | Ocast8signed => sign_ext 8 nv
+ | Ocast8unsigned => zero_ext 8 nv
+ | Ocast16signed => sign_ext 16 nv
+ | Ocast16unsigned => zero_ext 16 nv
+ | Omul => modarith nv
+ | Omulimm n => modarith nv
+ | Oand => bitwise nv
+ | Oandimm n => andimm nv n
+ | Oor => bitwise nv
+ | Oorimm n => orimm nv n
+ | Oxor => bitwise nv
+ | Oxorimm n => bitwise nv
+ | Oshlimm n => shlimm nv n
+ | Oshrimm n => shrimm nv n
+ | Oshruimm n => shruimm nv n
+ | Ororimm n => ror nv n
+ | Olea addr => needs_of_addressing addr nv
+ | Ocmp c => needs_of_condition c
+ | Osingleoffloat => singleoffloat nv
+ | _ => default nv
+ end.
+
+Definition operation_is_redundant (op: operation) (nv: nval): bool :=
+ match op with
+ | Ocast8signed => sign_ext_redundant 8 nv
+ | Ocast8unsigned => zero_ext_redundant 8 nv
+ | Ocast16signed => sign_ext_redundant 16 nv
+ | Ocast16unsigned => zero_ext_redundant 16 nv
+ | Oandimm n => andimm_redundant nv n
+ | Oorimm n => orimm_redundant nv n
+ | Osingleoffloat => singleoffloat_redundant nv
+ | _ => false
+ end.
+
+Ltac InvAgree :=
+ match goal with
+ | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree
+ | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree
+ | [H: list_forall2 _ nil _ |- _ ] => inv H; InvAgree
+ | [H: list_forall2 _ (_::_) _ |- _ ] => inv H; InvAgree
+ | _ => idtac
+ end.
+
+Ltac TrivialExists :=
+ match goal with
+ | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto
+ | _ => idtac
+ end.
+
+Section SOUNDNESS.
+
+Variable ge: genv.
+Variable sp: block.
+Variables m m': mem.
+Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p.
+
+Lemma needs_of_condition_sound:
+ forall cond args b args',
+ eval_condition cond args m = Some b ->
+ vagree_list args args' (needs_of_condition cond) ->
+ eval_condition cond args' m' = Some b.
+Proof.
+ intros. destruct cond; simpl in H;
+ try (eapply default_needs_of_condition_sound; eauto; fail);
+ simpl in *; FuncInv; InvAgree.
+- eapply maskzero_sound; eauto.
+- destruct (Val.maskzero_bool v i) as [b'|] eqn:MZ; try discriminate.
+ erewrite maskzero_sound; eauto.
+Qed.
+
+Lemma needs_of_addressing_sound:
+ forall (ge: genv) sp addr args v nv args',
+ eval_addressing ge (Vptr sp Int.zero) addr args = Some v ->
+ vagree_list args args' (needs_of_addressing addr nv) ->
+ exists v',
+ eval_addressing ge (Vptr sp Int.zero) addr args' = Some v'
+ /\ vagree v v' nv.
+Proof.
+ unfold needs_of_addressing; intros.
+ destruct addr; simpl in *; FuncInv; InvAgree; TrivialExists;
+ auto using add_sound, add_sound_2, mul_sound, mul_sound_2 with na.
+Qed.
+
+Lemma needs_of_operation_sound:
+ forall op args v nv args',
+ eval_operation ge (Vptr sp Int.zero) op args m = Some v ->
+ vagree_list args args' (needs_of_operation op nv) ->
+ nv <> Nothing ->
+ exists v',
+ eval_operation ge (Vptr sp Int.zero) op args' m' = Some v'
+ /\ vagree v v' nv.
+Proof.
+ unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail);
+ simpl in *; FuncInv; InvAgree; TrivialExists.
+- auto with na.
+- auto with na.
+- auto with na.
+- apply sign_ext_sound; auto. compute; auto.
+- apply zero_ext_sound; auto. omega.
+- apply sign_ext_sound; auto. compute; auto.
+- apply zero_ext_sound; auto. omega.
+- apply mul_sound; auto.
+- apply mul_sound; auto with na.
+- apply and_sound; auto.
+- apply andimm_sound; auto.
+- apply or_sound; auto.
+- apply orimm_sound; auto.
+- apply xor_sound; auto.
+- apply xor_sound; auto with na.
+- apply shlimm_sound; auto.
+- apply shrimm_sound; auto.
+- apply shruimm_sound; auto.
+- apply ror_sound; auto.
+- eapply needs_of_addressing_sound; eauto.
+- apply singleoffloat_sound; auto.
+- destruct (eval_condition c args m) as [b|] eqn:EC; simpl in H2.
+ erewrite needs_of_condition_sound by eauto.
+ subst v; simpl. auto with na.
+ subst v; auto with na.
+Qed.
+
+Lemma operation_is_redundant_sound:
+ forall op nv arg1 args v arg1',
+ operation_is_redundant op nv = true ->
+ eval_operation ge (Vptr sp Int.zero) op (arg1 :: args) m = Some v ->
+ vagree arg1 arg1' (needs_of_operation op nv) ->
+ vagree v arg1' nv.
+Proof.
+ intros. destruct op; simpl in *; try discriminate; FuncInv; subst.
+- apply sign_ext_redundant_sound; auto. omega.
+- apply zero_ext_redundant_sound; auto. omega.
+- apply sign_ext_redundant_sound; auto. omega.
+- apply zero_ext_redundant_sound; auto. omega.
+- apply andimm_redundant_sound; auto.
+- apply orimm_redundant_sound; auto.
+- apply singleoffloat_redundant_sound; auto.
+Qed.
+
+End SOUNDNESS.
+
+
diff --git a/ia32/Op.v b/ia32/Op.v
index f2e6b13..26e6688 100644
--- a/ia32/Op.v
+++ b/ia32/Op.v
@@ -174,8 +174,8 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool
| 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))
+ | Cmaskzero n, v1 :: nil => Val.maskzero_bool v1 n
+ | Cmasknotzero n, v1 :: nil => option_map negb (Val.maskzero_bool v1 n)
| _, _ => None
end.
@@ -483,9 +483,9 @@ Proof.
repeat (destruct vl; auto). apply Val.negate_cmp_bool.
repeat (destruct vl; auto). apply Val.negate_cmpu_bool.
repeat (destruct vl; auto).
- repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0); auto. destruct b; auto.
- destruct vl; auto. destruct v; auto. destruct vl; auto.
- destruct vl; auto. destruct v; auto. destruct vl; auto. simpl. rewrite negb_involutive. auto.
+ repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0) as [[]|]; auto.
+ destruct vl; auto. destruct vl; auto.
+ destruct vl; auto. destruct vl; auto. destruct (Val.maskzero_bool v i) as [[]|]; auto.
Qed.
(** Shifting stack-relative references. This is used in [Stacking]. *)
@@ -534,27 +534,32 @@ Qed.
(** Offset an addressing mode [addr] by a quantity [delta], so that
it designates the pointer [delta] bytes past the pointer designated
- by [addr]. May be undefined, in which case [None] is returned. *)
+ by [addr]. On PowerPC and ARM, this may be undefined, in which case
+ [None] is returned. On IA32, it is always defined, but we keep the
+ same interface. *)
-Definition offset_addressing (addr: addressing) (delta: int) : option addressing :=
+Definition offset_addressing_total (addr: addressing) (delta: int) : addressing :=
match addr with
- | Aindexed n => Some(Aindexed (Int.add n delta))
- | Aindexed2 n => Some(Aindexed2 (Int.add n delta))
- | Ascaled sc n => Some(Ascaled sc (Int.add n delta))
- | Aindexed2scaled sc n => Some(Aindexed2scaled sc (Int.add n delta))
- | Aglobal s n => Some(Aglobal s (Int.add n delta))
- | Abased s n => Some(Abased s (Int.add n delta))
- | Abasedscaled sc s n => Some(Abasedscaled sc s (Int.add n delta))
- | Ainstack n => Some(Ainstack (Int.add n delta))
+ | Aindexed n => Aindexed (Int.add n delta)
+ | Aindexed2 n => Aindexed2 (Int.add n delta)
+ | Ascaled sc n => Ascaled sc (Int.add n delta)
+ | Aindexed2scaled sc n => Aindexed2scaled sc (Int.add n delta)
+ | Aglobal s n => Aglobal s (Int.add n delta)
+ | Abased s n => Abased s (Int.add n delta)
+ | Abasedscaled sc s n => Abasedscaled sc s (Int.add n delta)
+ | Ainstack n => Ainstack (Int.add n delta)
end.
-Lemma eval_offset_addressing:
- forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v,
- offset_addressing addr delta = Some addr' ->
+Definition offset_addressing (addr: addressing) (delta: int) : option addressing :=
+ Some(offset_addressing_total addr delta).
+
+Lemma eval_offset_addressing_total:
+ forall (F V: Type) (ge: Genv.t F V) sp addr args delta v,
eval_addressing ge sp addr args = Some v ->
- eval_addressing ge sp addr' args = Some(Val.add v (Vint delta)).
+ eval_addressing ge sp (offset_addressing_total addr delta) args =
+ Some(Val.add v (Vint delta)).
Proof.
- intros. destruct addr; simpl in H; inv H; simpl in *; FuncInv; inv H.
+ intros. destruct addr; simpl in *; FuncInv; subst.
rewrite Val.add_assoc; auto.
rewrite !Val.add_assoc; auto.
rewrite !Val.add_assoc; auto.
@@ -567,6 +572,16 @@ Proof.
rewrite Val.add_assoc. auto.
Qed.
+Lemma eval_offset_addressing:
+ forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v,
+ offset_addressing addr delta = Some addr' ->
+ eval_addressing ge sp addr args = Some v ->
+ eval_addressing ge sp addr' args = Some(Val.add v (Vint delta)).
+Proof.
+ intros. unfold offset_addressing in H; inv H.
+ eapply eval_offset_addressing_total; eauto.
+Qed.
+
(** Operations that are so cheap to recompute that CSE should not factor them out. *)
Definition is_trivial_op (op: operation) : bool :=
@@ -757,8 +772,8 @@ Proof.
eauto 3 using val_cmpu_bool_inject, Mem.valid_pointer_implies.
inv H3; inv H2; simpl in H0; inv H0; auto.
inv H3; inv H2; simpl in H0; inv H0; auto.
- inv H3; try discriminate; inv H5; auto.
- inv H3; try discriminate; inv H5; auto.
+ inv H3; try discriminate; auto.
+ inv H3; try discriminate; auto.
Qed.
Ltac TrivialExists :=
diff --git a/ia32/SelectOp.vp b/ia32/SelectOp.vp
index 1471405..d8a2127 100644
--- a/ia32/SelectOp.vp
+++ b/ia32/SelectOp.vp
@@ -71,24 +71,12 @@ Definition notint (e: expr) := Eop (Oxorimm Int.mone) (e ::: Enil).
(** ** 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)
+ | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil
+ | Eop (Olea addr) args => Eop (Olea (offset_addressing_total addr n)) args
+ | _ => Eop (Olea (Aindexed n)) (e ::: Enil)
end.
Nondetfunction add (e1: expr) (e2: expr) :=
diff --git a/ia32/SelectOpproof.v b/ia32/SelectOpproof.v
index cec3b59..02d3bee 100644
--- a/ia32/SelectOpproof.v
+++ b/ia32/SelectOpproof.v
@@ -145,22 +145,6 @@ Proof.
intros. unfold symbol_address. destruct (Genv.find_symbol); auto.
Qed.
-Lemma eval_offset_addressing:
- forall addr n args v,
- eval_addressing ge sp addr args = Some v ->
- 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 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 n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)).
Proof.
@@ -170,7 +154,7 @@ Proof.
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.
+ inv H0. simpl in H6. TrivialExists. simpl. eapply eval_offset_addressing_total; eauto.
TrivialExists.
Qed.
diff --git a/ia32/ValueAOp.v b/ia32/ValueAOp.v
new file mode 100644
index 0000000..a7c72d3
--- /dev/null
+++ b/ia32/ValueAOp.v
@@ -0,0 +1,158 @@
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Op.
+Require Import ValueDomain.
+Require Import RTL.
+
+(** Value analysis for IA32 operators *)
+
+Definition eval_static_condition (cond: condition) (vl: list aval): abool :=
+ match cond, vl with
+ | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2
+ | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2
+ | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n)
+ | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n)
+ | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2
+ | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2)
+ | Cmaskzero n, v1 :: nil => maskzero v1 n
+ | Cmasknotzero n, v1 :: nil => cnot (maskzero v1 n)
+ | _, _ => Bnone
+ end.
+
+Definition eval_static_addressing (addr: addressing) (vl: list aval): aval :=
+ match addr, vl with
+ | Aindexed n, v1::nil => add v1 (I n)
+ | Aindexed2 n, v1::v2::nil => add (add v1 v2) (I n)
+ | Ascaled sc ofs, v1::nil => add (mul v1 (I sc)) (I ofs)
+ | Aindexed2scaled sc ofs, v1::v2::nil => add v1 (add (mul v2 (I sc)) (I ofs))
+ | Aglobal s ofs, nil => Ptr (Gl s ofs)
+ | Abased s ofs, v1::nil => add (Ptr (Gl s ofs)) v1
+ | Abasedscaled sc s ofs, v1::nil => add (Ptr (Gl s ofs)) (mul v1 (I sc))
+ | Ainstack ofs, nil => Ptr(Stk ofs)
+ | _, _ => Vbot
+ end.
+
+Definition eval_static_operation (op: operation) (vl: list aval): aval :=
+ match op, vl with
+ | Omove, v1::nil => v1
+ | Ointconst n, nil => I n
+ | Ofloatconst n, nil => if propagate_float_constants tt then F n else ftop
+ | Oindirectsymbol id, nil => Ptr (Gl id Int.zero)
+ | Ocast8signed, v1 :: nil => sign_ext 8 v1
+ | Ocast8unsigned, v1 :: nil => zero_ext 8 v1
+ | Ocast16signed, v1 :: nil => sign_ext 16 v1
+ | Ocast16unsigned, v1 :: nil => zero_ext 16 v1
+ | Oneg, v1::nil => neg v1
+ | Osub, v1::v2::nil => sub v1 v2
+ | Omul, v1::v2::nil => mul v1 v2
+ | Omulimm n, v1::nil => mul v1 (I n)
+ | Omulhs, v1::v2::nil => mulhs v1 v2
+ | Omulhu, v1::v2::nil => mulhu v1 v2
+ | Odiv, v1::v2::nil => divs v1 v2
+ | Odivu, v1::v2::nil => divu v1 v2
+ | Omod, v1::v2::nil => mods v1 v2
+ | Omodu, v1::v2::nil => modu v1 v2
+ | Oand, v1::v2::nil => and v1 v2
+ | Oandimm n, v1::nil => and v1 (I n)
+ | Oor, v1::v2::nil => or v1 v2
+ | Oorimm n, v1::nil => or v1 (I n)
+ | Oxor, v1::v2::nil => xor v1 v2
+ | Oxorimm n, v1::nil => xor v1 (I n)
+ | Oshl, v1::v2::nil => shl v1 v2
+ | Oshlimm n, v1::nil => shl v1 (I n)
+ | Oshr, v1::v2::nil => shr v1 v2
+ | Oshrimm n, v1::nil => shr v1 (I n)
+ | Oshrximm n, v1::nil => shrx v1 (I n)
+ | Oshru, v1::v2::nil => shru v1 v2
+ | Oshruimm n, v1::nil => shru v1 (I n)
+ | Ororimm n, v1::nil => ror v1 (I n)
+ | Oshldimm n, v1::v2::nil => or (shl v1 (I n)) (shru v2 (I (Int.sub Int.iwordsize n)))
+ | Olea addr, _ => eval_static_addressing addr vl
+ | Onegf, v1::nil => negf v1
+ | Oabsf, v1::nil => absf v1
+ | Oaddf, v1::v2::nil => addf v1 v2
+ | Osubf, v1::v2::nil => subf v1 v2
+ | Omulf, v1::v2::nil => mulf v1 v2
+ | Odivf, v1::v2::nil => divf v1 v2
+ | Osingleoffloat, v1::nil => singleoffloat v1
+ | Ointoffloat, v1::nil => intoffloat v1
+ | Ofloatofint, v1::nil => floatofint v1
+ | Omakelong, v1::v2::nil => longofwords v1 v2
+ | Olowlong, v1::nil => loword v1
+ | Ohighlong, v1::nil => hiword v1
+ | Ocmp c, _ => of_optbool (eval_static_condition c vl)
+ | _, _ => Vbot
+ end.
+
+Section SOUNDNESS.
+
+Variable bc: block_classification.
+Variable ge: genv.
+Hypothesis GENV: genv_match bc ge.
+Variable sp: block.
+Hypothesis STACK: bc sp = BCstack.
+
+Theorem eval_static_condition_sound:
+ forall cond vargs m aargs,
+ list_forall2 (vmatch bc) vargs aargs ->
+ cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs).
+Proof.
+ intros until aargs; intros VM.
+ inv VM.
+ destruct cond; auto with va.
+ inv H0.
+ destruct cond; simpl; eauto with va.
+ inv H2.
+ destruct cond; simpl; eauto with va.
+ destruct cond; auto with va.
+Qed.
+
+Lemma symbol_address_sound:
+ forall id ofs,
+ vmatch bc (symbol_address ge id ofs) (Ptr (Gl id ofs)).
+Proof.
+ intros; apply symbol_address_sound; apply GENV.
+Qed.
+
+Hint Resolve symbol_address_sound: va.
+
+Ltac InvHyps :=
+ match goal with
+ | [H: None = Some _ |- _ ] => discriminate
+ | [H: Some _ = Some _ |- _] => inv H
+ | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ ,
+ H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps
+ | _ => idtac
+ end.
+
+Theorem eval_static_addressing_sound:
+ forall addr vargs vres aargs,
+ eval_addressing ge (Vptr sp Int.zero) addr vargs = Some vres ->
+ list_forall2 (vmatch bc) vargs aargs ->
+ vmatch bc vres (eval_static_addressing addr aargs).
+Proof.
+ unfold eval_addressing, eval_static_addressing; intros;
+ destruct addr; InvHyps; eauto with va.
+ rewrite Int.add_zero_l; auto with va.
+Qed.
+
+Theorem eval_static_operation_sound:
+ forall op vargs m vres aargs,
+ eval_operation ge (Vptr sp Int.zero) op vargs m = Some vres ->
+ list_forall2 (vmatch bc) vargs aargs ->
+ vmatch bc vres (eval_static_operation op aargs).
+Proof.
+ unfold eval_operation, eval_static_operation; intros;
+ destruct op; InvHyps; eauto with va.
+ destruct (propagate_float_constants tt); constructor.
+ eapply eval_static_addressing_sound; eauto.
+ apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
+Qed.
+
+End SOUNDNESS.
+
diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml
index 929b61e..ca48341 100644
--- a/lib/Camlcoq.ml
+++ b/lib/Camlcoq.ml
@@ -363,6 +363,16 @@ let time3 name fn arg1 arg2 arg3 =
add_to_timer name (Unix.gettimeofday() -. start);
raise x
+let time4 name fn arg1 arg2 arg3 arg4 =
+ let start = Unix.gettimeofday() in
+ try
+ let res = fn arg1 arg2 arg3 arg4 in
+ add_to_timer name (Unix.gettimeofday() -. start);
+ res
+ with x ->
+ add_to_timer name (Unix.gettimeofday() -. start);
+ raise x
+
let print_timers () =
Hashtbl.iter
(fun name time -> Printf.printf "%-20s %.3f\n" name time)
diff --git a/lib/Integers.v b/lib/Integers.v
index cbbf28c..d85007b 100644
--- a/lib/Integers.v
+++ b/lib/Integers.v
@@ -2454,6 +2454,19 @@ Proof.
generalize wordsize_pos; generalize wordsize_max_unsigned; omega.
Qed.
+Theorem ror_rol_neg:
+ forall x y, (zwordsize | modulus) -> ror x y = rol x (neg y).
+Proof.
+ intros. apply same_bits_eq; intros.
+ rewrite bits_ror by auto. rewrite bits_rol by auto.
+ f_equal. apply eqmod_mod_eq. omega.
+ apply eqmod_trans with (i - (- unsigned y)).
+ apply eqmod_refl2; omega.
+ apply eqmod_sub. apply eqmod_refl.
+ apply eqmod_divides with modulus.
+ apply eqm_unsigned_repr. auto.
+Qed.
+
Theorem or_ror:
forall x y z,
ltu y iwordsize = true ->
diff --git a/lib/IntvSets.v b/lib/IntvSets.v
new file mode 100644
index 0000000..9f1a895
--- /dev/null
+++ b/lib/IntvSets.v
@@ -0,0 +1,410 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Finite sets of integer intervals *)
+
+Require Import Coqlib.
+
+Module ISet.
+
+(** "Raw", non-dependent implementation. A set of intervals is a
+ list of nonempty semi-open intervals [(lo, hi)],
+ sorted in increasing order of the low bound,
+ and with no overlap nor adjacency between elements.
+ In particular, if the list contains [(lo1, hi1)] followed by [(lo2, hi2)],
+ we have [lo1 < hi1 < lo2 < hi2]. *)
+
+Module R.
+
+Inductive t : Type := Nil | Cons (lo hi: Z) (tl: t).
+
+Fixpoint In (x: Z) (s: t) :=
+ match s with
+ | Nil => False
+ | Cons l h s' => l <= x < h \/ In x s'
+ end.
+
+Inductive ok: t -> Prop :=
+ | ok_nil: ok Nil
+ | ok_cons: forall l h s
+ (BOUNDS: l < h)
+ (BELOW: forall x, In x s -> h < x)
+ (OK: ok s),
+ ok (Cons l h s).
+
+Fixpoint mem (x: Z) (s: t) : bool :=
+ match s with
+ | Nil => false
+ | Cons l h s' => if zlt x h then zle l x else mem x s'
+ end.
+
+Lemma mem_In:
+ forall x s, ok s -> (mem x s = true <-> In x s).
+Proof.
+ induction 1; simpl.
+- intuition congruence.
+- destruct (zlt x h).
++ destruct (zle l x); simpl.
+ * tauto.
+ * split; intros. congruence.
+ exfalso. destruct H0. omega. exploit BELOW; eauto. omega.
++ rewrite IHok. intuition.
+Qed.
+
+Fixpoint contains (L H: Z) (s: t) : bool :=
+ match s with
+ | Nil => false
+ | Cons l h s' => (zle H h && zle l L) || contains L H s'
+ end.
+
+Lemma contains_In:
+ forall l0 h0, l0 < h0 -> forall s, ok s ->
+ (contains l0 h0 s = true <-> (forall x, l0 <= x < h0 -> In x s)).
+Proof.
+ induction 2; simpl.
+- intuition. elim (H0 l0); omega.
+- destruct (zle h0 h); simpl.
+ destruct (zle l l0); simpl.
+ intuition.
+ rewrite IHok. intuition. destruct (H3 x); auto. exfalso.
+ destruct (H3 l0). omega. omega. exploit BELOW; eauto. omega.
+ rewrite IHok. intuition. destruct (H3 x); auto. exfalso.
+ destruct (H3 h). omega. omega. exploit BELOW; eauto. omega.
+Qed.
+
+Fixpoint add (L H: Z) (s: t) {struct s} : t :=
+ match s with
+ | Nil => Cons L H Nil
+ | Cons l h s' =>
+ if zlt h L then Cons l h (add L H s')
+ else if zlt H l then Cons L H s
+ else add (Z.min l L) (Z.max h H) s'
+ end.
+
+Lemma In_add:
+ forall x s, ok s -> forall l0 h0, (In x (add l0 h0 s) <-> l0 <= x < h0 \/ In x s).
+Proof.
+ induction 1; simpl; intros.
+ tauto.
+ destruct (zlt h l0).
+ simpl. rewrite IHok. tauto.
+ destruct (zlt h0 l).
+ simpl. tauto.
+ rewrite IHok. intuition.
+ assert (l0 <= x < h0 \/ l <= x < h) by xomega. tauto.
+ left; xomega.
+ left; xomega.
+Qed.
+
+Lemma add_ok:
+ forall s, ok s -> forall l0 h0, l0 < h0 -> ok (add l0 h0 s).
+Proof.
+ induction 1; simpl; intros.
+ constructor. auto. intros. inv H0. constructor.
+ destruct (zlt h l0).
+ constructor; auto. intros. rewrite In_add in H1; auto.
+ destruct H1. omega. auto.
+ destruct (zlt h0 l).
+ constructor. auto. simpl; intros. destruct H1. omega. exploit BELOW; eauto. omega.
+ constructor. omega. auto. auto.
+ apply IHok. xomega.
+Qed.
+
+Fixpoint remove (L H: Z) (s: t) {struct s} : t :=
+ match s with
+ | Nil => Nil
+ | Cons l h s' =>
+ if zlt h L then Cons l h (remove L H s')
+ else if zlt H l then s
+ else if zlt l L then
+ if zlt H h then Cons l L (Cons H h s') else Cons l L (remove L H s')
+ else
+ if zlt H h then Cons H h s' else remove L H s'
+ end.
+
+Lemma In_remove:
+ forall x l0 h0 s, ok s ->
+ (In x (remove l0 h0 s) <-> ~(l0 <= x < h0) /\ In x s).
+Proof.
+ induction 1; simpl.
+ tauto.
+ destruct (zlt h l0).
+ simpl. rewrite IHok. intuition omega.
+ destruct (zlt h0 l).
+ simpl. intuition. exploit BELOW; eauto. omega.
+ destruct (zlt l l0).
+ destruct (zlt h0 h); simpl. clear IHok. split.
+ intros [A | [A | A]].
+ split. omega. left; omega.
+ split. omega. left; omega.
+ split. exploit BELOW; eauto. omega. auto.
+ intros [A [B | B]].
+ destruct (zlt x l0). left; omega. right; left; omega.
+ auto.
+ intuition omega.
+ destruct (zlt h0 h); simpl.
+ intuition. exploit BELOW; eauto. omega.
+ rewrite IHok. intuition. omegaContradiction.
+Qed.
+
+Lemma remove_ok:
+ forall l0 h0, l0 < h0 -> forall s, ok s -> ok (remove l0 h0 s).
+Proof.
+ induction 2; simpl.
+ constructor.
+ destruct (zlt h l0).
+ constructor; auto. intros; apply BELOW. rewrite In_remove in H1; tauto.
+ destruct (zlt h0 l).
+ constructor; auto.
+ destruct (zlt l l0).
+ destruct (zlt h0 h).
+ constructor. omega. intros. inv H1. omega. exploit BELOW; eauto. omega.
+ constructor. omega. auto. auto.
+ constructor; auto. intros. rewrite In_remove in H1 by auto. destruct H1. exploit BELOW; eauto. omega.
+ destruct (zlt h0 h).
+ constructor; auto.
+ auto.
+Qed.
+
+Fixpoint inter (s1 s2: t) {struct s1} : t :=
+ let fix intr (s2: t) : t :=
+ match s1, s2 with
+ | Nil, _ => Nil
+ | _, Nil => Nil
+ | Cons l1 h1 s1', Cons l2 h2 s2' =>
+ if zle h1 l2 then inter s1' s2
+ else if zle h2 l1 then intr s2'
+ else if zle l1 l2 then
+ if zle h2 h1 then Cons l2 h2 (intr s2') else Cons l2 h1 (inter s1' s2)
+ else
+ if zle h1 h2 then Cons l1 h1 (inter s1' s2) else Cons l1 h2 (intr s2')
+ end
+ in intr s2.
+
+Lemma In_inter:
+ forall x s1, ok s1 -> forall s2, ok s2 ->
+ (In x (inter s1 s2) <-> In x s1 /\ In x s2).
+Proof.
+ induction 1.
+ simpl. induction 1; simpl. tauto. tauto.
+ assert (ok (Cons l h s)) by (constructor; auto).
+ induction 1; simpl.
+ tauto.
+ assert (ok (Cons l0 h0 s0)) by (constructor; auto).
+ destruct (zle h l0).
+ rewrite IHok; auto. simpl. intuition. omegaContradiction.
+ exploit BELOW0; eauto. intros. omegaContradiction.
+ destruct (zle h0 l).
+ simpl in IHok0; rewrite IHok0. intuition. omegaContradiction.
+ exploit BELOW; eauto. intros; omegaContradiction.
+ destruct (zle l l0).
+ destruct (zle h0 h).
+ simpl. simpl in IHok0; rewrite IHok0. intuition.
+ simpl. rewrite IHok; auto. simpl. intuition. exploit BELOW0; eauto. intros; omegaContradiction.
+ destruct (zle h h0).
+ simpl. rewrite IHok; auto. simpl. intuition.
+ simpl. simpl in IHok0; rewrite IHok0. intuition.
+ exploit BELOW; eauto. intros; omegaContradiction.
+Qed.
+
+Lemma inter_ok:
+ forall s1, ok s1 -> forall s2, ok s2 -> ok (inter s1 s2).
+Proof.
+ induction 1.
+ intros; simpl. destruct s2; constructor.
+ assert (ok (Cons l h s)). constructor; auto.
+ induction 1; simpl.
+ constructor.
+ assert (ok (Cons l0 h0 s0)). constructor; auto.
+ destruct (zle h l0).
+ auto.
+ destruct (zle h0 l).
+ auto.
+ destruct (zle l l0).
+ destruct (zle h0 h).
+ constructor; auto. intros.
+ assert (In x (inter (Cons l h s) s0)) by exact H3.
+ rewrite In_inter in H4; auto. apply BELOW0. tauto.
+ constructor. omega. intros. rewrite In_inter in H3; auto. apply BELOW. tauto.
+ auto.
+ destruct (zle h h0).
+ constructor. omega. intros. rewrite In_inter in H3; auto. apply BELOW. tauto.
+ auto.
+ constructor. omega. intros.
+ assert (In x (inter (Cons l h s) s0)) by exact H3.
+ rewrite In_inter in H4; auto. apply BELOW0. tauto.
+ auto.
+Qed.
+
+Fixpoint union (s1 s2: t) : t :=
+ match s1, s2 with
+ | Nil, _ => s2
+ | _, Nil => s1
+ | Cons l1 h1 s1', Cons l2 h2 s2' => add l1 h1 (add l2 h2 (union s1' s2'))
+ end.
+
+Lemma In_ok_union:
+ forall s1, ok s1 -> forall s2, ok s2 ->
+ ok (union s1 s2) /\ (forall x, In x s1 \/ In x s2 <-> In x (union s1 s2)).
+Proof.
+ induction 1; destruct 1; simpl.
+ split. constructor. tauto.
+ split. constructor; auto. tauto.
+ split. constructor; auto. tauto.
+ destruct (IHok s0) as [A B]; auto.
+ split. apply add_ok; auto. apply add_ok; auto.
+ intros. rewrite In_add. rewrite In_add. rewrite <- B. tauto. auto. apply add_ok; auto.
+Qed.
+
+Fixpoint beq (s1 s2: t) : bool :=
+ match s1, s2 with
+ | Nil, Nil => true
+ | Cons l1 h1 t1, Cons l2 h2 t2 => zeq l1 l2 && zeq h1 h2 && beq t1 t2
+ | _, _ => false
+ end.
+
+Lemma beq_spec:
+ forall s1, ok s1 -> forall s2, ok s2 ->
+ (beq s1 s2 = true <-> (forall x, In x s1 <-> In x s2)).
+Proof.
+ induction 1; destruct 1; simpl.
+- tauto.
+- split; intros. discriminate. exfalso. apply (H0 l). left; omega.
+- split; intros. discriminate. exfalso. apply (H0 l). left; omega.
+- split; intros.
++ InvBooleans. subst. rewrite IHok in H3 by auto. rewrite H3. tauto.
++ destruct (zeq l l0). destruct (zeq h h0). simpl. subst.
+ apply IHok. auto. intros; split; intros.
+ destruct (proj1 (H1 x)); auto. exfalso. exploit BELOW; eauto. omega.
+ destruct (proj2 (H1 x)); auto. exfalso. exploit BELOW0; eauto. omega.
+ exfalso. subst l0. destruct (zlt h h0).
+ destruct (proj2 (H1 h)). left; omega. omega. exploit BELOW; eauto. omega.
+ destruct (proj1 (H1 h0)). left; omega. omega. exploit BELOW0; eauto. omega.
+ exfalso. destruct (zlt l l0).
+ destruct (proj1 (H1 l)). left; omega. omega. exploit BELOW0; eauto. omega.
+ destruct (proj2 (H1 l0)). left; omega. omega. exploit BELOW; eauto. omega.
+Qed.
+
+End R.
+
+(** Exported interface, wrapping the [ok] invariant in a dependent type. *)
+
+Definition t := { r: R.t | R.ok r }.
+
+Program Definition In (x: Z) (s: t) := R.In x s.
+
+Program Definition empty : t := R.Nil.
+Next Obligation. constructor. Qed.
+
+Theorem In_empty: forall x, ~(In x empty).
+Proof.
+ unfold In; intros; simpl. tauto.
+Qed.
+
+Program Definition interval (l h: Z) : t :=
+ if zlt l h then R.Cons l h R.Nil else R.Nil.
+Next Obligation.
+ constructor; auto. simpl; tauto. constructor.
+Qed.
+Next Obligation.
+ constructor.
+Qed.
+
+Theorem In_interval: forall x l h, In x (interval l h) <-> l <= x < h.
+Proof.
+ intros. unfold In, interval; destruct (zlt l h); simpl.
+ intuition.
+ intuition.
+Qed.
+
+Program Definition add (l h: Z) (s: t) : t :=
+ if zlt l h then R.add l h s else s.
+Next Obligation.
+ apply R.add_ok. apply proj2_sig. auto.
+Qed.
+
+Theorem In_add: forall x l h s, In x (add l h s) <-> l <= x < h \/ In x s.
+Proof.
+ unfold add, In; intros.
+ destruct (zlt l h).
+ simpl. apply R.In_add. apply proj2_sig.
+ intuition. omegaContradiction.
+Qed.
+
+Program Definition remove (l h: Z) (s: t) : t :=
+ if zlt l h then R.remove l h s else s.
+Next Obligation.
+ apply R.remove_ok. auto. apply proj2_sig.
+Qed.
+
+Theorem In_remove: forall x l h s, In x (remove l h s) <-> ~(l <= x < h) /\ In x s.
+Proof.
+ unfold remove, In; intros.
+ destruct (zlt l h).
+ simpl. apply R.In_remove. apply proj2_sig.
+ intuition.
+Qed.
+
+Program Definition inter (s1 s2: t) : t := R.inter s1 s2.
+Next Obligation. apply R.inter_ok; apply proj2_sig. Qed.
+
+Theorem In_inter: forall x s1 s2, In x (inter s1 s2) <-> In x s1 /\ In x s2.
+Proof.
+ unfold inter, In; intros; simpl. apply R.In_inter; apply proj2_sig.
+Qed.
+
+Program Definition union (s1 s2: t) : t := R.union s1 s2.
+Next Obligation.
+ destruct (R.In_ok_union _ (proj2_sig s1) _ (proj2_sig s2)). auto.
+Qed.
+
+Theorem In_union: forall x s1 s2, In x (union s1 s2) <-> In x s1 \/ In x s2.
+Proof.
+ unfold union, In; intros; simpl.
+ destruct (R.In_ok_union _ (proj2_sig s1) _ (proj2_sig s2)).
+ generalize (H0 x); tauto.
+Qed.
+
+Program Definition mem (x: Z) (s: t) := R.mem x s.
+
+Theorem mem_spec: forall x s, mem x s = true <-> In x s.
+Proof.
+ unfold mem, In; intros. apply R.mem_In. apply proj2_sig.
+Qed.
+
+Program Definition contains (l h: Z) (s: t) :=
+ if zlt l h then R.contains l h s else true.
+
+Theorem contains_spec:
+ forall l h s, contains l h s = true <-> (forall x, l <= x < h -> In x s).
+Proof.
+ unfold contains, In; intros. destruct (zlt l h).
+ apply R.contains_In. auto. apply proj2_sig.
+ split; intros. omegaContradiction. auto.
+Qed.
+
+Program Definition beq (s1 s2: t) : bool := R.beq s1 s2.
+
+Theorem beq_spec:
+ forall s1 s2, beq s1 s2 = true <-> (forall x, In x s1 <-> In x s2).
+Proof.
+ unfold mem, In; intros. apply R.beq_spec; apply proj2_sig.
+Qed.
+
+End ISet.
+
+
+
+
diff --git a/lib/Lattice.v b/lib/Lattice.v
index cb28b5b..5a941a1 100644
--- a/lib/Lattice.v
+++ b/lib/Lattice.v
@@ -66,42 +66,28 @@ End SEMILATTICE_WITH_TOP.
Set Implicit Arguments.
-(** Given a semi-lattice with top [L], the following functor implements
+(** Given a semi-lattice (without top) [L], the following functor implements
a semi-lattice structure over finite maps from positive numbers to [L.t].
- The default value for these maps is either [L.top] or [L.bot]. *)
-
-Module LPMap(L: SEMILATTICE_WITH_TOP) <: SEMILATTICE_WITH_TOP.
+ The default value for these maps is [L.bot]. Bottom elements are not smashed. *)
-Inductive t' : Type :=
- | Bot: t'
- | Top_except: PTree.t L.t -> t'.
+Module LPMap1(L: SEMILATTICE) <: SEMILATTICE.
-Definition t: Type := t'.
+Definition t := PTree.t L.t.
Definition get (p: positive) (x: t) : L.t :=
- match x with
- | Bot => L.bot
- | Top_except m => match m!p with None => L.top | Some x => x end
- end.
+ match x!p with None => L.bot | Some x => x end.
Definition set (p: positive) (v: L.t) (x: t) : t :=
- match x with
- | Bot => Bot
- | Top_except m =>
- if L.beq v L.bot
- then Bot
- else Top_except (if L.beq v L.top then PTree.remove p m else PTree.set p v m)
- end.
+ if L.beq v L.bot
+ then PTree.remove p x
+ else PTree.set p v x.
Lemma gsspec:
forall p v x q,
- x <> Bot -> ~L.eq v L.bot ->
L.eq (get q (set p v x)) (if peq q p then v else get q x).
Proof.
- intros. unfold set. destruct x. congruence.
- destruct (L.beq v L.bot) eqn:EBOT.
- elim H0. apply L.beq_correct; auto.
- destruct (L.beq v L.top) eqn:ETOP; simpl.
+ intros. unfold set, get.
+ destruct (L.beq v L.bot) eqn:EBOT.
rewrite PTree.grspec. unfold PTree.elt_eq. destruct (peq q p).
apply L.eq_sym. apply L.beq_correct; auto.
apply L.eq_refl.
@@ -126,20 +112,13 @@ Proof.
unfold eq; intros. eapply L.eq_trans; eauto.
Qed.
-Definition beq (x y: t) : bool :=
- match x, y with
- | Bot, Bot => true
- | Top_except m, Top_except n => PTree.beq L.beq m n
- | _, _ => false
- end.
+Definition beq (x y: t) : bool := PTree.beq L.beq x y.
Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof.
- destruct x; destruct y; simpl; intro; try congruence.
- apply eq_refl.
- red; intro; simpl.
- rewrite PTree.beq_correct in H. generalize (H p).
- destruct (t0!p); destruct (t1!p); intuition.
+ unfold beq; intros; red; intros. unfold get.
+ rewrite PTree.beq_correct in H. specialize (H p).
+ destruct (x!p); destruct (y!p); intuition.
apply L.beq_correct; auto.
apply L.eq_refl.
Qed.
@@ -157,11 +136,11 @@ Proof.
unfold ge; intros. apply L.ge_trans with (get p y); auto.
Qed.
-Definition bot := Bot.
+Definition bot : t := PTree.empty _.
Lemma get_bot: forall p, get p bot = L.bot.
Proof.
- unfold bot; intros; simpl. auto.
+ unfold bot, get; intros; simpl. rewrite PTree.gempty. auto.
Qed.
Lemma ge_bot: forall x, ge x bot.
@@ -169,18 +148,6 @@ Proof.
unfold ge; intros. rewrite get_bot. apply L.ge_bot.
Qed.
-Definition top := Top_except (PTree.empty L.t).
-
-Lemma get_top: forall p, get p top = L.top.
-Proof.
- unfold top; intros; simpl. rewrite PTree.gempty. auto.
-Qed.
-
-Lemma ge_top: forall x, ge top x.
-Proof.
- unfold ge; intros. rewrite get_top. apply L.ge_top.
-Qed.
-
(** A [combine] operation over the type [PTree.t L.t] that attempts
to share its result with its arguments. *)
@@ -407,6 +374,168 @@ Qed.
End COMBINE.
+Definition lub (x y: t) : t :=
+ combine
+ (fun a b =>
+ match a, b with
+ | Some u, Some v => Some (L.lub u v)
+ | None, _ => b
+ | _, None => a
+ end)
+ x y.
+
+Lemma gcombine_bot:
+ forall f t1 t2 p,
+ f None None = None ->
+ L.eq (get p (combine f t1 t2))
+ (match f t1!p t2!p with Some x => x | None => L.bot end).
+Proof.
+ intros. unfold get. generalize (gcombine f H t1 t2 p). unfold opt_eq.
+ destruct ((combine f t1 t2)!p); destruct (f t1!p t2!p).
+ auto. contradiction. contradiction. intros; apply L.eq_refl.
+Qed.
+
+Lemma ge_lub_left:
+ forall x y, ge (lub x y) x.
+Proof.
+ unfold ge, lub; intros.
+ eapply L.ge_trans. apply L.ge_refl. apply gcombine_bot; auto.
+ unfold get. destruct x!p. destruct y!p.
+ apply L.ge_lub_left.
+ apply L.ge_refl. apply L.eq_refl.
+ apply L.ge_bot.
+Qed.
+
+Lemma ge_lub_right:
+ forall x y, ge (lub x y) y.
+Proof.
+ unfold ge, lub; intros.
+ eapply L.ge_trans. apply L.ge_refl. apply gcombine_bot; auto.
+ unfold get. destruct y!p. destruct x!p.
+ apply L.ge_lub_right.
+ apply L.ge_refl. apply L.eq_refl.
+ apply L.ge_bot.
+Qed.
+
+End LPMap1.
+
+(** Given a semi-lattice with top [L], the following functor implements
+ a semi-lattice-with-top structure over finite maps from positive numbers to [L.t].
+ The default value for these maps is [L.top]. Bottom elements are smashed. *)
+
+Module LPMap(L: SEMILATTICE_WITH_TOP) <: SEMILATTICE_WITH_TOP.
+
+Inductive t' : Type :=
+ | Bot: t'
+ | Top_except: PTree.t L.t -> t'.
+
+Definition t: Type := t'.
+
+Definition get (p: positive) (x: t) : L.t :=
+ match x with
+ | Bot => L.bot
+ | Top_except m => match m!p with None => L.top | Some x => x end
+ end.
+
+Definition set (p: positive) (v: L.t) (x: t) : t :=
+ match x with
+ | Bot => Bot
+ | Top_except m =>
+ if L.beq v L.bot
+ then Bot
+ else Top_except (if L.beq v L.top then PTree.remove p m else PTree.set p v m)
+ end.
+
+Lemma gsspec:
+ forall p v x q,
+ x <> Bot -> ~L.eq v L.bot ->
+ L.eq (get q (set p v x)) (if peq q p then v else get q x).
+Proof.
+ intros. unfold set. destruct x. congruence.
+ destruct (L.beq v L.bot) eqn:EBOT.
+ elim H0. apply L.beq_correct; auto.
+ destruct (L.beq v L.top) eqn:ETOP; simpl.
+ rewrite PTree.grspec. unfold PTree.elt_eq. destruct (peq q p).
+ apply L.eq_sym. apply L.beq_correct; auto.
+ apply L.eq_refl.
+ rewrite PTree.gsspec. destruct (peq q p); apply L.eq_refl.
+Qed.
+
+Definition eq (x y: t) : Prop :=
+ forall p, L.eq (get p x) (get p y).
+
+Lemma eq_refl: forall x, eq x x.
+Proof.
+ unfold eq; intros. apply L.eq_refl.
+Qed.
+
+Lemma eq_sym: forall x y, eq x y -> eq y x.
+Proof.
+ unfold eq; intros. apply L.eq_sym; auto.
+Qed.
+
+Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
+Proof.
+ unfold eq; intros. eapply L.eq_trans; eauto.
+Qed.
+
+Definition beq (x y: t) : bool :=
+ match x, y with
+ | Bot, Bot => true
+ | Top_except m, Top_except n => PTree.beq L.beq m n
+ | _, _ => false
+ end.
+
+Lemma beq_correct: forall x y, beq x y = true -> eq x y.
+Proof.
+ destruct x; destruct y; simpl; intro; try congruence.
+ apply eq_refl.
+ red; intro; simpl.
+ rewrite PTree.beq_correct in H. generalize (H p).
+ destruct (t0!p); destruct (t1!p); intuition.
+ apply L.beq_correct; auto.
+ apply L.eq_refl.
+Qed.
+
+Definition ge (x y: t) : Prop :=
+ forall p, L.ge (get p x) (get p y).
+
+Lemma ge_refl: forall x y, eq x y -> ge x y.
+Proof.
+ unfold ge, eq; intros. apply L.ge_refl. auto.
+Qed.
+
+Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
+Proof.
+ unfold ge; intros. apply L.ge_trans with (get p y); auto.
+Qed.
+
+Definition bot := Bot.
+
+Lemma get_bot: forall p, get p bot = L.bot.
+Proof.
+ unfold bot; intros; simpl. auto.
+Qed.
+
+Lemma ge_bot: forall x, ge x bot.
+Proof.
+ unfold ge; intros. rewrite get_bot. apply L.ge_bot.
+Qed.
+
+Definition top := Top_except (PTree.empty L.t).
+
+Lemma get_top: forall p, get p top = L.top.
+Proof.
+ unfold top; intros; simpl. rewrite PTree.gempty. auto.
+Qed.
+
+Lemma ge_top: forall x, ge top x.
+Proof.
+ unfold ge; intros. rewrite get_top. apply L.ge_top.
+Qed.
+
+Module LM := LPMap1(L).
+
Definition opt_lub (x y: L.t) : option L.t :=
let z := L.lub x y in
if L.beq z L.top then None else Some z.
@@ -417,7 +546,7 @@ Definition lub (x y: t) : t :=
| _, Bot => x
| Top_except m, Top_except n =>
Top_except
- (combine
+ (LM.combine
(fun a b =>
match a, b with
| Some u, Some v => opt_lub u v
@@ -429,11 +558,11 @@ Definition lub (x y: t) : t :=
Lemma gcombine_top:
forall f t1 t2 p,
f None None = None ->
- L.eq (get p (Top_except (combine f t1 t2)))
+ L.eq (get p (Top_except (LM.combine f t1 t2)))
(match f t1!p t2!p with Some x => x | None => L.top end).
Proof.
- intros. simpl. generalize (gcombine f H t1 t2 p). unfold opt_eq.
- destruct ((combine f t1 t2)!p); destruct (f t1!p t2!p).
+ intros. simpl. generalize (LM.gcombine f H t1 t2 p). unfold LM.opt_eq.
+ destruct ((LM.combine f t1 t2)!p); destruct (f t1!p t2!p).
auto. contradiction. contradiction. intros; apply L.eq_refl.
Qed.
diff --git a/powerpc/CombineOp.v b/powerpc/CombineOp.v
index 5cb7630..6ad6987 100644
--- a/powerpc/CombineOp.v
+++ b/powerpc/CombineOp.v
@@ -17,13 +17,7 @@ Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Op.
-Require SelectOp.
-
-Definition valnum := positive.
-
-Inductive rhs : Type :=
- | Op: operation -> list valnum -> rhs
- | Load: memory_chunk -> addressing -> list valnum -> rhs.
+Require Import CSEdomain.
Section COMBINE.
diff --git a/powerpc/CombineOpproof.v b/powerpc/CombineOpproof.v
index 0e328df..4d8fed7 100644
--- a/powerpc/CombineOpproof.v
+++ b/powerpc/CombineOpproof.v
@@ -21,8 +21,8 @@ Require Import Memory.
Require Import Op.
Require Import Registers.
Require Import RTL.
+Require Import CSEdomain.
Require Import CombineOp.
-Require Import CSE.
Section COMBINE.
@@ -30,9 +30,21 @@ Variable ge: genv.
Variable sp: val.
Variable m: mem.
Variable get: valnum -> option rhs.
-Variable valu: valnum -> val.
-Hypothesis get_sound: forall v rhs, get v = Some rhs -> equation_holds valu ge sp m v rhs.
+Variable valu: valuation.
+Hypothesis get_sound: forall v rhs, get v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v).
+Lemma get_op_sound:
+ forall v op vl, get v = Some (Op op vl) -> eval_operation ge sp op (map valu vl) m = Some (valu v).
+Proof.
+ intros. exploit get_sound; eauto. intros REV; inv REV; auto.
+Qed.
+
+Ltac UseGetSound :=
+ match goal with
+ | [ H: get _ = Some _ |- _ ] =>
+ let x := fresh "EQ" in (generalize (get_op_sound _ _ _ H); intros x; simpl in x; FuncInv)
+ end.
+
Lemma combine_compimm_ne_0_sound:
forall x cond args,
combine_compimm_ne_0 get x = Some(cond, args) ->
@@ -41,12 +53,11 @@ Lemma combine_compimm_ne_0_sound:
Proof.
intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ.
(* of cmp *)
- exploit get_sound; eauto. unfold equation_holds. simpl. intro EQ; inv EQ.
+ UseGetSound. rewrite <- H.
destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
(* of and *)
- exploit get_sound; eauto. unfold equation_holds; simpl.
- destruct args; try discriminate. destruct args; try discriminate. simpl.
- intros EQ; inv EQ. destruct (valu v); simpl; auto.
+ UseGetSound. rewrite <- H.
+ destruct v; simpl; auto.
Qed.
Lemma combine_compimm_eq_0_sound:
@@ -57,13 +68,11 @@ Lemma combine_compimm_eq_0_sound:
Proof.
intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ.
(* of cmp *)
- exploit get_sound; eauto. unfold equation_holds. simpl. intro EQ; inv EQ.
+ UseGetSound. rewrite <- H.
rewrite eval_negate_condition.
destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
(* of and *)
- exploit get_sound; eauto. unfold equation_holds; simpl.
- destruct args; try discriminate. destruct args; try discriminate. simpl.
- intros EQ; inv EQ. destruct (valu v); simpl; auto.
+ UseGetSound. rewrite <- H. destruct v; auto.
Qed.
Lemma combine_compimm_eq_1_sound:
@@ -74,7 +83,7 @@ Lemma combine_compimm_eq_1_sound:
Proof.
intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ.
(* of cmp *)
- exploit get_sound; eauto. unfold equation_holds. simpl. intro EQ; inv EQ.
+ UseGetSound. rewrite <- H.
destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
Qed.
@@ -86,7 +95,7 @@ Lemma combine_compimm_ne_1_sound:
Proof.
intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ.
(* of cmp *)
- exploit get_sound; eauto. unfold equation_holds. simpl. intro EQ; inv EQ.
+ UseGetSound. rewrite <- H.
rewrite eval_negate_condition.
destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
Qed.
@@ -122,8 +131,7 @@ Theorem combine_addr_sound:
Proof.
intros. functional inversion H; subst.
(* indexed - addimm *)
- exploit get_sound; eauto. unfold equation_holds; simpl; intro EQ. FuncInv.
- rewrite <- H0. rewrite Val.add_assoc. auto.
+ UseGetSound. simpl; rewrite <- H0. rewrite Val.add_assoc. auto.
Qed.
Theorem combine_op_sound:
@@ -133,45 +141,41 @@ Theorem combine_op_sound:
Proof.
intros. functional inversion H; subst.
(* addimm - addimm *)
- exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
- rewrite <- H1. rewrite Val.add_assoc. auto.
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.add_assoc. auto.
(* addimm - subimm *)
Opaque Val.sub.
- exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
- rewrite <- H1. change (Vint (Int.add m0 n)) with (Val.add (Vint m0) (Vint n)).
+ UseGetSound; simpl. rewrite <- H0.
+ change (Vint (Int.add m0 n)) with (Val.add (Vint m0) (Vint n)).
rewrite Val.sub_add_l. auto.
(* subimm - addimm *)
- exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
- rewrite <- H1.
+ UseGetSound; simpl. rewrite <- H0.
Transparent Val.sub.
destruct v; simpl; auto. repeat rewrite Int.sub_add_opp. rewrite Int.add_assoc.
rewrite Int.neg_add_distr. decEq. decEq. decEq. apply Int.add_commut.
(* andimm - andimm *)
+ UseGetSound; simpl.
generalize (Int.eq_spec p m0); rewrite H7; intros.
- exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
- rewrite <- H2. rewrite Val.and_assoc. simpl. fold p. rewrite H0. auto.
- exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
- rewrite <- H1. rewrite Val.and_assoc. auto.
+ rewrite <- H0. rewrite Val.and_assoc. simpl. fold p. rewrite H1. auto.
+ UseGetSound; simpl.
+ rewrite <- H0. rewrite Val.and_assoc. auto.
(* andimm - rolm *)
+ UseGetSound; simpl.
generalize (Int.eq_spec p m0); rewrite H7; intros.
- exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
- rewrite <- H2. destruct v; simpl; auto. unfold Int.rolm.
- rewrite Int.and_assoc. fold p; rewrite H0. auto.
- exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
- rewrite <- H1. destruct v; simpl; auto. unfold Int.rolm. rewrite Int.and_assoc. auto.
+ rewrite <- H0. destruct v; simpl; auto. unfold Int.rolm.
+ rewrite Int.and_assoc. fold p. rewrite H1. auto.
+ UseGetSound; simpl.
+ rewrite <- H0. destruct v; simpl; auto. unfold Int.rolm.
+ rewrite Int.and_assoc. auto.
(* orimm *)
- exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
- rewrite <- H1. rewrite Val.or_assoc. auto.
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.or_assoc. auto.
(* xorimm *)
- exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
- rewrite <- H1. rewrite Val.xor_assoc. auto.
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.xor_assoc. auto.
(* rolm - andimm *)
- exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
- rewrite <- H1. rewrite <- Val.rolm_zero. rewrite Val.rolm_rolm.
+ UseGetSound; simpl. rewrite <- H0.
+ rewrite <- Val.rolm_zero. rewrite Val.rolm_rolm.
rewrite (Int.add_commut Int.zero). rewrite Int.add_zero. auto.
(* rolm - rolm *)
- exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
- rewrite <- H1. rewrite Val.rolm_rolm. auto.
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.rolm_rolm. auto.
(* cmp *)
simpl. decEq; decEq. eapply combine_cond_sound; eauto.
Qed.
diff --git a/powerpc/ConstpropOp.vp b/powerpc/ConstpropOp.vp
index 9bee4db..9dbaa78 100644
--- a/powerpc/ConstpropOp.vp
+++ b/powerpc/ConstpropOp.vp
@@ -10,8 +10,8 @@
(* *)
(* *********************************************************************)
-(** Static analysis and strength reduction for operators
- and conditions. This is the machine-dependent part of [Constprop]. *)
+(** Strength reduction for operators and conditions.
+ This is the machine-dependent part of [Constprop]. *)
Require Import Coqlib.
Require Import AST.
@@ -19,138 +19,7 @@ Require Import Integers.
Require Import Floats.
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. *)
- | L: int64 -> approx (** A know 64-bit integer 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.
-
-Parameter propagate_float_constants: unit -> bool.
-
-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 => if propagate_float_constants tt then F n else Unknown
- | 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)
- | Oaddsymbol s ofs, I n :: nil => G s (Int.add ofs 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)
- | Omulhs, I n1 :: I n2 :: nil => I(Int.mulhs n1 n2)
- | Omulhu, I n1 :: I n2 :: nil => I(Int.mulhu n1 n2)
- | Odiv, I n1 :: I n2 :: nil =>
- if Int.eq n2 Int.zero then Unknown else
- if Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone 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)
- | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1)
- | Ointoffloat, F n1 :: nil => eval_static_intoffloat n1
- | Ofloatofwords, I n1 :: I n2 :: nil => if propagate_float_constants tt then F(Float.from_words n1 n2) else Unknown
- | Omakelong, I n1 :: I n2 :: nil => L(Int64.ofwords n1 n2)
- | Olowlong, L n :: nil => I(Int64.loword n)
- | Ohighlong, L n :: nil => I(Int64.hiword n)
- | Ocmp c, vl => eval_static_condition_val c vl
- | _, _ => Unknown
- end.
-
-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, G id ofs::nil => G id (Int.add ofs n)
- | Aindexed n, S ofs::nil => S (Int.add ofs n)
- | Aindexed2, I n1::I n2::nil => I (Int.add n1 n2)
- | Aindexed2, G id ofs::I n2::nil => G id (Int.add ofs n2)
- | Aindexed2, I n1::G id ofs::nil => G id (Int.add ofs n1)
- | Aindexed2, S ofs::I n2::nil => S (Int.add ofs n2)
- | Aindexed2, I n1::S ofs::nil => S (Int.add ofs n1)
- | Aglobal id ofs, nil => G id ofs
- | Abased id ofs, I n1::nil => G id (Int.add ofs n1)
- | Ainstack ofs, nil => S ofs
- | _, _ => Unknown
- end.
+Require Import ValueDomain.
(** * Operator strength reduction *)
@@ -162,7 +31,7 @@ Nondetfunction eval_static_addressing (addr: addressing) (vl: list approx) :=
Section STRENGTH_REDUCTION.
Nondetfunction cond_strength_reduction
- (cond: condition) (args: list reg) (vl: list approx) :=
+ (cond: condition) (args: list reg) (vl: list aval) :=
match cond, args, vl with
| Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
(Ccompimm (swap_comparison c) n1, r2 :: nil)
@@ -230,10 +99,12 @@ Definition make_divuimm (n: int) (r1 r2: reg) :=
| None => (Odivu, r1 :: r2 :: nil)
end.
-Definition make_andimm (n: int) (r: reg) :=
- if Int.eq n Int.zero
- then (Ointconst Int.zero, nil)
+Definition make_andimm (n: int) (r: reg) (a: aval) :=
+ if Int.eq n Int.zero then (Ointconst Int.zero, nil)
else if Int.eq n Int.mone then (Omove, r :: nil)
+ else if match a with Uns m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero
+ | _ => false end
+ then (Omove, r :: nil)
else (Oandimm n, r :: nil).
Definition make_orimm (n: int) (r: reg) :=
@@ -251,19 +122,33 @@ Definition make_mulfimm (n: float) (r r1 r2: reg) :=
then (Oaddf, r :: r :: nil)
else (Omulf, r1 :: r2 :: nil).
+Definition make_cast8signed (r: reg) (a: aval) :=
+ if vincl a (Sgn 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil).
+Definition make_cast16signed (r: reg) (a: aval) :=
+ if vincl a (Sgn 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil).
+Definition make_singleoffloat (r: reg) (a: aval) :=
+ if vincl a Fsingle && generate_float_constants tt
+ then (Omove, r :: nil)
+ else (Osingleoffloat, r :: nil).
+
Nondetfunction op_strength_reduction
- (op: operation) (args: list reg) (vl: list approx) :=
+ (op: operation) (args: list reg) (vl: list aval) :=
match op, args, vl with
+ | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1
+ | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1
| Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_addimm n1 r2
| Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm n2 r1
+ | Oadd, r1 :: r2 :: nil, Ptr(Gl s n1) :: v2 :: nil => (Oaddsymbol s n1, r2 :: nil)
+ | Oadd, r1 :: r2 :: nil, v1 :: Ptr(Gl s n1) :: nil => (Oaddsymbol s n1, r1 :: nil)
| 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
+ | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2
+ | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1
+ | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1
| Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2
| Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1
| Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2
@@ -271,6 +156,7 @@ Nondetfunction op_strength_reduction
| 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
+ | Osingleoffloat, r1 :: nil, v1 :: nil => make_singleoffloat r1 v1
| Ocmp c, args, vl =>
let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args')
| Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2
@@ -279,19 +165,19 @@ Nondetfunction op_strength_reduction
end.
Nondetfunction addr_strength_reduction
- (addr: addressing) (args: list reg) (vl: list approx) :=
+ (addr: addressing) (args: list reg) (vl: list aval) :=
match addr, args, vl with
- | Aindexed2, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil =>
+ | Aindexed2, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil =>
(Aglobal symb (Int.add n1 n2), nil)
- | Aindexed2, r1 :: r2 :: nil, I n1 :: G symb n2 :: nil =>
+ | Aindexed2, r1 :: r2 :: nil, I n1 :: Ptr(Gl symb n2) :: nil =>
(Aglobal symb (Int.add n1 n2), nil)
- | Aindexed2, r1 :: r2 :: nil, S n1 :: I n2 :: nil =>
+ | Aindexed2, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil =>
(Ainstack (Int.add n1 n2), nil)
- | Aindexed2, r1 :: r2 :: nil, I n1 :: S n2 :: nil =>
+ | Aindexed2, r1 :: r2 :: nil, I n1 :: Ptr(Stk n2) :: nil =>
(Ainstack (Int.add n1 n2), nil)
- | Aindexed2, r1 :: r2 :: nil, G symb n1 :: v2 :: nil =>
+ | Aindexed2, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil =>
(Abased symb n1, r2 :: nil)
- | Aindexed2, r1 :: r2 :: nil, v1 :: G symb n2 :: nil =>
+ | Aindexed2, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil =>
(Abased symb n2, r1 :: nil)
| Aindexed2, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
(Aindexed n1, r2 :: nil)
@@ -299,9 +185,9 @@ Nondetfunction addr_strength_reduction
(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 =>
+ | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil =>
(Aglobal symb (Int.add n1 n), nil)
- | Aindexed n, r1 :: nil, S n1 :: nil =>
+ | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil =>
(Ainstack (Int.add n1 n), nil)
| _, _, _ =>
(addr, args)
diff --git a/powerpc/ConstpropOpproof.v b/powerpc/ConstpropOpproof.v
index 2aba9c2..e7dd3a4 100644
--- a/powerpc/ConstpropOpproof.v
+++ b/powerpc/ConstpropOpproof.v
@@ -10,7 +10,7 @@
(* *)
(* *********************************************************************)
-(** Correctness proof for constant propagation (processor-dependent part). *)
+(** Correctness proof for operator strength reduction. *)
Require Import Coqlib.
Require Import AST.
@@ -23,168 +23,8 @@ Require Import Events.
Require Import Op.
Require Import Registers.
Require Import RTL.
+Require Import ValueDomain.
Require Import ConstpropOp.
-Require Import Constprop.
-
-(** * Correctness of the static analysis *)
-
-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)
- of a register at a program point predicted by the static analysis
- are a superset of the values actually encountered during concrete
- executions. We formalize this correspondence between run-time values and
- compile-time approximations by the following predicate. *)
-
-Definition val_match_approx (a: approx) (v: val) : Prop :=
- match a with
- | Unknown => True
- | I p => v = Vint p
- | F p => v = Vfloat p
- | L p => v = Vlong p
- | G symb ofs => v = symbol_address ge symb ofs
- | S ofs => v = Val.add sp (Vint ofs)
- | _ => False
- end.
-
-Inductive val_list_match_approx: list approx -> list val -> Prop :=
- | vlma_nil:
- val_list_match_approx nil nil
- | vlma_cons:
- forall a al v vl,
- val_match_approx a v ->
- val_list_match_approx al vl ->
- val_list_match_approx (a :: al) (v :: vl).
-
-Ltac SimplVMA :=
- match goal with
- | H: (val_match_approx (I _) ?v) |- _ =>
- simpl in H; (try subst v); SimplVMA
- | H: (val_match_approx (F _) ?v) |- _ =>
- simpl in H; (try subst v); SimplVMA
- | H: (val_match_approx (L _) ?v) |- _ =>
- simpl in H; (try subst v); 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.
-
-Ltac InvVLMA :=
- match goal with
- | H: (val_list_match_approx nil ?vl) |- _ =>
- inv H
- | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ =>
- inv H; SimplVMA; InvVLMA
- | _ =>
- idtac
- end.
-
-(** We then show that [eval_static_operation] is a correct abstract
- interpretations of [eval_operation]: if the concrete arguments match
- the given approximations, the concrete results match the
- approximations returned by [eval_static_operation]. *)
-
-Lemma eval_static_condition_correct:
- forall cond al vl m b,
- val_list_match_approx al vl ->
- eval_static_condition cond al = Some b ->
- eval_condition cond vl m = Some b.
-Proof.
- intros until b.
- unfold eval_static_condition.
- case (eval_static_condition_match cond al); intros;
- InvVLMA; simpl; congruence.
-Qed.
-
-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 al vl m v,
- val_list_match_approx al vl ->
- eval_operation ge sp op vl m = Some v ->
- val_match_approx (eval_static_operation op al) v.
-Proof.
- intros until v.
- unfold eval_static_operation.
- case (eval_static_operation_match op al); intros;
- InvVLMA; simpl in *; FuncInv; try subst v; auto.
-
- destruct (propagate_float_constants tt); simpl; auto.
-
- rewrite shift_symbol_address; auto.
-
- rewrite Int.add_commut. rewrite shift_symbol_address. rewrite Val.add_commut. auto.
-
- rewrite Int.add_commut; auto.
-
- rewrite Val.add_assoc. rewrite Int.add_commut. auto.
-
- change (Val.add (Vint n1) (Val.add sp (Vint n2)) = Val.add sp (Vint (Int.add n1 n2))).
- rewrite Val.add_permut. auto.
-
- rewrite shift_symbol_address; auto.
-
- rewrite Val.add_assoc; auto.
-
- rewrite shift_symbol_address; auto.
-
- unfold symbol_address. destruct (Genv.find_symbol ge s1); auto.
-
- rewrite Val.sub_add_opp. rewrite Val.add_assoc. simpl. rewrite Int.sub_add_opp. auto.
-
- destruct (Int.eq n2 Int.zero). inv H0.
- destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); 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 n Int.iwordsize); simpl; auto.
- destruct (Int.ltu n (Int.repr 31)); inv H0. 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.
-
- destruct (propagate_float_constants tt); simpl; auto.
-
- unfold eval_static_condition_val, Val.of_optbool.
- destruct (eval_static_condition c vl0) eqn:?.
- rewrite (eval_static_condition_correct _ _ _ m _ H Heqo).
- destruct b; simpl; auto.
- simpl; auto.
-Qed.
-
-Lemma eval_static_addressing_correct:
- 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 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. apply Val.add_commut.
- repeat rewrite Val.add_assoc. auto.
- fold (Val.add (Vint n1) (Val.add sp (Vint ofs))).
- rewrite Val.add_permut. decEq. rewrite Val.add_commut. auto.
- rewrite shift_symbol_address. auto.
-Qed.
(** * Correctness of strength reduction *)
@@ -196,51 +36,91 @@ Qed.
Section STRENGTH_REDUCTION.
-Variable app: D.t.
+Variable bc: block_classification.
+Variable ge: genv.
+Hypothesis GENV: genv_match bc ge.
+Variable sp: block.
+Hypothesis STACK: bc sp = BCstack.
+Variable ae: AE.t.
Variable rs: regset.
Variable m: mem.
-Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r.
+Hypothesis MATCH: ematch bc rs ae.
+
+Lemma match_G:
+ forall r id ofs,
+ AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef rs#r (symbol_address ge id ofs).
+Proof.
+ intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH.
+Qed.
+
+Lemma match_S:
+ forall r ofs,
+ AE.get r ae = Ptr(Stk ofs) -> Val.lessdef rs#r (Vptr sp ofs).
+Proof.
+ intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH.
+Qed.
Ltac InvApproxRegs :=
match goal with
| [ H: _ :: _ = _ :: _ |- _ ] =>
injection H; clear H; intros; InvApproxRegs
- | [ H: ?v = approx_reg app ?r |- _ ] =>
+ | [ H: ?v = AE.get ?r ae |- _ ] =>
generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs
| _ => idtac
end.
+Ltac SimplVM :=
+ match goal with
+ | [ H: vmatch _ ?v (I ?n) |- _ ] =>
+ let E := fresh in
+ assert (E: v = Vint n) by (inversion H; auto);
+ rewrite E in *; clear H; SimplVM
+ | [ H: vmatch _ ?v (F ?n) |- _ ] =>
+ let E := fresh in
+ assert (E: v = Vfloat n) by (inversion H; auto);
+ rewrite E in *; clear H; SimplVM
+ | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] =>
+ let E := fresh in
+ assert (E: Val.lessdef v (Op.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto);
+ clear H; SimplVM
+ | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] =>
+ let E := fresh in
+ assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto);
+ clear H; SimplVM
+ | _ => idtac
+ end.
+
Lemma cond_strength_reduction_correct:
forall cond args vl,
- vl = approx_regs app args ->
+ vl = map (fun r => AE.get r ae) 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 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.
+ case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVM.
+- apply Val.swap_cmp_bool.
+- auto.
+- apply Val.swap_cmpu_bool.
+- auto.
+- auto.
Qed.
Lemma 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.
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v.
Proof.
intros. unfold make_addimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros.
subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto.
exists (Val.add rs#r (Vint n)); auto.
Qed.
-
+
Lemma make_shlimm_correct:
forall n r1 r2,
rs#r2 = Vint n ->
let (op, args) := make_shlimm n r1 r2 in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v.
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v.
Proof.
intros; unfold make_shlimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
@@ -254,7 +134,7 @@ Lemma make_shrimm_correct:
forall n r1 r2,
rs#r2 = Vint n ->
let (op, args) := make_shrimm n r1 r2 in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v.
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v.
Proof.
intros; unfold make_shrimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
@@ -268,7 +148,7 @@ Lemma make_shruimm_correct:
forall n r1 r2,
rs#r2 = Vint n ->
let (op, args) := make_shruimm n r1 r2 in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v.
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v.
Proof.
intros; unfold make_shruimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
@@ -282,7 +162,7 @@ Lemma make_mulimm_correct:
forall n r1 r2,
rs#r2 = Vint n ->
let (op, args) := make_mulimm n r1 r2 in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v.
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v.
Proof.
intros; unfold make_mulimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
@@ -301,7 +181,7 @@ Lemma make_divimm_correct:
Val.divs rs#r1 rs#r2 = Some v ->
rs#r2 = Vint n ->
let (op, args) := make_divimm n r1 r2 in
- exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
+ exists w, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some w /\ Val.lessdef v w.
Proof.
intros; unfold make_divimm.
destruct (Int.is_power2 n) eqn:?.
@@ -316,7 +196,7 @@ Lemma make_divuimm_correct:
Val.divu rs#r1 rs#r2 = Some v ->
rs#r2 = Vint n ->
let (op, args) := make_divuimm n r1 r2 in
- exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
+ exists w, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some w /\ Val.lessdef v w.
Proof.
intros; unfold make_divuimm.
destruct (Int.is_power2 n) eqn:?.
@@ -330,22 +210,35 @@ Proof.
Qed.
Lemma make_andimm_correct:
- forall n r,
- let (op, args) := make_andimm n r in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v.
+ forall n r x,
+ vmatch bc rs#r x ->
+ let (op, args) := make_andimm n r x in
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v.
Proof.
intros; unfold make_andimm.
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.
+ destruct (match x with Uns k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero
+ | _ => false end) eqn:UNS.
+ destruct x; try congruence.
+ exists (rs#r); split; auto.
+ inv H; auto. simpl. replace (Int.and i n) with i; auto.
+ generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ.
+ Int.bit_solve. destruct (zlt i0 n0).
+ replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)).
+ rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto.
+ rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto.
+ rewrite Int.bits_not by auto. apply negb_involutive.
+ rewrite H5 by auto. auto.
econstructor; split; eauto. auto.
Qed.
Lemma make_orimm_correct:
forall n r,
let (op, args) := make_orimm n r in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v.
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v.
Proof.
intros; unfold make_orimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros.
@@ -358,7 +251,7 @@ Qed.
Lemma make_xorimm_correct:
forall n r,
let (op, args) := make_xorimm n r in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v.
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v.
Proof.
intros; unfold make_xorimm.
predSpec Int.eq Int.eq_spec n Int.zero; intros.
@@ -370,7 +263,7 @@ Lemma make_mulfimm_correct:
forall n r1 r2,
rs#r2 = Vfloat n ->
let (op, args) := make_mulfimm n r1 r1 r2 in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
Proof.
intros; unfold make_mulfimm.
destruct (Float.eq_dec n (Float.floatofint (Int.repr 2))); intros.
@@ -383,7 +276,7 @@ Lemma make_mulfimm_correct_2:
forall n r1 r2,
rs#r1 = Vfloat n ->
let (op, args) := make_mulfimm n r2 r1 r2 in
- exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
Proof.
intros; unfold make_mulfimm.
destruct (Float.eq_dec n (Float.floatofint (Int.repr 2))); intros.
@@ -393,81 +286,146 @@ Proof.
simpl. econstructor; split; eauto.
Qed.
+Lemma make_cast8signed_correct:
+ forall r x,
+ vmatch bc rs#r x ->
+ let (op, args) := make_cast8signed r x in
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.sign_ext 8 rs#r) v.
+Proof.
+ intros; unfold make_cast8signed. destruct (vincl x (Sgn 8)) eqn:INCL.
+ exists rs#r; split; auto.
+ assert (V: vmatch bc rs#r (Sgn 8)).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite is_sgn_sign_ext in H3 by auto. rewrite H3; auto.
+ econstructor; split; simpl; eauto.
+Qed.
+
+Lemma make_cast16signed_correct:
+ forall r x,
+ vmatch bc rs#r x ->
+ let (op, args) := make_cast16signed r x in
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.sign_ext 16 rs#r) v.
+Proof.
+ intros; unfold make_cast16signed. destruct (vincl x (Sgn 16)) eqn:INCL.
+ exists rs#r; split; auto.
+ assert (V: vmatch bc rs#r (Sgn 16)).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite is_sgn_sign_ext in H3 by auto. rewrite H3; auto.
+ econstructor; split; simpl; eauto.
+Qed.
+
+Lemma make_singleoffloat_correct:
+ forall r x,
+ vmatch bc rs#r x ->
+ let (op, args) := make_singleoffloat r x in
+ exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.singleoffloat rs#r) v.
+Proof.
+ intros; unfold make_singleoffloat.
+ destruct (vincl x Fsingle && generate_float_constants tt) eqn:INCL.
+ InvBooleans. exists rs#r; split; auto.
+ assert (V: vmatch bc rs#r Fsingle).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite Float.singleoffloat_of_single by auto. auto.
+ econstructor; split; simpl; eauto.
+Qed.
+
Lemma op_strength_reduction_correct:
forall op args vl v,
- vl = approx_regs app args ->
- eval_operation ge sp op rs##args m = Some v ->
+ vl = map (fun r => AE.get r ae) args ->
+ eval_operation ge (Vptr sp Int.zero) 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.
+ exists w, eval_operation ge (Vptr sp Int.zero) op' rs##args' m = Some w /\ Val.lessdef v w.
Proof.
intros until v; unfold op_strength_reduction;
case (op_strength_reduction_match op args vl); simpl; intros.
+(* cast8signed *)
+ InvApproxRegs; SimplVM; inv H0. apply make_cast8signed_correct; auto.
+(* cast8signed *)
+ InvApproxRegs; SimplVM; inv H0. apply make_cast16signed_correct; auto.
(* 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.
+ InvApproxRegs; SimplVM; inv H0. fold (Val.add (Vint n1) rs#r2). rewrite Val.add_commut. apply make_addimm_correct.
+ InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct.
+ InvApproxRegs; SimplVM; inv H0. econstructor; split; eauto. apply Val.add_lessdef; auto.
+ InvApproxRegs; SimplVM; inv H0. econstructor; split; eauto. rewrite Val.add_commut. apply Val.add_lessdef; auto.
(* 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.
+ InvApproxRegs; SimplVM; inv H0. fold (Val.sub (Vint n1) rs#r2). econstructor; split; eauto.
+ InvApproxRegs; SimplVM; inv H0. 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.
+ InvApproxRegs; SimplVM; inv H0. fold (Val.mul (Vint n1) rs#r2). rewrite Val.mul_commut. apply make_mulimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto.
(* divs *)
- assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
+ assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
apply make_divimm_correct; auto.
(* divu *)
- assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
+ assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; 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.
+ InvApproxRegs; SimplVM; inv H0. fold (Val.and (Vint n1) rs#r2). rewrite Val.and_commut. apply make_andimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct. auto.
+ inv H; inv H0. apply make_andimm_correct. auto.
(* 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.
+ InvApproxRegs; SimplVM; inv H0. fold (Val.or (Vint n1) rs#r2). rewrite Val.or_commut. apply make_orimm_correct.
+ InvApproxRegs; SimplVM; inv H0. 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.
+ InvApproxRegs; SimplVM; inv H0. fold (Val.xor (Vint n1) rs#r2). rewrite Val.xor_commut. apply make_xorimm_correct.
+ InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct.
(* shl *)
- InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shlimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_shlimm_correct; auto.
(* shr *)
- InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shrimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_shrimm_correct; auto.
(* shru *)
- InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shruimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_shruimm_correct; auto.
+(* singleoffloat *)
+ InvApproxRegs; SimplVM; inv H0. apply make_singleoffloat_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.
(* mulf *)
- inv H0. assert (rs#r2 = Vfloat n2). InvApproxRegs; SimplVMA; auto.
- apply make_mulfimm_correct; auto.
- inv H0. assert (rs#r1 = Vfloat n1). InvApproxRegs; SimplVMA; auto.
- apply make_mulfimm_correct_2; auto.
+ InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) rs#r2).
+ rewrite <- H2. apply make_mulfimm_correct_2; auto.
(* default *)
exists v; auto.
Qed.
-
+
+Remark shift_symbol_address:
+ forall symb ofs n,
+ Op.symbol_address ge symb (Int.add ofs n) = Val.add (Op.symbol_address ge symb ofs) (Vint n).
+Proof.
+ unfold Op.symbol_address; intros. destruct (Genv.find_symbol ge symb); auto.
+Qed.
+
Lemma addr_strength_reduction_correct:
- forall addr args vl,
- vl = approx_regs app args ->
+ forall addr args vl res,
+ vl = map (fun r => AE.get r ae) args ->
+ eval_addressing ge (Vptr sp Int.zero) addr rs##args = Some res ->
let (addr', args') := addr_strength_reduction addr args vl in
- eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args.
+ exists res', eval_addressing ge (Vptr sp Int.zero) addr' rs##args' = Some res' /\ Val.lessdef res res'.
Proof.
- 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.
+ intros until res. unfold addr_strength_reduction.
+ destruct (addr_strength_reduction_match addr args vl); simpl;
+ intros VL EA; InvApproxRegs; SimplVM; try (inv EA).
+- rewrite shift_symbol_address. econstructor; split; eauto. apply Val.add_lessdef; auto.
+- fold (Val.add (Vint n1) rs#r2). rewrite Int.add_commut. rewrite shift_symbol_address. rewrite Val.add_commut.
+ econstructor; split; eauto. apply Val.add_lessdef; auto.
+- rewrite Int.add_zero_l.
+ change (Vptr sp (Int.add n1 n2)) with (Val.add (Vptr sp n1) (Vint n2)).
+ econstructor; split; eauto. apply Val.add_lessdef; auto.
+- fold (Val.add (Vint n1) rs#r2). rewrite Int.add_zero_l. rewrite Int.add_commut.
+ change (Vptr sp (Int.add n2 n1)) with (Val.add (Vptr sp n2) (Vint n1)).
+ rewrite Val.add_commut. econstructor; split; eauto. apply Val.add_lessdef; auto.
+- econstructor; split; eauto. apply Val.add_lessdef; auto.
+- rewrite Val.add_commut. econstructor; split; eauto. apply Val.add_lessdef; auto.
+- fold (Val.add (Vint n1) rs#r2).
+ rewrite Val.add_commut. econstructor; split; eauto.
+- econstructor; split; eauto.
+- rewrite shift_symbol_address. econstructor; split; eauto.
+- rewrite shift_symbol_address. econstructor; split; eauto. apply Val.add_lessdef; auto.
+- rewrite Int.add_zero_l.
+ change (Vptr sp (Int.add n1 n)) with (Val.add (Vptr sp n1) (Vint n)).
+ econstructor; split; eauto. apply Val.add_lessdef; auto.
+- exists res; auto.
Qed.
End STRENGTH_REDUCTION.
-
-End ANALYSIS.
-
diff --git a/powerpc/NeedOp.v b/powerpc/NeedOp.v
new file mode 100644
index 0000000..63323eb
--- /dev/null
+++ b/powerpc/NeedOp.v
@@ -0,0 +1,160 @@
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Op.
+Require Import NeedDomain.
+Require Import RTL.
+
+(** Neededness analysis for PowerPC operators *)
+
+Definition needs_of_condition (cond: condition): nval :=
+ match cond with
+ | Cmaskzero n | Cmasknotzero n => maskzero n
+ | _ => All
+ end.
+
+Definition needs_of_operation (op: operation) (nv: nval): nval :=
+ match op with
+ | Omove => nv
+ | Ointconst n => Nothing
+ | Ofloatconst n => Nothing
+ | Oaddrsymbol id ofs => Nothing
+ | Oaddrstack ofs => Nothing
+ | Ocast8signed => sign_ext 8 nv
+ | Ocast16signed => sign_ext 16 nv
+ | Oadd => modarith nv
+ | Oaddimm n => modarith nv
+ | Omul => modarith nv
+ | Omulimm n => modarith nv
+ | Oand => bitwise nv
+ | Oandimm n => andimm nv n
+ | Oor => bitwise nv
+ | Oorimm n => orimm nv n
+ | Oxor => bitwise nv
+ | Oxorimm n => bitwise nv
+ | Onot => bitwise nv
+ | Onand => bitwise nv
+ | Onor => bitwise nv
+ | Onxor => bitwise nv
+ | Oandc => bitwise nv
+ | Oorc => bitwise nv
+ | Oshrimm n => shrimm nv n
+ | Orolm amount mask => rolm nv amount mask
+ | Osingleoffloat => singleoffloat nv
+ | Ocmp c => needs_of_condition c
+ | _ => default nv
+ end.
+
+Definition operation_is_redundant (op: operation) (nv: nval): bool :=
+ match op with
+ | Ocast8signed => sign_ext_redundant 8 nv
+ | Ocast16signed => sign_ext_redundant 16 nv
+ | Oandimm n => andimm_redundant nv n
+ | Oorimm n => orimm_redundant nv n
+ | Orolm amount mask => rolm_redundant nv amount mask
+ | Osingleoffloat => singleoffloat_redundant nv
+ | _ => false
+ end.
+
+Ltac InvAgree :=
+ match goal with
+ | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree
+ | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree
+ | [H: list_forall2 _ nil _ |- _ ] => inv H; InvAgree
+ | [H: list_forall2 _ (_::_) _ |- _ ] => inv H; InvAgree
+ | _ => idtac
+ end.
+
+Ltac TrivialExists :=
+ match goal with
+ | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto
+ | _ => idtac
+ end.
+
+Section SOUNDNESS.
+
+Variable ge: genv.
+Variable sp: block.
+Variables m m': mem.
+Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p.
+
+Lemma needs_of_condition_sound:
+ forall cond args b args',
+ eval_condition cond args m = Some b ->
+ vagree_list args args' (needs_of_condition cond) ->
+ eval_condition cond args' m' = Some b.
+Proof.
+ intros. destruct cond; simpl in H;
+ try (eapply default_needs_of_condition_sound; eauto; fail);
+ simpl in *; FuncInv; InvAgree.
+- eapply maskzero_sound; eauto.
+- destruct (Val.maskzero_bool v i) as [b'|] eqn:MZ; try discriminate.
+ erewrite maskzero_sound; eauto.
+Qed.
+
+Lemma needs_of_operation_sound:
+ forall op args v nv args',
+ eval_operation ge (Vptr sp Int.zero) op args m = Some v ->
+ vagree_list args args' (needs_of_operation op nv) ->
+ nv <> Nothing ->
+ exists v',
+ eval_operation ge (Vptr sp Int.zero) op args' m' = Some v'
+ /\ vagree v v' nv.
+Proof.
+ unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail);
+ simpl in *; FuncInv; InvAgree; TrivialExists.
+- auto with na.
+- auto with na.
+- auto with na.
+- auto with na.
+- apply sign_ext_sound; auto. compute; auto.
+- apply sign_ext_sound; auto. compute; auto.
+- apply add_sound; auto.
+- apply add_sound; auto with na.
+- apply mul_sound; auto.
+- apply mul_sound; auto with na.
+- apply and_sound; auto.
+- apply andimm_sound; auto.
+- apply or_sound; auto.
+- apply orimm_sound; auto.
+- apply xor_sound; auto.
+- apply xor_sound; auto with na.
+- apply notint_sound; auto.
+- apply notint_sound. apply and_sound; rewrite bitwise_idem; auto.
+- apply notint_sound. apply or_sound; rewrite bitwise_idem; auto.
+- apply notint_sound. apply xor_sound; rewrite bitwise_idem; auto.
+- apply and_sound; auto. apply notint_sound; rewrite bitwise_idem; auto.
+- apply or_sound; auto. apply notint_sound; rewrite bitwise_idem; auto.
+- apply shrimm_sound; auto.
+- apply rolm_sound; auto.
+- apply singleoffloat_sound; auto.
+- destruct (eval_condition c args m) as [b|] eqn:EC; simpl in H2.
+ erewrite needs_of_condition_sound by eauto.
+ subst v; simpl. auto with na.
+ subst v; auto with na.
+Qed.
+
+Lemma operation_is_redundant_sound:
+ forall op nv arg1 args v arg1',
+ operation_is_redundant op nv = true ->
+ eval_operation ge (Vptr sp Int.zero) op (arg1 :: args) m = Some v ->
+ vagree arg1 arg1' (needs_of_operation op nv) ->
+ vagree v arg1' nv.
+Proof.
+ intros. destruct op; simpl in *; try discriminate; FuncInv; subst.
+- apply sign_ext_redundant_sound; auto. omega.
+- apply sign_ext_redundant_sound; auto. omega.
+- apply andimm_redundant_sound; auto.
+- apply orimm_redundant_sound; auto.
+- apply rolm_redundant_sound; auto.
+- apply singleoffloat_redundant_sound; auto.
+Qed.
+
+End SOUNDNESS.
+
+
+
diff --git a/powerpc/Op.v b/powerpc/Op.v
index dbc474e..3545b18 100644
--- a/powerpc/Op.v
+++ b/powerpc/Op.v
@@ -166,8 +166,8 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool
| 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))
+ | Cmaskzero n, v1 :: nil => Val.maskzero_bool v1 n
+ | Cmasknotzero n, v1 :: nil => option_map negb (Val.maskzero_bool v1 n)
| _, _ => None
end.
@@ -452,8 +452,8 @@ Proof.
repeat (destruct vl; auto). apply Val.negate_cmpu_bool.
repeat (destruct vl; auto).
repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0); auto. destruct b; auto.
- destruct vl; auto. destruct v; auto. destruct vl; auto.
- destruct vl; auto. destruct v; auto. destruct vl; auto. simpl. rewrite negb_involutive. auto.
+ repeat (destruct vl; auto).
+ repeat (destruct vl; auto). destruct (Val.maskzero_bool v i) as [[]|]; auto.
Qed.
(** Shifting stack-relative references. This is used in [Stacking]. *)
@@ -747,6 +747,8 @@ Proof.
eauto 3 using val_cmpu_bool_inject, Mem.valid_pointer_implies.
inv H3; inv H2; simpl in H0; inv H0; auto.
inv H3; inv H2; simpl in H0; inv H0; auto.
+ inv H3; try discriminate; auto.
+ inv H3; try discriminate; auto.
Qed.
Ltac TrivialExists :=
diff --git a/powerpc/ValueAOp.v b/powerpc/ValueAOp.v
new file mode 100644
index 0000000..12cb8e4
--- /dev/null
+++ b/powerpc/ValueAOp.v
@@ -0,0 +1,160 @@
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Op.
+Require Import ValueDomain.
+Require Import RTL.
+
+(** Value analysis for PowerPC operators *)
+
+Definition eval_static_condition (cond: condition) (vl: list aval): abool :=
+ match cond, vl with
+ | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2
+ | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2
+ | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n)
+ | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n)
+ | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2
+ | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2)
+ | Cmaskzero n, v1 :: nil => maskzero v1 n
+ | Cmasknotzero n, v1 :: nil => cnot (maskzero v1 n)
+ | _, _ => Bnone
+ end.
+
+Definition eval_static_addressing (addr: addressing) (vl: list aval): aval :=
+ match addr, vl with
+ | Aindexed n, v1::nil => add v1 (I n)
+ | Aindexed2, v1::v2::nil => add v1 v2
+ | Aglobal s ofs, nil => Ptr (Gl s ofs)
+ | Abased s ofs, v1::nil => add (Ptr (Gl s ofs)) v1
+ | Ainstack ofs, nil => Ptr(Stk ofs)
+ | _, _ => Vbot
+ end.
+
+Definition eval_static_operation (op: operation) (vl: list aval): aval :=
+ match op, vl with
+ | Omove, v1::nil => v1
+ | Ointconst n, nil => I n
+ | Ofloatconst n, nil => if propagate_float_constants tt then F n else ftop
+ | Oaddrsymbol id ofs, nil => Ptr (Gl id ofs)
+ | Oaddrstack ofs, nil => Ptr (Stk ofs)
+ | Ocast8signed, v1 :: nil => sign_ext 8 v1
+ | Ocast16signed, v1 :: nil => sign_ext 16 v1
+ | Oadd, v1::v2::nil => add v1 v2
+ | Oaddimm n, v1::nil => add v1 (I n)
+ | Oaddsymbol id ofs, v1::nil => add (Ptr (Gl id ofs)) v1
+ | Osub, v1::v2::nil => sub v1 v2
+ | Osubimm n, v1::nil => sub (I n) v1
+ | Omul, v1::v2::nil => mul v1 v2
+ | Omulimm n, v1::nil => mul v1 (I n)
+ | Omulhs, v1::v2::nil => mulhs v1 v2
+ | Omulhu, v1::v2::nil => mulhu v1 v2
+ | Odiv, v1::v2::nil => divs v1 v2
+ | Odivu, v1::v2::nil => divu v1 v2
+ | Oand, v1::v2::nil => and v1 v2
+ | Oandimm n, v1::nil => and v1 (I n)
+ | Oor, v1::v2::nil => or v1 v2
+ | Oorimm n, v1::nil => or v1 (I n)
+ | Oxor, v1::v2::nil => xor v1 v2
+ | Oxorimm n, v1::nil => xor v1 (I n)
+ | Onot, v1::nil => notint v1
+ | Onand, v1::v2::nil => notint(and v1 v2)
+ | Onor, v1::v2::nil => notint(or v1 v2)
+ | Onxor, v1::v2::nil => notint(xor v1 v2)
+ | Oandc, v1::v2::nil => and v1 (notint v2)
+ | Oorc, v1::v2::nil => or v1 (notint v2)
+ | Oshl, v1::v2::nil => shl v1 v2
+ | Oshr, v1::v2::nil => shr v1 v2
+ | Oshrimm n, v1::nil => shr v1 (I n)
+ | Oshrximm n, v1::nil => shrx v1 (I n)
+ | Oshru, v1::v2::nil => shru v1 v2
+ | Orolm amount mask, v1::nil => rolm v1 amount mask
+ | Oroli amount mask, v1::v2::nil => or (and v1 (I (Int.not mask))) (rolm v2 amount mask)
+ | Onegf, v1::nil => negf v1
+ | Oabsf, v1::nil => absf v1
+ | Oaddf, v1::v2::nil => addf v1 v2
+ | Osubf, v1::v2::nil => subf v1 v2
+ | Omulf, v1::v2::nil => mulf v1 v2
+ | Odivf, v1::v2::nil => divf v1 v2
+ | Osingleoffloat, v1::nil => singleoffloat v1
+ | Ointoffloat, v1::nil => intoffloat v1
+ | Ofloatofwords, v1::v2::nil => floatofwords v1 v2
+ | Omakelong, v1::v2::nil => longofwords v1 v2
+ | Olowlong, v1::nil => loword v1
+ | Ohighlong, v1::nil => hiword v1
+ | Ocmp c, _ => of_optbool (eval_static_condition c vl)
+ | _, _ => Vbot
+ end.
+
+Section SOUNDNESS.
+
+Variable bc: block_classification.
+Variable ge: genv.
+Hypothesis GENV: genv_match bc ge.
+Variable sp: block.
+Hypothesis STACK: bc sp = BCstack.
+
+Theorem eval_static_condition_sound:
+ forall cond vargs m aargs,
+ list_forall2 (vmatch bc) vargs aargs ->
+ cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs).
+Proof.
+ intros until aargs; intros VM.
+ inv VM.
+ destruct cond; auto with va.
+ inv H0.
+ destruct cond; simpl; eauto with va.
+ inv H2.
+ destruct cond; simpl; eauto with va.
+ destruct cond; auto with va.
+Qed.
+
+Lemma symbol_address_sound:
+ forall id ofs,
+ vmatch bc (symbol_address ge id ofs) (Ptr (Gl id ofs)).
+Proof.
+ intros; apply symbol_address_sound; apply GENV.
+Qed.
+
+Hint Resolve symbol_address_sound: va.
+
+Ltac InvHyps :=
+ match goal with
+ | [H: None = Some _ |- _ ] => discriminate
+ | [H: Some _ = Some _ |- _] => inv H
+ | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ ,
+ H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps
+ | _ => idtac
+ end.
+
+Theorem eval_static_addressing_sound:
+ forall addr vargs vres aargs,
+ eval_addressing ge (Vptr sp Int.zero) addr vargs = Some vres ->
+ list_forall2 (vmatch bc) vargs aargs ->
+ vmatch bc vres (eval_static_addressing addr aargs).
+Proof.
+ unfold eval_addressing, eval_static_addressing; intros;
+ destruct addr; InvHyps; eauto with va.
+ rewrite Int.add_zero_l; auto with va.
+Qed.
+
+Theorem eval_static_operation_sound:
+ forall op vargs m vres aargs,
+ eval_operation ge (Vptr sp Int.zero) op vargs m = Some vres ->
+ list_forall2 (vmatch bc) vargs aargs ->
+ vmatch bc vres (eval_static_operation op aargs).
+Proof.
+ unfold eval_operation, eval_static_operation; intros;
+ destruct op; InvHyps; eauto with va.
+ destruct (propagate_float_constants tt); constructor.
+ rewrite Int.add_zero_l; eauto with va.
+ fold (Val.sub (Vint i) a1). auto with va.
+ apply floatofwords_sound; auto.
+ apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
+Qed.
+
+End SOUNDNESS.
+