summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e>2006-09-04 15:08:29 +0000
committerGravatar xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e>2006-09-04 15:08:29 +0000
commit73729d23ac13275c0d28d23bc1b1f6056104e5d9 (patch)
treee3044ce75edb30377bd8c87356b7617eba5ed223
parentc79434827bf2bd71f857f4471f7bbf381fddd189 (diff)
Fusion de la branche "traces":
- Ajout de traces d'evenements d'E/S dans les semantiques - Ajout constructions switch et allocation dynamique - Initialisation des variables globales - Portage Coq 8.1 beta Debut d'integration du front-end C: - Traduction Clight -> Csharpminor dans cfrontend/ - Modifications de Csharpminor et Globalenvs en consequence. git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@72 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e
-rw-r--r--.depend70
-rw-r--r--Makefile18
-rw-r--r--backend/AST.v96
-rw-r--r--backend/Allocation.v41
-rw-r--r--backend/Allocproof.v336
-rw-r--r--backend/Allocproof_aux.v850
-rw-r--r--backend/Alloctyping.v74
-rw-r--r--backend/Alloctyping_aux.v895
-rw-r--r--backend/CSE.v15
-rw-r--r--backend/CSEproof.v134
-rw-r--r--backend/Cmconstr.v51
-rw-r--r--backend/Cmconstrproof.v727
-rw-r--r--backend/Cminor.v207
-rw-r--r--backend/Cminorgen.v74
-rw-r--r--backend/Cminorgenproof.v1209
-rw-r--r--backend/Coloring.v6
-rw-r--r--backend/Coloringproof.v49
-rw-r--r--backend/Constprop.v24
-rw-r--r--backend/Constpropproof.v112
-rw-r--r--backend/Conventions.v115
-rw-r--r--backend/Csharpminor.v260
-rw-r--r--backend/Events.v103
-rw-r--r--backend/Globalenvs.v94
-rw-r--r--backend/InterfGraph.v137
-rw-r--r--backend/Kildall.v280
-rw-r--r--backend/LTL.v152
-rw-r--r--backend/LTLtyping.v14
-rw-r--r--backend/Linear.v97
-rw-r--r--backend/Linearize.v7
-rw-r--r--backend/Linearizeproof.v138
-rw-r--r--backend/Linearizetyping.v16
-rw-r--r--backend/Lineartyping.v13
-rw-r--r--backend/Mach.v101
-rw-r--r--backend/Machabstr.v274
-rw-r--r--backend/Machabstr2mach.v100
-rw-r--r--backend/Machtyping.v107
-rw-r--r--backend/Main.v58
-rw-r--r--backend/Mem.v132
-rw-r--r--backend/Op.v21
-rw-r--r--backend/PPC.v99
-rw-r--r--backend/PPCgen.v13
-rw-r--r--backend/PPCgenproof.v286
-rw-r--r--backend/PPCgenproof1.v112
-rw-r--r--backend/Parallelmove.v2759
-rw-r--r--backend/RTL.v123
-rw-r--r--backend/RTLgen.v23
-rw-r--r--backend/RTLgenproof.v503
-rw-r--r--backend/RTLgenproof1.v51
-rw-r--r--backend/RTLtyping.v1230
-rw-r--r--backend/Stacking.v7
-rw-r--r--backend/Stackingproof.v185
-rw-r--r--backend/Stackingtyping.v20
-rw-r--r--backend/Tunneling.v7
-rw-r--r--backend/Tunnelingproof.v136
-rw-r--r--backend/Tunnelingtyping.v11
-rw-r--r--caml/Allocationaux.ml39
-rw-r--r--caml/Allocationaux.mli5
-rw-r--r--caml/CMlexer.mll2
-rw-r--r--caml/CMparser.mly22
-rw-r--r--caml/CMtypecheck.ml22
-rw-r--r--caml/Camlcoq.ml5
-rw-r--r--caml/Coloringaux.ml10
-rw-r--r--caml/Floataux.ml13
-rw-r--r--caml/PrintPPC.ml67
-rw-r--r--caml/RTLtypingaux.ml122
-rw-r--r--cfrontend/Csem.v752
-rw-r--r--cfrontend/Cshmgen.v598
-rw-r--r--cfrontend/Cshmgenproof1.v288
-rw-r--r--cfrontend/Cshmgenproof2.v419
-rw-r--r--cfrontend/Cshmgenproof3.v1503
-rw-r--r--cfrontend/Csyntax.v456
-rw-r--r--cfrontend/Ctyping.v420
-rw-r--r--extraction/.depend194
-rw-r--r--extraction/Makefile13
-rw-r--r--extraction/extraction.v18
-rw-r--r--lib/Coqlib.v148
-rw-r--r--lib/Floats.v1
-rw-r--r--lib/Integers.v71
-rw-r--r--lib/Iteration.v293
-rw-r--r--lib/Ordered.v24
-rw-r--r--lib/Parmov.v1206
-rw-r--r--lib/union_find.v127
-rw-r--r--test/cminor/Makefile22
-rw-r--r--test/cminor/almabench.cmp22
-rw-r--r--test/cminor/fft.cm11
-rw-r--r--test/cminor/lists.cm27
-rw-r--r--test/cminor/sha1.cmp17
-rw-r--r--test/harness/mainlists.c40
88 files changed, 11331 insertions, 8418 deletions
diff --git a/.depend b/.depend
index dc2aa64..c35ce16 100644
--- a/.depend
+++ b/.depend
@@ -5,60 +5,68 @@ lib/union_find.vo: lib/union_find.v
lib/Inclusion.vo: lib/Inclusion.v
lib/Lattice.vo: lib/Lattice.v lib/Coqlib.vo lib/Maps.vo
lib/Ordered.vo: lib/Ordered.v lib/Coqlib.vo lib/Maps.vo
-lib/Integers.vo: lib/Integers.v lib/Coqlib.vo backend/AST.vo
-lib/Floats.vo: lib/Floats.v backend/AST.vo lib/Integers.vo
-backend/AST.vo: backend/AST.v lib/Coqlib.vo
+lib/Iteration.vo: lib/Iteration.v lib/Coqlib.vo
+lib/Integers.vo: lib/Integers.v lib/Coqlib.vo
+lib/Floats.vo: lib/Floats.v lib/Integers.vo
+lib/Parmov.vo: lib/Parmov.v lib/Coqlib.vo
+backend/AST.vo: backend/AST.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo
backend/Values.vo: backend/Values.v lib/Coqlib.vo backend/AST.vo lib/Integers.vo lib/Floats.vo
backend/Mem.vo: backend/Mem.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo
+backend/Events.vo: backend/Events.v lib/Coqlib.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo
backend/Globalenvs.vo: backend/Globalenvs.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo
backend/Op.vo: backend/Op.v lib/Coqlib.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo
-backend/Cminor.vo: backend/Cminor.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Op.vo backend/Globalenvs.vo
+backend/Cminor.vo: backend/Cminor.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Events.vo backend/Values.vo backend/Mem.vo backend/Op.vo backend/Globalenvs.vo
backend/Cmconstr.vo: backend/Cmconstr.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Op.vo backend/Globalenvs.vo backend/Cminor.vo
-backend/Cmconstrproof.vo: backend/Cmconstrproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Op.vo backend/Globalenvs.vo backend/Cminor.vo backend/Cmconstr.vo
-backend/Csharpminor.vo: backend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo
+backend/Cmconstrproof.vo: backend/Cmconstrproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Op.vo backend/Globalenvs.vo backend/Cminor.vo backend/Cmconstr.vo
+backend/Csharpminor.vo: backend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo
backend/Cminorgen.vo: backend/Cminorgen.v lib/Coqlib.vo lib/Maps.vo lib/Sets.vo backend/AST.vo lib/Integers.vo backend/Mem.vo backend/Csharpminor.vo backend/Op.vo backend/Cminor.vo backend/Cmconstr.vo
-backend/Cminorgenproof.vo: backend/Cminorgenproof.v lib/Coqlib.vo lib/Maps.vo lib/Sets.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Csharpminor.vo backend/Op.vo backend/Cminor.vo backend/Cmconstr.vo backend/Cminorgen.vo backend/Cmconstrproof.vo
+backend/Cminorgenproof.vo: backend/Cminorgenproof.v lib/Coqlib.vo lib/Maps.vo lib/Sets.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Csharpminor.vo backend/Op.vo backend/Cminor.vo backend/Cmconstr.vo backend/Cminorgen.vo backend/Cmconstrproof.vo
backend/Registers.vo: backend/Registers.v lib/Coqlib.vo backend/AST.vo lib/Maps.vo lib/Sets.vo
-backend/RTL.vo: backend/RTL.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo
+backend/RTL.vo: backend/RTL.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo
backend/RTLgen.vo: backend/RTLgen.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo
-backend/RTLgenproof1.vo: backend/RTLgenproof1.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo backend/RTLgen.vo
-backend/RTLgenproof.vo: backend/RTLgenproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo backend/RTLgen.vo backend/RTLgenproof1.vo
-backend/RTLtyping.vo: backend/RTLtyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo lib/union_find.vo backend/Globalenvs.vo backend/Values.vo backend/Mem.vo lib/Integers.vo
-backend/Kildall.vo: backend/Kildall.v lib/Coqlib.vo lib/Maps.vo lib/Lattice.vo
+backend/RTLgenproof1.vo: backend/RTLgenproof1.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo backend/RTLgen.vo
+backend/RTLgenproof.vo: backend/RTLgenproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo backend/RTLgen.vo backend/RTLgenproof1.vo
+backend/RTLtyping.vo: backend/RTLtyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Conventions.vo backend/Globalenvs.vo backend/Values.vo backend/Mem.vo lib/Integers.vo backend/Events.vo
+backend/Kildall.vo: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo
backend/Constprop.vo: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo
-backend/Constpropproof.vo: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/Constprop.vo
+backend/Constpropproof.vo: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/Constprop.vo
backend/CSE.vo: backend/CSE.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo
-backend/CSEproof.vo: backend/CSEproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/CSE.vo
+backend/CSEproof.vo: backend/CSEproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/CSE.vo
backend/Locations.vo: backend/Locations.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Values.vo
backend/Conventions.vo: backend/Conventions.v lib/Coqlib.vo backend/AST.vo backend/Locations.vo
-backend/LTL.vo: backend/LTL.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo
+backend/LTL.vo: backend/LTL.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo
backend/LTLtyping.vo: backend/LTLtyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo
backend/InterfGraph.vo: backend/InterfGraph.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo backend/Registers.vo backend/Locations.vo
backend/Coloring.vo: backend/Coloring.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo backend/Conventions.vo backend/InterfGraph.vo
backend/Coloringproof.vo: backend/Coloringproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo backend/Conventions.vo backend/InterfGraph.vo backend/Coloring.vo
-backend/Parallelmove.vo: backend/Parallelmove.v backend/Conventions.vo lib/Coqlib.vo backend/Values.vo backend/LTL.vo backend/Locations.vo backend/AST.vo
+backend/Parallelmove.vo: backend/Parallelmove.v lib/Coqlib.vo lib/Parmov.vo backend/Values.vo backend/Events.vo backend/AST.vo backend/Locations.vo backend/Conventions.vo
backend/Allocation.vo: backend/Allocation.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Kildall.vo backend/Locations.vo backend/Conventions.vo backend/Coloring.vo backend/Parallelmove.vo backend/LTL.vo
-backend/Allocproof_aux.vo: backend/Allocproof_aux.v lib/Coqlib.vo backend/Values.vo backend/Parallelmove.vo backend/Allocation.vo backend/LTL.vo backend/Locations.vo backend/Conventions.vo
-backend/Allocproof.vo: backend/Allocproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo backend/Conventions.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/Allocproof_aux.vo backend/LTL.vo
-backend/Alloctyping_aux.vo: backend/Alloctyping_aux.v lib/Coqlib.vo backend/Locations.vo backend/LTL.vo backend/Allocation.vo backend/LTLtyping.vo backend/Allocproof_aux.vo backend/Parallelmove.vo lib/Inclusion.vo
-backend/Alloctyping.vo: backend/Alloctyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/Allocproof.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/Conventions.vo backend/Alloctyping_aux.vo
+backend/Allocproof.vo: backend/Allocproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo backend/Conventions.vo backend/Coloring.vo backend/Coloringproof.vo backend/Parallelmove.vo backend/Allocation.vo backend/LTL.vo
+backend/Alloctyping.vo: backend/Alloctyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/Allocproof.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/Conventions.vo backend/Parallelmove.vo
backend/Tunneling.vo: backend/Tunneling.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Values.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo
-backend/Tunnelingproof.vo: backend/Tunnelingproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Tunneling.vo
+backend/Tunnelingproof.vo: backend/Tunnelingproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Tunneling.vo
backend/Tunnelingtyping.vo: backend/Tunnelingtyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/Tunneling.vo
-backend/Linear.vo: backend/Linear.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo
+backend/Linear.vo: backend/Linear.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo
backend/Lineartyping.vo: backend/Lineartyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo backend/Conventions.vo
backend/Linearize.vo: backend/Linearize.v lib/Coqlib.vo lib/Maps.vo lib/Sets.vo backend/AST.vo backend/Values.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Kildall.vo lib/Lattice.vo
-backend/Linearizeproof.vo: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Linearize.vo lib/Lattice.vo
+backend/Linearizeproof.vo: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Linearize.vo lib/Lattice.vo
backend/Linearizetyping.vo: backend/Linearizetyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Linearize.vo backend/LTLtyping.vo backend/Lineartyping.vo backend/Conventions.vo
-backend/Mach.vo: backend/Mach.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo
-backend/Machabstr.vo: backend/Machabstr.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Mem.vo lib/Integers.vo backend/Values.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo
-backend/Machtyping.vo: backend/Machtyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Mem.vo lib/Integers.vo backend/Values.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo backend/Machabstr.vo
+backend/Mach.vo: backend/Mach.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo
+backend/Machabstr.vo: backend/Machabstr.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Mem.vo lib/Integers.vo backend/Values.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo
+backend/Machtyping.vo: backend/Machtyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Mem.vo lib/Integers.vo backend/Values.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo backend/Machabstr.vo
backend/Stacking.vo: backend/Stacking.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Conventions.vo
-backend/Stackingproof.vo: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Op.vo backend/Mem.vo backend/Globalenvs.vo backend/Locations.vo backend/Mach.vo backend/Machabstr.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo backend/Stacking.vo
+backend/Stackingproof.vo: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Op.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Locations.vo backend/Mach.vo backend/Machabstr.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo backend/Stacking.vo
backend/Stackingtyping.vo: backend/Stackingtyping.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo backend/AST.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machtyping.vo backend/Stacking.vo backend/Stackingproof.vo
-backend/Machabstr2mach.vo: backend/Machabstr2mach.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Machabstr.vo backend/Mach.vo backend/Machtyping.vo backend/Stackingproof.vo
-backend/PPC.vo: backend/PPC.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo
+backend/Machabstr2mach.vo: backend/Machabstr2mach.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Machabstr.vo backend/Mach.vo backend/Machtyping.vo backend/Stackingproof.vo
+backend/PPC.vo: backend/PPC.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo
backend/PPCgen.vo: backend/PPCgen.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/PPC.vo
-backend/PPCgenproof1.vo: backend/PPCgenproof1.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/PPC.vo backend/PPCgen.vo
-backend/PPCgenproof.vo: backend/PPCgenproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/PPC.vo backend/PPCgen.vo backend/PPCgenproof1.vo
+backend/PPCgenproof1.vo: backend/PPCgenproof1.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/PPC.vo backend/PPCgen.vo backend/Conventions.vo
+backend/PPCgenproof.vo: backend/PPCgenproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/PPC.vo backend/PPCgen.vo backend/PPCgenproof1.vo
backend/Main.vo: backend/Main.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Values.vo backend/Csharpminor.vo backend/Cminor.vo backend/RTL.vo backend/LTL.vo backend/Linear.vo backend/Mach.vo backend/PPC.vo backend/Cminorgen.vo backend/RTLgen.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/Stacking.vo backend/PPCgen.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/Lineartyping.vo backend/Machtyping.vo backend/Cminorgenproof.vo backend/RTLgenproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo backend/Machabstr2mach.vo backend/PPCgenproof.vo
+cfrontend/Csyntax.vo: cfrontend/Csyntax.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo backend/AST.vo
+cfrontend/Csem.vo: cfrontend/Csem.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/AST.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo cfrontend/Csyntax.vo
+cfrontend/Ctyping.vo: cfrontend/Ctyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo cfrontend/Csyntax.vo
+cfrontend/Cshmgen.vo: cfrontend/Cshmgen.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo backend/AST.vo cfrontend/Csyntax.vo backend/Csharpminor.vo
+cfrontend/Cshmgenproof1.vo: cfrontend/Cshmgenproof1.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo backend/AST.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Csharpminor.vo cfrontend/Cshmgen.vo
+cfrontend/Cshmgenproof2.vo: cfrontend/Cshmgenproof2.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo backend/AST.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo
+cfrontend/Cshmgenproof3.vo: cfrontend/Cshmgenproof3.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo backend/AST.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo cfrontend/Cshmgenproof2.vo
diff --git a/Makefile b/Makefile
index 6900b3d..8df29ed 100644
--- a/Makefile
+++ b/Makefile
@@ -2,16 +2,16 @@ COQC=coqc $(INCLUDES)
COQDEP=coqdep $(INCLUDES)
COQDOC=coqdoc
-INCLUDES=-I lib -I backend
+INCLUDES=-I lib -I backend -I cfrontend
# Files in lib/
LIB=Coqlib.v Maps.v Sets.v union_find.v Inclusion.v Lattice.v Ordered.v \
- Integers.v Floats.v
+ Iteration.v Integers.v Floats.v Parmov.v
# Files in backend/
-BACKEND=AST.v Values.v Mem.v Globalenvs.v \
+BACKEND=AST.v Values.v Mem.v Events.v Globalenvs.v \
Op.v Cminor.v \
Cmconstr.v Cmconstrproof.v \
Csharpminor.v Cminorgen.v Cminorgenproof.v \
@@ -24,8 +24,7 @@ BACKEND=AST.v Values.v Mem.v Globalenvs.v \
Locations.v Conventions.v LTL.v LTLtyping.v \
InterfGraph.v Coloring.v Coloringproof.v \
Parallelmove.v Allocation.v \
- Allocproof_aux.v Allocproof.v \
- Alloctyping_aux.v Alloctyping.v \
+ Allocproof.v Alloctyping.v \
Tunneling.v Tunnelingproof.v Tunnelingtyping.v \
Linear.v Lineartyping.v \
Linearize.v Linearizeproof.v Linearizetyping.v \
@@ -35,11 +34,16 @@ BACKEND=AST.v Values.v Mem.v Globalenvs.v \
PPC.v PPCgen.v PPCgenproof1.v PPCgenproof.v \
Main.v
+# Files in cfrontend/
+
+CFRONTEND=Csyntax.v Csem.v Ctyping.v Cshmgen.v \
+ Cshmgenproof1.v Cshmgenproof2.v Cshmgenproof3.v
+
# All source files
-FILES=$(LIB:%=lib/%) $(BACKEND:%=backend/%)
+FILES=$(LIB:%=lib/%) $(BACKEND:%=backend/%) $(CFRONTEND:%=cfrontend/%)
-FLATFILES=$(LIB) $(BACKEND)
+FLATFILES=$(LIB) $(BACKEND) $(CFRONTEND)
proof: $(FILES:.v=.vo)
diff --git a/backend/AST.v b/backend/AST.v
index aae9e86..1342bef 100644
--- a/backend/AST.v
+++ b/backend/AST.v
@@ -2,6 +2,8 @@
the abstract syntax trees of many of the intermediate languages. *)
Require Import Coqlib.
+Require Import Integers.
+Require Import Floats.
Set Implicit Arguments.
@@ -33,6 +35,12 @@ Record signature : Set := mksignature {
sig_res: option typ
}.
+Definition proj_sig_res (s: signature) : typ :=
+ match s.(sig_res) with
+ | None => Tint
+ | Some t => t
+ end.
+
(** Memory accesses (load and store instructions) are annotated by
a ``memory chunk'' indicating the type, size and signedness of the
chunk of memory being accessed. *)
@@ -46,41 +54,20 @@ Inductive memory_chunk : Set :=
| Mfloat32 : memory_chunk (**r 32-bit single-precision float *)
| Mfloat64 : memory_chunk. (**r 64-bit double-precision float *)
-(** Comparison instructions can perform one of the six following comparisons
- between their two operands. *)
-
-Inductive comparison : Set :=
- | Ceq : comparison (**r same *)
- | Cne : comparison (**r different *)
- | Clt : comparison (**r less than *)
- | Cle : comparison (**r less than or equal *)
- | Cgt : comparison (**r greater than *)
- | Cge : comparison. (**r greater than or equal *)
-
-Definition negate_comparison (c: comparison): comparison :=
- match c with
- | Ceq => Cne
- | Cne => Ceq
- | Clt => Cge
- | Cle => Cgt
- | Cgt => Cle
- | Cge => Clt
- end.
+(** Initialization data for global variables. *)
-Definition swap_comparison (c: comparison): comparison :=
- match c with
- | Ceq => Ceq
- | Cne => Cne
- | Clt => Cgt
- | Cle => Cge
- | Cgt => Clt
- | Cge => Cle
- end.
+Inductive init_data: Set :=
+ | Init_int8: int -> init_data
+ | Init_int16: int -> init_data
+ | Init_int32: int -> init_data
+ | Init_float32: float -> init_data
+ | Init_float64: float -> init_data
+ | Init_space: Z -> init_data.
(** Whole programs consist of:
- a collection of function definitions (name and description);
- the name of the ``main'' function that serves as entry point in the program;
-- a collection of global variable declarations (name and size in bytes).
+- a collection of global variable declarations (name and initializer).
The type of function descriptions varies among the various intermediate
languages and is taken as parameter to the [program] type. The other parts
@@ -89,7 +76,7 @@ of whole programs are common to all languages. *)
Record program (funct: Set) : Set := mkprogram {
prog_funct: list (ident * funct);
prog_main: ident;
- prog_vars: list (ident * Z)
+ prog_vars: list (ident * list init_data)
}.
(** We now define a general iterator over programs that applies a given
@@ -214,3 +201,50 @@ Proof.
Qed.
End TRANSF_PARTIAL_PROGRAM.
+
+(** For most languages, the functions composing the program are either
+ internal functions, defined within the language, or external functions
+ (a.k.a. system calls) that emit an event when applied. We define
+ a type for such functions and some generic transformation functions. *)
+
+Record external_function : Set := mkextfun {
+ ef_id: ident;
+ ef_sig: signature
+}.
+
+Inductive fundef (F: Set): Set :=
+ | Internal: F -> fundef F
+ | External: external_function -> fundef F.
+
+Implicit Arguments External [F].
+
+Section TRANSF_FUNDEF.
+
+Variable A B: Set.
+Variable transf: A -> B.
+
+Definition transf_fundef (fd: fundef A): fundef B :=
+ match fd with
+ | Internal f => Internal (transf f)
+ | External ef => External ef
+ end.
+
+End TRANSF_FUNDEF.
+
+Section TRANSF_PARTIAL_FUNDEF.
+
+Variable A B: Set.
+Variable transf_partial: A -> option B.
+
+Definition transf_partial_fundef (fd: fundef A): option (fundef B) :=
+ match fd with
+ | Internal f =>
+ match transf_partial f with
+ | None => None
+ | Some f' => Some (Internal f')
+ end
+ | External ef => Some (External ef)
+ end.
+
+End TRANSF_PARTIAL_FUNDEF.
+
diff --git a/backend/Allocation.v b/backend/Allocation.v
index 30f9dcc..d919d1e 100644
--- a/backend/Allocation.v
+++ b/backend/Allocation.v
@@ -87,6 +87,8 @@ Definition transfer
| Icall sig ros args res s =>
reg_list_live args
(reg_sum_live ros (reg_dead res after))
+ | Ialloc arg res s =>
+ reg_live arg (reg_dead res after)
| Icond cond args ifso ifnot =>
reg_list_live args after
| Ireturn optarg =>
@@ -214,20 +216,10 @@ Definition add_move (src dst: loc) (k: block) :=
length. This is a parallel move, meaning that arbitrary overlap
between the sources and destinations is permitted. *)
-Fixpoint listsLoc2Moves (src dst : list loc) {struct src} : Moves :=
- match src, dst with
- | nil, _ => nil
- | s :: srcs, nil => nil
- | s :: srcs, d :: dsts => (s, d) :: listsLoc2Moves srcs dsts
- end.
-
-Definition parallel_move_order (src dst : list loc) :=
- Parallelmove.P_move (listsLoc2Moves src dst).
-
Definition parallel_move (srcs dsts: list loc) (k: block) : block :=
- List.fold_left
- (fun k p => add_move (fst p) (snd p) k)
- (parallel_move_order srcs dsts) k.
+ List.fold_right
+ (fun p k => add_move (fst p) (snd p) k)
+ k (parmove srcs dsts).
(** ** Constructors for LTL instructions *)
@@ -261,6 +253,10 @@ Definition add_store (chunk: memory_chunk) (addr: addressing)
(Bstore chunk addr rargs rsrc (Bgoto s))
end.
+Definition add_alloc (arg: loc) (res: loc) (s: node) :=
+ add_reload arg Conventions.loc_alloc_argument
+ (Balloc (add_spill Conventions.loc_alloc_result res (Bgoto s))).
+
(** For function calls, we also add appropriate moves to and from
the canonical locations for function arguments and function results,
as dictated by the calling conventions. *)
@@ -344,10 +340,12 @@ Definition transf_instr
| Icall sig ros args res s =>
add_call sig (sum_left_map assign ros) (List.map assign args)
(assign res) s
+ | Ialloc arg res s =>
+ add_alloc (assign arg) (assign res) s
| Icond cond args ifso ifnot =>
add_cond cond (List.map assign args) ifso ifnot
| Ireturn optarg =>
- add_return (RTL.fn_sig f) (option_map assign optarg)
+ add_return f.(RTL.fn_sig) (option_map assign optarg)
end.
Definition transf_entrypoint
@@ -391,7 +389,7 @@ Qed.
transformation as described above. *)
Definition transf_function (f: RTL.function) : option LTL.function :=
- match type_rtl_function f with
+ match type_function f with
| None => None
| Some env =>
match analyze f with
@@ -413,6 +411,17 @@ Definition transf_function (f: RTL.function) : option LTL.function :=
end
end.
+Definition transf_fundef (fd: RTL.fundef) : option LTL.fundef :=
+ match fd with
+ | External ef =>
+ if type_external_function ef then Some (External ef) else None
+ | Internal f =>
+ match transf_function f with
+ | None => None
+ | Some tf => Some (Internal tf)
+ end
+ end.
+
Definition transf_program (p: RTL.program) : option LTL.program :=
- transform_partial_program transf_function p.
+ transform_partial_program transf_fundef p.
diff --git a/backend/Allocproof.v b/backend/Allocproof.v
index 138e6d7..07c0f58 100644
--- a/backend/Allocproof.v
+++ b/backend/Allocproof.v
@@ -8,6 +8,7 @@ Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Registers.
@@ -17,8 +18,8 @@ Require Import Locations.
Require Import Conventions.
Require Import Coloring.
Require Import Coloringproof.
+Require Import Parallelmove.
Require Import Allocation.
-Require Import Allocproof_aux.
(** * Semantic properties of calling conventions *)
@@ -473,7 +474,7 @@ Qed.
Lemma add_reload_correct:
forall src dst k rs m,
exists rs',
- exec_instrs ge sp (add_reload src dst k) rs m k rs' m /\
+ exec_instrs ge sp (add_reload src dst k) rs m E0 k rs' m /\
rs' (R dst) = rs src /\
forall l, Loc.diff (R dst) l -> rs' l = rs l.
Proof.
@@ -493,7 +494,7 @@ Qed.
Lemma add_spill_correct:
forall src dst k rs m,
exists rs',
- exec_instrs ge sp (add_spill src dst k) rs m k rs' m /\
+ exec_instrs ge sp (add_spill src dst k) rs m E0 k rs' m /\
rs' dst = rs (R src) /\
forall l, Loc.diff dst l -> rs' l = rs l.
Proof.
@@ -520,7 +521,7 @@ Lemma add_reloads_correct_rec:
list_norepet itmps ->
list_norepet ftmps ->
exists rs',
- exec_instrs ge sp (add_reloads srcs (regs_for_rec srcs itmps ftmps) k) rs m k rs' m /\
+ exec_instrs ge sp (add_reloads srcs (regs_for_rec srcs itmps ftmps) k) rs m E0 k rs' m /\
reglist (regs_for_rec srcs itmps ftmps) rs' = map rs srcs /\
(forall r, ~(In r itmps) -> ~(In r ftmps) -> rs' (R r) = rs (R r)) /\
(forall s, rs' (S s) = rs (S s)).
@@ -578,7 +579,7 @@ Proof.
generalize (IHsrcs itmps ftmps k rs1 m R1 R2 R3 R4 R5 R6 R7).
intros [rs' [EX [RES [OTH1 OTH2]]]].
exists rs'.
- split. eapply exec_trans; eauto.
+ split. eapply exec_trans; eauto. traceEq.
split. simpl. apply (f_equal2 (@cons val)).
rewrite OTH1; auto.
rewrite RES. apply list_map_exten. intros.
@@ -599,7 +600,7 @@ Lemma add_reloads_correct:
(List.length srcs <= 3)%nat ->
Loc.disjoint srcs temporaries ->
exists rs',
- exec_instrs ge sp (add_reloads srcs (regs_for srcs) k) rs m k rs' m /\
+ exec_instrs ge sp (add_reloads srcs (regs_for srcs) k) rs m E0 k rs' m /\
reglist (regs_for srcs) rs' = List.map rs srcs /\
forall l, Loc.notin l temporaries -> rs' l = rs l.
Proof.
@@ -638,7 +639,7 @@ Qed.
Lemma add_move_correct:
forall src dst k rs m,
exists rs',
- exec_instrs ge sp (add_move src dst k) rs m k rs' m /\
+ exec_instrs ge sp (add_move src dst k) rs m E0 k rs' m /\
rs' dst = rs src /\
forall l, Loc.diff l dst -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> rs' l = rs l.
Proof.
@@ -660,13 +661,33 @@ Proof.
generalize (add_spill_correct tmp (S s0) k rs1 m);
intros [rs2 [EX2 [RES2 OTH2]]].
exists rs2. split.
- eapply exec_trans; eauto.
+ eapply exec_trans; eauto. traceEq.
split. congruence.
intros. rewrite OTH2. apply OTH1.
apply Loc.diff_sym. unfold tmp; case (slot_type s); auto.
apply Loc.diff_sym; auto.
Qed.
+Lemma effect_move_sequence:
+ forall k moves rs m,
+ let k' := List.fold_right (fun p k => add_move (fst p) (snd p) k) k moves in
+ exists rs',
+ exec_instrs ge sp k' rs m E0 k rs' m /\
+ effect_seqmove moves rs rs'.
+Proof.
+ induction moves; intros until m; simpl.
+ exists rs; split. constructor. constructor.
+ destruct a as [src dst]; simpl.
+ set (k1 := fold_right
+ (fun (p : loc * loc) (k : block) => add_move (fst p) (snd p) k)
+ k moves) in *.
+ destruct (add_move_correct src dst k1 rs m) as [rs1 [A [B C]]].
+ destruct (IHmoves rs1 m) as [rs' [D E]].
+ exists rs'; split.
+ eapply exec_trans; eauto. traceEq.
+ econstructor; eauto. red. tauto.
+Qed.
+
Theorem parallel_move_correct:
forall srcs dsts k rs m,
List.length srcs = List.length dsts ->
@@ -675,13 +696,16 @@ Theorem parallel_move_correct:
Loc.disjoint srcs temporaries ->
Loc.disjoint dsts temporaries ->
exists rs',
- exec_instrs ge sp (parallel_move srcs dsts k) rs m k rs' m /\
+ exec_instrs ge sp (parallel_move srcs dsts k) rs m E0 k rs' m /\
List.map rs' dsts = List.map rs srcs /\
rs' (R IT3) = rs (R IT3) /\
forall l, Loc.notin l dsts -> Loc.notin l temporaries -> rs' l = rs l.
Proof.
- apply (parallel_move_correctX ge sp).
- apply add_move_correct.
+ intros.
+ generalize (effect_move_sequence k (parmove srcs dsts) rs m).
+ intros [rs' [EXEC EFFECT]].
+ exists rs'. split. exact EXEC.
+ apply effect_parmove; auto.
Qed.
Lemma add_op_correct:
@@ -690,7 +714,7 @@ Lemma add_op_correct:
Loc.disjoint args temporaries ->
eval_operation ge sp op (List.map rs args) = Some v ->
exists rs',
- exec_block ge sp (add_op op args res s) rs m (Cont s) rs' m /\
+ exec_block ge sp (add_op op args res s) rs m E0 (Cont s) rs' m /\
rs' res = v /\
forall l, Loc.diff l res -> Loc.notin l temporaries -> rs' l = rs l.
Proof.
@@ -721,7 +745,7 @@ Proof.
split. apply exec_Bgoto. eapply exec_trans. eexact EX1.
eapply exec_trans; eauto.
apply exec_one. unfold rs2. apply exec_Bop.
- unfold rargs. rewrite RES1. auto.
+ unfold rargs. rewrite RES1. auto. traceEq.
split. rewrite RES3. unfold rs2; apply Locmap.gss.
intros. rewrite OTHER3. unfold rs2. rewrite Locmap.gso.
apply OTHER1. assumption.
@@ -737,7 +761,7 @@ Lemma add_load_correct:
eval_addressing ge sp addr (List.map rs args) = Some a ->
loadv chunk m a = Some v ->
exists rs',
- exec_block ge sp (add_load chunk addr args res s) rs m (Cont s) rs' m /\
+ exec_block ge sp (add_load chunk addr args res s) rs m E0 (Cont s) rs' m /\
rs' res = v /\
forall l, Loc.diff l res -> Loc.notin l temporaries -> rs' l = rs l.
Proof.
@@ -755,7 +779,7 @@ Proof.
split. apply exec_Bgoto. eapply exec_trans; eauto.
eapply exec_trans; eauto.
apply exec_one. unfold rs2. apply exec_Bload with a.
- unfold rargs; rewrite RES1. assumption. assumption.
+ unfold rargs; rewrite RES1. assumption. assumption. traceEq.
split. rewrite RES3. unfold rs2; apply Locmap.gss.
intros. rewrite OTHER3. unfold rs2. rewrite Locmap.gso.
apply OTHER1. assumption.
@@ -772,7 +796,7 @@ Lemma add_store_correct:
eval_addressing ge sp addr (List.map rs args) = Some a ->
storev chunk m a (rs src) = Some m' ->
exists rs',
- exec_block ge sp (add_store chunk addr args src s) rs m (Cont s) rs' m' /\
+ exec_block ge sp (add_store chunk addr args src s) rs m E0 (Cont s) rs' m' /\
forall l, Loc.notin l temporaries -> rs' l = rs l.
Proof.
intros.
@@ -795,10 +819,42 @@ Proof.
split. apply exec_Bgoto.
eapply exec_trans. rewrite <- EQ. eexact EX1.
apply exec_one. apply exec_Bstore with a.
- rewrite RES2. assumption. rewrite RES3. assumption.
+ rewrite RES2. assumption. rewrite RES3. assumption. traceEq.
exact OTHER1.
Qed.
+Lemma add_alloc_correct:
+ forall arg res s rs m m' sz b,
+ rs arg = Vint sz ->
+ Mem.alloc m 0 (Int.signed sz) = (m', b) ->
+ exists rs',
+ exec_block ge sp (add_alloc arg res s) rs m E0 (Cont s) rs' m' /\
+ rs' res = Vptr b Int.zero /\
+ forall l,
+ Loc.diff l (R Conventions.loc_alloc_argument) ->
+ Loc.diff l (R Conventions.loc_alloc_result) ->
+ Loc.diff l res ->
+ rs' l = rs l.
+Proof.
+ intros; unfold add_alloc.
+ generalize (add_reload_correct arg loc_alloc_argument
+ (Balloc (add_spill loc_alloc_result res (Bgoto s)))
+ rs m).
+ intros [rs1 [EX1 [RES1 OTHER1]]].
+ pose (rs2 := Locmap.set (R loc_alloc_result) (Vptr b Int.zero) rs1).
+ generalize (add_spill_correct loc_alloc_result res (Bgoto s) rs2 m').
+ intros [rs3 [EX3 [RES3 OTHER3]]].
+ exists rs3.
+ split. apply exec_Bgoto. eapply exec_trans. eexact EX1.
+ eapply exec_trans. apply exec_one. eapply exec_Balloc; eauto. congruence.
+ fold rs2. eexact EX3. reflexivity. traceEq.
+ split. rewrite RES3; unfold rs2. apply Locmap.gss.
+ intros. rewrite OTHER3. unfold rs2. rewrite Locmap.gso.
+ apply OTHER1. apply Loc.diff_sym; auto.
+ apply Loc.diff_sym; auto.
+ apply Loc.diff_sym; auto.
+Qed.
+
Lemma add_cond_correct:
forall cond args ifso ifnot rs m b s,
(List.length args <= 3)%nat ->
@@ -806,7 +862,7 @@ Lemma add_cond_correct:
eval_condition cond (List.map rs args) = Some b ->
s = (if b then ifso else ifnot) ->
exists rs',
- exec_block ge sp (add_cond cond args ifso ifnot) rs m (Cont s) rs' m /\
+ exec_block ge sp (add_cond cond args ifso ifnot) rs m E0 (Cont s) rs' m /\
forall l, Loc.notin l temporaries -> rs' l = rs l.
Proof.
intros. unfold add_cond.
@@ -825,7 +881,7 @@ Proof.
exact OTHER1.
Qed.
-Definition find_function2 (los: loc + ident) (ls: locset) : option function :=
+Definition find_function2 (los: loc + ident) (ls: locset) : option fundef :=
match los with
| inl l => Genv.find_funct ge (ls l)
| inr symb =>
@@ -836,21 +892,21 @@ Definition find_function2 (los: loc + ident) (ls: locset) : option function :=
end.
Lemma add_call_correct:
- forall f vargs m vres m' sig los args res s ls
+ forall f vargs m t vres m' sig los args res s ls
(EXECF:
forall lsi,
- List.map lsi (loc_arguments f.(fn_sig)) = vargs ->
+ List.map lsi (loc_arguments (funsig f)) = vargs ->
exists lso,
- exec_function ge f lsi m lso m'
- /\ lso (R (loc_result f.(fn_sig))) = vres)
+ exec_function ge f lsi m t lso m'
+ /\ lso (R (loc_result (funsig f))) = vres)
(FIND: find_function2 los ls = Some f)
- (SIG: sig = f.(fn_sig))
+ (SIG: sig = funsig f)
(VARGS: List.map ls args = vargs)
(LARGS: List.length args = List.length sig.(sig_args))
(AARGS: locs_acceptable args)
(RES: loc_acceptable res),
exists ls',
- exec_block ge sp (add_call sig los args res s) ls m (Cont s) ls' m' /\
+ exec_block ge sp (add_call sig los args res s) ls m t (Cont s) ls' m' /\
ls' res = vres /\
forall l,
Loc.notin l destroyed_at_call -> loc_acceptable l -> Loc.diff l res ->
@@ -896,7 +952,7 @@ Proof.
eapply exec_trans. apply exec_one. apply exec_Bcall with f.
unfold find_function. rewrite TMP2. rewrite RES1.
assumption. assumption. eexact EX3.
- exact EX5.
+ eexact EX5. reflexivity. reflexivity. traceEq.
(* Result *)
split. rewrite RES5. unfold ls4. rewrite return_regs_result.
assumption.
@@ -936,7 +992,7 @@ Proof.
eapply exec_trans. eexact EX2.
eapply exec_trans. apply exec_one. apply exec_Bcall with f.
unfold find_function. assumption. assumption. eexact EX3.
- exact EX5.
+ eexact EX5. reflexivity. traceEq.
(* Result *)
split. rewrite RES5.
unfold ls4. rewrite return_regs_result.
@@ -955,7 +1011,7 @@ Lemma add_undefs_correct:
(forall l, In l res -> loc_acceptable l) ->
(forall ofs ty, In (S (Local ofs ty)) res -> ls (S (Local ofs ty)) = Vundef) ->
exists ls',
- exec_instrs ge sp (add_undefs res b) ls m b ls' m /\
+ exec_instrs ge sp (add_undefs res b) ls m E0 b ls' m /\
(forall l, In l res -> ls' l = Vundef) /\
(forall l, Loc.notin l res -> ls' l = ls l).
Proof.
@@ -972,7 +1028,7 @@ Proof.
intros [ls2 [EX2 [RES2 OTHER2]]].
exists ls2. split.
eapply exec_trans. apply exec_one. apply exec_Bop.
- simpl; reflexivity. exact EX2.
+ simpl; reflexivity. eexact EX2. traceEq.
split. intros. case (In_dec Loc.eq l res); intro.
apply RES2; auto.
rewrite OTHER2. elim H1; intro.
@@ -1006,7 +1062,7 @@ Lemma add_entry_correct:
locs_acceptable undefs ->
(forall ofs ty, ls (S (Local ofs ty)) = Vundef) ->
exists ls',
- exec_block ge sp (add_entry sig params undefs s) ls m (Cont s) ls' m /\
+ exec_block ge sp (add_entry sig params undefs s) ls m E0 (Cont s) ls' m /\
List.map ls' params = List.map ls (loc_parameters sig) /\
(forall l, In l undefs -> ls' l = Vundef).
Proof.
@@ -1029,7 +1085,7 @@ Proof.
intros [ls2 [EX2 [RES2 OTHER2]]].
exists ls2.
split. apply exec_Bgoto. unfold add_entry.
- eapply exec_trans. eexact EX1. eexact EX2.
+ eapply exec_trans. eexact EX1. eexact EX2. traceEq.
split. rewrite <- RES1. apply list_map_exten.
intros. symmetry. apply OTHER2. eapply Loc.disjoint_notin; eauto.
exact RES2.
@@ -1038,7 +1094,7 @@ Qed.
Lemma add_return_correct:
forall sig optarg ls m,
exists ls',
- exec_block ge sp (add_return sig optarg) ls m Return ls' m /\
+ exec_block ge sp (add_return sig optarg) ls m E0 Return ls' m /\
match optarg with
| Some arg => ls' (R (loc_result sig)) = ls arg
| None => ls' (R (loc_result sig)) = Vundef
@@ -1131,51 +1187,53 @@ 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_function.
+ apply Genv.find_symbol_transf_partial with transf_fundef.
exact TRANSF.
Qed.
Lemma functions_translated:
- forall (v: val) (f: RTL.function),
+ forall (v: val) (f: RTL.fundef),
Genv.find_funct ge v = Some f ->
exists tf,
- Genv.find_funct tge v = Some tf /\ transf_function f = Some tf.
+ Genv.find_funct tge v = Some tf /\ transf_fundef f = Some tf.
Proof.
intros.
generalize
- (Genv.find_funct_transf_partial transf_function TRANSF H).
- case (transf_function f).
+ (Genv.find_funct_transf_partial transf_fundef TRANSF H).
+ case (transf_fundef f).
intros tf [A B]. exists tf. tauto.
intros [A B]. elim B. reflexivity.
Qed.
Lemma function_ptr_translated:
- forall (b: Values.block) (f: RTL.function),
+ forall (b: Values.block) (f: RTL.fundef),
Genv.find_funct_ptr ge b = Some f ->
exists tf,
- Genv.find_funct_ptr tge b = Some tf /\ transf_function f = Some tf.
+ Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = Some tf.
Proof.
intros.
generalize
- (Genv.find_funct_ptr_transf_partial transf_function TRANSF H).
- case (transf_function f).
+ (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF H).
+ case (transf_fundef f).
intros tf [A B]. exists tf. tauto.
intros [A B]. elim B. reflexivity.
Qed.
Lemma sig_function_translated:
forall f tf,
- transf_function f = Some tf ->
- tf.(LTL.fn_sig) = f.(RTL.fn_sig).
+ transf_fundef f = Some tf ->
+ LTL.funsig tf = RTL.funsig f.
Proof.
- intros f tf. unfold transf_function.
- destruct (type_rtl_function f).
+ intros f tf. destruct f; simpl.
+ unfold transf_function.
+ destruct (type_function f).
destruct (analyze f).
- destruct (regalloc f t0).
+ destruct (regalloc f t).
intro EQ; injection EQ; intro EQ1; rewrite <- EQ1; simpl; auto.
- intros; discriminate.
- intros; discriminate.
- intros; discriminate.
+ congruence. congruence. congruence.
+ destruct (type_external_function e).
+ intro EQ; inversion EQ; subst tf. reflexivity.
+ congruence.
Qed.
Lemma entrypoint_function_translated:
@@ -1184,9 +1242,9 @@ Lemma entrypoint_function_translated:
tf.(LTL.fn_entrypoint) = f.(RTL.fn_nextpc).
Proof.
intros f tf. unfold transf_function.
- destruct (type_rtl_function f).
+ destruct (type_function f).
destruct (analyze f).
- destruct (regalloc f t0).
+ destruct (regalloc f t).
intro EQ; injection EQ; intro EQ1; rewrite <- EQ1; simpl; auto.
intros; discriminate.
intros; discriminate.
@@ -1220,43 +1278,43 @@ Qed.
Definition exec_instr_prop
(c: RTL.code) (sp: val)
- (pc: node) (rs: regset) (m: mem)
+ (pc: node) (rs: regset) (m: mem) (t: trace)
(pc': node) (rs': regset) (m': mem) : Prop :=
forall f env live assign ls
(CF: c = f.(RTL.fn_code))
- (WT: wt_function env f)
+ (WT: wt_function f env)
(ASG: regalloc f live (live0 f live) env = Some assign)
(AG: agree assign (transfer f pc live!!pc) rs ls),
let tc := PTree.map (transf_instr f live assign) c in
exists ls',
- exec_blocks tge tc sp pc ls m (Cont pc') ls' m' /\
+ exec_blocks tge tc sp pc ls m t (Cont pc') ls' m' /\
agree assign live!!pc rs' ls'.
Definition exec_instrs_prop
(c: RTL.code) (sp: val)
- (pc: node) (rs: regset) (m: mem)
+ (pc: node) (rs: regset) (m: mem) (t: trace)
(pc': node) (rs': regset) (m': mem) : Prop :=
forall f env live assign ls,
forall (CF: c = f.(RTL.fn_code))
- (WT: wt_function env f)
+ (WT: wt_function f env)
(ANL: analyze f = Some live)
(ASG: regalloc f live (live0 f live) env = Some assign)
(AG: agree assign (transfer f pc live!!pc) rs ls)
(VALIDPC': c!pc' <> None),
let tc := PTree.map (transf_instr f live assign) c in
exists ls',
- exec_blocks tge tc sp pc ls m (Cont pc') ls' m' /\
+ exec_blocks tge tc sp pc ls m t (Cont pc') ls' m' /\
agree assign (transfer f pc' live!!pc') rs' ls'.
Definition exec_function_prop
- (f: RTL.function) (args: list val) (m: mem)
- (res: val) (m': mem) : Prop :=
+ (f: RTL.fundef) (args: list val) (m: mem)
+ (t: trace) (res: val) (m': mem) : Prop :=
forall ls tf,
- transf_function f = Some tf ->
- List.map ls (Conventions.loc_arguments tf.(fn_sig)) = args ->
+ transf_fundef f = Some tf ->
+ List.map ls (Conventions.loc_arguments (funsig tf)) = args ->
exists ls',
- LTL.exec_function tge tf ls m ls' m' /\
- ls' (R (Conventions.loc_result tf.(fn_sig))) = res.
+ LTL.exec_function tge tf ls m t ls' m' /\
+ ls' (R (Conventions.loc_result (funsig tf))) = res.
(** The simulation proof is by structural induction over the RTL evaluation
derivation. We prove each case of the proof as a separate lemma.
@@ -1298,7 +1356,7 @@ Lemma transl_Inop_correct:
forall (c : PTree.t instruction) (sp: val) (pc : positive)
(rs : regset) (m : mem) (pc' : RTL.node),
c ! pc = Some (Inop pc') ->
- exec_instr_prop c sp pc rs m pc' rs m.
+ exec_instr_prop c sp pc rs m E0 pc' rs m.
Proof.
intros; red; intros; CleanupHyps.
exists ls. split.
@@ -1312,7 +1370,7 @@ Lemma transl_Iop_correct:
(res : reg) (pc' : RTL.node) (v: val),
c ! pc = Some (Iop op args res pc') ->
eval_operation ge sp op (rs ## args) = Some v ->
- exec_instr_prop c sp pc rs m pc' (rs # res <- v) m.
+ exec_instr_prop c sp pc rs m E0 pc' (rs # res <- v) m.
Proof.
intros; red; intros; CleanupHyps.
caseEq (Regset.mem res live!!pc); intro LV;
@@ -1364,7 +1422,7 @@ Lemma transl_Iload_correct:
c ! pc = Some (Iload chunk addr args dst pc') ->
eval_addressing ge sp addr rs ## args = Some a ->
loadv chunk m a = Some v ->
- exec_instr_prop c sp pc rs m pc' rs # dst <- v m.
+ exec_instr_prop c sp pc rs m E0 pc' rs # dst <- v m.
Proof.
intros; red; intros; CleanupHyps.
caseEq (Regset.mem dst live!!pc); intro LV;
@@ -1407,7 +1465,7 @@ Lemma transl_Istore_correct:
c ! pc = Some (Istore chunk addr args src pc') ->
eval_addressing ge sp addr rs ## args = Some a ->
storev chunk m a rs # src = Some m' ->
- exec_instr_prop c sp pc rs m pc' rs m'.
+ exec_instr_prop c sp pc rs m E0 pc' rs m'.
Proof.
intros; red; intros; CleanupHyps.
assert (LL: (List.length (List.map assign args) <= 2)%nat).
@@ -1444,19 +1502,19 @@ Lemma transl_Icall_correct:
forall (c : PTree.t instruction) (sp: val) (pc : positive)
(rs : regset) (m : mem) (sig : signature) (ros : reg + ident)
(args : list reg) (res : reg) (pc' : RTL.node)
- (f : RTL.function) (vres : val) (m' : mem),
+ (f : RTL.fundef) (vres : val) (m' : mem) (t: trace),
c ! pc = Some (Icall sig ros args res pc') ->
RTL.find_function ge ros rs = Some f ->
- sig = RTL.fn_sig f ->
- RTL.exec_function ge f (rs##args) m vres m' ->
- exec_function_prop f (rs##args) m vres m' ->
- exec_instr_prop c sp pc rs m pc' (rs#res <- vres) m'.
+ RTL.funsig f = sig ->
+ RTL.exec_function ge f (rs##args) m t vres m' ->
+ exec_function_prop f (rs##args) m t vres m' ->
+ exec_instr_prop c sp pc rs m t pc' (rs#res <- vres) m'.
Proof.
intros; red; intros; CleanupHyps.
set (los := sum_left_map assign ros).
assert (FIND: exists tf,
find_function2 tge los ls = Some tf /\
- transf_function f = Some tf).
+ transf_fundef f = Some tf).
unfold los. destruct ros; simpl; simpl in H0.
apply functions_translated.
replace (ls (assign r)) with rs#r. assumption.
@@ -1466,7 +1524,7 @@ Proof.
apply function_ptr_translated. auto.
discriminate.
elim FIND; intros tf [AFIND TRF]; clear FIND.
- assert (ASIG: sig = fn_sig tf).
+ assert (ASIG: sig = funsig tf).
rewrite (sig_function_translated _ _ TRF). auto.
generalize (fun ls => H3 ls tf TRF); intro AEXECF.
assert (AVARGS: List.map ls (List.map assign args) = rs##args).
@@ -1482,7 +1540,7 @@ Proof.
unfold correct_alloc_instr. intros [CORR1 CORR2].
assert (ARES: loc_acceptable (assign res)).
eapply regalloc_acceptable; eauto.
- generalize (add_call_correct tge sp tf _ _ _ _ _ _ _ _ pc' _
+ generalize (add_call_correct tge sp tf _ _ _ _ _ _ _ _ _ pc' _
AEXECF AFIND ASIG AVARGS ALARGS
AACCEPT ARES).
intros [ls' [EX [RES OTHER]]].
@@ -1491,13 +1549,42 @@ Proof.
simpl. eapply agree_call; eauto.
Qed.
+Lemma transl_Ialloc_correct:
+ forall (c : PTree.t instruction) (sp: val) (pc : positive)
+ (rs : Regmap.t val) (m : mem) (pc': RTL.node) (arg res: reg)
+ (sz: int) (m': mem) (b: Values.block),
+ c ! pc = Some (Ialloc arg res pc') ->
+ rs#arg = Vint sz ->
+ Mem.alloc m 0 (Int.signed sz) = (m', b) ->
+ exec_instr_prop c sp pc rs m E0 pc' (rs # res <- (Vptr b Int.zero)) m'.
+Proof.
+ intros; red; intros; CleanupHyps.
+ assert (SZ: ls (assign arg) = Vint sz).
+ rewrite <- H0. eapply agree_eval_reg. eauto.
+ generalize (add_alloc_correct tge sp (assign arg) (assign res)
+ pc' ls m m' sz b SZ H1).
+ intros [ls' [EX [RES OTHER]]].
+ exists ls'.
+ split. CleanupGoal. exact EX.
+ rewrite CF in H.
+ generalize (regalloc_correct_1 f env live _ _ _ _ ASG H).
+ unfold correct_alloc_instr. intros [CORR1 CORR2].
+ eapply agree_call with (args := arg :: nil) (ros := inr reg 1%positive) (ls := ls) (ls' := ls'); eauto.
+ intros. apply OTHER.
+ eapply Loc.in_notin_diff; eauto.
+ unfold loc_alloc_argument, destroyed_at_call; simpl; tauto.
+ eapply Loc.in_notin_diff; eauto.
+ unfold loc_alloc_argument, destroyed_at_call; simpl; tauto.
+ auto.
+Qed.
+
Lemma transl_Icond_true_correct:
forall (c : PTree.t instruction) (sp: val) (pc : positive)
(rs : Regmap.t val) (m : mem) (cond : condition) (args : list reg)
(ifso ifnot : RTL.node),
c ! pc = Some (Icond cond args ifso ifnot) ->
eval_condition cond rs ## args = Some true ->
- exec_instr_prop c sp pc rs m ifso rs m.
+ exec_instr_prop c sp pc rs m E0 ifso rs m.
Proof.
intros; red; intros; CleanupHyps.
assert (LL: (List.length (map assign args) <= 3)%nat).
@@ -1523,7 +1610,7 @@ Lemma transl_Icond_false_correct:
(ifso ifnot : RTL.node),
c ! pc = Some (Icond cond args ifso ifnot) ->
eval_condition cond rs ## args = Some false ->
- exec_instr_prop c sp pc rs m ifnot rs m.
+ exec_instr_prop c sp pc rs m E0 ifnot rs m.
Proof.
intros; red; intros; CleanupHyps.
assert (LL: (List.length (map assign args) <= 3)%nat).
@@ -1545,7 +1632,7 @@ Qed.
Lemma transl_refl_correct:
forall (c : RTL.code) (sp: val) (pc : RTL.node) (rs : regset)
- (m : mem), exec_instrs_prop c sp pc rs m pc rs m.
+ (m : mem), exec_instrs_prop c sp pc rs m E0 pc rs m.
Proof.
intros; red; intros.
exists ls. split. apply exec_blocks_refl. assumption.
@@ -1553,10 +1640,10 @@ Qed.
Lemma transl_one_correct:
forall (c : RTL.code) (sp: val) (pc : RTL.node) (rs : regset)
- (m : mem) (pc' : RTL.node) (rs' : regset) (m' : mem),
- RTL.exec_instr ge c sp pc rs m pc' rs' m' ->
- exec_instr_prop c sp pc rs m pc' rs' m' ->
- exec_instrs_prop c sp pc rs m pc' rs' m'.
+ (m : mem) (t: trace) (pc' : RTL.node) (rs' : regset) (m' : mem),
+ RTL.exec_instr ge c sp pc rs m t pc' rs' m' ->
+ exec_instr_prop c sp pc rs m t pc' rs' m' ->
+ exec_instrs_prop c sp pc rs m t pc' rs' m'.
Proof.
intros; red; intros.
generalize (H0 f env live assign ls CF WT ASG AG).
@@ -1573,13 +1660,14 @@ Qed.
Lemma transl_trans_correct:
forall (c : RTL.code) (sp: val) (pc1 : RTL.node) (rs1 : regset)
- (m1 : mem) (pc2 : RTL.node) (rs2 : regset) (m2 : mem)
- (pc3 : RTL.node) (rs3 : regset) (m3 : mem),
- RTL.exec_instrs ge c sp pc1 rs1 m1 pc2 rs2 m2 ->
- exec_instrs_prop c sp pc1 rs1 m1 pc2 rs2 m2 ->
- RTL.exec_instrs ge c sp pc2 rs2 m2 pc3 rs3 m3 ->
- exec_instrs_prop c sp pc2 rs2 m2 pc3 rs3 m3 ->
- exec_instrs_prop c sp pc1 rs1 m1 pc3 rs3 m3.
+ (m1 : mem) (t1: trace) (pc2 : RTL.node) (rs2 : regset) (m2 : mem)
+ (t2: trace) (pc3 : RTL.node) (rs3 : regset) (m3 : mem) (t3: trace),
+ RTL.exec_instrs ge c sp pc1 rs1 m1 t1 pc2 rs2 m2 ->
+ exec_instrs_prop c sp pc1 rs1 m1 t1 pc2 rs2 m2 ->
+ RTL.exec_instrs ge c sp pc2 rs2 m2 t2 pc3 rs3 m3 ->
+ exec_instrs_prop c sp pc2 rs2 m2 t2 pc3 rs3 m3 ->
+ t3 = t1 ** t2 ->
+ exec_instrs_prop c sp pc1 rs1 m1 t3 pc3 rs3 m3.
Proof.
intros; red; intros.
assert (VALIDPC2: c!pc2 <> None).
@@ -1589,7 +1677,7 @@ Proof.
generalize (H2 f env live assign ls1 CF WT ANL ASG AG1 VALIDPC').
intros [ls2 [EX2 AG2]].
exists ls2. split.
- eapply exec_blocks_trans. eexact EX1. exact EX2.
+ eapply exec_blocks_trans. eexact EX1. eexact EX2. auto.
exact AG2.
Qed.
@@ -1609,14 +1697,14 @@ Qed.
Lemma transf_entrypoint_correct:
forall f env live assign c ls args sp m,
- wt_function env f ->
+ wt_function f env ->
regalloc f live (live0 f live) env = Some assign ->
c!(RTL.fn_nextpc f) = None ->
List.map ls (loc_parameters (RTL.fn_sig f)) = args ->
(forall ofs ty, ls (S (Local ofs ty)) = Vundef) ->
let tc := transf_entrypoint f live assign c in
exists ls',
- exec_blocks tge tc sp (RTL.fn_nextpc f) ls m
+ exec_blocks tge tc sp (RTL.fn_nextpc f) ls m E0
(Cont (RTL.fn_entrypoint f)) ls' m /\
agree assign (transfer f (RTL.fn_entrypoint f) live!!(RTL.fn_entrypoint f))
(init_regs args (RTL.fn_params f)) ls'.
@@ -1680,20 +1768,20 @@ Qed.
Lemma transl_function_correct:
forall (f : RTL.function) (m m1 : mem) (stk : Values.block)
- (args : list val) (pc : RTL.node) (rs : regset) (m2 : mem)
+ (args : list val) (t: trace) (pc : RTL.node) (rs : regset) (m2 : mem)
(or : option reg) (vres : val),
alloc m 0 (RTL.fn_stacksize f) = (m1, stk) ->
RTL.exec_instrs ge (RTL.fn_code f) (Vptr stk Int.zero)
- (RTL.fn_entrypoint f) (init_regs args (fn_params f)) m1 pc rs m2 ->
+ (RTL.fn_entrypoint f) (init_regs args (fn_params f)) m1 t pc rs m2 ->
exec_instrs_prop (RTL.fn_code f) (Vptr stk Int.zero)
- (RTL.fn_entrypoint f) (init_regs args (fn_params f)) m1 pc rs m2 ->
+ (RTL.fn_entrypoint f) (init_regs args (fn_params f)) m1 t pc rs m2 ->
(RTL.fn_code f) ! pc = Some (Ireturn or) ->
vres = regmap_optget or Vundef rs ->
- exec_function_prop f args m vres (free m2 stk).
+ exec_function_prop (Internal f) args m t vres (free m2 stk).
Proof.
intros; red; intros until tf.
- unfold transf_function.
- caseEq (type_rtl_function f).
+ unfold transf_fundef, transf_function.
+ caseEq (type_function f).
intros env TRF.
caseEq (analyze f).
intros live ANL.
@@ -1704,7 +1792,7 @@ Proof.
set (tc1 := PTree.map (transf_instr f live alloc) (RTL.fn_code f)).
set (tc2 := transf_entrypoint f live alloc tc1).
intro EQ; injection EQ; intro TF; clear EQ. intro VARGS.
- generalize (type_rtl_function_correct _ _ TRF); intro WTF.
+ generalize (type_function_correct _ _ TRF); intro WTF.
assert (NEWINSTR: tc1!(RTL.fn_nextpc f) = None).
unfold tc1; rewrite PTree.gmap. unfold option_map.
elim (RTL.fn_code_wf f (fn_nextpc f)); intro.
@@ -1712,7 +1800,7 @@ Proof.
rewrite H4. auto.
pose (ls1 := call_regs ls).
assert (VARGS1: List.map ls1 (loc_parameters (RTL.fn_sig f)) = args).
- replace (RTL.fn_sig f) with (fn_sig tf).
+ replace (RTL.fn_sig f) with (funsig tf).
rewrite <- VARGS. unfold loc_parameters.
rewrite list_map_compose. apply list_map_exten.
intros. symmetry. unfold ls1. eapply call_regs_param_of_arg; eauto.
@@ -1732,9 +1820,9 @@ Proof.
intros [ls4 [EX4 RES4]].
exists ls4.
(* Execution *)
- split. apply exec_funct with m1.
- rewrite <- TF; simpl; assumption.
- rewrite <- TF; simpl. fold ls1.
+ split. rewrite <- TF; apply exec_funct_internal with m1; simpl.
+ assumption.
+ fold ls1.
eapply exec_blocks_trans. eexact EX2.
apply exec_blocks_extends with tc1.
intro p. unfold tc2. unfold transf_entrypoint.
@@ -1746,7 +1834,7 @@ Proof.
eapply exec_blocks_trans. eexact EX3.
eapply exec_blocks_one.
unfold tc1. rewrite PTree.gmap. rewrite H2. simpl. reflexivity.
- exact EX4.
+ eexact EX4. reflexivity. traceEq.
destruct or.
simpl in RES4. simpl in H3.
rewrite H3. rewrite <- TF; simpl. rewrite RES4.
@@ -1760,6 +1848,20 @@ Proof.
intros; discriminate.
Qed.
+Lemma transl_external_function_correct:
+ forall (ef : external_function) (args : list val) (m : mem)
+ (t: trace) (res: val),
+ event_match ef args t res ->
+ exec_function_prop (External ef) args m t res m.
+Proof.
+ intros; red; intros.
+ simpl in H0.
+ destruct (type_external_function ef); simplify_eq H0; intro.
+ exists (Locmap.set (R (loc_result (funsig tf))) res ls); split.
+ subst tf. eapply exec_funct_external; eauto.
+ apply Locmap.gss.
+Qed.
+
(** The correctness of the code transformation is obtained by
structural induction (and case analysis on the last rule used)
on the RTL evaluation derivation.
@@ -1767,14 +1869,10 @@ Qed.
[exec_instrs_prop] and [exec_function_prop] as the induction
hypotheses, and the lemmas above as cases for the induction. *)
-Scheme exec_instr_ind_3 := Minimality for RTL.exec_instr Sort Prop
- with exec_instrs_ind_3 := Minimality for RTL.exec_instrs Sort Prop
- with exec_function_ind_3 := Minimality for RTL.exec_function Sort Prop.
-
Theorem transl_function_correctness:
- forall f args m res m',
- RTL.exec_function ge f args m res m' ->
- exec_function_prop f args m res m'.
+ forall f args m t res m',
+ RTL.exec_function ge f args m t res m' ->
+ exec_function_prop f args m t res m'.
Proof
(exec_function_ind_3 ge
exec_instr_prop
@@ -1786,6 +1884,7 @@ Proof
transl_Iload_correct
transl_Istore_correct
transl_Icall_correct
+ transl_Ialloc_correct
transl_Icond_true_correct
transl_Icond_false_correct
@@ -1793,23 +1892,24 @@ Proof
transl_one_correct
transl_trans_correct
- transl_function_correct).
+ transl_function_correct
+ transl_external_function_correct).
(** The semantic equivalence between the original and transformed programs
follows easily. *)
Theorem transl_program_correct:
- forall (r: val),
- RTL.exec_program prog r -> LTL.exec_program tprog r.
+ forall (t: trace) (r: val),
+ RTL.exec_program prog t r -> LTL.exec_program tprog t r.
Proof.
- intros r [b [f [m [FIND1 [FIND2 [SIG EXEC]]]]]].
+ intros t r [b [f [m [FIND1 [FIND2 [SIG EXEC]]]]]].
generalize (function_ptr_translated _ _ FIND2).
intros [tf [TFIND TRF]].
- assert (SIG2: tf.(fn_sig) = mksignature nil (Some Tint)).
+ assert (SIG2: funsig tf = mksignature nil (Some Tint)).
rewrite <- SIG. apply sig_function_translated; auto.
- assert (VPARAMS: map (Locmap.init Vundef) (loc_arguments (fn_sig tf)) = nil).
+ assert (VPARAMS: map (Locmap.init Vundef) (loc_arguments (funsig tf)) = nil).
rewrite SIG2. reflexivity.
- generalize (transl_function_correctness _ _ _ _ _ EXEC
+ generalize (transl_function_correctness _ _ _ _ _ _ EXEC
(Locmap.init Vundef) tf TRF VPARAMS).
intros [ls' [TEXEC RES]].
red. exists b; exists tf; exists ls'; exists m.
diff --git a/backend/Allocproof_aux.v b/backend/Allocproof_aux.v
deleted file mode 100644
index d1b213e..0000000
--- a/backend/Allocproof_aux.v
+++ /dev/null
@@ -1,850 +0,0 @@
-(** Correctness results for the [parallel_move] function defined in
- file [Allocation].
-
- The present file, contributed by Laurence Rideau, glues the general
- results over the parallel move algorithm (see file [Parallelmove])
- with the correctness proof for register allocation (file [Allocproof]).
-*)
-
-Require Import Coqlib.
-Require Import Values.
-Require Import Parallelmove.
-Require Import Allocation.
-Require Import LTL.
-Require Import Locations.
-Require Import Conventions.
-
-Section parallel_move_correction.
-Variable ge : LTL.genv.
-Variable sp : val.
-Hypothesis
- add_move_correct :
- forall src dst k rs m,
- (exists rs' ,
- exec_instrs ge sp (add_move src dst k) rs m k rs' m /\
- (rs' dst = rs src /\
- (forall l,
- Loc.diff l dst ->
- Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> rs' l = rs l)) ).
-
-Lemma exec_instr_update:
- forall a1 a2 k e m,
- (exists rs' ,
- exec_instrs ge sp (add_move a1 a2 k) e m k rs' m /\
- (rs' a2 = update e a2 (e a1) a2 /\
- (forall l,
- Loc.diff l a2 ->
- Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> rs' l = (update e a2 (e a1)) l))
- ).
-Proof.
-intros; destruct (add_move_correct a1 a2 k e m) as [rs' [Hf [R1 R2]]].
-exists rs'; (repeat split); auto.
-generalize (get_update_id e a2); unfold get, Locmap.get; intros H; rewrite H;
- auto.
-intros l H0; generalize (get_update_diff e a2); unfold get, Locmap.get;
- intros H; rewrite H; auto.
-apply Loc.diff_sym; assumption.
-Qed.
-
-Lemma map_inv:
- forall (A B : Set) (f f' : A -> B) l,
- map f l = map f' l -> forall x, In x l -> f x = f' x.
-Proof.
-induction l; simpl; intros Hmap x Hin.
-elim Hin.
-inversion Hmap.
-elim Hin; intros H; [subst a | apply IHl]; auto.
-Qed.
-
-Fixpoint reswellFormed (p : Moves) : Prop :=
- match p with
- nil => True
- | (s, d) :: l => Loc.notin s (getdst l) /\ reswellFormed l
- end.
-
-Definition temporaries1 := R IT1 :: (R FT1 :: nil).
-
-Lemma no_overlap_list_pop:
- forall p m, no_overlap_list (m :: p) -> no_overlap_list p.
-Proof.
-induction p; unfold no_overlap_list, no_overlap; destruct m as [m1 m2]; simpl;
- auto.
-Qed.
-
-Lemma exec_instrs_pmov:
- forall p k rs m,
- no_overlap_list p ->
- Loc.disjoint (getdst p) temporaries1 ->
- Loc.disjoint (getsrc p) temporaries1 ->
- (exists rs' ,
- exec_instrs
- ge sp
- (fold_left
- (fun (k0 : block) => fun (p0 : loc * loc) => add_move (fst p0) (snd p0) k0)
- p k) rs m k rs' m /\
- (forall l,
- (forall r, In r (getdst p) -> r = l \/ Loc.diff r l) ->
- Loc.diff l (Locations.R IT1) ->
- Loc.diff l (Locations.R FT1) -> rs' l = (sexec p rs) l) ).
-Proof.
-induction p; intros k rs m.
-simpl; exists rs; (repeat split); auto; apply exec_refl.
-destruct a as [a1 a2]; simpl; intros Hno_O Hdisd Hdiss;
- elim (IHp (add_move a1 a2 k) rs m);
- [idtac | apply no_overlap_list_pop with (a1, a2) |
- apply (Loc.disjoint_cons_left a2) | apply (Loc.disjoint_cons_left a1)];
- (try assumption).
-intros rs' Hexec;
- destruct (add_move_correct a1 a2 k rs' m) as [rs'' [Hexec2 [R1 R2]]].
-exists rs''; elim Hexec; intros; (repeat split).
-apply exec_trans with ( b2 := add_move a1 a2 k ) ( rs2 := rs' ) ( m2 := m );
- auto.
-intros l Heqd Hdi Hdf; case (Loc.eq a2 l); intro.
-subst l; generalize get_update_id; unfold get, Locmap.get; intros Hgui;
- rewrite Hgui; rewrite R1.
-apply H0; auto.
-unfold no_overlap_list, no_overlap in Hno_O |-; simpl in Hno_O |-; intros;
- generalize (Hno_O a1).
-intros H8; elim H8 with ( s := r );
- [intros H9; left | intros H9; right; apply Loc.diff_sym | left | right]; auto.
-unfold Loc.disjoint in Hdiss |-; apply Hdiss; simpl; left; trivial.
-apply Hdiss; simpl; [left | right; left]; auto.
-elim (Heqd a2);
- [intros H7; absurd (a2 = l); auto | intros H7; auto | left; trivial].
-generalize get_update_diff; unfold get, Locmap.get; intros H6; rewrite H6; auto.
-rewrite R2; auto.
-apply Loc.diff_sym; auto.
-Qed.
-
-Definition p_move :=
- fun (l : list (loc * loc)) =>
- fun (k : block) =>
- fold_left
- (fun (k0 : block) => fun (p : loc * loc) => add_move (fst p) (snd p) k0)
- (P_move l) k.
-
-Lemma norepet_SD: forall p, Loc.norepet (getdst p) -> simpleDest p.
-Proof.
-induction p; (simpl; auto).
-destruct a as [a1 a2].
-intro; inversion H.
-split.
-apply notindst_nW; auto.
-apply IHp; auto.
-Qed.
-
-Theorem SDone_stepf:
- forall S1, StateDone (stepf S1) = nil -> StateDone S1 = nil.
-Proof.
-destruct S1 as [[t b] d]; destruct t.
-destruct b; auto.
-destruct m as [m1 m2]; simpl.
-destruct b.
-simpl; intro; discriminate.
-case (Loc.eq m2 (fst (last (m :: b)))); simpl; intros; discriminate.
-destruct m as [a1 a2]; simpl.
-destruct b.
-case (Loc.eq a1 a2); simpl; intros; auto.
-destruct m as [m1 m2]; case (Loc.eq a1 m2); intro; (try (simpl; auto; fail)).
-case (split_move t m2).
-(repeat destruct p); simpl; intros; auto.
-destruct b; (try (simpl; intro; discriminate)); auto.
-case (Loc.eq m2 (fst (last (m :: b)))); intro; simpl; intro; discriminate.
-Qed.
-
-Theorem SDone_Pmov: forall S1, StateDone (Pmov S1) = nil -> StateDone S1 = nil.
-Proof.
-intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)).
-clear S1; intros S1; intros Hrec.
-destruct S1 as [[t b] d].
-rewrite Pmov_equation.
-destruct t.
-destruct b; auto.
-intro; assert (StateDone (stepf (nil, m :: b, d)) = nil);
- [apply Hrec; auto; apply stepf1_dec | apply SDone_stepf]; auto.
-intro; assert (StateDone (stepf (m :: t, b, d)) = nil);
- [apply Hrec; auto; apply stepf1_dec | apply SDone_stepf]; auto.
-Qed.
-
-Lemma no_overlap_temp: forall r s, In s temporaries -> r = s \/ Loc.diff r s.
-Proof.
-intros r s H; case (Loc.eq r s); intros e; [left | right]; (try assumption).
-unfold Loc.diff; destruct r.
-destruct s; trivial.
-red; intro; elim e; rewrite H0; auto.
-destruct s0; destruct s; trivial;
- (elim H; [intros H1 | intros [H1|[H1|[H1|[H1|[H1|H1]]]]]]; (try discriminate);
- inversion H1).
-Qed.
-
-Lemma getsrcdst_app:
- forall l1 l2,
- getdst l1 ++ getdst l2 = getsrc l1 ++ getsrc l2 ->
- getdst l1 = getsrc l1 /\ getdst l2 = getsrc l2.
-Proof.
-induction l1; simpl; auto.
-destruct a as [a1 a2]; intros; inversion H.
-subst a1; inversion H;
- (elim IHl1 with ( l2 := l2 );
- [intros H0 H3; (try clear IHl1); (try exact H0) | idtac]; auto).
-rewrite H0; auto.
-Qed.
-
-Lemma In_norepet:
- forall r x l, Loc.norepet l -> In x l -> In r l -> r = x \/ Loc.diff r x.
-Proof.
-induction l; simpl; intros.
-elim H1.
-inversion H.
-subst hd.
-elim H1; intros H2; clear H1; elim H0; intros H1.
-rewrite <- H1; rewrite <- H2; auto.
-subst a; right; apply Loc.in_notin_diff with l; auto.
-subst a; right; apply Loc.diff_sym; apply Loc.in_notin_diff with l; auto.
-apply IHl; auto.
-Qed.
-
-Definition no_overlap_stateD (S : State) :=
- no_overlap
- (getsrc (StateToMove S ++ (StateBeing S ++ StateDone S)))
- (getdst (StateToMove S ++ (StateBeing S ++ StateDone S))).
-
-Ltac
-incl_tac_rec :=
-(auto with datatypes; fail)
- ||
- (apply in_cons; incl_tac_rec)
- ||
- (apply in_or_app; left; incl_tac_rec)
- ||
- (apply in_or_app; right; incl_tac_rec)
- ||
- (apply incl_appl; incl_tac_rec) ||
- (apply incl_appr; incl_tac_rec) || (apply incl_tl; incl_tac_rec).
-
-Ltac incl_tac := (repeat (apply incl_cons || apply incl_app)); incl_tac_rec.
-
-Ltac
-in_tac :=
-match goal with
-| |- In ?x ?L1 =>
-match goal with
-| H:In x ?L2 |- _ =>
-let H1 := fresh "H" in
-(assert (H1: incl L2 L1); [incl_tac | apply (H1 x)]); auto; fail
-| _ => fail end end.
-
-Lemma in_cons_noteq:
- forall (A : Set) (a b : A) (l : list A), In a (b :: l) -> a <> b -> In a l.
-Proof.
-intros A a b l; simpl; intros.
-elim H; intros H1; (try assumption).
-absurd (a = b); auto.
-Qed.
-
-Lemma no_overlapD_inv:
- forall S1 S2, step S1 S2 -> no_overlap_stateD S1 -> no_overlap_stateD S2.
-Proof.
-intros S1 S2 STEP; inversion STEP; unfold no_overlap_stateD, no_overlap; simpl;
- auto; (repeat (rewrite getsrc_app; rewrite getdst_app; simpl)); intros.
-apply H1; in_tac.
-destruct m as [m1 m2]; apply H1; in_tac.
-apply H1; in_tac.
-case (Loc.eq r (T r0)); intros e.
-elim (no_overlap_temp s0 r);
- [intro; left; auto | intro; right; apply Loc.diff_sym; auto | unfold T in e |-].
-destruct (Loc.type r0); simpl; [right; left | right; right; right; right; left];
- auto.
-case (Loc.eq s0 (T r0)); intros es.
-apply (no_overlap_temp r s0); unfold T in es |-; destruct (Loc.type r0); simpl;
- [right; left | right; right; right; right; left]; auto.
-apply H1; apply in_cons_noteq with ( b := T r0 ); auto; in_tac.
-apply H3; in_tac.
-Qed.
-
-Lemma no_overlapD_invpp:
- forall S1 S2, stepp S1 S2 -> no_overlap_stateD S1 -> no_overlap_stateD S2.
-Proof.
-intros; induction H as [r|r1 r2 r3 H H1 HrecH]; auto.
-apply HrecH; auto.
-apply no_overlapD_inv with r1; auto.
-Qed.
-
-Lemma no_overlapD_invf:
- forall S1, stepInv S1 -> no_overlap_stateD S1 -> no_overlap_stateD (stepf S1).
-Proof.
-intros; destruct S1 as [[t1 b1] d1].
-destruct t1; destruct b1; auto.
-set (S1:=(nil (A:=Move), m :: b1, d1)).
-apply (no_overlapD_invpp S1); [apply dstep_step; auto | assumption].
-apply f2ind; [unfold S1 | idtac | idtac]; auto.
-generalize H0; clear H0; unfold no_overlap_stateD; destruct m as [m1 m2].
-intros; apply no_overlap_noOverlap.
-unfold no_overlap_state; simpl.
-generalize H0; clear H0; unfold no_overlap; (repeat rewrite getdst_app);
- (repeat rewrite getsrc_app); simpl; intros.
-apply H0.
-elim H1; intros H4; [left; assumption | right; in_tac].
-elim H2; intros H4; [left; assumption | right; in_tac].
-set (S1:=(m :: t1, nil (A:=Move), d1)).
-apply (no_overlapD_invpp S1); [apply dstep_step; auto | assumption].
-apply f2ind; [unfold S1 | idtac | idtac]; auto.
-generalize H0; clear H0; unfold no_overlap_stateD; destruct m as [m1 m2].
-intros; apply no_overlap_noOverlap.
-unfold no_overlap_state; simpl.
-generalize H0; clear H0; unfold no_overlap; (repeat rewrite getdst_app);
- (repeat rewrite getsrc_app); simpl; (repeat rewrite app_nil); intros.
-apply H0.
-elim H1; intros H4; [left; assumption | right; (try in_tac)].
-elim H2; intros H4; [left; assumption | right; in_tac].
-set (S1:=(m :: t1, m0 :: b1, d1)).
-apply (no_overlapD_invpp S1); [apply dstep_step; auto | assumption].
-apply f2ind; [unfold S1 | idtac | idtac]; auto.
-generalize H0; clear H0; unfold no_overlap_stateD; destruct m as [m1 m2].
-intros; apply no_overlap_noOverlap.
-unfold no_overlap_state; simpl.
-generalize H0; clear H0; unfold no_overlap; (repeat rewrite getdst_app);
- (repeat rewrite getsrc_app); destruct m0; simpl; intros.
-apply H0.
-elim H1; intros H4; [left; assumption | right; in_tac].
-elim H2; intros H4; [left; assumption | right; in_tac].
-Qed.
-
-Lemma no_overlapD_res:
- forall S1, stepInv S1 -> no_overlap_stateD S1 -> no_overlap_stateD (Pmov S1).
-Proof.
-intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)).
-clear S1; intros S1 Hrec.
-destruct S1 as [[t b] d].
-rewrite Pmov_equation.
-destruct t; auto.
-destruct b; auto.
-intros; apply Hrec.
-apply stepf1_dec; auto.
-apply (dstep_inv (nil, m :: b, d)); auto.
-apply f2ind'; auto.
-apply no_overlap_noOverlap.
-generalize H0; unfold no_overlap_stateD, no_overlap_state, no_overlap; simpl.
-destruct m; (repeat rewrite getdst_app); (repeat rewrite getsrc_app).
-intros H1 r1 H2 s H3; (try assumption).
-apply H1; in_tac.
-apply no_overlapD_invf; auto.
-intros; apply Hrec.
-apply stepf1_dec; auto.
-apply (dstep_inv (m :: t, b, d)); auto.
-apply f2ind'; auto.
-apply no_overlap_noOverlap.
-generalize H0; destruct m;
- unfold no_overlap_stateD, no_overlap_state, no_overlap; simpl;
- (repeat (rewrite getdst_app; simpl)); (repeat (rewrite getsrc_app; simpl)).
-simpl; intros H1 r1 H2 s H3; (try assumption).
-apply H1.
-elim H2; intros H4; [left; (try assumption) | right; in_tac].
-elim H3; intros H4; [left; (try assumption) | right; in_tac].
-apply no_overlapD_invf; auto.
-Qed.
-
-Definition temporaries1_3 := R IT1 :: (R FT1 :: (R IT3 :: nil)).
-
-Definition temporaries2 := R IT2 :: (R FT2 :: nil).
-
-Definition no_tmp13_state (S1 : State) :=
- Loc.disjoint (getsrc (StateDone S1)) temporaries1_3 /\
- Loc.disjoint (getdst (StateDone S1)) temporaries1_3.
-
-Definition Done_well_formed (S1 S2 : State) :=
- forall x,
- (In x (getsrc (StateDone S2)) ->
- In x temporaries2 \/ In x (getsrc (StateToMove S1 ++ StateBeing S1))) /\
- (In x (getdst (StateDone S2)) ->
- In x temporaries2 \/ In x (getdst (StateToMove S1 ++ StateBeing S1))).
-
-Lemma Done_notmp3_inv:
- forall S1 S2,
- step S1 S2 ->
- (forall x,
- In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) ->
- Loc.diff x (R IT3)) ->
- forall x,
- In x (getdst (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) ->
- Loc.diff x (R IT3).
-Proof.
-intros S1 S2 STEP; inversion STEP; (try (simpl; trivial; fail));
- simpl StateDone; simpl StateToMove; simpl StateBeing; simpl getdst;
- (repeat (rewrite getdst_app; simpl)); intros.
-apply H1; in_tac.
-destruct m; apply H1; in_tac.
-apply H1; in_tac.
-case (Loc.eq x (T r0)); intros e.
-unfold T in e |-; destruct (Loc.type r0); rewrite e; simpl; red; intro;
- discriminate.
-apply H1; apply in_cons_noteq with ( b := T r0 ); auto; in_tac.
-apply H3; in_tac.
-Qed.
-
-Lemma Done_notmp3_invpp:
- forall S1 S2,
- stepp S1 S2 ->
- (forall x,
- In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) ->
- Loc.diff x (R IT3)) ->
- forall x,
- In x (getdst (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) ->
- Loc.diff x (R IT3).
-Proof.
-intros S1 S2 H H0; (try assumption).
-induction H as [r|r1 r2 r3 H1 H2 Hrec]; auto.
-apply Hrec; auto.
-apply Done_notmp3_inv with r1; auto.
-Qed.
-
-Lemma Done_notmp3_invf:
- forall S1,
- stepInv S1 ->
- (forall x,
- In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) ->
- Loc.diff x (R IT3)) ->
- forall x,
- In
- x
- (getdst
- (StateToMove (stepf S1) ++ (StateBeing (stepf S1) ++ StateDone (stepf S1)))) ->
- Loc.diff x (R IT3).
-Proof.
-intros S1 H H0; (try assumption).
-generalize H; unfold stepInv; intros [Hpath [HSD [HnoO [Hnotmp HnotmpL]]]].
-destruct S1 as [[t1 b1] d1]; set (S1:=(t1, b1, d1)); destruct t1; destruct b1;
- auto; apply (Done_notmp3_invpp S1); auto; apply dstep_step; auto; apply f2ind;
- unfold S1; auto.
-Qed.
-
-Lemma Done_notmp3_res:
- forall S1,
- stepInv S1 ->
- (forall x,
- In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) ->
- Loc.diff x (R IT3)) ->
- forall x,
- In
- x
- (getdst
- (StateToMove (Pmov S1) ++ (StateBeing (Pmov S1) ++ StateDone (Pmov S1)))) ->
- Loc.diff x (R IT3).
-Proof.
-intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)).
-clear S1; intros S1 Hrec.
-destruct S1 as [[t b] d]; set (S1:=(t, b, d)).
-unfold S1; rewrite Pmov_equation.
-intros H; generalize H; intros [Hpath [HSD [HnoO [Htmp HtmpL]]]].
-destruct t; [destruct b; auto | idtac];
- (intro; apply Hrec;
- [apply stepf1_dec | apply (dstep_inv S1); auto; apply f2ind'
- | apply Done_notmp3_invf]; auto).
-Qed.
-
-Lemma Done_notmp1_inv:
- forall S1 S2,
- step S1 S2 ->
- (forall x,
- In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) ->
- forall x,
- In x (getdst (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1).
-Proof.
-intros S1 S2 STEP; inversion STEP; (try (simpl; trivial; fail));
- (repeat (rewrite getdst_app; simpl)); intros.
-apply H1; in_tac.
-destruct m; apply H1; in_tac.
-apply H1; in_tac.
-case (Loc.eq x (T r0)); intro.
-rewrite e; unfold T; case (Loc.type r0); simpl; split; red; intro; discriminate.
-apply H1; apply in_cons_noteq with ( b := T r0 ); (try assumption); in_tac.
-apply H3; in_tac.
-Qed.
-
-Lemma Done_notmp1_invpp:
- forall S1 S2,
- stepp S1 S2 ->
- (forall x,
- In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) ->
- forall x,
- In x (getdst (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1).
-Proof.
-intros S1 S2 H H0; (try assumption).
-induction H as [r|r1 r2 r3 H1 H2 Hrec]; auto.
-apply Hrec; auto.
-apply Done_notmp1_inv with r1; auto.
-Qed.
-
-Lemma Done_notmp1_invf:
- forall S1,
- stepInv S1 ->
- (forall x,
- In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) ->
- forall x,
- In
- x
- (getdst
- (StateToMove (stepf S1) ++ (StateBeing (stepf S1) ++ StateDone (stepf S1)))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1).
-Proof.
-intros S1 H H0; (try assumption).
-generalize H; unfold stepInv; intros [Hpath [HSD [HnoO [Hnotmp HnotmpL]]]].
-destruct S1 as [[t1 b1] d1]; set (S1:=(t1, b1, d1)); destruct t1; destruct b1;
- auto; apply (Done_notmp1_invpp S1); auto; apply dstep_step; auto; apply f2ind;
- unfold S1; auto.
-Qed.
-
-Lemma Done_notmp1_res:
- forall S1,
- stepInv S1 ->
- (forall x,
- In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) ->
- forall x,
- In
- x
- (getdst
- (StateToMove (Pmov S1) ++ (StateBeing (Pmov S1) ++ StateDone (Pmov S1)))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1).
-Proof.
-intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)).
-clear S1; intros S1 Hrec.
-destruct S1 as [[t b] d]; set (S1:=(t, b, d)).
-intros H; generalize H; intros [Hpath [HSD [HnoO [Htmp HtmpL]]]].
-unfold S1; rewrite Pmov_equation.
-destruct t; [destruct b; auto | idtac];
- (intro; apply Hrec;
- [apply stepf1_dec | apply (dstep_inv S1); auto; apply f2ind'
- | apply Done_notmp1_invf]; auto).
-Qed.
-
-Lemma Done_notmp1src_inv:
- forall S1 S2,
- step S1 S2 ->
- (forall x,
- In x (getsrc (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) ->
- forall x,
- In x (getsrc (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1).
-Proof.
-intros S1 S2 STEP; inversion STEP; (try (simpl; trivial; fail));
- (repeat (rewrite getsrc_app; simpl)); intros.
-apply H1; in_tac.
-destruct m; apply H1; in_tac.
-apply H1; in_tac.
-case (Loc.eq x (T r0)); intro.
-rewrite e; unfold T; case (Loc.type r0); simpl; split; red; intro; discriminate.
-apply H1; apply in_cons_noteq with ( b := T r0 ); (try assumption); in_tac.
-apply H3; in_tac.
-Qed.
-
-Lemma Done_notmp1src_invpp:
- forall S1 S2,
- stepp S1 S2 ->
- (forall x,
- In x (getsrc (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) ->
- forall x,
- In x (getsrc (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1).
-Proof.
-intros S1 S2 H H0; (try assumption).
-induction H as [r|r1 r2 r3 H1 H2 Hrec]; auto.
-apply Hrec; auto.
-apply Done_notmp1src_inv with r1; auto.
-Qed.
-
-Lemma Done_notmp1src_invf:
- forall S1,
- stepInv S1 ->
- (forall x,
- In x (getsrc (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) ->
- forall x,
- In
- x
- (getsrc
- (StateToMove (stepf S1) ++ (StateBeing (stepf S1) ++ StateDone (stepf S1)))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1).
-Proof.
-intros S1 H H0.
-generalize H; unfold stepInv; intros [Hpath [HSD [HnoO [Hnotmp HnotmpL]]]].
-destruct S1 as [[t1 b1] d1]; set (S1:=(t1, b1, d1)); destruct t1; destruct b1;
- auto; apply (Done_notmp1src_invpp S1); auto; apply dstep_step; auto;
- apply f2ind; unfold S1; auto.
-Qed.
-
-Lemma Done_notmp1src_res:
- forall S1,
- stepInv S1 ->
- (forall x,
- In x (getsrc (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) ->
- forall x,
- In
- x
- (getsrc
- (StateToMove (Pmov S1) ++ (StateBeing (Pmov S1) ++ StateDone (Pmov S1)))) ->
- Loc.diff x (R IT1) /\ Loc.diff x (R FT1).
-Proof.
-intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)).
-clear S1; intros S1 Hrec.
-destruct S1 as [[t b] d]; set (S1:=(t, b, d)).
-intros H; generalize H; intros [Hpath [HSD [HnoO [Htmp HtmpL]]]].
-unfold S1; rewrite Pmov_equation.
-destruct t; [destruct b; auto | idtac];
- (intro; apply Hrec;
- [apply stepf1_dec | apply (dstep_inv S1); auto; apply f2ind'
- | apply Done_notmp1src_invf]; auto).
-Qed.
-
-Lemma dst_tmp2_step:
- forall S1 S2,
- step S1 S2 ->
- forall x,
- In x (getdst (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) ->
- In x temporaries2 \/
- In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))).
-Proof.
-intros S1 S2 STEP; inversion STEP; (repeat (rewrite getdst_app; simpl)); intros;
- (try (right; in_tac)).
-destruct m; right; in_tac.
-case (Loc.eq x (T r0)); intro.
-rewrite e; unfold T; case (Loc.type r0); left; [left | right; left]; trivial.
-right; apply in_cons_noteq with ( b := T r0 ); auto; in_tac.
-Qed.
-
-Lemma dst_tmp2_stepp:
- forall S1 S2,
- stepp S1 S2 ->
- forall x,
- In x (getdst (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) ->
- In x temporaries2 \/
- In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))).
-Proof.
-intros S1 S2 H.
-induction H as [r|r1 r2 r3 H1 H2 Hrec]; auto.
-intros.
-elim Hrec with ( x := x );
- [intros H0; (try clear Hrec); (try exact H0) | intros H0; (try clear Hrec)
- | try clear Hrec]; auto.
-generalize (dst_tmp2_step r1 r2); auto.
-Qed.
-
-Lemma dst_tmp2_stepf:
- forall S1,
- stepInv S1 ->
- forall x,
- In
- x
- (getdst
- (StateToMove (stepf S1) ++ (StateBeing (stepf S1) ++ StateDone (stepf S1)))) ->
- In x temporaries2 \/
- In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))).
-Proof.
-intros S1 H H0.
-generalize H; unfold stepInv; intros [Hpath [HSD [HnoO [Hnotmp HnotmpL]]]].
-destruct S1 as [[t1 b1] d1]; set (S1:=(t1, b1, d1)); destruct t1; destruct b1;
- auto; apply (dst_tmp2_stepp S1); auto; apply dstep_step; auto; apply f2ind;
- unfold S1; auto.
-Qed.
-
-Lemma dst_tmp2_res:
- forall S1,
- stepInv S1 ->
- forall x,
- In
- x
- (getdst
- (StateToMove (Pmov S1) ++ (StateBeing (Pmov S1) ++ StateDone (Pmov S1)))) ->
- In x temporaries2 \/
- In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))).
-Proof.
-intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)).
-clear S1; intros S1 Hrec.
-destruct S1 as [[t b] d]; set (S1:=(t, b, d)).
-intros H; generalize H; intros [Hpath [HSD [HnoO [Htmp HtmpL]]]].
-unfold S1; rewrite Pmov_equation; intros.
-destruct t; auto.
-destruct b; auto.
-elim Hrec with ( y := stepf S1 ) ( x := x );
- [intros H1 | intros H1 | try clear Hrec | try clear Hrec | try assumption].
-left; (try assumption).
-apply dst_tmp2_stepf; auto.
-apply stepf1_dec; auto.
-apply (dstep_inv S1); auto; unfold S1; apply f2ind'; auto.
-elim Hrec with ( y := stepf S1 ) ( x := x );
- [intro; left; (try assumption) | intros H1; apply dst_tmp2_stepf; auto |
- apply stepf1_dec; auto |
- apply (dstep_inv S1); auto; unfold S1; apply f2ind'; auto | try assumption].
-Qed.
-
-Lemma getdst_lists2moves:
- forall srcs dsts,
- length srcs = length dsts ->
- getsrc (listsLoc2Moves srcs dsts) = srcs /\
- getdst (listsLoc2Moves srcs dsts) = dsts.
-Proof.
-induction srcs; intros dsts; destruct dsts; simpl; auto; intro;
- (try discriminate).
-inversion H.
-elim IHsrcs with ( dsts := dsts ); auto; intros.
-rewrite H2; rewrite H0; auto.
-Qed.
-
-Lemma stepInv_pnilnil:
- forall p,
- simpleDest p ->
- Loc.disjoint (getsrc p) temporaries ->
- Loc.disjoint (getdst p) temporaries ->
- no_overlap_list p -> stepInv (p, nil, nil).
-Proof.
-unfold stepInv; simpl; (repeat split); auto.
-rewrite app_nil; auto.
-generalize (no_overlap_noOverlap (p, nil, nil)).
-simpl; (intros H3; apply H3).
-generalize H2; unfold no_overlap_state, no_overlap_list; simpl; intro.
-rewrite app_nil; auto.
-apply disjoint_tmp__noTmp; auto.
-Qed.
-
-Lemma noO_list_pnilnil:
- forall (p : Moves),
- simpleDest p ->
- Loc.disjoint (getsrc p) temporaries ->
- Loc.disjoint (getdst p) temporaries ->
- no_overlap_list p -> no_overlap_list (StateDone (Pmov (p, nil, nil))).
-Proof.
-intros; generalize (no_overlapD_res (p, nil, nil));
- unfold no_overlap_stateD, no_overlap_list.
-rewrite STM_Pmov; rewrite SB_Pmov; simpl; rewrite app_nil; intro.
-apply H3; auto.
-apply stepInv_pnilnil; auto.
-Qed.
-
-Lemma dis_srctmp1_pnilnil:
- forall (p : Moves),
- simpleDest p ->
- Loc.disjoint (getsrc p) temporaries ->
- Loc.disjoint (getdst p) temporaries ->
- no_overlap_list p ->
- Loc.disjoint (getsrc (StateDone (Pmov (p, nil, nil)))) temporaries1.
-Proof.
-intros; generalize (Done_notmp1src_res (p, nil, nil)); simpl.
-rewrite STM_Pmov; rewrite SB_Pmov; simpl; rewrite app_nil; intro.
-unfold temporaries1.
-apply Loc.notin_disjoint; auto.
-simpl; intros.
-assert (HsI: stepInv (p, nil, nil)); (try apply stepInv_pnilnil); auto.
-elim H3 with x; (try assumption).
-intros; (repeat split); auto.
-intros; split;
- (apply Loc.in_notin_diff with ( ll := temporaries );
- [apply Loc.disjoint_notin with (getsrc p) | simpl]; auto).
-Qed.
-
-Lemma dis_dsttmp1_pnilnil:
- forall (p : Moves),
- simpleDest p ->
- Loc.disjoint (getsrc p) temporaries ->
- Loc.disjoint (getdst p) temporaries ->
- no_overlap_list p ->
- Loc.disjoint (getdst (StateDone (Pmov (p, nil, nil)))) temporaries1.
-Proof.
-intros; generalize (Done_notmp1_res (p, nil, nil)); simpl.
-rewrite STM_Pmov; rewrite SB_Pmov; simpl; rewrite app_nil; intro.
-unfold temporaries1.
-apply Loc.notin_disjoint; auto.
-simpl; intros.
-assert (HsI: stepInv (p, nil, nil)); (try apply stepInv_pnilnil); auto.
-elim H3 with x; (try assumption).
-intros; (repeat split); auto.
-intros; split;
- (apply Loc.in_notin_diff with ( ll := temporaries );
- [apply Loc.disjoint_notin with (getdst p) | simpl]; auto).
-Qed.
-
-Lemma parallel_move_correct':
- forall p k rs m,
- Loc.norepet (getdst p) ->
- no_overlap_list p ->
- Loc.disjoint (getsrc p) temporaries ->
- Loc.disjoint (getdst p) temporaries ->
- (exists rs' ,
- exec_instrs ge sp (p_move p k) rs m k rs' m /\
- (List.map rs' (getdst p) = List.map rs (getsrc p) /\
- (rs' (R IT3) = rs (R IT3) /\
- (forall l,
- Loc.notin l (getdst p) -> Loc.notin l temporaries -> rs' l = rs l)))
- ).
-Proof.
-unfold p_move, P_move.
-intros p k rs m Hnorepet HnoOverlap Hdisjointsrc Hdisjointdst.
-assert (HsD: simpleDest p); (try (apply norepet_SD; assumption)).
-assert (HsI: stepInv (p, nil, nil)); (try (apply stepInv_pnilnil; assumption)).
-generalize HsI; unfold stepInv; simpl StateToMove; simpl StateBeing;
- (repeat rewrite app_nil); intros [_ [_ [HnoO [Hnotmp _]]]].
-elim (exec_instrs_pmov (StateDone (Pmov (p, nil, nil))) k rs m); auto;
- (try apply noO_list_pnilnil); (try apply dis_dsttmp1_pnilnil);
- (try apply dis_srctmp1_pnilnil); auto.
-intros rs' [Hexec R]; exists rs'; (repeat split); auto.
-rewrite <- (Fpmov_correct_map p rs); auto.
-apply list_map_exten; intros; rewrite <- R; auto;
- (try
- (apply Loc.in_notin_diff with ( ll := temporaries );
- [apply Loc.disjoint_notin with (getdst p) | simpl]; auto)).
-generalize (dst_tmp2_res (p, nil, nil)); intros.
-elim H0 with ( x := r );
- [intros H2; right |
- simpl; rewrite app_nil; intros H2; apply In_norepet with (getdst p); auto |
- try assumption | rewrite STM_Pmov; rewrite SB_Pmov; auto].
-apply Loc.diff_sym; apply Loc.in_notin_diff with ( ll := temporaries );
- (try assumption).
-apply Loc.disjoint_notin with (getdst p); auto.
-generalize H2; unfold temporaries, temporaries2; intros; in_tac.
-rewrite <- (Fpmov_correct_IT3 p rs); auto; rewrite <- R;
- (try (simpl; intro; discriminate)); auto.
-intros r H; right; apply (Done_notmp3_res (p, nil, nil)); auto;
- (try (rewrite STM_Pmov; rewrite SB_Pmov; auto)).
-simpl; rewrite app_nil; intros; apply Loc.in_notin_diff with temporaries; auto.
-apply Loc.disjoint_notin with (getdst p); auto.
-simpl; right; right; left; trivial.
-intros; rewrite <- (Fpmov_correct_ext p rs); auto; rewrite <- R; auto;
- (try (apply Loc.in_notin_diff with temporaries; simpl; auto)).
-intros r H1; right; generalize (dst_tmp2_res (p, nil, nil)); intros.
-elim H2 with ( x := r );
- [intros H3 | simpl; rewrite app_nil; intros H3 | assumption
- | rewrite STM_Pmov; rewrite SB_Pmov; auto].
-apply Loc.diff_sym; apply Loc.in_notin_diff with temporaries; auto.
-generalize H3; unfold temporaries, temporaries2; intros; in_tac.
-apply Loc.diff_sym; apply Loc.in_notin_diff with ( ll := getdst p ); auto.
-Qed.
-
-Lemma parallel_move_correctX:
- forall srcs dsts k rs m,
- List.length srcs = List.length dsts ->
- no_overlap srcs dsts ->
- Loc.norepet dsts ->
- Loc.disjoint srcs temporaries ->
- Loc.disjoint dsts temporaries ->
- (exists rs' ,
- exec_instrs ge sp (parallel_move srcs dsts k) rs m k rs' m /\
- (List.map rs' dsts = List.map rs srcs /\
- (rs' (R IT3) = rs (R IT3) /\
- (forall l, Loc.notin l dsts -> Loc.notin l temporaries -> rs' l = rs l))) ).
-Proof.
-intros; unfold parallel_move, parallel_move_order;
- generalize (parallel_move_correct' (listsLoc2Moves srcs dsts) k rs m).
-elim (getdst_lists2moves srcs dsts); auto.
-intros heq1 heq2; rewrite heq1; rewrite heq2; unfold p_move.
-intros H4; apply H4; auto.
-unfold no_overlap_list; rewrite heq1; rewrite heq2; auto.
-Qed.
-
-End parallel_move_correction.
diff --git a/backend/Alloctyping.v b/backend/Alloctyping.v
index 39e53ee..e4f9f96 100644
--- a/backend/Alloctyping.v
+++ b/backend/Alloctyping.v
@@ -15,7 +15,7 @@ Require Import Allocproof.
Require Import RTLtyping.
Require Import LTLtyping.
Require Import Conventions.
-Require Import Alloctyping_aux.
+Require Import Parallelmove.
(** This file proves that register allocation (the translation from
RTL to LTL defined in file [Allocation]) preserves typing:
@@ -30,13 +30,13 @@ Variable live: PMap.t Regset.t.
Variable alloc: reg -> loc.
Variable tf: LTL.function.
-Hypothesis TYPE_RTL: type_rtl_function f = Some env.
+Hypothesis TYPE_RTL: type_function f = Some env.
Hypothesis ALLOC: regalloc f live (live0 f live) env = Some alloc.
Hypothesis TRANSL: transf_function f = Some tf.
-Lemma wt_rtl_function: RTLtyping.wt_function env f.
+Lemma wt_rtl_function: RTLtyping.wt_function f env.
Proof.
- apply type_rtl_function_correct; auto.
+ apply type_function_correct; auto.
Qed.
Lemma alloc_type: forall r, Loc.type (alloc r) = env r.
@@ -213,15 +213,34 @@ Proof.
auto.
Qed.
+Lemma wt_add_moves:
+ forall b moves,
+ (forall s d, In (s, d) moves ->
+ loc_read_ok s /\ loc_write_ok d /\ Loc.type s = Loc.type d) ->
+ wt_block tf b ->
+ wt_block tf
+ (List.fold_right (fun p k => add_move (fst p) (snd p) k) b moves).
+Proof.
+ induction moves; simpl; intros.
+ auto.
+ destruct a as [s d]. simpl.
+ elim (H s d). intros A [B C]. apply wt_add_move; auto. auto.
+Qed.
+
Theorem wt_parallel_move:
forall srcs dsts b,
List.map Loc.type srcs = List.map Loc.type dsts ->
locs_read_ok srcs ->
locs_write_ok dsts -> wt_block tf b -> wt_block tf (parallel_move srcs dsts b).
Proof.
- unfold locs_read_ok, locs_write_ok.
- apply wt_parallel_moveX; simpl; auto.
- exact wt_add_move.
+ intros. unfold parallel_move. apply wt_add_moves; auto.
+ intros.
+ elim (parmove_prop_2 _ _ _ _ H3); intros A B.
+ split. destruct A as [C|[C|C]].
+ apply H0; auto. subst s; exact I. subst s; exact I.
+ split. destruct B as [C|[C|C]].
+ apply H1; auto. subst d; exact I. subst d; exact I.
+ eapply parmove_prop_3; eauto.
Qed.
Lemma wt_add_op_move:
@@ -340,6 +359,18 @@ Proof.
rewrite loc_result_type. auto. constructor.
Qed.
+Lemma wt_add_alloc:
+ forall arg res s,
+ Loc.type arg = Tint -> Loc.type res = Tint ->
+ loc_read_ok arg -> loc_write_ok res ->
+ wt_block tf (add_alloc arg res s).
+Proof.
+ intros.
+ unfold add_alloc. apply wt_add_reload. auto. rewrite H; reflexivity.
+ apply wt_Balloc. apply wt_add_spill. auto. rewrite H0; reflexivity.
+ apply wt_Bgoto.
+Qed.
+
Lemma wt_add_cond:
forall cond args ifso ifnot,
List.map Loc.type args = type_of_condition cond ->
@@ -387,7 +418,10 @@ Lemma wt_add_entry:
Proof.
set (sig := RTL.fn_sig f).
assert (sig = tf.(fn_sig)).
- unfold sig. symmetry. apply Allocproof.sig_function_translated. auto.
+ unfold sig.
+ assert (transf_fundef (Internal f) = Some (Internal tf)).
+ unfold transf_fundef; rewrite TRANSL; auto.
+ generalize (Allocproof.sig_function_translated _ _ H). simpl; auto.
assert (locs_read_ok (loc_parameters sig)).
red; unfold loc_parameters. intros.
generalize (list_in_map_inv _ _ _ H0). intros [l1 [EQ IN]].
@@ -406,7 +440,7 @@ Qed.
Lemma wt_transf_instr:
forall pc instr,
- RTLtyping.wt_instr env f instr ->
+ RTLtyping.wt_instr env f.(RTL.fn_sig) instr ->
wt_block tf (transf_instr f live alloc pc instr).
Proof.
intros. inversion H; simpl.
@@ -441,6 +475,9 @@ Proof.
auto with allocty.
destruct ros; simpl; auto with allocty.
auto with allocty.
+ (* alloc *)
+ apply wt_add_alloc; auto with allocty.
+ rewrite alloc_type; auto. rewrite alloc_type; auto.
(* cond *)
apply wt_add_cond. rewrite alloc_types; auto. auto with allocty.
(* return *)
@@ -483,7 +520,7 @@ Lemma wt_transf_function:
transf_function f = Some tf -> wt_function tf.
Proof.
intros. generalize H; unfold transf_function.
- caseEq (type_rtl_function f). intros env TYP.
+ caseEq (type_function f). intros env TYP.
caseEq (analyze f). intros live ANL.
change (transfer f (RTL.fn_entrypoint f)
live!!(RTL.fn_entrypoint f))
@@ -497,13 +534,26 @@ Proof.
intros; discriminate.
Qed.
+Lemma wt_transf_fundef:
+ forall f tf,
+ transf_fundef f = Some tf -> wt_fundef tf.
+Proof.
+ intros until tf; destruct f; simpl.
+ caseEq (transf_function f). intros g TF EQ. inversion EQ.
+ constructor. eapply wt_transf_function; eauto.
+ congruence.
+ caseEq (type_external_function e); intros.
+ inversion H0. constructor. apply type_external_function_correct. auto.
+ congruence.
+Qed.
+
Lemma program_typing_preserved:
forall (p: RTL.program) (tp: LTL.program),
transf_program p = Some tp ->
LTLtyping.wt_program tp.
Proof.
intros; red; intros.
- generalize (transform_partial_program_function transf_function p i f H H0).
+ generalize (transform_partial_program_function transf_fundef p i f H H0).
intros [f0 [IN TRANSF]].
- apply wt_transf_function with f0; auto.
+ apply wt_transf_fundef with f0; auto.
Qed.
diff --git a/backend/Alloctyping_aux.v b/backend/Alloctyping_aux.v
deleted file mode 100644
index 0013c24..0000000
--- a/backend/Alloctyping_aux.v
+++ /dev/null
@@ -1,895 +0,0 @@
-(** Type preservation for parallel move compilation. *)
-
-(** This file, contributed by Laurence Rideau, shows that the parallel
- move compilation algorithm (file [Parallelmove]) generates a well-typed
- sequence of LTL instructions, provided the original problem is well-typed:
- the types of source and destination locations match pairwise. *)
-
-Require Import Coqlib.
-Require Import Locations.
-Require Import LTL.
-Require Import Allocation.
-Require Import LTLtyping.
-Require Import Allocproof_aux.
-Require Import Parallelmove.
-Require Import Inclusion.
-
-Section wt_move_correction.
-Variable tf : LTL.function.
-Variable loc_read_ok : loc -> Prop.
-Hypothesis loc_read_ok_R : forall r, loc_read_ok (R r).
-Variable loc_write_ok : loc -> Prop.
-Hypothesis loc_write_ok_R : forall r, loc_write_ok (R r).
-
-Let locs_read_ok (ll : list loc) : Prop :=
- forall l, In l ll -> loc_read_ok l.
-
-Let locs_write_ok (ll : list loc) : Prop :=
- forall l, In l ll -> loc_write_ok l.
-
-Hypothesis
- wt_add_move :
- forall (src dst : loc) (b : LTL.block),
- loc_read_ok src ->
- loc_write_ok dst ->
- Loc.type src = Loc.type dst ->
- wt_block tf b -> wt_block tf (add_move src dst b).
-
-Lemma in_move__in_srcdst:
- forall m p, In m p -> In (fst m) (getsrc p) /\ In (snd m) (getdst p).
-Proof.
-intros; induction p.
-inversion H.
-destruct a as [a1 a2]; destruct m as [m1 m2]; simpl.
-elim H; intro.
-inversion H0.
-subst a2; subst a1.
-split; [left; trivial | left; trivial].
-split; right; (elim IHp; simpl; intros; auto).
-Qed.
-
-Lemma T_type: forall r, Loc.type r = Loc.type (T r).
-Proof.
-intro; unfold T.
-case (Loc.type r); auto.
-Qed.
-
-Theorem incl_nil: forall A (l : list A), incl nil l.
-Proof.
-intros A l a; simpl; intros H; case H.
-Qed.
-Hint Resolve incl_nil :datatypes.
-
-Lemma split_move_incl:
- forall (l t1 t2 : Moves) (s d : Reg),
- split_move l s = Some (t1, d, t2) -> incl t1 l /\ incl t2 l.
-Proof.
-induction l.
-simpl; (intros; discriminate).
-intros t1 t2 s d; destruct a as [a1 a2]; simpl.
-case (Loc.eq a1 s); intro.
-intros.
-inversion H.
-split; auto.
-apply incl_nil.
-apply incl_tl; apply incl_refl; auto.
-caseEq (split_move l s); intro; (try (intros; discriminate)).
-destruct p as [[p1 p2] p3].
-intros.
-inversion H0.
-elim (IHl p1 p3 s p2); intros; auto.
-subst p3.
-split; auto.
-generalize H1; unfold incl; simpl.
-intros H4 a [H7|H6]; [try exact H7 | idtac].
-left; (try assumption).
-right; apply H4; auto.
-apply incl_tl; auto.
-Qed.
-
-Lemma in_split_move:
- forall (l t1 t2 : Moves) (s d : Reg),
- split_move l s = Some (t1, d, t2) -> In (s, d) l.
-Proof.
-induction l.
-simpl; intros; discriminate.
-intros t1 t2 s d; simpl.
-destruct a as [a1 a2].
-case (Loc.eq a1 s).
-intros.
-inversion H.
-subst a1; left; auto.
-intro; caseEq (split_move l s); (intros; (try discriminate)).
-destruct p as [[p1 p2] p3].
-right; inversion H0.
-subst p2.
-apply (IHl p1 p3); auto.
-Qed.
-
-Lemma move_types_stepf:
- forall S1,
- (forall x1 x2,
- In (x1, x2) (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1)) ->
- Loc.type x1 = Loc.type x2) ->
- forall x1 x2,
- In
- (x1, x2)
- (StateToMove (stepf S1) ++ (StateBeing (stepf S1) ++ StateDone (stepf S1))) ->
- Loc.type x1 = Loc.type x2.
-Proof.
-intros S1 H x1 x2.
-destruct S1 as [[t1 b1] d1]; set (S1:=(t1, b1, d1)); destruct t1; destruct b1;
- auto; simpl StateToMove in H |-; simpl StateBeing in H |-;
- simpl StateDone in H |-; simpl app in H |-.
-intro;
- elim
- (in_app_or
- (StateToMove (stepf S1)) (StateBeing (stepf S1) ++ StateDone (stepf S1))
- (x1, x2)); auto.
-assert (StateToMove (stepf S1) = nil).
-simpl stepf.
-destruct m as [s d].
-case (Loc.eq d (fst (last b1))); case b1; simpl; auto.
-rewrite H1; intros H2; inversion H2.
-intro; elim (in_app_or (StateBeing (stepf S1)) (StateDone (stepf S1)) (x1, x2));
- auto.
-assert
- (StateBeing (stepf S1) = nil \/
- (StateBeing (stepf S1) = b1 \/ StateBeing (stepf S1) = replace_last_s b1)).
-simpl stepf.
-destruct m as [s d].
-case (Loc.eq d (fst (last b1))); case b1; simpl; auto.
-elim H2; [intros H3; (try clear H2); (try exact H3) | intros H3; (try clear H2)].
-rewrite H3; intros H4; inversion H4.
-elim H3; [intros H2; (try clear H3); (try exact H2) | intros H2; (try clear H3)].
-rewrite H2; intros H4.
-apply H; (try in_tac).
-rewrite H2; intros H4.
-caseEq b1; intro; simpl; auto.
-rewrite H3 in H4; simpl in H4 |-; inversion H4.
-intros l H5; rewrite H5 in H4.
-generalize (app_rewriter _ l m0).
-intros [y [r H3]]; (try exact H3).
-rewrite H3 in H4.
-destruct y.
-rewrite last_replace in H4.
-elim (in_app_or r ((T r0, r1) :: nil) (x1, x2)); auto.
-intro; apply H.
-rewrite H5.
-rewrite H3; in_tac.
-intros H6; inversion H6.
-inversion H7.
-rewrite <- T_type.
-rewrite <- H10; apply H.
-rewrite H5; rewrite H3; (try in_tac).
-assert (In (r0, r1) ((r0, r1) :: nil)); [simpl; auto | in_tac].
-inversion H7.
-intro.
-destruct m as [s d].
-assert
- (StateDone (stepf S1) = (s, d) :: d1 \/
- StateDone (stepf S1) = (s, d) :: ((d, T d) :: d1)).
-simpl.
-case (Loc.eq d (fst (last b1))); case b1; simpl; auto.
-elim H3; [intros H4; (try clear H3); (try exact H4) | intros H4; (try clear H3)].
-apply H; (try in_tac).
-rewrite H4 in H2; in_tac.
-rewrite H4 in H2.
-simpl in H2 |-.
-elim H2; [intros H3; apply H | intros H3; elim H3; intros; [idtac | apply H]];
- (try in_tac).
-simpl; left; auto.
-inversion H5; apply T_type.
-intro;
- elim
- (in_app_or
- (StateToMove (stepf S1)) (StateBeing (stepf S1) ++ StateDone (stepf S1))
- (x1, x2)); auto.
-simpl stepf.
-destruct m as [s d].
-case (Loc.eq s d); simpl; intros; apply H; in_tac.
-intro; elim (in_app_or (StateBeing (stepf S1)) (StateDone (stepf S1)) (x1, x2));
- auto.
-simpl stepf.
-destruct m as [s d].
-case (Loc.eq s d); intros; apply H; (try in_tac).
-inversion H2.
-simpl stepf.
-destruct m as [s d].
-case (Loc.eq s d); intros; apply H; (try in_tac).
-simpl in H2 |-; in_tac.
-simpl in H2 |-; in_tac.
-intro;
- elim
- (in_app_or
- (StateToMove (stepf S1)) (StateBeing (stepf S1) ++ StateDone (stepf S1))
- (x1, x2)); auto.
-simpl stepf.
-destruct m as [s d].
-destruct m0 as [s0 d0].
-case (Loc.eq s d0); [simpl; intros; apply H; in_tac | idtac].
-caseEq (split_move t1 d0); intro.
-destruct p as [[t2 b2] d2].
-intros Hsplit Hd; simpl StateToMove; intro.
-elim (split_move_incl t1 t2 d2 d0 b2 Hsplit); auto.
-intros; apply H.
-assert (In (x1, x2) ((s, d) :: (t1 ++ t1))).
-generalize H1; simpl; intros.
-elim H4; [intros H5; left; (try exact H5) | intros H5; right].
-elim (in_app_or t2 d2 (x1, x2)); auto; intro; apply in_or_app; left.
-unfold incl in H2 |-.
-apply H2; auto.
-unfold incl in H3 |-; apply H3; auto.
-in_tac.
-intro; case (Loc.eq d0 (fst (last b1))); case b1; auto; simpl StateToMove;
- intros; apply H; in_tac.
-intro; elim (in_app_or (StateBeing (stepf S1)) (StateDone (stepf S1)) (x1, x2));
- auto.
-simpl stepf.
-destruct m as [s d].
-destruct m0 as [s0 d0].
-case (Loc.eq s d0).
-intros e; rewrite <- e; simpl StateBeing.
-rewrite <- e in H.
-intro; apply H; in_tac.
-caseEq (split_move t1 d0); intro.
-destruct p as [[t2 b2] d2].
-simpl StateBeing.
-intros.
-apply H.
-generalize (in_split_move t1 t2 d2 d0 b2 H2).
-intros.
-elim H3; intros.
-rewrite <- H5.
-in_tac.
-in_tac.
-caseEq b1.
-simpl; intros e n F; elim F.
-intros m l H3 H4.
-case (Loc.eq d0 (fst (last (m :: l)))).
-generalize (app_rewriter Move l m).
-intros [y [r H5]]; rewrite H5.
-simpl StateBeing.
-destruct y as [y1 y2]; generalize (last_replace r y1 y2).
-simpl; intros heq H6.
-unfold Move in heq |-; unfold Move.
-rewrite heq.
-intro.
-elim (in_app_or r ((T y1, y2) :: nil) (x1, x2)); auto.
-intro; apply H.
-rewrite H3; rewrite H5; in_tac.
-simpl; intros [H8|H8]; inversion H8.
-rewrite <- T_type.
-apply H.
-rewrite H3; rewrite H5.
-rewrite <- H11; assert (In (y1, y2) ((y1, y2) :: nil)); auto.
-simpl; auto.
-in_tac.
-simpl StateBeing; intros.
-apply H; rewrite H3; (try in_tac).
-simpl stepf.
-destruct m as [s d].
-destruct m0 as [s0 d0].
-case (Loc.eq s d0); [simpl; intros; apply H; in_tac | idtac].
-caseEq (split_move t1 d0); intro.
-destruct p as [[t2 b2] d2].
-intros Hsplit Hd; simpl StateDone; intro.
-apply H; (try in_tac).
-case (Loc.eq d0 (fst (last b1))); case b1; simpl StateDone; intros;
- (try (apply H; in_tac)).
-elim H3; intros.
-apply H.
-assert (In (x1, x2) ((s0, d0) :: nil)); auto.
-rewrite H4; auto.
-simpl; left; auto.
-in_tac.
-elim H4; intros.
-inversion H5; apply T_type.
-apply H; in_tac.
-Qed.
-
-Lemma move_types_res:
- forall S1,
- (forall x1 x2,
- In (x1, x2) (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1)) ->
- Loc.type x1 = Loc.type x2) ->
- forall x1 x2,
- In
- (x1, x2)
- (StateToMove (Pmov S1) ++ (StateBeing (Pmov S1) ++ StateDone (Pmov S1))) ->
- Loc.type x1 = Loc.type x2.
-Proof.
-intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)).
-clear S1; intros S1 Hrec.
-destruct S1 as [[t b] d]; set (S1:=(t, b, d)).
-unfold S1; rewrite Pmov_equation; intros.
-destruct t; auto.
-destruct b; auto.
-apply (Hrec (stepf S1)).
-apply stepf1_dec; auto.
-apply move_types_stepf; auto.
-unfold S1; auto.
-apply (Hrec (stepf S1)).
-apply stepf1_dec; auto.
-apply move_types_stepf; auto.
-unfold S1; auto.
-Qed.
-
-Lemma srcdst_tmp2_stepf:
- forall S1 x1 x2,
- In
- (x1, x2)
- (StateToMove (stepf S1) ++ (StateBeing (stepf S1) ++ StateDone (stepf S1))) ->
- (In x1 temporaries2 \/
- In x1 (getsrc (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1)))) /\
- (In x2 temporaries2 \/
- In x2 (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1)))).
-Proof.
-intros S1 x1 x2 H.
-(repeat rewrite getsrc_app); (repeat rewrite getdst_app).
-destruct S1 as [[t1 b1] d1]; set (S1:=(t1, b1, d1)); destruct t1; destruct b1;
- auto.
-simpl in H |-.
-elim (in_move__in_srcdst (x1, x2) d1); intros; auto.
-elim
- (in_app_or
- (StateToMove (stepf S1)) (StateBeing (stepf S1) ++ StateDone (stepf S1))
- (x1, x2)); auto.
-assert (StateToMove (stepf S1) = nil).
-simpl stepf.
-destruct m as [s d].
-case (Loc.eq d (fst (last b1))); case b1; simpl; auto.
-rewrite H0; intros H2; inversion H2.
-intro; elim (in_app_or (StateBeing (stepf S1)) (StateDone (stepf S1)) (x1, x2));
- auto.
-simpl stepf.
-destruct m as [s d].
-caseEq b1.
-simpl.
-intros h1 h2; inversion h2.
-intros m l heq; generalize (app_rewriter _ l m).
-intros [y [r H3]]; (try exact H3).
-rewrite H3.
-destruct y.
-rewrite last_app; simpl fst.
-case (Loc.eq d r0).
-intros heqd.
-rewrite last_replace.
-simpl.
-intro; elim (in_app_or r ((T r0, r1) :: nil) (x1, x2)); auto.
-rewrite heq; rewrite H3.
-rewrite getsrc_app; simpl; rewrite getdst_app; simpl.
-intro; elim (in_move__in_srcdst (x1, x2) r); auto; simpl; intros; split; right;
- right; in_tac.
-intro.
-inversion H2; inversion H4.
-split.
-unfold T; case (Loc.type r0); left; [left | right]; auto.
-right; right; (try assumption).
-rewrite heq; rewrite H3.
-rewrite H7; simpl.
-rewrite getdst_app; simpl.
-assert (In x2 (x2 :: nil)); simpl; auto.
-in_tac.
-simpl StateBeing.
-intros; elim (in_move__in_srcdst (x1, x2) (r ++ ((r0, r1) :: nil))); auto;
- intros; split; right; right.
-unfold snd in H4 |-; unfold fst in H2 |-; rewrite heq; rewrite H3; (try in_tac).
-unfold snd in H4 |-; unfold fst in H2 |-; rewrite heq; rewrite H3; (try in_tac).
-simpl stepf.
-destruct m as [s d].
-caseEq b1; intro.
-simpl StateDone; intro.
-unfold S1, StateToMove, StateBeing.
-simpl app.
-elim (in_move__in_srcdst (x1, x2) ((s, d) :: d1)); auto; intros; split; right.
-simpl snd in H4 |-; simpl fst in H3 |-; simpl getdst in H4 |-;
- simpl getsrc in H3 |-; (try in_tac).
-simpl snd in H4 |-; simpl fst in H3 |-; simpl getdst in H4 |-;
- simpl getsrc in H3 |-; (try in_tac).
-intros; generalize (app_rewriter _ l m).
-intros [y [r H4]].
-generalize H2; rewrite H4; rewrite last_app.
-destruct y as [y1 y2].
-simpl fst.
-case (Loc.eq d y1).
-simpl StateDone; intros.
-elim H3; [intros H6; inversion H6; (try exact H6) | intros H6; (try clear H5)].
-simpl; split; right; left; auto.
-elim H6; [intros H5; inversion H5; (try exact H5) | intros H5; (try clear H6)].
-split; [right; simpl; right | left].
-rewrite H1; rewrite H4; rewrite getsrc_app; simpl getsrc.
-rewrite <- e; rewrite H8; assert (In x1 (x1 :: nil)); simpl; auto; (try in_tac).
-unfold T; case (Loc.type x1); simpl; auto.
-elim (in_move__in_srcdst (x1, x2) d1); auto; intros; split; right; right;
- (try in_tac).
-intro; simpl StateDone.
-unfold S1, StateToMove, StateBeing, StateDone.
-simpl getsrc; simpl app; (try in_tac).
-intro; elim (in_move__in_srcdst (x1, x2) ((s, d) :: d1));
- (auto; (simpl fst; simpl snd; simpl getsrc; simpl getdst); intros);
- (split; right; (try in_tac)).
-unfold S1, StateToMove, StateBeing, StateDone.
-elim
- (in_app_or
- (StateToMove (stepf S1)) (StateBeing (stepf S1) ++ StateDone (stepf S1))
- (x1, x2)); auto.
-simpl stepf.
-destruct m as [s d].
-case (Loc.eq s d).
-simpl StateToMove.
-intros; elim (in_move__in_srcdst (x1, x2) t1); auto;
- (repeat (rewrite getsrc_app; simpl getsrc));
- (repeat (rewrite getdst_app; simpl getdst)); simpl fst; simpl snd; intros;
- split; right; simpl; right; (try in_tac).
-simpl StateToMove.
-intros; elim (in_move__in_srcdst (x1, x2) t1); auto;
- (repeat (rewrite getsrc_app; simpl getsrc));
- (repeat (rewrite getdst_app; simpl getdst)); simpl fst; simpl snd; intros;
- split; right; simpl; right; (try in_tac).
-intro; elim (in_app_or (StateBeing (stepf S1)) (StateDone (stepf S1)) (x1, x2));
- auto.
-simpl stepf.
-destruct m as [s d].
-case (Loc.eq s d).
-simpl StateBeing; intros h1 h2; inversion h2.
-simpl StateBeing; intros h1 h2.
-elim (in_move__in_srcdst (x1, x2) ((s, d) :: nil)); auto; simpl fst; simpl snd;
- simpl; intros; split; right; (try in_tac).
-elim H1; [intros H3; left; (try exact H3) | intros H3; inversion H3].
-elim H2; [intros H3; left; (try exact H3) | intros H3; inversion H3].
-simpl stepf.
-destruct m as [s d].
-case (Loc.eq s d).
-simpl StateDone; intros h1 h2.
-elim (in_move__in_srcdst (x1, x2) d1); auto; simpl fst; simpl snd; simpl;
- intros; split; right; right; (try in_tac).
-simpl StateDone; intros h1 h2.
-elim (in_move__in_srcdst (x1, x2) d1); auto; simpl fst; simpl snd; simpl;
- intros; split; right; right; (try in_tac).
-elim
- (in_app_or
- (StateToMove (stepf S1)) (StateBeing (stepf S1) ++ StateDone (stepf S1))
- (x1, x2)); auto.
-simpl stepf.
-destruct m as [s d].
-destruct m0 as [s0 d0].
-case (Loc.eq s d0).
-unfold S1, StateToMove, StateBeing, StateDone.
-simpl app at 1.
-intros; elim (in_move__in_srcdst (x1, x2) t1);
- (auto; simpl; intros; (split; right; right; (try in_tac))).
-intro; caseEq (split_move t1 d0); intro.
-destruct p as [[t2 b2] d2].
-intros Hsplit; unfold S1, StateToMove, StateBeing, StateDone; intro.
-elim (split_move_incl t1 t2 d2 d0 b2 Hsplit); auto.
-intros.
-assert (In (x1, x2) ((s, d) :: (t1 ++ t1))).
-generalize H0; simpl; intros.
-elim H3; [intros H5; left; (try exact H5) | intros H5; right].
-elim (in_app_or t2 d2 (x1, x2)); auto; intro; apply in_or_app; left.
-unfold incl in H1 |-.
-apply H1; auto.
-unfold incl in H2 |-; apply H2; auto.
-split; right.
-elim (in_move__in_srcdst (x1, x2) ((s, d) :: (t1 ++ t1)));
- (auto; simpl; intros; (try in_tac)).
-elim H4; [intros H6; (try clear H4); (try exact H6) | intros H6; (try clear H4)].
-left; (try assumption).
-right; (try in_tac).
-rewrite getsrc_app in H6; (try in_tac).
-elim (in_move__in_srcdst (x1, x2) ((s, d) :: (t1 ++ t1)));
- (auto; simpl; intros; (try in_tac)).
-elim H5; [intros H6; (try clear H5); (try exact H6) | intros H6; (try clear H5)].
-left; (try assumption).
-right; rewrite getdst_app in H6; (try in_tac).
-caseEq b1; intro.
-unfold S1, StateToMove, StateBeing, StateDone.
-intro; elim (in_move__in_srcdst (x1, x2) ((s, d) :: t1)); (auto; intros).
-simpl snd in H4 |-; simpl fst in H3 |-; split; right; (try in_tac).
-intros l heq; generalize (app_rewriter _ l m).
-intros [y [r H1]]; rewrite H1.
-destruct y as [y1 y2].
-rewrite last_app; simpl fst.
-case (Loc.eq d0 y1).
-unfold S1, StateToMove, StateBeing, StateDone.
-intros; elim (in_move__in_srcdst (x1, x2) ((s, d) :: t1)); auto; intros.
-simpl snd in H4 |-; simpl fst in H3 |-; (split; right; (try in_tac)).
-unfold S1, StateToMove, StateBeing, StateDone.
-intros; elim (in_move__in_srcdst (x1, x2) ((s, d) :: t1)); auto; intros.
-simpl snd in H4 |-; simpl fst in H3 |-; (split; right; (try in_tac)).
-intro; elim (in_app_or (StateBeing (stepf S1)) (StateDone (stepf S1)) (x1, x2));
- auto.
-simpl stepf.
-destruct m as [s d].
-destruct m0 as [s0 d0].
-case (Loc.eq s d0).
-intros e; rewrite <- e; simpl StateBeing.
-unfold S1, StateToMove, StateBeing, StateDone.
-intros; elim (in_move__in_srcdst (x1, x2) ((s, d) :: ((s0, s) :: b1))); auto;
- simpl; intros.
-split; right; (try in_tac).
-elim H2; [intros H4; left; (try exact H4) | intros H4; (try clear H2)].
-elim H4; [intros H2; right; (try exact H2) | intros H2; (try clear H4)].
-assert (In x1 (s0 :: nil)); auto; (try in_tac).
-simpl; auto.
-right; (try in_tac).
-elim H3; [intros H4; left; (try exact H4) | intros H4; (try clear H3)].
-elim H4; [intros H3; right; (try exact H3) | intros H3; (try clear H4)].
-rewrite <- e; (try in_tac).
-assert (In x2 (s :: nil)); [simpl; auto | try in_tac].
-right; (try in_tac).
-intro; caseEq (split_move t1 d0); intro.
-destruct p as [[t2 b2] d2].
-simpl StateBeing.
-intros.
-generalize (in_split_move t1 t2 d2 d0 b2 H1).
-intros.
-split; right; elim H2; intros.
-rewrite H4 in H3; elim (in_move__in_srcdst (x1, x2) t1); auto; intros.
-simpl snd in H6 |-; simpl fst in H5 |-; (try in_tac).
-unfold S1, StateToMove, StateBeing, StateDone.
-simpl getsrc; (try in_tac).
-elim (in_move__in_srcdst (x1, x2) ((s0, d0) :: b1)); (auto; intros).
-simpl snd in H6 |-; simpl fst in H5 |-; (try in_tac).
-unfold S1, StateToMove, StateBeing, StateDone.
-simpl.
-simpl in H5 |-.
-elim H5; [intros H7; (try clear H5); (try exact H7) | intros H7; (try clear H5)].
-assert (In x1 (s0 :: nil)); simpl; auto.
-right; in_tac.
-right; in_tac.
-inversion H4.
-simpl.
-subst b2.
-rewrite H4 in H3.
-elim (in_move__in_srcdst (x1, x2) t1); (auto; intros).
-simpl snd in H7 |-.
-right; in_tac.
-unfold S1, StateToMove, StateBeing, StateDone.
-elim (in_move__in_srcdst (x1, x2) ((s0, d0) :: b1)); auto; intros.
-simpl snd in H6 |-; (try in_tac).
-apply
- (in_or_app (getdst ((s, d) :: t1)) (getdst ((s0, d0) :: b1) ++ getdst d1) x2);
- right; (try in_tac).
-caseEq b1.
-intros h1 h2; inversion h2.
-intros m l heq.
-generalize (app_rewriter _ l m); intros [y [r H2]]; rewrite H2.
-destruct y as [y1 y2].
-rewrite last_app; simpl fst.
-case (Loc.eq d0 y1).
-unfold S1, StateToMove, StateBeing, StateDone.
-generalize (last_replace r y1 y2).
-unfold Move; intros H3 H6.
-rewrite H3.
-intro.
-elim (in_app_or r ((T y1, y2) :: nil) (x1, x2)); auto.
-intro.
-rewrite heq; rewrite H2; (split; right).
-elim (in_move__in_srcdst (x1, x2) r); auto; simpl fst; simpl snd; intros;
- (try in_tac).
-simpl.
-rewrite getsrc_app; (right; (try in_tac)).
-elim (in_move__in_srcdst (x1, x2) r); auto; simpl fst; simpl snd; intros;
- (try in_tac).
-simpl.
-rewrite getdst_app; right; (try in_tac).
-intros h; inversion h; inversion H5.
-split; [left; simpl; auto | right].
-unfold T; case (Loc.type y1); auto.
-subst y2.
-rewrite heq; rewrite H2.
-simpl.
-rewrite getdst_app; simpl.
-assert (In x2 (x2 :: nil)); [simpl; auto | right; (try in_tac)].
-unfold S1, StateToMove, StateBeing, StateDone.
-intro; rewrite heq; rewrite H2; (split; right).
-intros; elim (in_move__in_srcdst (x1, x2) (r ++ ((y1, y2) :: nil))); auto;
- intros.
-simpl snd in H5 |-; simpl fst in H4 |-.
-simpl.
-right; (try in_tac).
-apply in_or_app; right; simpl; right; (try in_tac).
-elim (in_move__in_srcdst (x1, x2) (r ++ ((y1, y2) :: nil))); auto; intros.
-simpl snd in H5 |-.
-simpl.
-right; (try in_tac).
-apply in_or_app; right; simpl; right; (try in_tac).
-simpl stepf.
-destruct m as [s d].
-destruct m0 as [s0 d0].
-case (Loc.eq s d0).
-unfold S1, StateToMove, StateBeing, StateDone.
-intros; elim (in_move__in_srcdst (x1, x2) d1); auto; intros.
-simpl in H3 |-; simpl in H2 |-.
-split; right; (try in_tac).
-intro; caseEq (split_move t1 d0); intro.
-destruct p as [[t2 b2] d2].
-simpl StateDone.
-unfold S1, StateToMove, StateBeing, StateDone.
-intros; elim (in_move__in_srcdst (x1, x2) d1); auto; intros.
-simpl in H3 |-; simpl in H4 |-.
-split; right; (try in_tac).
-caseEq b1.
-unfold S1, StateToMove, StateBeing, StateDone.
-intros; elim (in_move__in_srcdst (x1, x2) ((s0, d0) :: d1)); auto; intros.
-simpl in H5 |-; simpl in H4 |-; split; right; (try in_tac).
-simpl.
-elim H4; [intros H6; right; (try exact H6) | intros H6; (try clear H4)].
-assert (In x1 (x1 :: nil)); [simpl; auto | rewrite H6; (try in_tac)].
-right; (try in_tac).
-elim H5; [intros H6; right; simpl; (try exact H6) | intros H6; (try clear H5)].
-assert (In x2 (x2 :: nil)); [simpl; auto | rewrite H6; (try in_tac)].
-try in_tac.
-intros m l heq.
-generalize (app_rewriter _ l m); intros [y [r H2]]; rewrite H2.
-destruct y as [y1 y2].
-rewrite last_app; simpl fst.
-case (Loc.eq d0 y1).
-unfold S1, StateToMove, StateBeing, StateDone.
-unfold S1, StateToMove, StateBeing, StateDone.
-intros.
-elim H3; intros.
-inversion H4.
-simpl; split; right; auto.
-right; apply in_or_app; right; simpl; auto.
-right; apply in_or_app; right; simpl; auto.
-elim H4; intros.
-inversion H5.
-simpl; split; [right | left].
-rewrite heq; rewrite H2; simpl.
-rewrite <- e; rewrite H7.
-rewrite getsrc_app; simpl.
-right; assert (In x1 (x1 :: nil)); [simpl; auto | try in_tac].
-unfold T; case (Loc.type x1); auto.
-elim (in_move__in_srcdst (x1, x2) d1); (auto; intros).
-simpl snd in H7 |-; simpl fst in H6 |-; split; right; (try in_tac).
-unfold S1, StateToMove, StateBeing, StateDone.
-intros; elim (in_move__in_srcdst (x1, x2) ((s0, d0) :: d1));
- (auto; simpl; intros).
-split; right.
-elim H4; [intros H6; right; (try exact H6) | intros H6; (try clear H4)].
-apply in_or_app; right; simpl; auto.
-right; (try in_tac).
-elim H5; [intros H6; right; (try exact H6) | intros H6; (try clear H5)].
-apply in_or_app; right; simpl; auto.
-right; (try in_tac).
-Qed.
-
-Lemma getsrc_f: forall s l, In s (getsrc l) -> (exists d , In (s, d) l ).
-Proof.
-induction l; simpl getsrc.
-simpl; (intros h; elim h).
-intros; destruct a as [a1 a2].
-simpl in H |-.
-elim H; [intros H0; (try clear H); (try exact H0) | intros H0; (try clear H)].
-subst a1.
-exists a2; simpl; auto.
-simpl.
-elim IHl; [intros d H; (try clear IHl); (try exact H) | idtac]; auto.
-exists d; [right; (try assumption)].
-Qed.
-
-Lemma incl_src: forall l1 l2, incl l1 l2 -> incl (getsrc l1) (getsrc l2).
-Proof.
-intros.
-unfold incl in H |-.
-unfold incl.
-intros a H0; (try assumption).
-generalize (getsrc_f a).
-intros H1; elim H1 with ( l := l1 );
- [intros d H2; (try clear H1); (try exact H2) | idtac]; auto.
-assert (In (a, d) l2).
-apply H; auto.
-elim (in_move__in_srcdst (a, d) l2); auto.
-Qed.
-
-Lemma getdst_f: forall d l, In d (getdst l) -> (exists s , In (s, d) l ).
-Proof.
-induction l; simpl getdst.
-simpl; (intros h; elim h).
-intros; destruct a as [a1 a2].
-simpl in H |-.
-elim H; [intros H0; (try clear H); (try exact H0) | intros H0; (try clear H)].
-subst a2.
-exists a1; simpl; auto.
-simpl.
-elim IHl; [intros s H; (try clear IHl); (try exact H) | idtac]; auto.
-exists s; [right; (try assumption)].
-Qed.
-
-Lemma incl_dst: forall l1 l2, incl l1 l2 -> incl (getdst l1) (getdst l2).
-Proof.
-intros.
-unfold incl in H |-.
-unfold incl.
-intros a H0; (try assumption).
-generalize (getdst_f a).
-intros H1; elim H1 with ( l := l1 );
- [intros d H2; (try clear H1); (try exact H2) | idtac]; auto.
-assert (In (d, a) l2).
-apply H; auto.
-elim (in_move__in_srcdst (d, a) l2); auto.
-Qed.
-
-Lemma src_tmp2_res:
- forall S1 x1 x2,
- In
- (x1, x2)
- (StateToMove (Pmov S1) ++ (StateBeing (Pmov S1) ++ StateDone (Pmov S1))) ->
- (In x1 temporaries2 \/
- In x1 (getsrc (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1)))) /\
- (In x2 temporaries2 \/
- In x2 (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1)))).
-Proof.
-intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)).
-clear S1; intros S1 Hrec.
-destruct S1 as [[t b] d]; set (S1:=(t, b, d)).
-unfold S1; rewrite Pmov_equation; intros.
-destruct t.
-destruct b.
-apply srcdst_tmp2_stepf; auto.
-elim Hrec with ( y := stepf S1 ) ( x1 := x1 ) ( x2 := x2 );
- [idtac | apply stepf1_dec; auto | auto].
-intros.
-elim H1; [intros H2; (try clear H1); (try exact H2) | intros H2; (try clear H1)].
-elim H0; [intros H1; (try clear H0); (try exact H1) | intros H1; (try clear H0)].
-split; [left; (try assumption) | idtac].
-left; (try assumption).
-elim (getsrc_f x1) with ( 1 := H1 ); intros x3 H3.
-split; auto.
-elim srcdst_tmp2_stepf with ( 1 := H3 ); auto.
-elim H0; [intros H1; (try clear H0); (try exact H1) | intros H1; (try clear H0)].
-elim (getdst_f x2) with ( 1 := H2 ); intros x3 H3.
-split; auto.
-elim srcdst_tmp2_stepf with ( 1 := H3 ); auto.
-elim (getsrc_f x1) with ( 1 := H1 ); intros x3 H3.
-elim srcdst_tmp2_stepf with ( 1 := H3 ); auto.
-clear H3.
-elim (getdst_f x2) with ( 1 := H2 ); intros x4 H3.
-elim srcdst_tmp2_stepf with ( 1 := H3 ); auto.
-elim Hrec with ( y := stepf S1 ) ( x1 := x1 ) ( x2 := x2 );
- [idtac | apply stepf1_dec; auto | auto].
-intros.
-elim H1; [intros H2; (try clear H1); (try exact H2) | intros H2; (try clear H1)].
-elim H0; [intros H1; (try clear H0); (try exact H1) | intros H1; (try clear H0)].
-split; [left; (try assumption) | idtac].
-left; (try assumption).
-elim (getsrc_f x1) with ( 1 := H1 ); intros x3 H3.
-split; auto.
-elim srcdst_tmp2_stepf with ( 1 := H3 ); auto.
-elim H0; [intros H1; (try clear H0); (try exact H1) | intros H1; (try clear H0)].
-elim (getdst_f x2) with ( 1 := H2 ); intros x3 H3.
-split; auto.
-elim srcdst_tmp2_stepf with ( 1 := H3 ); auto.
-elim (getsrc_f x1) with ( 1 := H1 ); intros x3 H3.
-elim srcdst_tmp2_stepf with ( 1 := H3 ); auto.
-clear H3.
-elim (getdst_f x2) with ( 1 := H2 ); intros x4 H3.
-elim srcdst_tmp2_stepf with ( 1 := H3 ); auto.
-Qed.
-
-Lemma wt_add_moves:
- forall p b,
- List.map Loc.type (getsrc p) = List.map Loc.type (getdst p) ->
- locs_read_ok (getsrc p) ->
- locs_write_ok (getdst p) ->
- wt_block tf b ->
- wt_block
- tf
- (fold_left
- (fun (k0 : LTL.block) =>
- fun (p0 : loc * loc) => add_move (fst p0) (snd p0) k0) p b).
-Proof.
-induction p.
-intros; simpl; auto.
-intros; destruct a as [a1 a2]; simpl.
-apply IHp; auto.
-inversion H; auto.
-simpl in H0 |-.
-unfold locs_read_ok in H0 |-.
-simpl in H0 |-.
-unfold locs_read_ok; auto.
-generalize H1; unfold locs_write_ok; simpl; auto.
-apply wt_add_move; (try assumption).
-simpl in H0 |-.
-unfold locs_read_ok in H0 |-.
-apply H0.
-simpl; left; trivial.
-unfold locs_write_ok in H1 |-; apply H1.
-simpl; left; trivial.
-inversion H; auto.
-Qed.
-
-Lemma map_f_getsrc_getdst:
- forall (b : Set) (f : Reg -> b) p,
- map f (getsrc p) = map f (getdst p) ->
- forall x1 x2, In (x1, x2) p -> f x1 = f x2.
-Proof.
-intros b f0 p; induction p; simpl; auto.
-intros; contradiction.
-destruct a.
-simpl.
-intros heq; injection heq.
-intros h1 h2.
-intros x1 x2 [H3|H3].
-injection H3.
-intros; subst; auto.
-apply IHp; auto.
-Qed.
-
-Lemma wt_parallel_move':
- forall p b,
- List.map Loc.type (getsrc p) = List.map Loc.type (getdst p) ->
- locs_read_ok (getsrc p) ->
- locs_write_ok (getdst p) -> wt_block tf b -> wt_block tf (p_move p b).
-Proof.
-unfold p_move.
-unfold P_move.
-intros; apply wt_add_moves; auto.
-rewrite getsrc_map; rewrite getdst_map.
-rewrite list_map_compose.
-rewrite list_map_compose.
-apply list_map_exten.
-generalize (move_types_res (p, nil, nil)); auto.
-destruct x as [x1 x2]; simpl; intros; auto.
-symmetry; apply H3.
-simpl.
-rewrite app_nil.
-apply map_f_getsrc_getdst; auto.
-in_tac.
-unfold locs_read_ok.
-intros l H3.
-elim getsrc_f with ( 1 := H3 ); intros x3 H4.
-elim (src_tmp2_res (p, nil, nil) l x3).
-simpl.
-rewrite app_nil.
-intros [[H'|[H'|H']]|H'] _.
-subst l; hnf; auto.
-subst l; hnf; auto.
-contradiction.
-apply H0; auto.
-in_tac.
-intros l H3.
-elim getdst_f with ( 1 := H3 ); intros x3 H4.
-elim (src_tmp2_res (p, nil, nil) x3 l).
-simpl.
-rewrite app_nil.
-intros _ [[H'|[H'|H']]|H'].
-subst l; hnf; auto.
-subst l; hnf; auto.
-contradiction.
-apply H1; auto.
-in_tac.
-Qed.
-
-Theorem wt_parallel_moveX:
- forall srcs dsts b,
- List.map Loc.type srcs = List.map Loc.type dsts ->
- locs_read_ok srcs ->
- locs_write_ok dsts -> wt_block tf b -> wt_block tf (parallel_move srcs dsts b).
-Proof.
-unfold parallel_move, parallel_move_order, P_move.
-intros.
-generalize (wt_parallel_move' (listsLoc2Moves srcs dsts)); intros H'.
-unfold p_move, P_move in H' |-.
-apply H'; auto.
-elim (getdst_lists2moves srcs dsts); auto.
-unfold Allocation.listsLoc2Moves, listsLoc2Moves.
-intros heq1 heq2; rewrite heq1; rewrite heq2; auto.
-repeat rewrite <- (list_length_map Loc.type).
-rewrite H; auto.
-elim (getdst_lists2moves srcs dsts); auto.
-unfold Allocation.listsLoc2Moves, listsLoc2Moves.
-intros heq1 heq2; rewrite heq1; auto.
-repeat rewrite <- (list_length_map Loc.type).
-rewrite H; auto.
-elim (getdst_lists2moves srcs dsts); auto.
-unfold Allocation.listsLoc2Moves, listsLoc2Moves.
-intros heq1 heq2; rewrite heq2; auto.
-repeat rewrite <- (list_length_map Loc.type).
-rewrite H; auto.
-Qed.
-
-End wt_move_correction.
diff --git a/backend/CSE.v b/backend/CSE.v
index 243f6dd..6801013 100644
--- a/backend/CSE.v
+++ b/backend/CSE.v
@@ -178,6 +178,15 @@ 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 [Ialloc]. *)
+
+Definition add_unknown (n: numbering) (rd: reg) :=
+ mknumbering (Psucc n.(num_next))
+ n.(num_eqs)
+ (PTree.set rd n.(num_next) n.(num_reg)).
+
(** [kill_load n] removes all equations involving memory loads.
It is used to reflect the effect of a memory store, which can
potentially invalidate all such equations. *)
@@ -328,6 +337,8 @@ Definition transfer (f: function) (pc: node) (before: numbering) :=
kill_loads before
| Icall sig ros args res s =>
empty_numbering
+ | Ialloc arg res s =>
+ add_unknown before res
| Icond cond args ifso ifnot =>
before
| Ireturn optarg =>
@@ -415,6 +426,8 @@ Definition transf_function (f: function) : function :=
f.(fn_nextpc)
(transf_code_wf f approxs f.(fn_code_wf)).
+Definition transf_fundef := AST.transf_fundef transf_function.
+
Definition transf_program (p: program) : program :=
- transform_program transf_function p.
+ transform_program transf_fundef p.
diff --git a/backend/CSEproof.v b/backend/CSEproof.v
index db8a973..4420269 100644
--- a/backend/CSEproof.v
+++ b/backend/CSEproof.v
@@ -7,6 +7,7 @@ Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Registers.
@@ -177,6 +178,18 @@ Proof.
apply wf_add_rhs; auto.
Qed.
+Lemma wf_add_unknown:
+ forall n rd,
+ wf_numbering n ->
+ wf_numbering (add_unknown n rd).
+Proof.
+ intros. inversion H. unfold add_unknown. constructor; simpl.
+ intros. eapply wf_equation_increasing; eauto. auto with coqlib.
+ intros until v. rewrite PTree.gsspec. case (peq r rd); intros.
+ inversion H2. auto with coqlib.
+ apply Plt_trans_succ. eauto.
+Qed.
+
Lemma kill_load_eqs_incl:
forall eqs, List.incl (kill_load_eqs eqs) eqs.
Proof.
@@ -205,6 +218,7 @@ Proof.
apply wf_add_load; auto.
apply wf_kill_loads; auto.
apply wf_empty_numbering.
+ apply wf_add_unknown; auto.
Qed.
(** As a consequence, the numberings computed by the static analysis
@@ -497,6 +511,47 @@ Proof.
simpl. exists a; split; congruence.
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,
+ wf_numbering n ->
+ numbering_satisfiable ge sp rs m n ->
+ numbering_satisfiable ge sp
+ (rs#dst <- v) m (add_unknown n dst).
+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.
+Qed.
+
+(** Allocation of a fresh memory block preserves satisfiability. *)
+
+Lemma alloc_satisfiable:
+ forall lo hi b m' rs n,
+ Mem.alloc m lo hi = (m', b) ->
+ numbering_satisfiable ge sp rs m n ->
+ numbering_satisfiable ge sp rs m' n.
+Proof.
+ intros. destruct H0 as [valu [A B]].
+ exists valu; split; intros.
+ generalize (A _ _ H0). destruct rh; simpl.
+ auto.
+ intros [addr [C D]]. exists addr; split. auto.
+ destruct addr; simpl in *; try discriminate.
+ eapply Mem.load_alloc_other; eauto.
+ eauto.
+Qed.
+
(** [kill_load] preserves satisfiability. Moreover, the resulting numbering
is satisfiable in any concrete memory state. *)
@@ -612,8 +667,8 @@ End SATISFIABILITY.
(** The transfer function preserves satisfiability of numberings. *)
Lemma transfer_correct:
- forall ge c sp pc rs m pc' rs' m' f n,
- exec_instr ge c sp pc rs m pc' rs' m' ->
+ forall ge c sp pc rs m t pc' rs' m' f n,
+ exec_instr ge c sp pc rs m t pc' rs' m' ->
c = f.(fn_code) ->
wf_numbering n ->
numbering_satisfiable ge sp rs m n ->
@@ -628,6 +683,8 @@ Proof.
eapply kill_load_satisfiable; eauto.
(* Icall *)
apply empty_numbering_satisfiable.
+ (* Ialloc *)
+ apply add_unknown_satisfiable; auto. eapply alloc_satisfiable; eauto.
Qed.
(** The numberings associated to each instruction by the static analysis
@@ -637,8 +694,8 @@ Qed.
satisfiability at [pc']. *)
Theorem analysis_correct_1:
- forall ge c sp pc rs m pc' rs' m' f,
- exec_instr ge c sp pc rs m pc' rs' m' ->
+ forall ge c sp pc rs m t pc' rs' m' f,
+ exec_instr ge c sp pc rs m t pc' rs' m' ->
c = f.(fn_code) ->
numbering_satisfiable ge sp rs m (analyze f)!!pc ->
numbering_satisfiable ge sp rs' m' (analyze f)!!pc'.
@@ -655,15 +712,15 @@ Proof.
eapply Solver.fixpoint_solution; eauto.
elim (fn_code_wf f pc); intro. auto.
rewrite <- CODE in H0.
- elim (exec_instr_present _ _ _ _ _ _ _ _ _ EXEC H0).
+ elim (exec_instr_present _ _ _ _ _ _ _ _ _ _ EXEC H0).
rewrite CODE in EXEC. eapply successors_correct; eauto.
apply H0. auto.
intros. rewrite PMap.gi. apply empty_numbering_satisfiable.
Qed.
Theorem analysis_correct_N:
- forall ge c sp pc rs m pc' rs' m' f,
- exec_instrs ge c sp pc rs m pc' rs' m' ->
+ forall ge c sp pc rs m t pc' rs' m' f,
+ exec_instrs ge c sp pc rs m t pc' rs' m' ->
c = f.(fn_code) ->
numbering_satisfiable ge sp rs m (analyze f)!!pc ->
numbering_satisfiable ge sp rs' m' (analyze f)!!pc'.
@@ -702,19 +759,26 @@ Let tge := Genv.globalenv tprog.
Lemma symbols_preserved:
forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
-Proof (Genv.find_symbol_transf transf_function prog).
+Proof (Genv.find_symbol_transf transf_fundef prog).
Lemma functions_translated:
- forall (v: val) (f: RTL.function),
+ forall (v: val) (f: RTL.fundef),
Genv.find_funct ge v = Some f ->
- Genv.find_funct tge v = Some (transf_function f).
-Proof (@Genv.find_funct_transf _ _ transf_function prog).
+ Genv.find_funct tge v = Some (transf_fundef f).
+Proof (@Genv.find_funct_transf _ _ transf_fundef prog).
Lemma funct_ptr_translated:
- forall (b: block) (f: RTL.function),
+ forall (b: block) (f: RTL.fundef),
Genv.find_funct_ptr ge b = Some f ->
- Genv.find_funct_ptr tge b = Some (transf_function f).
-Proof (@Genv.find_funct_ptr_transf _ _ transf_function prog).
+ Genv.find_funct_ptr tge b = Some (transf_fundef f).
+Proof (@Genv.find_funct_ptr_transf _ _ transf_fundef prog).
+
+Lemma sig_translated:
+ forall (f: RTL.fundef),
+ funsig (transf_fundef f) = funsig f.
+Proof.
+ intros; case f; intros; reflexivity.
+Qed.
(** The proof of semantic preservation is a simulation argument using
diagrams of the following form:
@@ -732,26 +796,26 @@ Proof (@Genv.find_funct_ptr_transf _ _ transf_function prog).
Definition exec_instr_prop
(c: code) (sp: val)
- (pc: node) (rs: regset) (m: mem)
+ (pc: node) (rs: regset) (m: mem) (t: trace)
(pc': node) (rs': regset) (m': mem) : Prop :=
forall f
(CF: c = f.(RTL.fn_code))
(SAT: numbering_satisfiable ge sp rs m (analyze f)!!pc),
- exec_instr tge (transf_code (analyze f) c) sp pc rs m pc' rs' m'.
+ exec_instr tge (transf_code (analyze f) c) sp pc rs m t pc' rs' m'.
Definition exec_instrs_prop
(c: code) (sp: val)
- (pc: node) (rs: regset) (m: mem)
+ (pc: node) (rs: regset) (m: mem) (t: trace)
(pc': node) (rs': regset) (m': mem) : Prop :=
forall f
(CF: c = f.(RTL.fn_code))
(SAT: numbering_satisfiable ge sp rs m (analyze f)!!pc),
- exec_instrs tge (transf_code (analyze f) c) sp pc rs m pc' rs' m'.
+ exec_instrs tge (transf_code (analyze f) c) sp pc rs m t pc' rs' m'.
Definition exec_function_prop
- (f: RTL.function) (args: list val) (m: mem)
+ (f: RTL.fundef) (args: list val) (m: mem) (t: trace)
(res: val) (m': mem) : Prop :=
- exec_function tge (transf_function f) args m res m'.
+ exec_function tge (transf_fundef f) args m t res m'.
Ltac TransfInstr :=
match goal with
@@ -766,9 +830,9 @@ Ltac TransfInstr :=
derivation for the source program. *)
Lemma transf_function_correct:
- forall f args m res m',
- exec_function ge f args m res m' ->
- exec_function_prop f args m res m'.
+ forall f args m t res m',
+ exec_function ge f args m t res m' ->
+ exec_function_prop f args m t res m'.
Proof.
apply (exec_function_ind_3 ge
exec_instr_prop exec_instrs_prop exec_function_prop);
@@ -804,12 +868,15 @@ Proof.
rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
intro; eapply exec_Istore; eauto.
(* Icall *)
- assert (find_function tge ros rs = Some (transf_function f)).
+ assert (find_function tge ros rs = Some (transf_fundef f)).
destruct ros; simpl in H0; simpl.
apply functions_translated; auto.
rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
apply funct_ptr_translated; auto. discriminate.
- intro; eapply exec_Icall with (f := transf_function f); eauto.
+ intro; eapply exec_Icall with (f := transf_fundef f); eauto.
+ generalize (sig_translated f); congruence.
+ (* Ialloc *)
+ intro; eapply exec_Ialloc; eauto.
(* Icond true *)
intro; eapply exec_Icond_true; eauto.
(* Icond false *)
@@ -821,22 +888,23 @@ Proof.
(* trans *)
eapply exec_trans; eauto. apply H2; auto.
eapply analysis_correct_N; eauto.
- (* function *)
- intro. unfold transf_function; eapply exec_funct; simpl; eauto.
+ (* internal function *)
+ intro. unfold transf_function; simpl; eapply exec_funct_internal; simpl; eauto.
eapply H1; eauto. eapply analysis_correct_entry; eauto.
+ (* external function *)
+ unfold transf_function; simpl. apply exec_funct_external; auto.
Qed.
Theorem transf_program_correct:
- forall (r: val),
- exec_program prog r -> exec_program tprog r.
+ forall (t: trace) (r: val),
+ exec_program prog t r -> exec_program tprog t r.
Proof.
- intros r [fptr [f [m [FINDS [FINDF [SIG EXEC]]]]]].
- red. exists fptr; exists (transf_function f); exists m.
+ intros t r [fptr [f [m [FINDS [FINDF [SIG EXEC]]]]]].
+ red. exists fptr; exists (transf_fundef f); exists m.
split. change (prog_main tprog) with (prog_main prog).
rewrite symbols_preserved. assumption.
split. apply funct_ptr_translated; auto.
- split. unfold transf_function.
- rewrite <- SIG. destruct (analyze f); reflexivity.
+ split. generalize (sig_translated f); congruence.
apply transf_function_correct.
unfold tprog, transf_program. rewrite Genv.init_mem_transf.
exact EXEC.
diff --git a/backend/Cmconstr.v b/backend/Cmconstr.v
index e6168d1..f3a63fa 100644
--- a/backend/Cmconstr.v
+++ b/backend/Cmconstr.v
@@ -57,6 +57,8 @@ Fixpoint lift_expr (p: nat) (a: expr) {struct a}: expr :=
| Elet b c => Elet (lift_expr p b) (lift_expr (S p) c)
| Eletvar n =>
if le_gt_dec p n then Eletvar (S n) else Eletvar n
+ | Ealloc b =>
+ Ealloc (lift_expr p b)
end
with lift_condexpr (p: nat) (a: condexpr) {struct a}: condexpr :=
@@ -795,11 +797,6 @@ Definition divf (e1 e2: expr) := Eop Odivf (e1:::e2:::Enil).
(** ** Truncations and sign extensions *)
-Definition cast8unsigned (e: expr) :=
- rolm e Int.zero (Int.repr 255).
-Definition cast16unsigned (e: expr) :=
- rolm e Int.zero (Int.repr 65535).
-
Inductive cast8signed_cases: forall (e1: expr), Set :=
| cast8signed_case1:
forall (e2: expr),
@@ -822,6 +819,28 @@ Definition cast8signed (e: expr) :=
| cast8signed_default e1 => Eop Ocast8signed (e1 ::: Enil)
end.
+Inductive cast8unsigned_cases: forall (e1: expr), Set :=
+ | cast8unsigned_case1:
+ forall (e2: expr),
+ cast8unsigned_cases (Eop Ocast8unsigned (e2 ::: Enil))
+ | cast8unsigned_default:
+ forall (e1: expr),
+ cast8unsigned_cases e1.
+
+Definition cast8unsigned_match (e1: expr) :=
+ match e1 as z1 return cast8unsigned_cases z1 with
+ | Eop Ocast8unsigned (e2 ::: Enil) =>
+ cast8unsigned_case1 e2
+ | e1 =>
+ cast8unsigned_default e1
+ end.
+
+Definition cast8unsigned (e: expr) :=
+ match cast8unsigned_match e with
+ | cast8unsigned_case1 e1 => e
+ | cast8unsigned_default e1 => Eop Ocast8unsigned (e1 ::: Enil)
+ end.
+
Inductive cast16signed_cases: forall (e1: expr), Set :=
| cast16signed_case1:
forall (e2: expr),
@@ -844,6 +863,28 @@ Definition cast16signed (e: expr) :=
| cast16signed_default e1 => Eop Ocast16signed (e1 ::: Enil)
end.
+Inductive cast16unsigned_cases: forall (e1: expr), Set :=
+ | cast16unsigned_case1:
+ forall (e2: expr),
+ cast16unsigned_cases (Eop Ocast16unsigned (e2 ::: Enil))
+ | cast16unsigned_default:
+ forall (e1: expr),
+ cast16unsigned_cases e1.
+
+Definition cast16unsigned_match (e1: expr) :=
+ match e1 as z1 return cast16unsigned_cases z1 with
+ | Eop Ocast16unsigned (e2 ::: Enil) =>
+ cast16unsigned_case1 e2
+ | e1 =>
+ cast16unsigned_default e1
+ end.
+
+Definition cast16unsigned (e: expr) :=
+ match cast16unsigned_match e with
+ | cast16unsigned_case1 e1 => e
+ | cast16unsigned_default e1 => Eop Ocast16unsigned (e1 ::: Enil)
+ end.
+
Inductive singleoffloat_cases: forall (e1: expr), Set :=
| singleoffloat_case1:
forall (e2: expr),
diff --git a/backend/Cmconstrproof.v b/backend/Cmconstrproof.v
index f27fa73..b9976ee 100644
--- a/backend/Cmconstrproof.v
+++ b/backend/Cmconstrproof.v
@@ -16,6 +16,7 @@ Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Op.
Require Import Globalenvs.
Require Import Cminor.
@@ -67,34 +68,67 @@ Scheme eval_expr_ind_3 := Minimality for eval_expr Sort Prop
with eval_exprlist_ind_3 := Minimality for eval_exprlist Sort Prop.
Hint Resolve eval_Evar eval_Eassign eval_Eop eval_Eload eval_Estore
- eval_Ecall eval_Econdition
+ eval_Ecall eval_Econdition eval_Ealloc
eval_Elet eval_Eletvar
eval_CEtrue eval_CEfalse eval_CEcond
eval_CEcondition eval_Enil eval_Econs: evalexpr.
+Lemma eval_list_one:
+ forall sp le e1 m1 a t e2 m2 v,
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
+ eval_exprlist ge sp le e1 m1 (a ::: Enil) t e2 m2 (v :: nil).
+Proof.
+ intros. econstructor. eauto. constructor. traceEq.
+Qed.
+
+Lemma eval_list_two:
+ forall sp le e1 m1 a1 t1 e2 m2 v1 a2 t2 e3 m3 v2 t,
+ eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 ->
+ eval_expr ge sp le e2 m2 a2 t2 e3 m3 v2 ->
+ t = t1 ** t2 ->
+ eval_exprlist ge sp le e1 m1 (a1 ::: a2 ::: Enil) t e3 m3 (v1 :: v2 :: nil).
+Proof.
+ intros. econstructor. eauto. econstructor. eauto. constructor.
+ reflexivity. traceEq.
+Qed.
+
+Lemma eval_list_three:
+ forall sp le e1 m1 a1 t1 e2 m2 v1 a2 t2 e3 m3 v2 a3 t3 e4 m4 v3 t,
+ eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 ->
+ eval_expr ge sp le e2 m2 a2 t2 e3 m3 v2 ->
+ eval_expr ge sp le e3 m3 a3 t3 e4 m4 v3 ->
+ t = t1 ** t2 ** t3 ->
+ eval_exprlist ge sp le e1 m1 (a1 ::: a2 ::: a3 ::: Enil) t e4 m4 (v1 :: v2 :: v3 :: nil).
+Proof.
+ intros. econstructor. eauto. econstructor. eauto. econstructor. eauto. constructor.
+ reflexivity. reflexivity. traceEq.
+Qed.
+
+Hint Resolve eval_list_one eval_list_two eval_list_three: evalexpr.
+
Lemma eval_lift_expr:
- forall w sp le e1 m1 a e2 m2 v,
- eval_expr ge sp le e1 m1 a e2 m2 v ->
+ forall w sp le e1 m1 a t e2 m2 v,
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
forall p le', insert_lenv le p w le' ->
- eval_expr ge sp le' e1 m1 (lift_expr p a) e2 m2 v.
+ eval_expr ge sp le' e1 m1 (lift_expr p a) t e2 m2 v.
Proof.
intros w.
apply (eval_expr_ind_3 ge
- (fun sp le e1 m1 a e2 m2 v =>
+ (fun sp le e1 m1 a t e2 m2 v =>
forall p le', insert_lenv le p w le' ->
- eval_expr ge sp le' e1 m1 (lift_expr p a) e2 m2 v)
- (fun sp le e1 m1 a e2 m2 vb =>
+ eval_expr ge sp le' e1 m1 (lift_expr p a) t e2 m2 v)
+ (fun sp le e1 m1 a t e2 m2 vb =>
forall p le', insert_lenv le p w le' ->
- eval_condexpr ge sp le' e1 m1 (lift_condexpr p a) e2 m2 vb)
- (fun sp le e1 m1 al e2 m2 vl =>
+ eval_condexpr ge sp le' e1 m1 (lift_condexpr p a) t e2 m2 vb)
+ (fun sp le e1 m1 al t e2 m2 vl =>
forall p le', insert_lenv le p w le' ->
- eval_exprlist ge sp le' e1 m1 (lift_exprlist p al) e2 m2 vl));
+ eval_exprlist ge sp le' e1 m1 (lift_exprlist p al) t e2 m2 vl));
simpl; intros; eauto with evalexpr.
destruct v1; eapply eval_Econdition;
eauto with evalexpr; simpl; eauto with evalexpr.
- eapply eval_Elet. eauto. apply H2. apply insert_lenv_S; auto.
+ eapply eval_Elet. eauto. apply H2. apply insert_lenv_S; auto. auto.
case (le_gt_dec p n); intro.
apply eval_Eletvar. eapply insert_lenv_lookup2; eauto.
@@ -105,9 +139,9 @@ Proof.
Qed.
Lemma eval_lift:
- forall sp le e1 m1 a e2 m2 v w,
- eval_expr ge sp le e1 m1 a e2 m2 v ->
- eval_expr ge sp (w::le) e1 m1 (lift a) e2 m2 v.
+ forall sp le e1 m1 a t e2 m2 v w,
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
+ eval_expr ge sp (w::le) e1 m1 (lift a) t e2 m2 v.
Proof.
intros. unfold lift. eapply eval_lift_expr.
eexact H. apply insert_lenv_0.
@@ -126,67 +160,69 @@ Ltac TrivialOp cstr :=
of operator applications. *)
Lemma inv_eval_Eop_0:
- forall sp le e1 m1 op e2 m2 v,
- eval_expr ge sp le e1 m1 (Eop op Enil) e2 m2 v ->
- e2 = e1 /\ m2 = m1 /\ eval_operation ge sp op nil = Some v.
+ forall sp le e1 m1 op t e2 m2 v,
+ eval_expr ge sp le e1 m1 (Eop op Enil) t e2 m2 v ->
+ t = E0 /\ e2 = e1 /\ m2 = m1 /\ eval_operation ge sp op nil = Some v.
Proof.
intros. inversion H. inversion H6.
intuition. congruence.
Qed.
Lemma inv_eval_Eop_1:
- forall sp le e1 m1 op a1 e2 m2 v,
- eval_expr ge sp le e1 m1 (Eop op (a1 ::: Enil)) e2 m2 v ->
+ forall sp le e1 m1 op t a1 e2 m2 v,
+ eval_expr ge sp le e1 m1 (Eop op (a1 ::: Enil)) t e2 m2 v ->
exists v1,
- eval_expr ge sp le e1 m1 a1 e2 m2 v1 /\
+ eval_expr ge sp le e1 m1 a1 t e2 m2 v1 /\
eval_operation ge sp op (v1 :: nil) = Some v.
Proof.
intros.
- inversion H. inversion H6. inversion H21.
- subst e4; subst m4. subst e6; subst m6.
- exists v1; intuition. congruence.
+ inversion H. inversion H6. inversion H19.
+ subst. exists v1; intuition. rewrite E0_right. auto.
Qed.
Lemma inv_eval_Eop_2:
- forall sp le e1 m1 op a1 a2 e3 m3 v,
- eval_expr ge sp le e1 m1 (Eop op (a1 ::: a2 ::: Enil)) e3 m3 v ->
- exists e2, exists m2, exists v1, exists v2,
- eval_expr ge sp le e1 m1 a1 e2 m2 v1 /\
- eval_expr ge sp le e2 m2 a2 e3 m3 v2 /\
+ forall sp le e1 m1 op a1 a2 t3 e3 m3 v,
+ eval_expr ge sp le e1 m1 (Eop op (a1 ::: a2 ::: Enil)) t3 e3 m3 v ->
+ exists t1, exists t2, exists e2, exists m2, exists v1, exists v2,
+ eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 /\
+ eval_expr ge sp le e2 m2 a2 t2 e3 m3 v2 /\
+ t3 = t1 ** t2 /\
eval_operation ge sp op (v1 :: v2 :: nil) = Some v.
Proof.
intros.
- inversion H. inversion H6. inversion H21. inversion H32.
- subst e7; subst m7. subst e9; subst m9.
- exists e4; exists m4; exists v1; exists v2. intuition. congruence.
+ inversion H. subst. inversion H6. subst. inversion H8. subst.
+ inversion H10. subst.
+ exists t1; exists t0; exists e0; exists m0; exists v0; exists v1.
+ intuition. traceEq.
Qed.
Ltac SimplEval :=
match goal with
- | [ |- (eval_expr _ ?sp ?le ?e1 ?m1 (Eop ?op Enil) ?e2 ?m2 ?v) -> _] =>
+ | [ |- (eval_expr _ ?sp ?le ?e1 ?m1 (Eop ?op Enil) ?t ?e2 ?m2 ?v) -> _] =>
intro XX1;
- generalize (inv_eval_Eop_0 sp le e1 m1 op e2 m2 v XX1);
+ generalize (inv_eval_Eop_0 sp le e1 m1 op t e2 m2 v XX1);
clear XX1;
- intros [XX1 [XX2 XX3]];
- subst e2; subst m2; simpl in XX3;
- try (simplify_eq XX3; clear XX3;
+ intros [XX1 [XX2 [XX3 XX4]]];
+ subst t e2 m2; simpl in XX4;
+ try (simplify_eq XX4; clear XX4;
let EQ := fresh "EQ" in (intro EQ; rewrite EQ))
- | [ |- (eval_expr _ ?sp ?le ?e1 ?m1 (Eop ?op (?a1 ::: Enil)) ?e2 ?m2 ?v) -> _] =>
+ | [ |- (eval_expr _ ?sp ?le ?e1 ?m1 (Eop ?op (?a1 ::: Enil)) ?t ?e2 ?m2 ?v) -> _] =>
intro XX1;
- generalize (inv_eval_Eop_1 sp le e1 m1 op a1 e2 m2 v XX1);
+ generalize (inv_eval_Eop_1 sp le e1 m1 op t a1 e2 m2 v XX1);
clear XX1;
let v1 := fresh "v" in let EV := fresh "EV" in
let EQ := fresh "EQ" in
(intros [v1 [EV EQ]]; simpl in EQ)
- | [ |- (eval_expr _ ?sp ?le ?e1 ?m1 (Eop ?op (?a1 ::: ?a2 ::: Enil)) ?e2 ?m2 ?v) -> _] =>
+ | [ |- (eval_expr _ ?sp ?le ?e1 ?m1 (Eop ?op (?a1 ::: ?a2 ::: Enil)) ?t ?e2 ?m2 ?v) -> _] =>
intro XX1;
- generalize (inv_eval_Eop_2 sp le e1 m1 op a1 a2 e2 m2 v XX1);
+ generalize (inv_eval_Eop_2 sp le e1 m1 op a1 a2 t e2 m2 v XX1);
clear XX1;
+ let t1 := fresh "t" in let t2 := fresh "t" in
let e := fresh "e" in let m := fresh "m" in
let v1 := fresh "v" in let v2 := fresh "v" in
let EV1 := fresh "EV" in let EV2 := fresh "EV" in
- let EQ := fresh "EQ" in
- (intros [e [m [v1 [v2 [EV1 [EV2 EQ]]]]]]; simpl in EQ)
+ let EQ := fresh "EQ" in let TR := fresh "TR" in
+ (intros [t1 [t2 [e [m [v1 [v2 [EV1 [EV2 [TR EQ]]]]]]]]]; simpl in EQ)
| _ => idtac
end.
@@ -209,57 +245,57 @@ Ltac InvEval H :=
*)
Theorem eval_negint:
- forall sp le e1 m1 a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (negint a) e2 m2 (Vint (Int.neg x)).
+ forall sp le e1 m1 a t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) ->
+ eval_expr ge sp le e1 m1 (negint a) t e2 m2 (Vint (Int.neg x)).
Proof.
TrivialOp negint.
Qed.
Theorem eval_negfloat:
- forall sp le e1 m1 a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) ->
- eval_expr ge sp le e1 m1 (negfloat a) e2 m2 (Vfloat (Float.neg x)).
+ forall sp le e1 m1 a t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vfloat x) ->
+ eval_expr ge sp le e1 m1 (negfloat a) t e2 m2 (Vfloat (Float.neg x)).
Proof.
TrivialOp negfloat.
Qed.
Theorem eval_absfloat:
- forall sp le e1 m1 a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) ->
- eval_expr ge sp le e1 m1 (absfloat a) e2 m2 (Vfloat (Float.abs x)).
+ forall sp le e1 m1 a t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vfloat x) ->
+ eval_expr ge sp le e1 m1 (absfloat a) t e2 m2 (Vfloat (Float.abs x)).
Proof.
TrivialOp absfloat.
Qed.
Theorem eval_intoffloat:
- forall sp le e1 m1 a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) ->
- eval_expr ge sp le e1 m1 (intoffloat a) e2 m2 (Vint (Float.intoffloat x)).
+ forall sp le e1 m1 a t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vfloat x) ->
+ eval_expr ge sp le e1 m1 (intoffloat a) t e2 m2 (Vint (Float.intoffloat x)).
Proof.
TrivialOp intoffloat.
Qed.
Theorem eval_floatofint:
- forall sp le e1 m1 a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (floatofint a) e2 m2 (Vfloat (Float.floatofint x)).
+ forall sp le e1 m1 a t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) ->
+ eval_expr ge sp le e1 m1 (floatofint a) t e2 m2 (Vfloat (Float.floatofint x)).
Proof.
TrivialOp floatofint.
Qed.
Theorem eval_floatofintu:
- forall sp le e1 m1 a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (floatofintu a) e2 m2 (Vfloat (Float.floatofintu x)).
+ forall sp le e1 m1 a t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) ->
+ eval_expr ge sp le e1 m1 (floatofintu a) t e2 m2 (Vfloat (Float.floatofintu x)).
Proof.
TrivialOp floatofintu.
Qed.
Theorem eval_notint:
- forall sp le e1 m1 a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (notint a) e2 m2 (Vint (Int.not x)).
+ forall sp le e1 m1 a t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) ->
+ eval_expr ge sp le e1 m1 (notint a) t e2 m2 (Vint (Int.not x)).
Proof.
unfold notint; intros until x; case (notint_match a); intros.
InvEval H. FuncInv. EvalOp. simpl. congruence.
@@ -269,15 +305,15 @@ Proof.
eapply eval_Eop.
eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity.
eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity.
- apply eval_Enil.
- simpl. rewrite Int.or_idem. auto.
+ apply eval_Enil. reflexivity. reflexivity.
+ simpl. rewrite Int.or_idem. auto. traceEq.
Qed.
Lemma eval_notbool_base:
- forall sp le e1 m1 a e2 m2 v b,
- eval_expr ge sp le e1 m1 a e2 m2 v ->
+ forall sp le e1 m1 a t e2 m2 v b,
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
Val.bool_of_val v b ->
- eval_expr ge sp le e1 m1 (notbool_base a) e2 m2 (Val.of_bool (negb b)).
+ eval_expr ge sp le e1 m1 (notbool_base a) t e2 m2 (Val.of_bool (negb b)).
Proof.
TrivialOp notbool_base. simpl.
inversion H0.
@@ -290,10 +326,10 @@ Hint Resolve Val.bool_of_true_val Val.bool_of_false_val
Val.bool_of_true_val_inv Val.bool_of_false_val_inv: valboolof.
Theorem eval_notbool:
- forall a sp le e1 m1 e2 m2 v b,
- eval_expr ge sp le e1 m1 a e2 m2 v ->
+ forall a sp le e1 m1 t e2 m2 v b,
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
Val.bool_of_val v b ->
- eval_expr ge sp le e1 m1 (notbool a) e2 m2 (Val.of_bool (negb b)).
+ eval_expr ge sp le e1 m1 (notbool a) t e2 m2 (Val.of_bool (negb b)).
Proof.
assert (N1: forall v b, Val.is_false v -> Val.bool_of_val v b -> Val.is_true (Val.of_bool (negb b))).
intros. inversion H0; simpl; auto; subst v; simpl in H.
@@ -305,34 +341,33 @@ Proof.
induction a; simpl; intros; try (eapply eval_notbool_base; eauto).
destruct o; try (eapply eval_notbool_base; eauto).
- destruct e. inversion H. inversion H7. subst vl.
- simpl in H11. inversion H11. subst v0; subst v.
+ destruct e. InvEval H. injection XX4; clear XX4; intro; subst v.
inversion H0. rewrite Int.eq_false; auto.
simpl; eauto with evalexpr.
rewrite Int.eq_true; simpl; eauto with evalexpr.
eapply eval_notbool_base; eauto.
- inversion H. subst sp0 le0 e0 m op al e3 m0 v0.
- simpl in H11. eapply eval_Eop; eauto.
+ inversion H. subst.
+ simpl in H12. eapply eval_Eop; eauto.
simpl. caseEq (eval_condition c vl); intros.
- rewrite H1 in H11.
+ rewrite H1 in H12.
assert (b0 = b).
- destruct b0; inversion H11; subst v; inversion H0; auto.
+ destruct b0; inversion H12; subst v; inversion H0; auto.
subst b0. rewrite (Op.eval_negate_condition _ _ H1).
destruct b; reflexivity.
- rewrite H1 in H11; discriminate.
+ rewrite H1 in H12; discriminate.
inversion H; eauto 10 with evalexpr valboolof.
inversion H; eauto 10 with evalexpr valboolof.
- inversion H. eapply eval_Econdition. eexact H11.
- destruct v1; eauto.
+ inversion H. subst. eapply eval_Econdition with (t2 := t8). eexact H36.
+ destruct v4; eauto. auto.
Qed.
Theorem eval_addimm:
- forall sp le e1 m1 n a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (addimm n a) e2 m2 (Vint (Int.add x n)).
+ forall sp le e1 m1 n a t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) ->
+ eval_expr ge sp le e1 m1 (addimm n a) t e2 m2 (Vint (Int.add x n)).
Proof.
unfold addimm; intros until x.
generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro.
@@ -341,16 +376,16 @@ Proof.
InvEval H0. EvalOp. simpl. rewrite Int.add_commut. auto.
InvEval H0. destruct (Genv.find_symbol ge s); discriminate.
InvEval H0.
- destruct sp; simpl in XX3; discriminate.
+ destruct sp; simpl in XX4; discriminate.
InvEval H0. FuncInv. EvalOp. simpl. subst x.
rewrite Int.add_assoc. decEq; decEq; decEq. apply Int.add_commut.
EvalOp.
Qed.
Theorem eval_addimm_ptr:
- forall sp le e1 m1 n a e2 m2 b ofs,
- eval_expr ge sp le e1 m1 a e2 m2 (Vptr b ofs) ->
- eval_expr ge sp le e1 m1 (addimm n a) e2 m2 (Vptr b (Int.add ofs n)).
+ forall sp le e1 m1 n t a e2 m2 b ofs,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vptr b ofs) ->
+ eval_expr ge sp le e1 m1 (addimm n a) t e2 m2 (Vptr b (Int.add ofs n)).
Proof.
unfold addimm; intros until ofs.
generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro.
@@ -361,8 +396,8 @@ Proof.
destruct (Genv.find_symbol ge s).
rewrite Int.add_commut. congruence.
discriminate.
- InvEval H0. destruct sp; simpl in XX3; try discriminate.
- inversion XX3. EvalOp. simpl. decEq. decEq.
+ InvEval H0. destruct sp; simpl in XX4; try discriminate.
+ inversion XX4. EvalOp. simpl. decEq. decEq.
rewrite Int.add_assoc. decEq. apply Int.add_commut.
InvEval H0. FuncInv. subst b0; subst ofs. EvalOp. simpl.
rewrite (Int.add_commut n m). rewrite Int.add_assoc. auto.
@@ -370,13 +405,14 @@ Proof.
Qed.
Theorem eval_add:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
- eval_expr ge sp le e1 m1 (add a b) e3 m3 (Vint (Int.add x y)).
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
+ eval_expr ge sp le e1 m1 (add a b) (t1**t2) e3 m3 (Vint (Int.add x y)).
Proof.
intros until y. unfold add; case (add_match a b); intros.
- InvEval H. rewrite Int.add_commut. apply eval_addimm. assumption.
+ InvEval H. rewrite Int.add_commut. apply eval_addimm.
+ rewrite E0_left; assumption.
InvEval H. FuncInv. InvEval H0. FuncInv.
replace (Int.add x y) with (Int.add (Int.add i i0) (Int.add n1 n2)).
apply eval_addimm. EvalOp.
@@ -387,7 +423,7 @@ Proof.
apply eval_addimm. EvalOp.
subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut.
InvEval H0. FuncInv.
- apply eval_addimm. auto.
+ apply eval_addimm. rewrite E0_right. auto.
InvEval H0. FuncInv.
replace (Int.add x y) with (Int.add (Int.add x i) n2).
apply eval_addimm. EvalOp.
@@ -396,10 +432,10 @@ Proof.
Qed.
Theorem eval_add_ptr:
- forall sp le e1 m1 a e2 m2 p x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vptr p x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
- eval_expr ge sp le e1 m1 (add a b) e3 m3 (Vptr p (Int.add x y)).
+ forall sp le e1 m1 a t1 e2 m2 p x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vptr p x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
+ eval_expr ge sp le e1 m1 (add a b) (t1**t2) e3 m3 (Vptr p (Int.add x y)).
Proof.
intros until y. unfold add; case (add_match a b); intros.
InvEval H.
@@ -412,7 +448,7 @@ Proof.
replace (Int.add x y) with (Int.add (Int.add i y) n1).
apply eval_addimm_ptr. subst b0. EvalOp.
subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut.
- InvEval H0. apply eval_addimm_ptr. auto.
+ InvEval H0. apply eval_addimm_ptr. rewrite E0_right. auto.
InvEval H0. FuncInv.
replace (Int.add x y) with (Int.add (Int.add x i) n2).
apply eval_addimm_ptr. EvalOp.
@@ -421,14 +457,14 @@ Proof.
Qed.
Theorem eval_add_ptr_2:
- forall sp le e1 m1 a e2 m2 p x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vptr p y) ->
- eval_expr ge sp le e1 m1 (add a b) e3 m3 (Vptr p (Int.add y x)).
+ forall sp le e1 m1 a t1 e2 m2 p x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vptr p y) ->
+ eval_expr ge sp le e1 m1 (add a b) (t1**t2) e3 m3 (Vptr p (Int.add y x)).
Proof.
intros until y. unfold add; case (add_match a b); intros.
InvEval H.
- apply eval_addimm_ptr. auto.
+ apply eval_addimm_ptr. rewrite E0_left. auto.
InvEval H. FuncInv. InvEval H0. FuncInv.
replace (Int.add y x) with (Int.add (Int.add i0 i) (Int.add n1 n2)).
apply eval_addimm_ptr. subst b0. EvalOp.
@@ -448,15 +484,15 @@ Proof.
Qed.
Theorem eval_sub:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
- eval_expr ge sp le e1 m1 (sub a b) e3 m3 (Vint (Int.sub x y)).
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
+ eval_expr ge sp le e1 m1 (sub a b) (t1**t2) e3 m3 (Vint (Int.sub x y)).
Proof.
intros until y.
unfold sub; case (sub_match a b); intros.
InvEval H0. rewrite Int.sub_add_opp.
- apply eval_addimm. assumption.
+ apply eval_addimm. rewrite E0_right. assumption.
InvEval H. FuncInv. InvEval H0. FuncInv.
replace (Int.sub x y) with (Int.add (Int.sub i i0) (Int.sub n1 n2)).
apply eval_addimm. EvalOp.
@@ -476,15 +512,15 @@ Proof.
Qed.
Theorem eval_sub_ptr_int:
- forall sp le e1 m1 a e2 m2 p x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vptr p x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
- eval_expr ge sp le e1 m1 (sub a b) e3 m3 (Vptr p (Int.sub x y)).
+ forall sp le e1 m1 a t1 e2 m2 p x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vptr p x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
+ eval_expr ge sp le e1 m1 (sub a b) (t1**t2) e3 m3 (Vptr p (Int.sub x y)).
Proof.
intros until y.
unfold sub; case (sub_match a b); intros.
InvEval H0. rewrite Int.sub_add_opp.
- apply eval_addimm_ptr. assumption.
+ apply eval_addimm_ptr. rewrite E0_right. assumption.
InvEval H. FuncInv. InvEval H0. FuncInv.
subst b0.
replace (Int.sub x y) with (Int.add (Int.sub i i0) (Int.sub n1 n2)).
@@ -505,10 +541,10 @@ Proof.
Qed.
Theorem eval_sub_ptr_ptr:
- forall sp le e1 m1 a e2 m2 p x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vptr p x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vptr p y) ->
- eval_expr ge sp le e1 m1 (sub a b) e3 m3 (Vint (Int.sub x y)).
+ forall sp le e1 m1 a t1 e2 m2 p x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vptr p x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vptr p y) ->
+ eval_expr ge sp le e1 m1 (sub a b) (t1**t2) e3 m3 (Vint (Int.sub x y)).
Proof.
intros until y.
unfold sub; case (sub_match a b); intros.
@@ -535,9 +571,9 @@ Proof.
Qed.
Lemma eval_rolm:
- forall sp le e1 m1 a amount mask e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (rolm a amount mask) e2 m2 (Vint (Int.rolm x amount mask)).
+ forall sp le e1 m1 a amount mask t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) ->
+ eval_expr ge sp le e1 m1 (rolm a amount mask) t e2 m2 (Vint (Int.rolm x amount mask)).
Proof.
intros until x. unfold rolm; case (rolm_match a); intros.
InvEval H. eauto with evalexpr.
@@ -554,10 +590,10 @@ Proof.
Qed.
Theorem eval_shlimm:
- forall sp le e1 m1 a n e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
+ forall sp le e1 m1 a n t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) ->
Int.ltu n (Int.repr 32) = true ->
- eval_expr ge sp le e1 m1 (shlimm a n) e2 m2 (Vint (Int.shl x n)).
+ eval_expr ge sp le e1 m1 (shlimm a n) t e2 m2 (Vint (Int.shl x n)).
Proof.
intros. unfold shlimm.
generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro.
@@ -568,10 +604,10 @@ Proof.
Qed.
Theorem eval_shruimm:
- forall sp le e1 m1 a n e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
+ forall sp le e1 m1 a n t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) ->
Int.ltu n (Int.repr 32) = true ->
- eval_expr ge sp le e1 m1 (shruimm a n) e2 m2 (Vint (Int.shru x n)).
+ eval_expr ge sp le e1 m1 (shruimm a n) t e2 m2 (Vint (Int.shru x n)).
Proof.
intros. unfold shruimm.
generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro.
@@ -582,9 +618,9 @@ Proof.
Qed.
Lemma eval_mulimm_base:
- forall sp le e1 m1 a n e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (mulimm_base n a) e2 m2 (Vint (Int.mul x n)).
+ forall sp le e1 m1 a t n e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) ->
+ eval_expr ge sp le e1 m1 (mulimm_base n a) t e2 m2 (Vint (Int.mul x n)).
Proof.
intros; unfold mulimm_base.
generalize (Int.one_bits_decomp n).
@@ -597,7 +633,7 @@ Proof.
rewrite Int.add_zero. rewrite <- Int.shl_mul.
apply eval_shlimm. auto. auto with coqlib.
destruct l.
- intros. apply eval_Elet with e2 m2 (Vint x). auto.
+ intros. apply eval_Elet with t e2 m2 (Vint x) E0. auto.
rewrite H1. simpl. rewrite Int.add_zero.
rewrite Int.mul_add_distr_r.
rewrite <- Int.shl_mul.
@@ -609,18 +645,19 @@ Proof.
apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity.
auto with coqlib.
auto with evalexpr.
- reflexivity.
+ reflexivity. traceEq. reflexivity. traceEq.
intros. EvalOp.
Qed.
Theorem eval_mulimm:
- forall sp le e1 m1 a n e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (mulimm n a) e2 m2 (Vint (Int.mul x n)).
+ forall sp le e1 m1 a n t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) ->
+ eval_expr ge sp le e1 m1 (mulimm n a) t e2 m2 (Vint (Int.mul x n)).
Proof.
intros until x; unfold mulimm.
generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro.
- subst n. rewrite Int.mul_zero. eauto with evalexpr.
+ subst n. rewrite Int.mul_zero.
+ intro. eapply eval_Elet; eauto with evalexpr. traceEq.
generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intro.
subst n. rewrite Int.mul_one. auto.
case (mulimm_match a); intros.
@@ -633,24 +670,25 @@ Proof.
Qed.
Theorem eval_mul:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
- eval_expr ge sp le e1 m1 (mul a b) e3 m3 (Vint (Int.mul x y)).
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
+ eval_expr ge sp le e1 m1 (mul a b) (t1**t2) e3 m3 (Vint (Int.mul x y)).
Proof.
intros until y.
unfold mul; case (mul_match a b); intros.
- InvEval H. rewrite Int.mul_commut. apply eval_mulimm. auto.
- InvEval H0. apply eval_mulimm. auto.
+ InvEval H. rewrite Int.mul_commut. apply eval_mulimm.
+ rewrite E0_left; auto.
+ InvEval H0. rewrite E0_right. apply eval_mulimm. auto.
EvalOp.
Qed.
Theorem eval_divs:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
y <> Int.zero ->
- eval_expr ge sp le e1 m1 (divs a b) e3 m3 (Vint (Int.divs x y)).
+ eval_expr ge sp le e1 m1 (divs a b) (t1**t2) e3 m3 (Vint (Int.divs x y)).
Proof.
TrivialOp divs. simpl.
predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto.
@@ -662,11 +700,11 @@ Lemma eval_mod_aux:
y <> Int.zero ->
eval_operation ge sp divop (Vint x :: Vint y :: nil) =
Some (Vint (semdivop x y))) ->
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
y <> Int.zero ->
- eval_expr ge sp le e1 m1 (mod_aux divop a b) e3 m3
+ eval_expr ge sp le e1 m1 (mod_aux divop a b) (t1**t2) e3 m3
(Vint (Int.sub x (Int.mul (semdivop x y) y))).
Proof.
intros; unfold mod_aux.
@@ -678,18 +716,21 @@ Proof.
eapply eval_Econs. eapply eval_Eop.
eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity.
eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity.
- apply eval_Enil. apply H. assumption.
+ apply eval_Enil. reflexivity. reflexivity.
+ apply H. assumption.
eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity.
- apply eval_Enil. simpl; reflexivity. apply eval_Enil.
- reflexivity.
+ apply eval_Enil. reflexivity. reflexivity.
+ simpl; reflexivity. apply eval_Enil.
+ reflexivity. reflexivity. reflexivity.
+ reflexivity. traceEq.
Qed.
Theorem eval_mods:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
y <> Int.zero ->
- eval_expr ge sp le e1 m1 (mods a b) e3 m3 (Vint (Int.mods x y)).
+ eval_expr ge sp le e1 m1 (mods a b) (t1**t2) e3 m3 (Vint (Int.mods x y)).
Proof.
intros; unfold mods.
rewrite Int.mods_divs.
@@ -699,44 +740,44 @@ Proof.
Qed.
Lemma eval_divu_base:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
y <> Int.zero ->
- eval_expr ge sp le e1 m1 (Eop Odivu (a ::: b ::: Enil)) e3 m3 (Vint (Int.divu x y)).
+ eval_expr ge sp le e1 m1 (Eop Odivu (a ::: b ::: Enil)) (t1**t2) e3 m3 (Vint (Int.divu x y)).
Proof.
intros. EvalOp. simpl.
predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto.
Qed.
Theorem eval_divu:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
y <> Int.zero ->
- eval_expr ge sp le e1 m1 (divu a b) e3 m3 (Vint (Int.divu x y)).
+ eval_expr ge sp le e1 m1 (divu a b) (t1**t2) e3 m3 (Vint (Int.divu x y)).
Proof.
intros until y.
unfold divu; case (divu_match b); intros.
InvEval H0. caseEq (Int.is_power2 y).
intros. rewrite (Int.divu_pow2 x y i H0).
- apply eval_shruimm. auto.
+ apply eval_shruimm. rewrite E0_right. auto.
apply Int.is_power2_range with y. auto.
intros. subst n2. eapply eval_divu_base. eexact H. EvalOp. auto.
eapply eval_divu_base; eauto.
Qed.
Theorem eval_modu:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
y <> Int.zero ->
- eval_expr ge sp le e1 m1 (modu a b) e3 m3 (Vint (Int.modu x y)).
+ eval_expr ge sp le e1 m1 (modu a b) (t1**t2) e3 m3 (Vint (Int.modu x y)).
Proof.
intros until y; unfold modu; case (divu_match b); intros.
InvEval H0. caseEq (Int.is_power2 y).
intros. rewrite (Int.modu_and x y i H0).
- rewrite <- Int.rolm_zero. apply eval_rolm. auto.
+ rewrite <- Int.rolm_zero. apply eval_rolm. rewrite E0_right; auto.
intro. rewrite Int.modu_divu. eapply eval_mod_aux.
intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero.
contradiction. auto.
@@ -748,9 +789,9 @@ Proof.
Qed.
Theorem eval_andimm:
- forall sp le e1 m1 n a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (andimm n a) e2 m2 (Vint (Int.and x n)).
+ forall sp le e1 m1 n a t e2 m2 x,
+ eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) ->
+ eval_expr ge sp le e1 m1 (andimm n a) t e2 m2 (Vint (Int.and x n)).
Proof.
intros. unfold andimm. case (Int.is_rlw_mask n).
rewrite <- Int.rolm_zero. apply eval_rolm; auto.
@@ -758,25 +799,26 @@ Proof.
Qed.
Theorem eval_and:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
- eval_expr ge sp le e1 m1 (and a b) e3 m3 (Vint (Int.and x y)).
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
+ eval_expr ge sp le e1 m1 (and a b) (t1**t2) e3 m3 (Vint (Int.and x y)).
Proof.
intros until y; unfold and; case (mul_match a b); intros.
- InvEval H. rewrite Int.and_commut. apply eval_andimm; auto.
- InvEval H0. apply eval_andimm; auto.
+ InvEval H. rewrite Int.and_commut.
+ rewrite E0_left; apply eval_andimm; auto.
+ InvEval H0. rewrite E0_right; apply eval_andimm; auto.
EvalOp.
Qed.
Remark eval_same_expr_pure:
- forall a1 a2 sp le e1 m1 e2 m2 v1 e3 m3 v2,
+ forall a1 a2 sp le e1 m1 t1 e2 m2 v1 t2 e3 m3 v2,
same_expr_pure a1 a2 = true ->
- eval_expr ge sp le e1 m1 a1 e2 m2 v1 ->
- eval_expr ge sp le e2 m2 a2 e3 m3 v2 ->
- a2 = a1 /\ v2 = v1 /\ e2 = e1 /\ m2 = m1.
+ eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 ->
+ eval_expr ge sp le e2 m2 a2 t2 e3 m3 v2 ->
+ t1 = E0 /\ t2 = E0 /\ a2 = a1 /\ v2 = v1 /\ e2 = e1 /\ m2 = m1.
Proof.
- intros until v1.
+ intros until v2.
destruct a1; simpl; try (intros; discriminate).
destruct a2; simpl; try (intros; discriminate).
case (ident_eq i i0); intros.
@@ -786,22 +828,20 @@ Proof.
Qed.
Lemma eval_or:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
- eval_expr ge sp le e1 m1 (or a b) e3 m3 (Vint (Int.or x y)).
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
+ eval_expr ge sp le e1 m1 (or a b) (t1**t2) e3 m3 (Vint (Int.or x y)).
Proof.
intros until y; unfold or; case (or_match a b); intros.
generalize (Int.eq_spec amount1 amount2); case (Int.eq amount1 amount2); intro.
case (Int.is_rlw_mask (Int.or mask1 mask2)).
- caseEq (same_expr_pure t1 t2); intro.
+ caseEq (same_expr_pure t0 t3); intro.
simpl. InvEval H. FuncInv. InvEval H0. FuncInv.
- generalize (eval_same_expr_pure _ _ _ _ _ _ _ _ _ _ _ _ H2 EV EV0).
- intros [EQ1 [EQ2 [EQ3 EQ4]]].
- injection EQ2; intro EQ5.
- subst t2; subst e2; subst m2; subst i0.
- EvalOp. simpl. subst x; subst y; subst amount2.
- rewrite Int.or_rolm. auto.
+ generalize (eval_same_expr_pure _ _ _ _ _ _ _ _ _ _ _ _ _ _ H2 EV EV0).
+ intros [EQ1 [EQ2 [EQ3 [EQ4 [EQ5 EQ6]]]]].
+ injection EQ4; intro EQ7. subst.
+ EvalOp. simpl. rewrite Int.or_rolm. auto.
simpl. EvalOp.
simpl. EvalOp.
simpl. EvalOp.
@@ -809,173 +849,184 @@ Proof.
Qed.
Theorem eval_xor:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
- eval_expr ge sp le e1 m1 (xor a b) e3 m3 (Vint (Int.xor x y)).
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
+ eval_expr ge sp le e1 m1 (xor a b) (t1**t2) e3 m3 (Vint (Int.xor x y)).
Proof. TrivialOp xor. Qed.
Theorem eval_shl:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
Int.ltu y (Int.repr 32) = true ->
- eval_expr ge sp le e1 m1 (shl a b) e3 m3 (Vint (Int.shl x y)).
+ eval_expr ge sp le e1 m1 (shl a b) (t1**t2) e3 m3 (Vint (Int.shl x y)).
Proof.
intros until y; unfold shl; case (shift_match b); intros.
- InvEval H0. apply eval_shlimm; auto.
+ InvEval H0. rewrite E0_right. apply eval_shlimm; auto.
EvalOp. simpl. rewrite H1. auto.
Qed.
Theorem eval_shr:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
Int.ltu y (Int.repr 32) = true ->
- eval_expr ge sp le e1 m1 (shr a b) e3 m3 (Vint (Int.shr x y)).
+ eval_expr ge sp le e1 m1 (shr a b) (t1**t2) e3 m3 (Vint (Int.shr x y)).
Proof.
TrivialOp shr. simpl. rewrite H1. auto.
Qed.
Theorem eval_shru:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
Int.ltu y (Int.repr 32) = true ->
- eval_expr ge sp le e1 m1 (shru a b) e3 m3 (Vint (Int.shru x y)).
+ eval_expr ge sp le e1 m1 (shru a b) (t1**t2) e3 m3 (Vint (Int.shru x y)).
Proof.
intros until y; unfold shru; case (shift_match b); intros.
- InvEval H0. apply eval_shruimm; auto.
+ InvEval H0. rewrite E0_right; apply eval_shruimm; auto.
EvalOp. simpl. rewrite H1. auto.
Qed.
Theorem eval_addf:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vfloat y) ->
- eval_expr ge sp le e1 m1 (addf a b) e3 m3 (Vfloat (Float.add x y)).
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vfloat x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vfloat y) ->
+ eval_expr ge sp le e1 m1 (addf a b) (t1**t2) e3 m3 (Vfloat (Float.add x y)).
Proof.
intros until y; unfold addf; case (addf_match a b); intros.
- InvEval H. FuncInv. EvalOp. simpl. subst x. reflexivity.
+ InvEval H. FuncInv. EvalOp.
+ econstructor; eauto. econstructor; eauto. econstructor; eauto. constructor.
+ traceEq. simpl. subst x. reflexivity.
InvEval H0. FuncInv. eapply eval_Elet. eexact H. EvalOp.
- eapply eval_Econs. apply eval_lift. eexact EV.
- eapply eval_Econs. apply eval_lift. eexact EV0.
- eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity.
- apply eval_Enil.
- subst y. rewrite Float.addf_commut. reflexivity.
+ econstructor; eauto with evalexpr.
+ econstructor; eauto with evalexpr.
+ econstructor. apply eval_Eletvar. simpl; reflexivity.
+ constructor. reflexivity. traceEq.
+ subst y. rewrite Float.addf_commut. reflexivity. auto.
EvalOp.
Qed.
Theorem eval_subf:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vfloat y) ->
- eval_expr ge sp le e1 m1 (subf a b) e3 m3 (Vfloat (Float.sub x y)).
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vfloat x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vfloat y) ->
+ eval_expr ge sp le e1 m1 (subf a b) (t1**t2) e3 m3 (Vfloat (Float.sub x y)).
Proof.
intros until y; unfold subf; case (subf_match a b); intros.
- InvEval H. FuncInv. EvalOp. subst x. reflexivity.
+ InvEval H. FuncInv. EvalOp.
+ econstructor; eauto. econstructor; eauto. econstructor; eauto. constructor.
+ traceEq. subst x. reflexivity.
EvalOp.
Qed.
Theorem eval_mulf:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vfloat y) ->
- eval_expr ge sp le e1 m1 (mulf a b) e3 m3 (Vfloat (Float.mul x y)).
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vfloat x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vfloat y) ->
+ eval_expr ge sp le e1 m1 (mulf a b) (t1**t2) e3 m3 (Vfloat (Float.mul x y)).
Proof. TrivialOp mulf. Qed.
Theorem eval_divf:
- forall sp le e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vfloat y) ->
- eval_expr ge sp le e1 m1 (divf a b) e3 m3 (Vfloat (Float.div x y)).
+ forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vfloat x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vfloat y) ->
+ eval_expr ge sp le e1 m1 (divf a b) (t1**t2) e3 m3 (Vfloat (Float.div x y)).
Proof. TrivialOp divf. Qed.
Theorem eval_cast8signed:
- forall sp le e1 m1 a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (cast8signed a) e2 m2 (Vint (Int.cast8signed x)).
+ forall sp le e1 m1 a t e2 m2 v,
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
+ eval_expr ge sp le e1 m1 (cast8signed a) t e2 m2 (Val.cast8signed v).
Proof.
- intros until x; unfold cast8signed; case (cast8signed_match a); intros.
- InvEval H. FuncInv. EvalOp. subst x. rewrite Int.cast8_signed_idem. reflexivity.
+ intros until v; unfold cast8signed; case (cast8signed_match a); intros.
+ replace (Val.cast8signed v) with v. auto.
+ InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast8_signed_idem. reflexivity.
EvalOp.
Qed.
Theorem eval_cast8unsigned:
- forall sp le e1 m1 a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (cast8unsigned a) e2 m2 (Vint (Int.cast8unsigned x)).
+ forall sp le e1 m1 a t e2 m2 v,
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
+ eval_expr ge sp le e1 m1 (cast8unsigned a) t e2 m2 (Val.cast8unsigned v).
Proof.
- intros. unfold cast8unsigned. rewrite Int.cast8unsigned_and.
- rewrite <- Int.rolm_zero. eapply eval_rolm; eauto.
+ intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros.
+ replace (Val.cast8unsigned v) with v. auto.
+ InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast8_unsigned_idem. reflexivity.
+ EvalOp.
Qed.
-
+
Theorem eval_cast16signed:
- forall sp le e1 m1 a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (cast16signed a) e2 m2 (Vint (Int.cast16signed x)).
+ forall sp le e1 m1 a t e2 m2 v,
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
+ eval_expr ge sp le e1 m1 (cast16signed a) t e2 m2 (Val.cast16signed v).
Proof.
- intros until x; unfold cast16signed; case (cast16signed_match a); intros.
- InvEval H. FuncInv. EvalOp. subst x. rewrite Int.cast16_signed_idem. reflexivity.
+ intros until v; unfold cast16signed; case (cast16signed_match a); intros.
+ replace (Val.cast16signed v) with v. auto.
+ InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast16_signed_idem. reflexivity.
EvalOp.
Qed.
Theorem eval_cast16unsigned:
- forall sp le e1 m1 a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e1 m1 (cast16unsigned a) e2 m2 (Vint (Int.cast16unsigned x)).
+ forall sp le e1 m1 a t e2 m2 v,
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
+ eval_expr ge sp le e1 m1 (cast16unsigned a) t e2 m2 (Val.cast16unsigned v).
Proof.
- intros. unfold cast16unsigned. rewrite Int.cast16unsigned_and.
- rewrite <- Int.rolm_zero. eapply eval_rolm; eauto.
+ intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros.
+ replace (Val.cast16unsigned v) with v. auto.
+ InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast16_unsigned_idem. reflexivity.
+ EvalOp.
Qed.
Theorem eval_singleoffloat:
- forall sp le e1 m1 a e2 m2 x,
- eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) ->
- eval_expr ge sp le e1 m1 (singleoffloat a) e2 m2 (Vfloat (Float.singleoffloat x)).
+ forall sp le e1 m1 a t e2 m2 v,
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
+ eval_expr ge sp le e1 m1 (singleoffloat a) t e2 m2 (Val.singleoffloat v).
Proof.
- intros until x; unfold singleoffloat; case (singleoffloat_match a); intros.
- InvEval H. FuncInv. EvalOp. subst x. rewrite Float.singleoffloat_idem. reflexivity.
+ intros until v; unfold singleoffloat; case (singleoffloat_match a); intros.
+ replace (Val.singleoffloat v) with v. auto.
+ InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity.
EvalOp.
Qed.
Theorem eval_cmp:
- forall sp le c e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
- eval_expr ge sp le e1 m1 (cmp c a b) e3 m3 (Val.of_bool (Int.cmp c x y)).
+ forall sp le c e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
+ eval_expr ge sp le e1 m1 (cmp c a b) (t1**t2) e3 m3 (Val.of_bool (Int.cmp c x y)).
Proof.
TrivialOp cmp.
simpl. case (Int.cmp c x y); auto.
Qed.
Theorem eval_cmp_null_r:
- forall sp le c e1 m1 a e2 m2 p x b e3 m3 v,
- eval_expr ge sp le e1 m1 a e2 m2 (Vptr p x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint Int.zero) ->
+ forall sp le c e1 m1 a t1 e2 m2 p x b t2 e3 m3 v,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vptr p x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint Int.zero) ->
(c = Ceq /\ v = Vfalse) \/ (c = Cne /\ v = Vtrue) ->
- eval_expr ge sp le e1 m1 (cmp c a b) e3 m3 v.
+ eval_expr ge sp le e1 m1 (cmp c a b) (t1**t2) e3 m3 v.
Proof.
TrivialOp cmp.
simpl. elim H1; intros [EQ1 EQ2]; subst c; subst v; reflexivity.
Qed.
Theorem eval_cmp_null_l:
- forall sp le c e1 m1 a e2 m2 p x b e3 m3 v,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint Int.zero) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vptr p x) ->
+ forall sp le c e1 m1 a t1 e2 m2 p x b t2 e3 m3 v,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint Int.zero) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vptr p x) ->
(c = Ceq /\ v = Vfalse) \/ (c = Cne /\ v = Vtrue) ->
- eval_expr ge sp le e1 m1 (cmp c a b) e3 m3 v.
+ eval_expr ge sp le e1 m1 (cmp c a b) (t1**t2) e3 m3 v.
Proof.
TrivialOp cmp.
simpl. elim H1; intros [EQ1 EQ2]; subst c; subst v; reflexivity.
Qed.
Theorem eval_cmp_ptr:
- forall sp le c e1 m1 a e2 m2 p x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vptr p x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vptr p y) ->
- eval_expr ge sp le e1 m1 (cmp c a b) e3 m3 (Val.of_bool (Int.cmp c x y)).
+ forall sp le c e1 m1 a t1 e2 m2 p x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vptr p x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vptr p y) ->
+ eval_expr ge sp le e1 m1 (cmp c a b) (t1**t2) e3 m3 (Val.of_bool (Int.cmp c x y)).
Proof.
TrivialOp cmp.
simpl. unfold eq_block. rewrite zeq_true.
@@ -983,32 +1034,32 @@ Proof.
Qed.
Theorem eval_cmpu:
- forall sp le c e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vint x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vint y) ->
- eval_expr ge sp le e1 m1 (cmpu c a b) e3 m3 (Val.of_bool (Int.cmpu c x y)).
+ forall sp le c e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) ->
+ eval_expr ge sp le e1 m1 (cmpu c a b) (t1**t2) e3 m3 (Val.of_bool (Int.cmpu c x y)).
Proof.
TrivialOp cmpu.
simpl. case (Int.cmpu c x y); auto.
Qed.
Theorem eval_cmpf:
- forall sp le c e1 m1 a e2 m2 x b e3 m3 y,
- eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) ->
- eval_expr ge sp le e2 m2 b e3 m3 (Vfloat y) ->
- eval_expr ge sp le e1 m1 (cmpf c a b) e3 m3 (Val.of_bool (Float.cmp c x y)).
+ forall sp le c e1 m1 a t1 e2 m2 x b t2 e3 m3 y,
+ eval_expr ge sp le e1 m1 a t1 e2 m2 (Vfloat x) ->
+ eval_expr ge sp le e2 m2 b t2 e3 m3 (Vfloat y) ->
+ eval_expr ge sp le e1 m1 (cmpf c a b) (t1**t2) e3 m3 (Val.of_bool (Float.cmp c x y)).
Proof.
TrivialOp cmpf.
simpl. case (Float.cmp c x y); auto.
Qed.
Lemma eval_base_condition_of_expr:
- forall sp le a e1 m1 e2 m2 v (b: bool),
- eval_expr ge sp le e1 m1 a e2 m2 v ->
+ forall sp le a e1 m1 t e2 m2 v (b: bool),
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
Val.bool_of_val v b ->
eval_condexpr ge sp le e1 m1
(CEcond (Ccompuimm Cne Int.zero) (a ::: Enil))
- e2 m2 b.
+ t e2 m2 b.
Proof.
intros.
eapply eval_CEcond. eauto with evalexpr.
@@ -1016,62 +1067,60 @@ Proof.
Qed.
Lemma eval_condition_of_expr:
- forall a sp le e1 m1 e2 m2 v (b: bool),
- eval_expr ge sp le e1 m1 a e2 m2 v ->
+ forall a sp le e1 m1 t e2 m2 v (b: bool),
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
Val.bool_of_val v b ->
- eval_condexpr ge sp le e1 m1 (condexpr_of_expr a) e2 m2 b.
+ eval_condexpr ge sp le e1 m1 (condexpr_of_expr a) t e2 m2 b.
Proof.
induction a; simpl; intros;
try (eapply eval_base_condition_of_expr; eauto; fail).
destruct o; try (eapply eval_base_condition_of_expr; eauto; fail).
- destruct e. inversion H. subst sp0 le0 e m op al e0 m0 v0.
- inversion H7. subst sp0 le0 e m e1 m1 vl.
- simpl in H11. inversion H11; subst v.
+ destruct e. InvEval H. inversion XX4; subst v.
inversion H0.
rewrite Int.eq_false; auto. constructor.
subst i; rewrite Int.eq_true. constructor.
eapply eval_base_condition_of_expr; eauto.
- inversion H. eapply eval_CEcond; eauto. simpl in H11.
+ inversion H. subst. eapply eval_CEcond; eauto. simpl in H12.
destruct (eval_condition c vl); try discriminate.
- destruct b0; inversion H11; subst v0; subst v; inversion H0; congruence.
+ destruct b0; inversion H12; subst; inversion H0; congruence.
- inversion H.
+ inversion H. subst.
destruct v1; eauto with evalexpr.
Qed.
Theorem eval_conditionalexpr_true:
- forall sp le e1 m1 a1 e2 m2 v1 a2 e3 m3 v2 a3,
- eval_expr ge sp le e1 m1 a1 e2 m2 v1 ->
+ forall sp le e1 m1 a1 t1 e2 m2 v1 t2 a2 e3 m3 v2 a3,
+ eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 ->
Val.is_true v1 ->
- eval_expr ge sp le e2 m2 a2 e3 m3 v2 ->
- eval_expr ge sp le e1 m1 (conditionalexpr a1 a2 a3) e3 m3 v2.
+ eval_expr ge sp le e2 m2 a2 t2 e3 m3 v2 ->
+ eval_expr ge sp le e1 m1 (conditionalexpr a1 a2 a3) (t1**t2) e3 m3 v2.
Proof.
intros; unfold conditionalexpr.
- apply eval_Econdition with e2 m2 true; auto.
+ apply eval_Econdition with t1 e2 m2 true t2; auto.
eapply eval_condition_of_expr; eauto with valboolof.
Qed.
Theorem eval_conditionalexpr_false:
- forall sp le e1 m1 a1 e2 m2 v1 a2 e3 m3 v2 a3,
- eval_expr ge sp le e1 m1 a1 e2 m2 v1 ->
+ forall sp le e1 m1 a1 t1 e2 m2 v1 a2 t2 e3 m3 v2 a3,
+ eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 ->
Val.is_false v1 ->
- eval_expr ge sp le e2 m2 a3 e3 m3 v2 ->
- eval_expr ge sp le e1 m1 (conditionalexpr a1 a2 a3) e3 m3 v2.
+ eval_expr ge sp le e2 m2 a3 t2 e3 m3 v2 ->
+ eval_expr ge sp le e1 m1 (conditionalexpr a1 a2 a3) (t1**t2) e3 m3 v2.
Proof.
intros; unfold conditionalexpr.
- apply eval_Econdition with e2 m2 false; auto.
+ apply eval_Econdition with t1 e2 m2 false t2; auto.
eapply eval_condition_of_expr; eauto with valboolof.
Qed.
Lemma eval_addressing:
- forall sp le e1 m1 a e2 m2 v b ofs,
- eval_expr ge sp le e1 m1 a e2 m2 v ->
+ forall sp le e1 m1 a t e2 m2 v b ofs,
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
v = Vptr b ofs ->
match addressing a with (mode, args) =>
exists vl,
- eval_exprlist ge sp le e1 m1 args e2 m2 vl /\
+ eval_exprlist ge sp le e1 m1 args t e2 m2 vl /\
eval_addressing ge sp mode vl = Some v
end.
Proof.
@@ -1080,19 +1129,13 @@ Proof.
simpl. auto.
InvEval H. exists (@nil val). split. eauto with evalexpr.
simpl. auto.
- InvEval H. FuncInv.
+ InvEval H. InvEval EV. rewrite E0_left in TR. subst t1. FuncInv.
congruence.
- InvEval EV.
+ destruct (Genv.find_symbol ge s); congruence.
exists (Vint i0 :: nil). split. eauto with evalexpr.
simpl. subst v. destruct (Genv.find_symbol ge s). congruence.
discriminate.
InvEval H. FuncInv.
- destruct (Genv.find_symbol ge s); congruence.
- InvEval EV.
- exists (Vint i0 :: nil). split. eauto with evalexpr.
- simpl. destruct (Genv.find_symbol ge s). congruence.
- discriminate.
- InvEval H. FuncInv.
congruence.
exists (Vptr b0 i :: nil). split. eauto with evalexpr.
simpl. congruence.
@@ -1108,56 +1151,56 @@ Proof.
Qed.
Theorem eval_load:
- forall sp le e1 m1 a e2 m2 v chunk v',
- eval_expr ge sp le e1 m1 a e2 m2 v ->
+ forall sp le e1 m1 a t e2 m2 v chunk v',
+ eval_expr ge sp le e1 m1 a t e2 m2 v ->
Mem.loadv chunk m2 v = Some v' ->
- eval_expr ge sp le e1 m1 (load chunk a) e2 m2 v'.
+ eval_expr ge sp le e1 m1 (load chunk a) t e2 m2 v'.
Proof.
intros. generalize H0; destruct v; simpl; intro; try discriminate.
unfold load.
- generalize (eval_addressing _ _ _ _ _ _ _ _ _ _ H (refl_equal _)).
+ generalize (eval_addressing _ _ _ _ _ _ _ _ _ _ _ H (refl_equal _)).
destruct (addressing a). intros [vl [EV EQ]].
eapply eval_Eload; eauto.
Qed.
Theorem eval_store:
- forall sp le e1 m1 a1 e2 m2 v1 a2 e3 m3 v2 chunk m4,
- eval_expr ge sp le e1 m1 a1 e2 m2 v1 ->
- eval_expr ge sp le e2 m2 a2 e3 m3 v2 ->
+ forall sp le e1 m1 a1 t1 e2 m2 v1 a2 t2 e3 m3 v2 chunk m4,
+ eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 ->
+ eval_expr ge sp le e2 m2 a2 t2 e3 m3 v2 ->
Mem.storev chunk m3 v1 v2 = Some m4 ->
- eval_expr ge sp le e1 m1 (store chunk a1 a2) e3 m4 v2.
+ eval_expr ge sp le e1 m1 (store chunk a1 a2) (t1**t2) e3 m4 v2.
Proof.
intros. generalize H1; destruct v1; simpl; intro; try discriminate.
unfold store.
- generalize (eval_addressing _ _ _ _ _ _ _ _ _ _ H (refl_equal _)).
+ generalize (eval_addressing _ _ _ _ _ _ _ _ _ _ _ H (refl_equal _)).
destruct (addressing a1). intros [vl [EV EQ]].
eapply eval_Estore; eauto.
Qed.
Theorem exec_ifthenelse_true:
- forall sp e1 m1 a e2 m2 v ifso ifnot e3 m3 out,
- eval_expr ge sp nil e1 m1 a e2 m2 v ->
+ forall sp e1 m1 a t1 e2 m2 v ifso ifnot t2 e3 m3 out,
+ eval_expr ge sp nil e1 m1 a t1 e2 m2 v ->
Val.is_true v ->
- exec_stmt ge sp e2 m2 ifso e3 m3 out ->
- exec_stmt ge sp e1 m1 (ifthenelse a ifso ifnot) e3 m3 out.
+ exec_stmt ge sp e2 m2 ifso t2 e3 m3 out ->
+ exec_stmt ge sp e1 m1 (ifthenelse a ifso ifnot) (t1**t2) e3 m3 out.
Proof.
intros. unfold ifthenelse.
- apply exec_Sifthenelse with e2 m2 true.
+ apply exec_Sifthenelse with t1 e2 m2 true t2.
eapply eval_condition_of_expr; eauto with valboolof.
- auto.
+ auto. auto.
Qed.
Theorem exec_ifthenelse_false:
- forall sp e1 m1 a e2 m2 v ifso ifnot e3 m3 out,
- eval_expr ge sp nil e1 m1 a e2 m2 v ->
+ forall sp e1 m1 a t1 e2 m2 v ifso ifnot t2 e3 m3 out,
+ eval_expr ge sp nil e1 m1 a t1 e2 m2 v ->
Val.is_false v ->
- exec_stmt ge sp e2 m2 ifnot e3 m3 out ->
- exec_stmt ge sp e1 m1 (ifthenelse a ifso ifnot) e3 m3 out.
+ exec_stmt ge sp e2 m2 ifnot t2 e3 m3 out ->
+ exec_stmt ge sp e1 m1 (ifthenelse a ifso ifnot) (t1**t2) e3 m3 out.
Proof.
intros. unfold ifthenelse.
- apply exec_Sifthenelse with e2 m2 false.
+ apply exec_Sifthenelse with t1 e2 m2 false t2.
eapply eval_condition_of_expr; eauto with valboolof.
- auto.
+ auto. auto.
Qed.
End CMCONSTR.
diff --git a/backend/Cminor.v b/backend/Cminor.v
index 826c529..9eed009 100644
--- a/backend/Cminor.v
+++ b/backend/Cminor.v
@@ -5,6 +5,7 @@ Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
+Require Import Events.
Require Import Values.
Require Import Mem.
Require Import Op.
@@ -35,6 +36,7 @@ Inductive expr : Set :=
| Econdition : condexpr -> expr -> expr -> expr
| Elet : expr -> expr -> expr
| Eletvar : nat -> expr
+ | Ealloc : expr -> expr
with condexpr : Set :=
| CEtrue: condexpr
@@ -77,7 +79,14 @@ Record function : Set := mkfunction {
fn_body: stmt
}.
-Definition program := AST.program function.
+Definition fundef := AST.fundef function.
+Definition program := AST.program fundef.
+
+Definition funsig (fd: fundef) :=
+ match fd with
+ | Internal f => f.(fn_sig)
+ | External ef => ef.(ef_sig)
+ end.
(** * Operational semantics *)
@@ -120,7 +129,7 @@ Fixpoint switch_target (n: int) (dfl: nat) (cases: list (int * nat))
- [lenv]: let environments, map de Bruijn indices to values.
*)
-Definition genv := Genv.t function.
+Definition genv := Genv.t fundef.
Definition env := PTree.t val.
Definition letenv := list val.
@@ -157,56 +166,65 @@ Variable ge: genv.
Inductive eval_expr:
val -> letenv ->
- env -> mem -> expr ->
+ env -> mem -> expr -> trace ->
env -> mem -> val -> Prop :=
| eval_Evar:
forall sp le e m id v,
PTree.get id e = Some v ->
- eval_expr sp le e m (Evar id) e m v
+ eval_expr sp le e m (Evar id) E0 e m v
| eval_Eassign:
- forall sp le e m id a e1 m1 v,
- eval_expr sp le e m a e1 m1 v ->
- eval_expr sp le e m (Eassign id a) (PTree.set id v e1) m1 v
+ forall sp le e m id a t e1 m1 v,
+ eval_expr sp le e m a t e1 m1 v ->
+ eval_expr sp le e m (Eassign id a) t (PTree.set id v e1) m1 v
| eval_Eop:
- forall sp le e m op al e1 m1 vl v,
- eval_exprlist sp le e m al e1 m1 vl ->
+ forall sp le e m op al t e1 m1 vl v,
+ eval_exprlist sp le e m al t e1 m1 vl ->
eval_operation ge sp op vl = Some v ->
- eval_expr sp le e m (Eop op al) e1 m1 v
+ eval_expr sp le e m (Eop op al) t e1 m1 v
| eval_Eload:
- forall sp le e m chunk addr al e1 m1 v vl a,
- eval_exprlist sp le e m al e1 m1 vl ->
+ forall sp le e m chunk addr al t e1 m1 v vl a,
+ eval_exprlist sp le e m al t e1 m1 vl ->
eval_addressing ge sp addr vl = Some a ->
Mem.loadv chunk m1 a = Some v ->
- eval_expr sp le e m (Eload chunk addr al) e1 m1 v
+ eval_expr sp le e m (Eload chunk addr al) t e1 m1 v
| eval_Estore:
- forall sp le e m chunk addr al b e1 m1 vl e2 m2 m3 v a,
- eval_exprlist sp le e m al e1 m1 vl ->
- eval_expr sp le e1 m1 b e2 m2 v ->
+ forall sp le e m chunk addr al b t t1 e1 m1 vl t2 e2 m2 m3 v a,
+ eval_exprlist sp le e m al t1 e1 m1 vl ->
+ eval_expr sp le e1 m1 b t2 e2 m2 v ->
eval_addressing ge sp addr vl = Some a ->
Mem.storev chunk m2 a v = Some m3 ->
- eval_expr sp le e m (Estore chunk addr al b) e2 m3 v
+ t = t1 ** t2 ->
+ eval_expr sp le e m (Estore chunk addr al b) t e2 m3 v
| eval_Ecall:
- forall sp le e m sig a bl e1 e2 m1 m2 m3 vf vargs vres f,
- eval_expr sp le e m a e1 m1 vf ->
- eval_exprlist sp le e1 m1 bl e2 m2 vargs ->
+ forall sp le e m sig a bl t t1 e1 m1 t2 e2 m2 t3 m3 vf vargs vres f,
+ eval_expr sp le e m a t1 e1 m1 vf ->
+ eval_exprlist sp le e1 m1 bl t2 e2 m2 vargs ->
Genv.find_funct ge vf = Some f ->
- f.(fn_sig) = sig ->
- eval_funcall m2 f vargs m3 vres ->
- eval_expr sp le e m (Ecall sig a bl) e2 m3 vres
+ funsig f = sig ->
+ eval_funcall m2 f vargs t3 m3 vres ->
+ t = t1 ** t2 ** t3 ->
+ eval_expr sp le e m (Ecall sig a bl) t e2 m3 vres
| eval_Econdition:
- forall sp le e m a b c e1 m1 v1 e2 m2 v2,
- eval_condexpr sp le e m a e1 m1 v1 ->
- eval_expr sp le e1 m1 (if v1 then b else c) e2 m2 v2 ->
- eval_expr sp le e m (Econdition a b c) e2 m2 v2
+ forall sp le e m a b c t t1 e1 m1 v1 t2 e2 m2 v2,
+ eval_condexpr sp le e m a t1 e1 m1 v1 ->
+ eval_expr sp le e1 m1 (if v1 then b else c) t2 e2 m2 v2 ->
+ t = t1 ** t2 ->
+ eval_expr sp le e m (Econdition a b c) t e2 m2 v2
| eval_Elet:
- forall sp le e m a b e1 m1 v1 e2 m2 v2,
- eval_expr sp le e m a e1 m1 v1 ->
- eval_expr sp (v1::le) e1 m1 b e2 m2 v2 ->
- eval_expr sp le e m (Elet a b) e2 m2 v2
+ forall sp le e m a b t t1 e1 m1 v1 t2 e2 m2 v2,
+ eval_expr sp le e m a t1 e1 m1 v1 ->
+ eval_expr sp (v1::le) e1 m1 b t2 e2 m2 v2 ->
+ t = t1 ** t2 ->
+ eval_expr sp le e m (Elet a b) t e2 m2 v2
| eval_Eletvar:
forall sp le e m n v,
nth_error le n = Some v ->
- eval_expr sp le e m (Eletvar n) e m v
+ eval_expr sp le e m (Eletvar n) E0 e m v
+ | eval_Ealloc:
+ forall sp le e m a t e1 m1 n m2 b,
+ eval_expr sp le e m a t e1 m1 (Vint n) ->
+ Mem.alloc m1 0 (Int.signed n) = (m2, b) ->
+ eval_expr sp le e m (Ealloc a) t e1 m2 (Vptr b Int.zero)
(** Evaluation of a condition expression:
[eval_condexpr ge sp le e m a e' m' b]
@@ -216,24 +234,25 @@ Inductive eval_expr:
with eval_condexpr:
val -> letenv ->
- env -> mem -> condexpr ->
+ env -> mem -> condexpr -> trace ->
env -> mem -> bool -> Prop :=
| eval_CEtrue:
forall sp le e m,
- eval_condexpr sp le e m CEtrue e m true
+ eval_condexpr sp le e m CEtrue E0 e m true
| eval_CEfalse:
forall sp le e m,
- eval_condexpr sp le e m CEfalse e m false
+ eval_condexpr sp le e m CEfalse E0 e m false
| eval_CEcond:
- forall sp le e m cond al e1 m1 vl b,
- eval_exprlist sp le e m al e1 m1 vl ->
+ forall sp le e m cond al t1 e1 m1 vl b,
+ eval_exprlist sp le e m al t1 e1 m1 vl ->
eval_condition cond vl = Some b ->
- eval_condexpr sp le e m (CEcond cond al) e1 m1 b
+ eval_condexpr sp le e m (CEcond cond al) t1 e1 m1 b
| eval_CEcondition:
- forall sp le e m a b c e1 m1 vb1 e2 m2 vb2,
- eval_condexpr sp le e m a e1 m1 vb1 ->
- eval_condexpr sp le e1 m1 (if vb1 then b else c) e2 m2 vb2 ->
- eval_condexpr sp le e m (CEcondition a b c) e2 m2 vb2
+ forall sp le e m a b c t t1 e1 m1 vb1 t2 e2 m2 vb2,
+ eval_condexpr sp le e m a t1 e1 m1 vb1 ->
+ eval_condexpr sp le e1 m1 (if vb1 then b else c) t2 e2 m2 vb2 ->
+ t = t1 ** t2 ->
+ eval_condexpr sp le e m (CEcondition a b c) t e2 m2 vb2
(** Evaluation of a list of expressions:
[eval_exprlist ge sp le al m a e' m' vl]
@@ -244,16 +263,17 @@ with eval_condexpr:
with eval_exprlist:
val -> letenv ->
- env -> mem -> exprlist ->
+ env -> mem -> exprlist -> trace ->
env -> mem -> list val -> Prop :=
| eval_Enil:
forall sp le e m,
- eval_exprlist sp le e m Enil e m nil
+ eval_exprlist sp le e m Enil E0 e m nil
| eval_Econs:
- forall sp le e m a bl e1 m1 v e2 m2 vl,
- eval_expr sp le e m a e1 m1 v ->
- eval_exprlist sp le e1 m1 bl e2 m2 vl ->
- eval_exprlist sp le e m (Econs a bl) e2 m2 (v :: vl)
+ forall sp le e m a bl t t1 e1 m1 v t2 e2 m2 vl,
+ eval_expr sp le e m a t1 e1 m1 v ->
+ eval_exprlist sp le e1 m1 bl t2 e2 m2 vl ->
+ t = t1 ** t2 ->
+ eval_exprlist sp le e m (Econs a bl) t e2 m2 (v :: vl)
(** Evaluation of a function invocation: [eval_funcall ge m f args m' res]
means that the function [f], applied to the arguments [args] in
@@ -261,15 +281,19 @@ with eval_exprlist:
*)
with eval_funcall:
- mem -> function -> list val ->
+ mem -> fundef -> list val -> trace ->
mem -> val -> Prop :=
- | eval_funcall_intro:
- forall m f vargs m1 sp e e2 m2 out vres,
+ | eval_funcall_internal:
+ forall m f vargs m1 sp e t e2 m2 out vres,
Mem.alloc m 0 f.(fn_stackspace) = (m1, sp) ->
set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e ->
- exec_stmt (Vptr sp Int.zero) e m1 f.(fn_body) e2 m2 out ->
+ exec_stmt (Vptr sp Int.zero) e m1 f.(fn_body) t e2 m2 out ->
outcome_result_value out f.(fn_sig).(sig_res) vres ->
- eval_funcall m f vargs (Mem.free m2 sp) vres
+ eval_funcall m (Internal f) vargs t (Mem.free m2 sp) vres
+ | eval_funcall_external:
+ forall ef m args t res,
+ event_match ef args t res ->
+ eval_funcall m (External ef) args t m res
(** Execution of a statement: [exec_stmt ge sp e m s e' m' out]
means that statement [s] executes with outcome [out].
@@ -277,59 +301,62 @@ with eval_funcall:
with exec_stmt:
val ->
- env -> mem -> stmt ->
+ env -> mem -> stmt -> trace ->
env -> mem -> outcome -> Prop :=
| exec_Sskip:
forall sp e m,
- exec_stmt sp e m Sskip e m Out_normal
+ exec_stmt sp e m Sskip E0 e m Out_normal
| exec_Sexpr:
- forall sp e m a e1 m1 v,
- eval_expr sp nil e m a e1 m1 v ->
- exec_stmt sp e m (Sexpr a) e1 m1 Out_normal
+ forall sp e m a t e1 m1 v,
+ eval_expr sp nil e m a t e1 m1 v ->
+ exec_stmt sp e m (Sexpr a) t e1 m1 Out_normal
| exec_Sifthenelse:
- forall sp e m a s1 s2 e1 m1 v1 e2 m2 out,
- eval_condexpr sp nil e m a e1 m1 v1 ->
- exec_stmt sp e1 m1 (if v1 then s1 else s2) e2 m2 out ->
- exec_stmt sp e m (Sifthenelse a s1 s2) e2 m2 out
+ forall sp e m a s1 s2 t t1 e1 m1 v1 t2 e2 m2 out,
+ eval_condexpr sp nil e m a t1 e1 m1 v1 ->
+ exec_stmt sp e1 m1 (if v1 then s1 else s2) t2 e2 m2 out ->
+ t = t1 ** t2 ->
+ exec_stmt sp e m (Sifthenelse a s1 s2) t e2 m2 out
| exec_Sseq_continue:
- forall sp e m s1 e1 m1 s2 e2 m2 out,
- exec_stmt sp e m s1 e1 m1 Out_normal ->
- exec_stmt sp e1 m1 s2 e2 m2 out ->
- exec_stmt sp e m (Sseq s1 s2) e2 m2 out
+ forall sp e m t s1 t1 e1 m1 s2 t2 e2 m2 out,
+ exec_stmt sp e m s1 t1 e1 m1 Out_normal ->
+ exec_stmt sp e1 m1 s2 t2 e2 m2 out ->
+ t = t1 ** t2 ->
+ exec_stmt sp e m (Sseq s1 s2) t e2 m2 out
| exec_Sseq_stop:
- forall sp e m s1 s2 e1 m1 out,
- exec_stmt sp e m s1 e1 m1 out ->
+ forall sp e m t s1 s2 e1 m1 out,
+ exec_stmt sp e m s1 t e1 m1 out ->
out <> Out_normal ->
- exec_stmt sp e m (Sseq s1 s2) e1 m1 out
+ exec_stmt sp e m (Sseq s1 s2) t e1 m1 out
| exec_Sloop_loop:
- forall sp e m s e1 m1 e2 m2 out,
- exec_stmt sp e m s e1 m1 Out_normal ->
- exec_stmt sp e1 m1 (Sloop s) e2 m2 out ->
- exec_stmt sp e m (Sloop s) e2 m2 out
+ forall sp e m s t t1 e1 m1 t2 e2 m2 out,
+ exec_stmt sp e m s t1 e1 m1 Out_normal ->
+ exec_stmt sp e1 m1 (Sloop s) t2 e2 m2 out ->
+ t = t1 ** t2 ->
+ exec_stmt sp e m (Sloop s) t e2 m2 out
| exec_Sloop_stop:
- forall sp e m s e1 m1 out,
- exec_stmt sp e m s e1 m1 out ->
+ forall sp e m t s e1 m1 out,
+ exec_stmt sp e m s t e1 m1 out ->
out <> Out_normal ->
- exec_stmt sp e m (Sloop s) e1 m1 out
+ exec_stmt sp e m (Sloop s) t e1 m1 out
| exec_Sblock:
- forall sp e m s e1 m1 out,
- exec_stmt sp e m s e1 m1 out ->
- exec_stmt sp e m (Sblock s) e1 m1 (outcome_block out)
+ forall sp e m s t e1 m1 out,
+ exec_stmt sp e m s t e1 m1 out ->
+ exec_stmt sp e m (Sblock s) t e1 m1 (outcome_block out)
| exec_Sexit:
forall sp e m n,
- exec_stmt sp e m (Sexit n) e m (Out_exit n)
+ exec_stmt sp e m (Sexit n) E0 e m (Out_exit n)
| exec_Sswitch:
- forall sp e m a cases default e1 m1 n,
- eval_expr sp nil e m a e1 m1 (Vint n) ->
+ forall sp e m a cases default t1 e1 m1 n,
+ eval_expr sp nil e m a t1 e1 m1 (Vint n) ->
exec_stmt sp e m (Sswitch a cases default)
- e1 m1 (Out_exit (switch_target n default cases))
+ t1 e1 m1 (Out_exit (switch_target n default cases))
| exec_Sreturn_none:
forall sp e m,
- exec_stmt sp e m (Sreturn None) e m (Out_return None)
+ exec_stmt sp e m (Sreturn None) E0 e m (Out_return None)
| exec_Sreturn_some:
- forall sp e m a e1 m1 v,
- eval_expr sp nil e m a e1 m1 v ->
- exec_stmt sp e m (Sreturn (Some a)) e1 m1 (Out_return (Some v)).
+ forall sp e m a t e1 m1 v,
+ eval_expr sp nil e m a t e1 m1 v ->
+ exec_stmt sp e m (Sreturn (Some a)) t e1 m1 (Out_return (Some v)).
End RELSEM.
@@ -337,12 +364,12 @@ End RELSEM.
holds if the application of [p]'s main function to no arguments
in the initial memory state for [p] eventually returns value [r]. *)
-Definition exec_program (p: program) (r: val) : Prop :=
+Definition exec_program (p: program) (t: trace) (r: val) : Prop :=
let ge := Genv.globalenv p in
let m0 := Genv.init_mem p in
exists b, exists f, exists m,
Genv.find_symbol ge p.(prog_main) = Some b /\
Genv.find_funct_ptr ge b = Some f /\
- f.(fn_sig) = mksignature nil (Some Tint) /\
- eval_funcall ge m0 f nil m r.
+ funsig f = mksignature nil (Some Tint) /\
+ eval_funcall ge m0 f nil t m r.
diff --git a/backend/Cminorgen.v b/backend/Cminorgen.v
index cb88992..4c611b4 100644
--- a/backend/Cminorgen.v
+++ b/backend/Cminorgen.v
@@ -104,18 +104,27 @@ Definition make_cast (chunk: memory_chunk) (e: expr): expr :=
Definition make_load (chunk: memory_chunk) (e: expr): expr :=
Cmconstr.load chunk e.
-(** In Csharpminor, the value of a store expression is the stored data
- normalized to the memory chunk. In Cminor, it is the stored data.
- For the translation, we could normalize before storing. However,
- the memory model performs automatic normalization of the stored
- data. It is therefore correct to store the data as is, then
- normalize the result value of the store expression. This is more
- efficient in general because often the result value is ignored:
- the normalization code will therefore be eliminated later as dead
- code. *)
-
-Definition make_store (chunk: memory_chunk) (e1 e2: expr): expr :=
- make_cast chunk (Cmconstr.store chunk e1 e2).
+Definition store_arg (chunk: memory_chunk) (e: expr) : expr :=
+ match e with
+ | Eop op (Econs e1 Enil) =>
+ match op with
+ | Ocast8signed =>
+ match chunk with Mint8signed => e1 | _ => e end
+ | Ocast8unsigned =>
+ match chunk with Mint8unsigned => e1 | _ => e end
+ | Ocast16signed =>
+ match chunk with Mint16signed => e1 | _ => e end
+ | Ocast16unsigned =>
+ match chunk with Mint16unsigned => e1 | _ => e end
+ | Osingleoffloat =>
+ match chunk with Mfloat32 => e1 | _ => e end
+ | _ => e
+ end
+ | _ => e
+ end.
+
+Definition make_store (chunk: memory_chunk) (e1 e2: expr): stmt :=
+ Sexpr(Cmconstr.store chunk e1 (store_arg chunk e2)).
Definition make_stackaddr (ofs: Z): expr :=
Eop (Oaddrstack (Int.repr ofs)) Enil.
@@ -156,10 +165,10 @@ Definition var_get (cenv: compilenv) (id: ident): option expr :=
None
end.
-Definition var_set (cenv: compilenv) (id: ident) (rhs: expr): option expr :=
+Definition var_set (cenv: compilenv) (id: ident) (rhs: expr): option stmt :=
match PMap.get id cenv with
| Var_local chunk =>
- Some(Eassign id (make_cast chunk rhs))
+ Some(Sexpr(Eassign id (make_cast chunk rhs)))
| Var_stack_scalar chunk ofs =>
Some(make_store chunk (make_stackaddr ofs) rhs)
| Var_global_scalar chunk =>
@@ -199,16 +208,10 @@ Fixpoint transl_expr (cenv: compilenv) (e: Csharpminor.expr)
match e with
| Csharpminor.Evar id => var_get cenv id
| Csharpminor.Eaddrof id => var_addr cenv id
- | Csharpminor.Eassign id e =>
- do te <- transl_expr cenv e; var_set cenv id te
| Csharpminor.Eop op el =>
do tel <- transl_exprlist cenv el; make_op op tel
| Csharpminor.Eload chunk e =>
do te <- transl_expr cenv e; Some (make_load chunk te)
- | Csharpminor.Estore chunk e1 e2 =>
- do te1 <- transl_expr cenv e1;
- do te2 <- transl_expr cenv e2;
- Some (make_store chunk te1 te2)
| Csharpminor.Ecall sig e el =>
do te <- transl_expr cenv e;
do tel <- transl_exprlist cenv el;
@@ -224,6 +227,9 @@ Fixpoint transl_expr (cenv: compilenv) (e: Csharpminor.expr)
Some (Elet te1 te2)
| Csharpminor.Eletvar n =>
Some (Eletvar n)
+ | Csharpminor.Ealloc e =>
+ do te <- transl_expr cenv e;
+ Some (Ealloc te)
end
with transl_exprlist (cenv: compilenv) (el: Csharpminor.exprlist)
@@ -246,6 +252,12 @@ Fixpoint transl_stmt (cenv: compilenv) (s: Csharpminor.stmt)
Some Sskip
| Csharpminor.Sexpr e =>
do te <- transl_expr cenv e; Some(Sexpr te)
+ | Csharpminor.Sassign id e =>
+ do te <- transl_expr cenv e; var_set cenv id te
+ | Csharpminor.Sstore chunk e1 e2 =>
+ do te1 <- transl_expr cenv e1;
+ do te2 <- transl_expr cenv e2;
+ Some (make_store chunk te1 te2)
| Csharpminor.Sseq s1 s2 =>
do ts1 <- transl_stmt cenv s1;
do ts2 <- transl_stmt cenv s2;
@@ -280,11 +292,8 @@ Fixpoint addr_taken_expr (e: Csharpminor.expr): Identset.t :=
match e with
| Csharpminor.Evar id => Identset.empty
| Csharpminor.Eaddrof id => Identset.add id Identset.empty
- | Csharpminor.Eassign id e => addr_taken_expr e
| Csharpminor.Eop op el => addr_taken_exprlist el
| Csharpminor.Eload chunk e => addr_taken_expr e
- | Csharpminor.Estore chunk e1 e2 =>
- Identset.union (addr_taken_expr e1) (addr_taken_expr e2)
| Csharpminor.Ecall sig e el =>
Identset.union (addr_taken_expr e) (addr_taken_exprlist el)
| Csharpminor.Econdition e1 e2 e3 =>
@@ -293,6 +302,7 @@ Fixpoint addr_taken_expr (e: Csharpminor.expr): Identset.t :=
| Csharpminor.Elet e1 e2 =>
Identset.union (addr_taken_expr e1) (addr_taken_expr e2)
| Csharpminor.Eletvar n => Identset.empty
+ | Csharpminor.Ealloc e => addr_taken_expr e
end
with addr_taken_exprlist (e: Csharpminor.exprlist): Identset.t :=
@@ -306,6 +316,9 @@ Fixpoint addr_taken_stmt (s: Csharpminor.stmt): Identset.t :=
match s with
| Csharpminor.Sskip => Identset.empty
| Csharpminor.Sexpr e => addr_taken_expr e
+ | Csharpminor.Sassign id e => addr_taken_expr e
+ | Csharpminor.Sstore chunk e1 e2 =>
+ Identset.union (addr_taken_expr e1) (addr_taken_expr e2)
| Csharpminor.Sseq s1 s2 =>
Identset.union (addr_taken_stmt s1) (addr_taken_stmt s2)
| Csharpminor.Sifthenelse e s1 s2 =>
@@ -362,10 +375,10 @@ Definition build_compilenv
(globenv, 0).
Definition assign_global_variable
- (ce: compilenv) (id_vi: ident * var_kind) : compilenv :=
- match id_vi with
- | (id, Vscalar chunk) => PMap.set id (Var_global_scalar chunk) ce
- | (id, Varray sz) => PMap.set id Var_global_array ce
+ (ce: compilenv) (info: ident * var_kind * list init_data) : compilenv :=
+ match info with
+ | (id, Vscalar chunk, _) => PMap.set id (Var_global_scalar chunk) ce
+ | (id, Varray _, _) => PMap.set id Var_global_array ce
end.
Definition build_global_compilenv (p: Csharpminor.program) : compilenv :=
@@ -387,7 +400,7 @@ Fixpoint store_parameters
Sseq (Sexpr (Eassign id (make_cast chunk (Evar id))))
(store_parameters cenv rem)
| Var_stack_scalar chunk ofs =>
- Sseq (Sexpr (make_store chunk (make_stackaddr ofs) (Evar id)))
+ Sseq (make_store chunk (make_stackaddr ofs) (Evar id))
(store_parameters cenv rem)
| _ =>
Sskip (* should never happen *)
@@ -412,6 +425,9 @@ Definition transl_function
(Sseq (store_parameters cenv f.(Csharpminor.fn_params)) tbody))
else None.
+Definition transl_fundef (gce: compilenv) (f: Csharpminor.fundef): option fundef :=
+ transf_partial_fundef (transl_function gce) f.
+
Definition transl_program (p: Csharpminor.program) : option program :=
let gce := build_global_compilenv p in
- transform_partial_program (transl_function gce) (program_of_program p).
+ transform_partial_program (transl_fundef gce) (program_of_program p).
diff --git a/backend/Cminorgenproof.v b/backend/Cminorgenproof.v
index 7b3bc9b..7820095 100644
--- a/backend/Cminorgenproof.v
+++ b/backend/Cminorgenproof.v
@@ -8,6 +8,7 @@ Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Csharpminor.
Require Import Op.
@@ -29,38 +30,51 @@ 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 (transl_function gce).
+ apply Genv.find_symbol_transf_partial with (transl_fundef gce).
exact TRANSL.
Qed.
Lemma function_ptr_translated:
- forall (b: block) (f: Csharpminor.function),
+ forall (b: block) (f: Csharpminor.fundef),
Genv.find_funct_ptr ge b = Some f ->
exists tf,
- Genv.find_funct_ptr tge b = Some tf /\ transl_function gce f = Some tf.
+ Genv.find_funct_ptr tge b = Some tf /\ transl_fundef gce f = Some tf.
Proof.
intros.
generalize
- (Genv.find_funct_ptr_transf_partial (transl_function gce) TRANSL H).
- case (transl_function gce f).
+ (Genv.find_funct_ptr_transf_partial (transl_fundef gce) TRANSL H).
+ case (transl_fundef gce f).
intros tf [A B]. exists tf. tauto.
intros [A B]. elim B. reflexivity.
Qed.
Lemma functions_translated:
- forall (v: val) (f: Csharpminor.function),
+ forall (v: val) (f: Csharpminor.fundef),
Genv.find_funct ge v = Some f ->
exists tf,
- Genv.find_funct tge v = Some tf /\ transl_function gce f = Some tf.
+ Genv.find_funct tge v = Some tf /\ transl_fundef gce f = Some tf.
Proof.
intros.
generalize
- (Genv.find_funct_transf_partial (transl_function gce) TRANSL H).
- case (transl_function gce f).
+ (Genv.find_funct_transf_partial (transl_fundef gce) TRANSL H).
+ case (transl_fundef gce f).
intros tf [A B]. exists tf. tauto.
intros [A B]. elim B. reflexivity.
Qed.
+Lemma sig_preserved:
+ forall f tf,
+ transl_fundef gce f = Some tf ->
+ Cminor.funsig tf = Csharpminor.funsig f.
+Proof.
+ intros until tf; destruct f; simpl.
+ unfold transl_function. destruct (build_compilenv gce f).
+ case (zle z Int.max_signed); try congruence.
+ intro. case (transl_stmt c (Csharpminor.fn_body f)); simpl; try congruence.
+ intros. inversion H. reflexivity.
+ intro. inversion H; reflexivity.
+Qed.
+
Definition global_compilenv_match (ce: compilenv) (gv: gvarenv) : Prop :=
forall id,
match ce!!id with
@@ -72,9 +86,9 @@ Definition global_compilenv_match (ce: compilenv) (gv: gvarenv) : Prop :=
Lemma global_compilenv_charact:
global_compilenv_match gce (global_var_env prog).
Proof.
- set (mkgve := fun gv vars =>
+ set (mkgve := fun gv (vars: list (ident * var_kind * list init_data)) =>
List.fold_left
- (fun gv (id_vi: ident * var_kind) => PTree.set (fst id_vi) (snd id_vi) gv)
+ (fun gve x => match x with (id, k, init) => PTree.set id k gve end)
vars gv).
assert (forall vars gv ce,
global_compilenv_match ce gv ->
@@ -83,7 +97,7 @@ Proof.
induction vars; simpl; intros.
auto.
apply IHvars. intro id1. unfold assign_global_variable.
- destruct a as [id2 lv2]. destruct lv2; simpl; rewrite PMap.gsspec; rewrite PTree.gsspec.
+ destruct a as [[id2 lv2] init2]. destruct lv2; simpl; rewrite PMap.gsspec; rewrite PTree.gsspec.
case (peq id1 id2); intro. auto. apply H.
case (peq id1 id2); intro. auto. apply H.
@@ -283,6 +297,7 @@ Qed.
must be normalized with respect to the memory chunk of the variable,
in the following sense. *)
+(*
Definition val_normalized (chunk: memory_chunk) (v: val) : Prop :=
exists v0, v = Val.load_result chunk v0.
@@ -305,34 +320,31 @@ Lemma load_result_normalized:
Proof.
intros chunk v [v0 EQ]. rewrite EQ. apply load_result_idem.
Qed.
-
+*)
Lemma match_env_store_local:
forall f cenv e m1 m2 te sp lo hi id b chunk v tv,
e!id = Some(b, Vscalar chunk) ->
- val_inject f v tv ->
- val_normalized chunk tv ->
+ val_inject f (Val.load_result chunk v) tv ->
store chunk m1 b 0 v = Some m2 ->
match_env f cenv e m1 te sp lo hi ->
match_env f cenv e m2 (PTree.set id tv te) sp lo hi.
Proof.
- intros. inversion H3. constructor; auto.
+ intros. inversion H2. constructor; auto.
intros. generalize (me_vars0 id0); intro.
- inversion H4; subst.
+ inversion H3; subst.
(* var_local *)
case (peq id id0); intro.
(* the stored variable *)
subst id0.
- change Csharpminor.var_kind with var_kind in H5.
- rewrite H in H6. injection H6; clear H6; intros; subst b0 chunk0.
+ change Csharpminor.var_kind with var_kind in H4.
+ rewrite H in H5. injection H5; clear H5; intros; subst b0 chunk0.
econstructor. eauto.
eapply load_store_same; eauto. auto.
rewrite PTree.gss. reflexivity.
- replace tv with (Val.load_result chunk tv).
- apply Mem.load_result_inject. constructor; auto.
- apply load_result_normalized; auto.
+ auto.
(* a different variable *)
econstructor; eauto.
- rewrite <- H7. eapply load_store_other; eauto.
+ rewrite <- H6. eapply load_store_other; eauto.
rewrite PTree.gso; auto.
(* var_stack_scalar *)
econstructor; eauto.
@@ -375,16 +387,15 @@ Qed.
Lemma match_callstack_store_local:
forall f cenv e te sp lo hi cs bound tbound m1 m2 id b chunk v tv,
e!id = Some(b, Vscalar chunk) ->
- val_inject f v tv ->
- val_normalized chunk tv ->
+ val_inject f (Val.load_result chunk v) tv ->
store chunk m1 b 0 v = Some m2 ->
match_callstack f (mkframe cenv e te sp lo hi :: cs) bound tbound m1 ->
match_callstack f (mkframe cenv e (PTree.set id tv te) sp lo hi :: cs) bound tbound m2.
Proof.
- intros. inversion H3. constructor; auto.
+ intros. inversion H2. constructor; auto.
eapply match_env_store_local; eauto.
eapply match_callstack_store_above; eauto.
- inversion H17.
+ inversion H16.
generalize (me_bounded0 _ _ _ H). omega.
Qed.
@@ -409,20 +420,19 @@ Qed.
Lemma match_callstack_store_local_unchanged:
forall f cenv e te sp lo hi cs bound tbound m1 m2 id b chunk v tv,
e!id = Some(b, Vscalar chunk) ->
- val_inject f v tv ->
- val_normalized chunk tv ->
+ val_inject f (Val.load_result chunk v) tv ->
store chunk m1 b 0 v = Some m2 ->
te!id = Some tv ->
match_callstack f (mkframe cenv e te sp lo hi :: cs) bound tbound m1 ->
match_callstack f (mkframe cenv e te sp lo hi :: cs) bound tbound m2.
Proof.
- intros. inversion H4. constructor; auto.
+ intros. inversion H3. constructor; auto.
apply match_env_extensional with (PTree.set id tv te).
eapply match_env_store_local; eauto.
intros. rewrite PTree.gsspec.
case (peq id0 id); intros. congruence. auto.
eapply match_callstack_store_above; eauto.
- inversion H18.
+ inversion H17.
generalize (me_bounded0 _ _ _ H). omega.
Qed.
@@ -698,6 +708,90 @@ Proof.
injection H; intros. rewrite <- H2; simpl. omega.
Qed.
+Lemma match_env_alloc:
+ forall m1 l h m2 b tm1 tm2 tb f1 ce e te sp lo hi,
+ alloc m1 l h = (m2, b) ->
+ alloc tm1 l h = (tm2, tb) ->
+ match_env f1 ce e m1 te sp lo hi ->
+ hi <= m1.(nextblock) ->
+ sp < tm1.(nextblock) ->
+ let f2 := extend_inject b (Some(tb, 0)) f1 in
+ inject_incr f1 f2 ->
+ match_env f2 ce e m2 te sp lo hi.
+Proof.
+ intros.
+ assert (BEQ: b = m1.(nextblock)). injection H; auto.
+ assert (TBEQ: tb = tm1.(nextblock)). injection H0; auto.
+ inversion H1. constructor; auto.
+ (* me_vars *)
+ intros. generalize (me_vars0 id); intro. inversion H5.
+ (* var_local *)
+ econstructor; eauto.
+ generalize (me_bounded0 _ _ _ H7). intro.
+ unfold f2, extend_inject. case (eq_block b0 b); intro.
+ subst b0. rewrite BEQ in H12. omegaContradiction.
+ auto.
+ (* var_stack_scalar *)
+ econstructor; eauto.
+ (* var_stack_array *)
+ econstructor; eauto.
+ (* var_global_scalar *)
+ econstructor; eauto.
+ (* var_global_array *)
+ econstructor; eauto.
+ (* me_bounded *)
+ intros until delta. unfold f2, extend_inject. case (eq_block b0 b); intro.
+ intro. injection H5; clear H5; intros.
+ rewrite H6 in TBEQ. rewrite TBEQ in H3. omegaContradiction.
+ eauto.
+ (* me_inj *)
+ intros until delta. unfold f2, extend_inject. case (eq_block b0 b); intros.
+ injection H5; clear H5; intros; subst b0 tb0 delta.
+ rewrite BEQ in H6. omegaContradiction.
+ eauto.
+Qed.
+
+Lemma match_callstack_alloc_rec:
+ forall f1 cs bound tbound m1,
+ match_callstack f1 cs bound tbound m1 ->
+ forall l h m2 b tm1 tm2 tb,
+ alloc m1 l h = (m2, b) ->
+ alloc tm1 l h = (tm2, tb) ->
+ bound <= m1.(nextblock) ->
+ tbound <= tm1.(nextblock) ->
+ let f2 := extend_inject b (Some(tb, 0)) f1 in
+ inject_incr f1 f2 ->
+ match_callstack f2 cs bound tbound m2.
+Proof.
+ induction 1; intros.
+ constructor.
+ inversion H. constructor.
+ intros. elim (mg_symbols0 _ _ H5); intros.
+ split; auto. elim (H4 b0); intros; congruence.
+ intros. generalize (mg_functions0 _ H5). elim (H4 b0); congruence.
+ constructor. auto. auto.
+ unfold f2. eapply match_env_alloc; eauto. omega. omega.
+ unfold f2; eapply IHmatch_callstack; eauto.
+ inversion H1; omega.
+ omega.
+Qed.
+
+Lemma match_callstack_alloc:
+ forall f1 cs m1 tm1 l h m2 b tm2 tb,
+ match_callstack f1 cs m1.(nextblock) tm1.(nextblock) m1 ->
+ alloc m1 l h = (m2, b) ->
+ alloc tm1 l h = (tm2, tb) ->
+ let f2 := extend_inject b (Some(tb, 0)) f1 in
+ inject_incr f1 f2 ->
+ match_callstack f2 cs m2.(nextblock) tm2.(nextblock) m2.
+Proof.
+ intros. unfold f2 in *.
+ apply match_callstack_incr_bound with m1.(nextblock) tm1.(nextblock).
+ eapply match_callstack_alloc_rec; eauto. omega. omega.
+ injection H0; intros; subst m2; simpl; omega.
+ injection H1; intros; subst tm2; simpl; omega.
+Qed.
+
(** [match_callstack] implies [match_globalenvs]. *)
Lemma match_callstack_match_globalenvs:
@@ -757,14 +851,14 @@ Qed.
provided arguments match pairwise ([val_list_inject f] hypothesis). *)
Lemma make_op_correct:
- forall al a op vl m2 v sp le te1 tm1 te2 tm2 tvl f,
+ forall al a op vl m2 v sp le te1 tm1 t te2 tm2 tvl f,
make_op op al = Some a ->
Csharpminor.eval_operation op vl m2 = Some v ->
- eval_exprlist tge (Vptr sp Int.zero) le te1 tm1 al te2 tm2 tvl ->
+ eval_exprlist tge (Vptr sp Int.zero) le te1 tm1 al t te2 tm2 tvl ->
val_list_inject f vl tvl ->
mem_inject f m2 tm2 ->
exists tv,
- eval_expr tge (Vptr sp Int.zero) le te1 tm1 a te2 tm2 tv
+ eval_expr tge (Vptr sp Int.zero) le te1 tm1 a t te2 tm2 tv
/\ val_inject f v tv.
Proof.
intros.
@@ -782,23 +876,27 @@ Proof.
(* floatconst *)
TrivialOp. econstructor. constructor. reflexivity.
(* Unary operators *)
- inversion H1. subst sp0 le0 e m a0 bl e2 m0 tvl.
- inversion H14. subst sp0 le0 e m e1 m1 vl0.
- inversion H2. subst vl v' vl'. inversion H8. subst vl0.
+ inversion H1; clear H1; subst.
+ inversion H11; clear H11; subst.
+ rewrite E0_right.
+ inversion H2; clear H2; subst. inversion H8; clear H8; subst.
destruct op; simplify_eq H; intro; subst a;
simpl in H0; destruct v1; simplify_eq H0; intro; subst v;
inversion H7; subst v0;
TrivialOp.
+ change (Vint (Int.cast8unsigned i)) with (Val.cast8unsigned (Vint i)). eauto with evalexpr.
+ change (Vint (Int.cast8signed i)) with (Val.cast8signed (Vint i)). eauto with evalexpr.
+ change (Vint (Int.cast16unsigned i)) with (Val.cast16unsigned (Vint i)). eauto with evalexpr.
+ change (Vint (Int.cast16signed i)) with (Val.cast16signed (Vint i)). eauto with evalexpr.
+ change (Vfloat (Float.singleoffloat f0)) with (Val.singleoffloat (Vfloat f0)). eauto with evalexpr.
(* Binary operations *)
- inversion H1. subst sp0 le0 e m a0 bl e2 m0 tvl.
- inversion H14. subst sp0 le0 e m a0 bl e2 m3 vl0.
- inversion H16. subst sp0 le0 e m e0 m0 vl1.
- inversion H2. subst vl v' vl'.
- inversion H8. subst vl0 v' vl'.
- inversion H12. subst vl.
+ inversion H1; clear H1; subst. inversion H11; clear H11; subst.
+ inversion H12; clear H12; subst. rewrite E0_right.
+ inversion H2; clear H2; subst. inversion H9; clear H9; subst.
+ inversion H10; clear H10; subst.
destruct op; simplify_eq H; intro; subst a;
simpl in H0; destruct v2; destruct v3; simplify_eq H0; intro; try subst v;
- inversion H7; inversion H9; subst v0; subst v1;
+ inversion H7; inversion H8; subst v0; subst v1;
TrivialOp.
(* add int ptr *)
exists (Vptr b2 (Int.add ofs2 i)); split.
@@ -815,7 +913,8 @@ Proof.
(* sub ptr ptr *)
destruct (eq_block b b0); simplify_eq H0; intro; subst v; subst b0.
assert (b4 = b2). congruence. subst b4.
- exists (Vint (Int.sub ofs2 ofs3)); split. eauto with evalexpr.
+ exists (Vint (Int.sub ofs3 ofs2)); split.
+ eauto with evalexpr.
subst ofs2 ofs3. replace x0 with x. rewrite Int.sub_shifted. constructor.
congruence.
(* divs *)
@@ -842,11 +941,11 @@ Proof.
(* cmp int ptr *)
elim (eval_compare_null_inv _ _ _ H0); intros; subst i1 i.
exists v; split. eauto with evalexpr.
- elim H18; intros [A B]; subst v; unfold Vtrue, Vfalse; constructor.
+ elim H12; intros [A B]; subst v; unfold Vtrue, Vfalse; constructor.
(* cmp ptr int *)
elim (eval_compare_null_inv _ _ _ H0); intros; subst i1 i0.
exists v; split. eauto with evalexpr.
- elim H18; intros [A B]; subst v; unfold Vtrue, Vfalse; constructor.
+ elim H12; intros [A B]; subst v; unfold Vtrue, Vfalse; constructor.
(* cmp ptr ptr *)
caseEq (valid_pointer m2 b (Int.signed i) && valid_pointer m2 b0 (Int.signed i0));
intro EQ; rewrite EQ in H0; try discriminate.
@@ -854,7 +953,7 @@ Proof.
assert (b4 = b2); [congruence|subst b4].
assert (x0 = x); [congruence|subst x0].
elim (andb_prop _ _ EQ); intros.
- exists (Val.of_bool (Int.cmp c ofs2 ofs3)); split.
+ exists (Val.of_bool (Int.cmp c ofs3 ofs2)); split.
eauto with evalexpr.
subst ofs2 ofs3. rewrite Int.translate_cmp.
apply val_inject_val_of_bool.
@@ -866,55 +965,51 @@ Qed.
normalized according to the given memory chunk. *)
Lemma make_cast_correct:
- forall f sp le te1 tm1 a te2 tm2 v chunk v' tv,
- eval_expr tge (Vptr sp Int.zero) le te1 tm1 a te2 tm2 tv ->
- cast chunk v = Some v' ->
+ forall f sp le te1 tm1 a t te2 tm2 v chunk tv,
+ eval_expr tge (Vptr sp Int.zero) le te1 tm1 a t te2 tm2 tv ->
val_inject f v tv ->
exists tv',
eval_expr tge (Vptr sp Int.zero) le
te1 tm1 (make_cast chunk a)
- te2 tm2 tv'
- /\ val_inject f v' tv'
- /\ val_normalized chunk tv'.
+ t te2 tm2 tv'
+ /\ val_inject f (Val.load_result chunk v) tv'.
Proof.
- intros. destruct chunk; destruct v; simplify_eq H0; intro; subst v'; simpl;
- inversion H1; subst tv.
+ intros. destruct chunk.
- exists (Vint (Int.cast8signed i)).
+ exists (Val.cast8signed tv).
split. apply eval_cast8signed; auto.
- split. constructor. exists (Vint i); reflexivity.
+ inversion H0; simpl; constructor.
- exists (Vint (Int.cast8unsigned i)).
+ exists (Val.cast8unsigned tv).
split. apply eval_cast8unsigned; auto.
- split. constructor. exists (Vint i); reflexivity.
+ inversion H0; simpl; constructor.
- exists (Vint (Int.cast16signed i)).
+ exists (Val.cast16signed tv).
split. apply eval_cast16signed; auto.
- split. constructor. exists (Vint i); reflexivity.
+ inversion H0; simpl; constructor.
- exists (Vint (Int.cast16unsigned i)).
+ exists (Val.cast16unsigned tv).
split. apply eval_cast16unsigned; auto.
- split. constructor. exists (Vint i); reflexivity.
-
- exists (Vint i).
- split. auto. split. auto. exists (Vint i); reflexivity.
+ inversion H0; simpl; constructor.
- exists (Vptr b2 ofs2).
- split. auto. split. auto. exists (Vptr b2 ofs2); reflexivity.
+ exists tv.
+ split. simpl; auto.
+ inversion H0; simpl; econstructor; eauto.
- exists (Vfloat (Float.singleoffloat f0)).
+ exists (Val.singleoffloat tv).
split. apply eval_singleoffloat; auto.
- split. constructor. exists (Vfloat f0); reflexivity.
+ inversion H0; simpl; constructor.
- exists (Vfloat f0).
- split. auto. split. auto. exists (Vfloat f0); reflexivity.
+ exists tv.
+ split. simpl; auto.
+ inversion H0; simpl; constructor.
Qed.
Lemma make_stackaddr_correct:
forall sp le te tm ofs,
eval_expr tge (Vptr sp Int.zero) le
te tm (make_stackaddr ofs)
- te tm (Vptr sp (Int.repr ofs)).
+ E0 te tm (Vptr sp (Int.repr ofs)).
Proof.
intros; unfold make_stackaddr.
eapply eval_Eop. econstructor. simpl. decEq. decEq.
@@ -926,7 +1021,7 @@ Lemma make_globaladdr_correct:
Genv.find_symbol tge id = Some b ->
eval_expr tge (Vptr sp Int.zero) le
te tm (make_globaladdr id)
- te tm (Vptr b Int.zero).
+ E0 te tm (Vptr b Int.zero).
Proof.
intros; unfold make_globaladdr.
eapply eval_Eop. econstructor. simpl. rewrite H. auto.
@@ -935,67 +1030,75 @@ Qed.
(** Correctness of [make_load] and [make_store]. *)
Lemma make_load_correct:
- forall sp le te1 tm1 a te2 tm2 va chunk v,
- eval_expr tge (Vptr sp Int.zero) le te1 tm1 a te2 tm2 va ->
+ forall sp le te1 tm1 a t te2 tm2 va chunk v,
+ eval_expr tge (Vptr sp Int.zero) le te1 tm1 a t te2 tm2 va ->
Mem.loadv chunk tm2 va = Some v ->
eval_expr tge (Vptr sp Int.zero) le
te1 tm1 (make_load chunk a)
- te2 tm2 v.
+ t te2 tm2 v.
Proof.
intros; unfold make_load.
eapply eval_load; eauto.
Qed.
-Lemma val_content_inject_cast:
- forall f chunk v1 v2 tv1,
- cast chunk v1 = Some v2 ->
- val_inject f v1 tv1 ->
- val_content_inject f (mem_chunk chunk) v2 tv1.
+Lemma store_arg_content_inject:
+ forall f sp le te1 tm1 a t te2 tm2 v va chunk,
+ eval_expr tge (Vptr sp Int.zero) le te1 tm1 a t te2 tm2 va ->
+ val_inject f v va ->
+ exists vb,
+ eval_expr tge (Vptr sp Int.zero) le te1 tm1 (store_arg chunk a) t te2 tm2 vb
+ /\ val_content_inject f (mem_chunk chunk) v vb.
Proof.
- intros. destruct chunk; destruct v1; simplify_eq H; intro; subst v2;
- inversion H0; simpl.
- apply val_content_inject_8. apply Int.cast8_unsigned_signed.
- apply val_content_inject_8. apply Int.cast8_unsigned_idem.
- apply val_content_inject_16. apply Int.cast16_unsigned_signed.
- apply val_content_inject_16. apply Int.cast16_unsigned_idem.
- constructor; constructor.
- constructor; econstructor; eauto.
- apply val_content_inject_32. apply Float.singleoffloat_idem.
- constructor; constructor.
+ intros.
+ assert (exists vb,
+ eval_expr tge (Vptr sp Int.zero) le te1 tm1 a t te2 tm2 vb
+ /\ val_content_inject f (mem_chunk chunk) v vb).
+ exists va; split. assumption. constructor. assumption.
+ inversion H; clear H; subst; simpl; trivial.
+ inversion H2; clear H2; subst; trivial.
+ inversion H4; clear H4; subst; trivial.
+ rewrite E0_right. rewrite E0_right in H1.
+ destruct op; trivial; destruct chunk; trivial;
+ exists v0; (split; [auto|
+ simpl in H3; inversion H3; clear H3; subst va;
+ destruct v0; simpl in H0; inversion H0; subst; try (constructor; constructor)]).
+ apply val_content_inject_8. apply Int.cast8_unsigned_signed.
+ apply val_content_inject_8. apply Int.cast8_unsigned_idem.
+ apply val_content_inject_16. apply Int.cast16_unsigned_signed.
+ apply val_content_inject_16. apply Int.cast16_unsigned_idem.
+ apply val_content_inject_32. apply Float.singleoffloat_idem.
Qed.
Lemma make_store_correct:
- forall f sp le te1 tm1 addr te2 tm2 tvaddr rhs te3 tm3 tvrhs
- chunk vrhs v m3 vaddr m4,
- eval_expr tge (Vptr sp Int.zero) le
- te1 tm1 addr te2 tm2 tvaddr ->
- eval_expr tge (Vptr sp Int.zero) le
- te2 tm2 rhs te3 tm3 tvrhs ->
- cast chunk vrhs = Some v ->
- Mem.storev chunk m3 vaddr v = Some m4 ->
+ forall f sp te1 tm1 addr te2 tm2 tvaddr rhs te3 tm3 tvrhs
+ chunk vrhs m3 vaddr m4 t1 t2,
+ eval_expr tge (Vptr sp Int.zero) nil
+ te1 tm1 addr t1 te2 tm2 tvaddr ->
+ eval_expr tge (Vptr sp Int.zero) nil
+ te2 tm2 rhs t2 te3 tm3 tvrhs ->
+ Mem.storev chunk m3 vaddr vrhs = Some m4 ->
mem_inject f m3 tm3 ->
val_inject f vaddr tvaddr ->
val_inject f vrhs tvrhs ->
- exists tm4, exists tv,
- eval_expr tge (Vptr sp Int.zero) le
+ exists tm4,
+ exec_stmt tge (Vptr sp Int.zero)
te1 tm1 (make_store chunk addr rhs)
- te3 tm4 tv
+ (t1**t2) te3 tm4 Out_normal
/\ mem_inject f m4 tm4
- /\ val_inject f v tv
/\ nextblock tm4 = nextblock tm3.
Proof.
intros. unfold make_store.
- assert (val_content_inject f (mem_chunk chunk) v tvrhs).
- eapply val_content_inject_cast; eauto.
- elim (storev_mapped_inject_1 _ _ _ _ _ _ _ _ _ H3 H2 H4 H6).
- intros tm4 [STORE MEMINJ].
- generalize (eval_store _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H H0 STORE).
+ exploit store_arg_content_inject. eexact H0. eauto.
+ intros [tv [EVAL VCINJ]].
+ exploit storev_mapped_inject_1; eauto.
+ intros [tm4 [STORE MEMINJ]].
+ exploit eval_store. eexact H. eexact EVAL. eauto.
intro EVALSTORE.
- elim (make_cast_correct _ _ _ _ _ _ _ _ _ _ _ _ EVALSTORE H1 H5).
- intros tv [EVALCAST [VALINJ VALNORM]].
- exists tm4; exists tv. intuition.
+ exists tm4.
+ split. apply exec_Sexpr with tv. auto.
+ split. auto.
unfold storev in STORE; destruct tvaddr; try discriminate.
- generalize (store_inv _ _ _ _ _ _ STORE). simpl. tauto.
+ exploit store_inv; eauto. simpl. tauto.
Qed.
(** Correctness of the variable accessors [var_get], [var_set]
@@ -1009,7 +1112,7 @@ Lemma var_get_correct:
eval_var_ref prog e id b chunk ->
load chunk m b 0 = Some v ->
exists tv,
- eval_expr tge (Vptr sp Int.zero) le te tm a te tm tv /\
+ eval_expr tge (Vptr sp Int.zero) le te tm a E0 te tm tv /\
val_inject f v tv.
Proof.
unfold var_get; intros.
@@ -1025,8 +1128,8 @@ Proof.
inversion H2; [subst|congruence].
assert (b0 = b). congruence. subst b0.
assert (chunk0 = chunk). congruence. subst chunk0.
- assert (loadv chunk m (Vptr b Int.zero) = Some v). assumption.
- generalize (loadv_inject _ _ _ _ _ _ _ H1 H9 H7).
+ exploit loadv_inject; eauto.
+ unfold loadv. eexact H3.
intros [tv [LOAD INJ]].
exists tv; split.
eapply make_load_correct; eauto. eapply make_stackaddr_correct; eauto.
@@ -1052,7 +1155,7 @@ Lemma var_addr_correct:
var_addr cenv id = Some a ->
eval_var_addr prog e id b ->
exists tv,
- eval_expr tge (Vptr sp Int.zero) le te tm a te tm tv /\
+ eval_expr tge (Vptr sp Int.zero) le te tm a E0 te tm tv /\
val_inject f (Vptr b Int.zero) tv.
Proof.
unfold var_addr; intros.
@@ -1086,65 +1189,61 @@ Proof.
Qed.
Lemma var_set_correct:
- forall cenv id rhs a f e te2 sp lo hi m2 cs tm2 le te1 tm1 vrhs b chunk v1 v2 m3,
+ forall cenv id rhs a f e te2 sp lo hi m2 cs tm2 te1 tm1 tv b chunk v m3 t,
var_set cenv id rhs = Some a ->
match_callstack f (mkframe cenv e te2 sp lo hi :: cs) m2.(nextblock) tm2.(nextblock) m2 ->
- eval_expr tge (Vptr sp Int.zero) le te1 tm1 rhs te2 tm2 vrhs ->
- val_inject f v1 vrhs ->
+ eval_expr tge (Vptr sp Int.zero) nil te1 tm1 rhs t te2 tm2 tv ->
+ val_inject f v tv ->
mem_inject f m2 tm2 ->
eval_var_ref prog e id b chunk ->
- cast chunk v1 = Some v2 ->
- store chunk m2 b 0 v2 = Some m3 ->
- exists te3, exists tm3, exists tv,
- eval_expr tge (Vptr sp Int.zero) le te1 tm1 a te3 tm3 tv /\
- val_inject f v2 tv /\
+ store chunk m2 b 0 v = Some m3 ->
+ exists te3, exists tm3,
+ exec_stmt tge (Vptr sp Int.zero) te1 tm1 a t te3 tm3 Out_normal /\
mem_inject f m3 tm3 /\
match_callstack f (mkframe cenv e te3 sp lo hi :: cs) m3.(nextblock) tm3.(nextblock) m3.
Proof.
unfold var_set; intros.
assert (NEXTBLOCK: nextblock m3 = nextblock m2).
- generalize (store_inv _ _ _ _ _ _ H6). simpl. tauto.
+ exploit store_inv; eauto. simpl; tauto.
inversion H0. subst f0 cenv0 e0 te sp0 lo0 hi0 cs0 bound tbound m.
- assert (match_var f id e m2 te2 sp cenv!!id). inversion H20; auto.
- inversion H7; subst; rewrite <- H8 in H; inversion H; subst; clear H.
+ assert (match_var f id e m2 te2 sp cenv!!id). inversion H19; auto.
+ inversion H6; subst; rewrite <- H7 in H; inversion H; subst; clear H.
(* var_local *)
inversion H4; [subst|congruence].
assert (b0 = b). congruence. subst b0.
assert (chunk0 = chunk). congruence. subst chunk0.
- elim (make_cast_correct _ _ _ _ _ _ _ _ _ _ _ _ H1 H5 H2).
- intros tv [EVAL [INJ NORM]].
- exists (PTree.set id tv te2); exists tm2; exists tv.
- split. eapply eval_Eassign. auto.
- split. auto.
+ exploit make_cast_correct; eauto.
+ intros [tv' [EVAL INJ]].
+ exists (PTree.set id tv' te2); exists tm2.
+ split. eapply exec_Sexpr. eapply eval_Eassign. eauto.
split. eapply store_unmapped_inject; eauto.
rewrite NEXTBLOCK. eapply match_callstack_store_local; eauto.
(* var_stack_scalar *)
inversion H4; [subst|congruence].
assert (b0 = b). congruence. subst b0.
assert (chunk0 = chunk). congruence. subst chunk0.
- assert (storev chunk m2 (Vptr b Int.zero) v2 = Some m3). assumption.
- generalize (make_stackaddr_correct sp le te1 tm1 ofs). intro EVALSTACKADDR.
- generalize (make_store_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
- EVALSTACKADDR H1 H5 H11 H3 H10 H2).
- intros [tm3 [tv [EVAL [MEMINJ [VALINJ TNEXTBLOCK]]]]].
- exists te2; exists tm3; exists tv.
- split. auto. split. auto. split. auto.
+ assert (storev chunk m2 (Vptr b Int.zero) v = Some m3). assumption.
+ exploit make_store_correct.
+ eapply make_stackaddr_correct.
+ eauto. eauto. eauto. eauto. eauto.
+ rewrite E0_left. intros [tm3 [EVAL [MEMINJ TNEXTBLOCK]]].
+ exists te2; exists tm3.
+ split. auto. split. auto.
rewrite NEXTBLOCK; rewrite TNEXTBLOCK.
eapply match_callstack_mapped; eauto.
- inversion H10; congruence.
+ inversion H9; congruence.
(* var_global_scalar *)
inversion H4; [congruence|subst].
assert (chunk0 = chunk). congruence. subst chunk0.
- assert (storev chunk m2 (Vptr b Int.zero) v2 = Some m3). assumption.
+ assert (storev chunk m2 (Vptr b Int.zero) v = Some m3). assumption.
assert (match_globalenvs f). eapply match_callstack_match_globalenvs; eauto.
- inversion H14. destruct (mg_symbols0 _ _ H11) as [A B].
- assert (val_inject f (Vptr b Int.zero) (Vptr b Int.zero)). econstructor; eauto.
- generalize (make_globaladdr_correct sp le te1 tm1 id b B). intro EVALGLOBALADDR.
- generalize (make_store_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
- EVALGLOBALADDR H1 H5 H13 H3 H15 H2).
- intros [tm3 [tv [EVAL [MEMINJ [VALINJ TNEXTBLOCK]]]]].
- exists te2; exists tm3; exists tv.
- split. auto. split. auto. split. auto.
+ inversion H13. destruct (mg_symbols0 _ _ H10) as [A B].
+ exploit make_store_correct.
+ eapply make_globaladdr_correct; eauto.
+ eauto. eauto. eauto. eauto. eauto.
+ rewrite E0_left. intros [tm3 [EVAL [MEMINJ TNEXTBLOCK]]].
+ exists te2; exists tm3.
+ split. auto. split. auto.
rewrite NEXTBLOCK; rewrite TNEXTBLOCK.
eapply match_callstack_mapped; eauto. congruence.
Qed.
@@ -1228,36 +1327,26 @@ Proof.
omega. omega. omega. omega. unfold sizeof; rewrite LV. omega.
intros. left. generalize (BOUND _ _ H5). omega.
elim H3; intros MINJ1 INCR1; clear H3.
- assert (MATCH1: match_callstack f1
- (mkframe cenv1 (PTree.set id (b1, lv) e) te sp lo (nextblock m1) :: cs)
- (nextblock m1) (nextblock tm) m1).
- unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto.
- assert (SZ1POS: 0 <= sz1). rewrite <- H1. omega.
- assert (BOUND1: forall b delta, f1 b = Some(sp, delta) ->
- high_bound m1 b + delta <= sz1).
+ exploit IHalloc_variables; eauto.
+ unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto.
+ rewrite <- H1. omega.
intros until delta; unfold f1, extend_inject, eq_block.
rewrite (high_bound_alloc _ _ b _ _ _ H).
case (zeq b b1); intros.
inversion H3. unfold sizeof; rewrite LV. omega.
generalize (BOUND _ _ H3). omega.
- generalize (IHalloc_variables _ _ _ ASVS MATCH1 MINJ1 SZ1POS BOUND1 DEFINED1).
intros [f' [INCR2 [MINJ2 MATCH2]]].
exists f'; intuition. eapply inject_incr_trans; eauto.
(* 1.2 info = Var_local chunk *)
intro EQ; injection EQ; intros; clear EQ. subst sz1.
- generalize (alloc_unmapped_inject _ _ _ _ _ _ _ MINJ H).
+ exploit alloc_unmapped_inject; eauto.
set (f1 := extend_inject b1 None f). intros [MINJ1 INCR1].
- assert (MATCH1: match_callstack f1
- (mkframe cenv1 (PTree.set id (b1, lv) e) te sp lo (nextblock m1) :: cs)
- (nextblock m1) (nextblock tm) m1).
- unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto.
- assert (BOUND1: forall b delta, f1 b = Some(sp, delta) ->
- high_bound m1 b + delta <= sz).
+ exploit IHalloc_variables; eauto.
+ unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto.
intros until delta; unfold f1, extend_inject, eq_block.
rewrite (high_bound_alloc _ _ b _ _ _ H).
case (zeq b b1); intros. discriminate.
eapply BOUND; eauto.
- generalize (IHalloc_variables _ _ _ ASVS MATCH1 MINJ1 SZPOS BOUND1 DEFINED1).
intros [f' [INCR2 [MINJ2 MATCH2]]].
exists f'; intuition. eapply inject_incr_trans; eauto.
(* 2. lv = LVarray dim, info = Var_stack_array *)
@@ -1273,20 +1362,15 @@ Proof.
unfold f1; eapply alloc_mapped_inject; eauto.
omega. omega. omega. omega. unfold sizeof; rewrite LV. omega.
intros. left. generalize (BOUND _ _ H8). omega.
- elim H6; intros MINJ1 INCR1; clear H6.
- assert (MATCH1: match_callstack f1
- (mkframe cenv1 (PTree.set id (b1, lv) e) te sp lo (nextblock m1) :: cs)
- (nextblock m1) (nextblock tm) m1).
+ destruct H6 as [MINJ1 INCR1].
+ exploit IHalloc_variables; eauto.
unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto.
- assert (SZ1POS: 0 <= sz1). rewrite <- H1. omega.
- assert (BOUND1: forall b delta, f1 b = Some(sp, delta) ->
- high_bound m1 b + delta <= sz1).
- intros until delta; unfold f1, extend_inject, eq_block.
- rewrite (high_bound_alloc _ _ b _ _ _ H).
- case (zeq b b1); intros.
- inversion H6. unfold sizeof; rewrite LV. omega.
- generalize (BOUND _ _ H6). omega.
- generalize (IHalloc_variables _ _ _ ASVS MATCH1 MINJ1 SZ1POS BOUND1 DEFINED1).
+ rewrite <- H1. omega.
+ intros until delta; unfold f1, extend_inject, eq_block.
+ rewrite (high_bound_alloc _ _ b _ _ _ H).
+ case (zeq b b1); intros.
+ inversion H6. unfold sizeof; rewrite LV. omega.
+ generalize (BOUND _ _ H6). omega.
intros [f' [INCR2 [MINJ2 MATCH2]]].
exists f'; intuition. eapply inject_incr_trans; eauto.
Qed.
@@ -1370,15 +1454,15 @@ Proof.
(* me_inj *)
intros until lv2. unfold Csharpminor.empty_env; rewrite PTree.gempty; congruence.
(* me_inv *)
- intros. elim (mi_mappedblocks _ _ _ H4 _ _ _ H5); intros.
- elim (fresh_block_alloc _ _ _ _ _ H2 H6).
+ intros. exploit mi_mappedblocks; eauto. intros [A B].
+ elim (fresh_block_alloc _ _ _ _ _ H2 A).
(* me_incr *)
- intros. elim (mi_mappedblocks _ _ _ H4 _ _ _ H5); intros.
+ intros. exploit mi_mappedblocks; eauto. intros [A B].
rewrite SP; auto.
rewrite SP; auto.
eapply alloc_right_inject; eauto.
omega.
- intros. elim (mi_mappedblocks _ _ _ H4 _ _ _ H5); intros.
+ intros. exploit mi_mappedblocks; eauto. intros [A B].
unfold block in SP; omegaContradiction.
(* defined *)
intros. unfold te. apply set_locals_params_defined.
@@ -1421,7 +1505,7 @@ Proof.
unfold block; rewrite H2; omega.
elim H4; intro. left; congruence. right; auto.
elim H3; intro. subst b b1.
- generalize (alloc_variables_nextblock_incr _ _ _ _ _ _ H0).
+ generalize (alloc_variables_nextblock_incr _ _ _ _ _ _ H0).
rewrite H2. omega.
generalize (B H4). rewrite H2. omega.
Qed.
@@ -1465,7 +1549,7 @@ Lemma store_parameters_correct:
exists te2, exists tm2,
exec_stmt tge (Vptr sp Int.zero)
te1 tm1 (store_parameters cenv params)
- te2 tm2 Out_normal
+ E0 te2 tm2 Out_normal
/\ mem_inject f m2 tm2
/\ match_callstack f (mkframe cenv e te2 sp lo hi :: cs) m2.(nextblock) tm2.(nextblock) m2.
Proof.
@@ -1476,59 +1560,54 @@ Proof.
intros until tm1. intros VVM NOREPET MINJ MATCH. simpl.
inversion VVM. subst f0 id0 chunk0 vars v vals te.
inversion MATCH. subst f0 cenv0 e0 te sp0 lo0 hi0 cs0 bound tbound m0.
- inversion H19.
+ inversion H18.
inversion NOREPET. subst hd tl.
assert (NEXT: nextblock m1 = nextblock m).
- generalize (store_inv _ _ _ _ _ _ H1). simpl; tauto.
- generalize (me_vars0 id). intro. inversion H3; subst.
+ exploit store_inv; eauto. simpl; tauto.
+ generalize (me_vars0 id). intro. inversion H2; subst.
(* cenv!!id = Var_local chunk *)
assert (b0 = b). congruence. subst b0.
assert (chunk0 = chunk). congruence. subst chunk0.
assert (v' = tv). congruence. subst v'.
- assert (eval_expr tge (Vptr sp Int.zero) nil te1 tm1 (Evar id) te1 tm1 tv).
- constructor. auto.
- generalize (make_cast_correct _ _ _ _ _ _ _ _ _ _ _ _
- H15 H0 H11).
- intros [tv' [EVAL1 [VINJ1 VNORM]]].
+ exploit make_cast_correct.
+ apply eval_Evar with (id := id). eauto.
+ eexact H10.
+ intros [tv' [EVAL1 VINJ1]].
set (te2 := PTree.set id tv' te1).
assert (VVM2: vars_vals_match f params vl te2).
apply vars_vals_match_extensional with te1; auto.
intros. unfold te2; apply PTree.gso. red; intro; subst id0.
- elim H5. change id with (fst (id, lv)). apply List.in_map; auto.
- generalize (store_unmapped_inject _ _ _ _ _ _ _ _ MINJ H1 H9); intro MINJ2.
- generalize (match_callstack_store_local _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
- H VINJ1 VNORM H1 MATCH);
+ elim H4. change id with (fst (id, lv)). apply List.in_map; auto.
+ exploit store_unmapped_inject; eauto. intro MINJ2.
+ exploit match_callstack_store_local; eauto.
fold te2; rewrite <- NEXT; intro MATCH2.
- destruct (IHbind_parameters _ _ _ _ _ _ _ _ VVM2 H6 MINJ2 MATCH2)
- as [te3 [tm3 [EXEC3 [MINJ3 MATCH3]]]].
+ exploit IHbind_parameters; eauto.
+ intros [te3 [tm3 [EXEC3 [MINJ3 MATCH3]]]].
exists te3; exists tm3.
(* execution *)
- split. apply exec_Sseq_continue with te2 tm1.
- econstructor. unfold te2. constructor. assumption.
- assumption.
+ split. apply exec_Sseq_continue with E0 te2 tm1 E0.
+ econstructor. unfold te2. constructor. eassumption.
+ assumption. traceEq.
(* meminj & match_callstack *)
tauto.
(* cenv!!id = Var_stack_scalar *)
assert (b0 = b). congruence. subst b0.
assert (chunk0 = chunk). congruence. subst chunk0.
- pose (EVAL1 := make_stackaddr_correct sp nil te1 tm1 ofs).
- assert (EVAL2: eval_expr tge (Vptr sp Int.zero) nil te1 tm1 (Evar id) te1 tm1 tv).
- constructor. auto.
- destruct (make_store_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
- (Vptr b Int.zero) _
- EVAL1 EVAL2 H0 H1 MINJ H8 H11)
- as [tm2 [tv' [EVAL3 [MINJ2 [VINJ NEXT1]]]]].
- assert (f b <> None). inversion H8. congruence.
- generalize (match_callstack_mapped _ _ _ _ _ MATCH _ _ _ _ _ H9 H1).
+ exploit make_store_correct.
+ eapply make_stackaddr_correct.
+ apply eval_Evar with (id := id).
+ eauto. 2:eauto. 2:eauto. unfold storev; eexact H0. eauto.
+ intros [tm2 [EVAL3 [MINJ2 NEXT1]]].
+ exploit match_callstack_mapped.
+ eexact MATCH. 2:eauto. inversion H7. congruence.
rewrite <- NEXT; rewrite <- NEXT1; intro MATCH2.
- destruct (IHbind_parameters _ _ _ _ _ _ _ _
- H12 H6 MINJ2 MATCH2) as [te3 [tm3 [EVAL4 [MINJ3 MATCH3]]]].
+ exploit IHbind_parameters; eauto.
+ intros [te3 [tm3 [EVAL4 [MINJ3 MATCH3]]]].
exists te3; exists tm3.
(* execution *)
- split. apply exec_Sseq_continue with te1 tm2.
- econstructor. eauto.
- assumption.
+ split. apply exec_Sseq_continue with (E0**E0) te1 tm2 E0.
+ auto. assumption. traceEq.
(* meminj & match_callstack *)
tauto.
@@ -1589,44 +1668,6 @@ Proof.
induction 1; simpl; eauto.
Qed.
-(****
-Lemma build_compilenv_domain:
- forall f id chunk,
- In (id, chunk) f.(Csharpminor.fn_params) ->
- (fst (build_compilenv gce f))!id <> None.
-Proof.
- assert (forall atk id lv cenv_sz id0,
- let cenv_sz' := assign_variable atk (id, lv) cenv_sz in
- (fst cenv_sz')!id <> None
- /\ ((fst cenv_sz)!id0 <> None -> (fst cenv_sz')!id0 <> None)).
- intros. unfold cenv_sz'. destruct cenv_sz as [cenv sz].
- unfold assign_variable. destruct lv.
- case (Identset.mem id atk); simpl. split. rewrite PTree.gss. congruence.
- rewrite PTree.gsspec. case (peq id0 id); intros. congruence. auto.
- split. rewrite PTree.gss. congruence.
- rewrite PTree.gsspec. case (peq id0 id); intros. congruence. auto.
- simpl. split. rewrite PTree.gss. congruence.
- rewrite PTree.gsspec. case (peq id0 id); intros. congruence. auto.
-
- assert (forall atk id_lv_list cenv_sz id lv,
- In (id, lv) id_lv_list \/ (fst cenv_sz)!id <> None ->
- (fst (assign_variables atk id_lv_list cenv_sz))!id <> None).
- induction id_lv_list; simpl; intros.
- tauto.
- apply IHid_lv_list with lv.
- destruct a as [id0 lv0].
- generalize (H atk id0 lv0 cenv_sz id).
- simpl. intro. intuition. injection H0; intros; subst id0 lv0. intuition.
-
- intros. unfold build_compilenv. apply H0 with (Vscalar chunk).
- left. unfold fn_variables. apply List.in_or_app. left.
- set (g := fun (id_chunk : ident * memory_chunk) => (fst id_chunk, Vscalar (snd id_chunk))).
- change positive with ident.
- change (id, Vscalar chunk) with (g (id, chunk)).
- apply List.in_map. auto.
-Qed.
-****)
-
(** The final result in this section: the behaviour of function entry
in the generated Cminor code (allocate stack data block and store
parameters whose address is taken) simulates what happens at function
@@ -1649,7 +1690,7 @@ Lemma function_entry_ok:
exists f2, exists te2, exists tm2,
exec_stmt tge (Vptr sp Int.zero)
te tm1 (store_parameters cenv fn.(Csharpminor.fn_params))
- te2 tm2 Out_normal
+ E0 te2 tm2 Out_normal
/\ mem_inject f2 m2 tm2
/\ inject_incr f f2
/\ match_callstack f2
@@ -1658,24 +1699,21 @@ Lemma function_entry_ok:
/\ (forall b, m.(nextblock) <= b < m1.(nextblock) <-> In b lb).
Proof.
intros.
- generalize (bind_parameters_length _ _ _ _ _ H0); intro LEN1.
- destruct (match_callstack_alloc_variables _ _ _ _ _ _ _ _ _ _ _ _ tvargs
- H2 H3 H H4 H1 H6)
- as [f1 [INCR1 [MINJ1 MATCH1]]].
- fold te in MATCH1.
- assert (VLI: val_list_inject f1 vargs tvargs).
- eapply val_list_inject_incr; eauto.
- generalize (vars_vals_match_holds _ _ _ _ LEN1 VLI _
- (list_norepet_append_commut _ _ H7)).
- fold te. intro VVM.
- assert (NOREPET: list_norepet (List.map (@fst ident memory_chunk) fn.(Csharpminor.fn_params))).
- unfold fn_params_names in H7.
- eapply list_norepet_append_left; eauto.
- destruct (store_parameters_correct _ _ _ _ _ H0 _ _ _ _ _ _ _ _
- VVM NOREPET MINJ1 MATCH1)
- as [te2 [tm2 [EXEC [MINJ2 MATCH2]]]].
+ exploit bind_parameters_length; eauto. intro LEN1.
+ exploit match_callstack_alloc_variables; eauto.
+ intros [f1 [INCR1 [MINJ1 MATCH1]]].
+ exploit vars_vals_match_holds.
+ eauto. apply val_list_inject_incr with f. eauto. eauto.
+ apply list_norepet_append_commut.
+ unfold fn_vars_names in H7. eexact H7.
+ intro VVM.
+ exploit store_parameters_correct.
+ eauto. eauto.
+ unfold fn_params_names in H7. eapply list_norepet_append_left; eauto.
+ eexact MINJ1. eauto.
+ intros [te2 [tm2 [EXEC [MINJ2 MATCH2]]]].
exists f1; exists te2; exists tm2.
- split. auto. split. auto. split. auto. split. auto.
+ split; auto. split; auto. split; auto. split; auto.
intros; eapply alloc_variables_list_block; eauto.
Qed.
@@ -1745,7 +1783,7 @@ Ltac monadInv H :=
hypotheses in the proof of simulation. *)
Definition eval_expr_prop
- (le: Csharpminor.letenv) (e: Csharpminor.env) (m1: mem) (a: Csharpminor.expr) (m2: mem) (v: val) : Prop :=
+ (le: Csharpminor.letenv) (e: Csharpminor.env) (m1: mem) (a: Csharpminor.expr) (t: trace) (m2: mem) (v: val) : Prop :=
forall cenv ta f1 tle te1 tm1 sp lo hi cs
(TR: transl_expr cenv a = Some ta)
(LINJ: val_list_inject f1 le tle)
@@ -1754,7 +1792,7 @@ Definition eval_expr_prop
(mkframe cenv e te1 sp lo hi :: cs)
m1.(nextblock) tm1.(nextblock) m1),
exists f2, exists te2, exists tm2, exists tv,
- eval_expr tge (Vptr sp Int.zero) tle te1 tm1 ta te2 tm2 tv
+ eval_expr tge (Vptr sp Int.zero) tle te1 tm1 ta t te2 tm2 tv
/\ val_inject f2 v tv
/\ mem_inject f2 m2 tm2
/\ inject_incr f1 f2
@@ -1763,7 +1801,7 @@ Definition eval_expr_prop
m2.(nextblock) tm2.(nextblock) m2.
Definition eval_exprlist_prop
- (le: Csharpminor.letenv) (e: Csharpminor.env) (m1: mem) (al: Csharpminor.exprlist) (m2: mem) (vl: list val) : Prop :=
+ (le: Csharpminor.letenv) (e: Csharpminor.env) (m1: mem) (al: Csharpminor.exprlist) (t: trace) (m2: mem) (vl: list val) : Prop :=
forall cenv tal f1 tle te1 tm1 sp lo hi cs
(TR: transl_exprlist cenv al = Some tal)
(LINJ: val_list_inject f1 le tle)
@@ -1772,7 +1810,7 @@ Definition eval_exprlist_prop
(mkframe cenv e te1 sp lo hi :: cs)
m1.(nextblock) tm1.(nextblock) m1),
exists f2, exists te2, exists tm2, exists tvl,
- eval_exprlist tge (Vptr sp Int.zero) tle te1 tm1 tal te2 tm2 tvl
+ eval_exprlist tge (Vptr sp Int.zero) tle te1 tm1 tal t te2 tm2 tvl
/\ val_list_inject f2 vl tvl
/\ mem_inject f2 m2 tm2
/\ inject_incr f1 f2
@@ -1781,14 +1819,14 @@ Definition eval_exprlist_prop
m2.(nextblock) tm2.(nextblock) m2.
Definition eval_funcall_prop
- (m1: mem) (fn: Csharpminor.function) (args: list val) (m2: mem) (res: val) : Prop :=
+ (m1: mem) (fn: Csharpminor.fundef) (args: list val) (t: trace) (m2: mem) (res: val) : Prop :=
forall tfn f1 tm1 cs targs
- (TR: transl_function gce fn = Some tfn)
+ (TR: transl_fundef gce fn = Some tfn)
(MINJ: mem_inject f1 m1 tm1)
(MATCH: match_callstack f1 cs m1.(nextblock) tm1.(nextblock) m1)
(ARGSINJ: val_list_inject f1 args targs),
exists f2, exists tm2, exists tres,
- eval_funcall tge tm1 tfn targs tm2 tres
+ eval_funcall tge tm1 tfn targs t tm2 tres
/\ val_inject f2 res tres
/\ mem_inject f2 m2 tm2
/\ inject_incr f1 f2
@@ -1807,7 +1845,7 @@ Inductive outcome_inject (f: meminj) : Csharpminor.outcome -> outcome -> Prop :=
outcome_inject f (Csharpminor.Out_return (Some v1)) (Out_return (Some v2)).
Definition exec_stmt_prop
- (e: Csharpminor.env) (m1: mem) (s: Csharpminor.stmt) (m2: mem) (out: Csharpminor.outcome): Prop :=
+ (e: Csharpminor.env) (m1: mem) (s: Csharpminor.stmt) (t: trace) (m2: mem) (out: Csharpminor.outcome): Prop :=
forall cenv ts f1 te1 tm1 sp lo hi cs
(TR: transl_stmt cenv s = Some ts)
(MINJ: mem_inject f1 m1 tm1)
@@ -1815,7 +1853,7 @@ Definition exec_stmt_prop
(mkframe cenv e te1 sp lo hi :: cs)
m1.(nextblock) tm1.(nextblock) m1),
exists f2, exists te2, exists tm2, exists tout,
- exec_stmt tge (Vptr sp Int.zero) te1 tm1 ts te2 tm2 tout
+ exec_stmt tge (Vptr sp Int.zero) te1 tm1 ts t te2 tm2 tout
/\ outcome_inject f2 out tout
/\ mem_inject f2 m2 tm2
/\ inject_incr f1 f2
@@ -1823,14 +1861,6 @@ Definition exec_stmt_prop
(mkframe cenv e te2 sp lo hi :: cs)
m2.(nextblock) tm2.(nextblock) m2.
-(*
-Check (eval_funcall_ind4 prog
- eval_expr_prop
- eval_exprlist_prop
- eval_funcall_prop
- exec_stmt_prop).
-*)
-
(** There are as many cases in the inductive proof as there are evaluation
rules in the Csharpminor semantics. We treat each case as a separate
lemma. *)
@@ -1841,33 +1871,12 @@ Lemma transl_expr_Evar_correct:
(b : block) (chunk : memory_chunk) (v : val),
eval_var_ref prog e id b chunk ->
load chunk m b 0 = Some v ->
- eval_expr_prop le e m (Csharpminor.Evar id) m v.
+ eval_expr_prop le e m (Csharpminor.Evar id) E0 m v.
Proof.
intros; red; intros. unfold transl_expr in TR.
- generalize (var_get_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ tle
- TR MATCH MINJ H H0).
+ exploit var_get_correct; eauto.
intros [tv [EVAL VINJ]].
- exists f1; exists te1; exists tm1; exists tv; intuition.
-Qed.
-
-Lemma transl_expr_Eassign_correct:
- forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem)
- (id : positive) (a : Csharpminor.expr) (m1 : mem) (b : block)
- (chunk : memory_chunk) (v1 v2 : val) (m2 : mem),
- Csharpminor.eval_expr prog le e m a m1 v1 ->
- eval_expr_prop le e m a m1 v1 ->
- eval_var_ref prog e id b chunk ->
- cast chunk v1 = Some v2 ->
- store chunk m1 b 0 v2 = Some m2 ->
- eval_expr_prop le e m (Csharpminor.Eassign id a) m2 v2.
-Proof.
- intros; red; intros. monadInv TR; intro EQ0.
- generalize (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH).
- intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR12 MATCH1]]]]]]]].
- generalize (var_set_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
- EQ0 MATCH1 EVAL1 VINJ1 MINJ1 H1 H2 H3).
- intros [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 MATCH2]]]]]].
- exists f2; exists te3; exists tm3; exists tv2. tauto.
+ exists f1; exists te1; exists tm1; exists tv; intuition eauto.
Qed.
Lemma transl_expr_Eaddrof_correct:
@@ -1875,199 +1884,162 @@ Lemma transl_expr_Eaddrof_correct:
(e : Csharpminor.env) (m : mem) (id : positive)
(b : block),
eval_var_addr prog e id b ->
- eval_expr_prop le e m (Eaddrof id) m (Vptr b Int.zero).
+ eval_expr_prop le e m (Eaddrof id) E0 m (Vptr b Int.zero).
Proof.
intros; red; intros. simpl in TR.
- generalize (var_addr_correct _ _ _ _ _ _ _ _ _ _ _ _ _ tle
- MATCH TR H).
+ exploit var_addr_correct; eauto.
intros [tv [EVAL VINJ]].
- exists f1; exists te1; exists tm1; exists tv. intuition.
+ exists f1; exists te1; exists tm1; exists tv. intuition eauto.
Qed.
Lemma transl_expr_Eop_correct:
forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem)
- (op : Csharpminor.operation) (al : Csharpminor.exprlist) (m1 : mem)
- (vl : list val) (v : val),
- Csharpminor.eval_exprlist prog le e m al m1 vl ->
- eval_exprlist_prop le e m al m1 vl ->
+ (op : Csharpminor.operation) (al : Csharpminor.exprlist)
+ (t: trace) (m1 : mem) (vl : list val) (v : val),
+ Csharpminor.eval_exprlist prog le e m al t m1 vl ->
+ eval_exprlist_prop le e m al t m1 vl ->
Csharpminor.eval_operation op vl m1 = Some v ->
- eval_expr_prop le e m (Csharpminor.Eop op al) m1 v.
+ eval_expr_prop le e m (Csharpminor.Eop op al) t m1 v.
Proof.
intros; red; intros. monadInv TR; intro EQ0.
- generalize (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH).
+ exploit H0; eauto.
intros [f2 [te2 [tm2 [tvl [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]].
- generalize (make_op_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _
- EQ0 H1 EVAL1 VINJ1 MINJ1).
+ exploit make_op_correct; eauto.
intros [tv [EVAL2 VINJ2]].
exists f2; exists te2; exists tm2; exists tv. intuition.
Qed.
Lemma transl_expr_Eload_correct:
forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem)
- (chunk : memory_chunk) (a : Csharpminor.expr) (m1 : mem)
+ (chunk : memory_chunk) (a : Csharpminor.expr) (t: trace) (m1 : mem)
(v1 v : val),
- Csharpminor.eval_expr prog le e m a m1 v1 ->
- eval_expr_prop le e m a m1 v1 ->
+ Csharpminor.eval_expr prog le e m a t m1 v1 ->
+ eval_expr_prop le e m a t m1 v1 ->
loadv chunk m1 v1 = Some v ->
- eval_expr_prop le e m (Csharpminor.Eload chunk a) m1 v.
+ eval_expr_prop le e m (Csharpminor.Eload chunk a) t m1 v.
Proof.
intros; red; intros.
monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH)
- as [f2 [te2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]].
- destruct (loadv_inject _ _ _ _ _ _ _ MINJ2 H1 VINJ1)
- as [tv [TLOAD VINJ]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]].
+ exploit loadv_inject; eauto.
+ intros [tv [TLOAD VINJ]].
exists f2; exists te2; exists tm2; exists tv.
intuition.
subst ta. eapply make_load_correct; eauto.
Qed.
-Lemma transl_expr_Estore_correct:
- forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem)
- (chunk : memory_chunk) (a b : Csharpminor.expr) (m1 : mem)
- (v1 : val) (m2 : mem) (v2 : val) (m3 : mem) (v3 : val),
- Csharpminor.eval_expr prog le e m a m1 v1 ->
- eval_expr_prop le e m a m1 v1 ->
- Csharpminor.eval_expr prog le e m1 b m2 v2 ->
- eval_expr_prop le e m1 b m2 v2 ->
- cast chunk v2 = Some v3 ->
- storev chunk m2 v1 v3 = Some m3 ->
- eval_expr_prop le e m (Csharpminor.Estore chunk a b) m3 v3.
-Proof.
- intros; red; intros. monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH)
- as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
- assert (LINJ2: val_list_inject f2 le tle). eapply val_list_inject_incr; eauto.
- destruct (H2 _ _ _ _ _ _ _ _ _ _ EQ0 LINJ2 MINJ2 MATCH2)
- as [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]].
- assert (VINJ1': val_inject f3 v1 tv1). eapply val_inject_incr; eauto.
- destruct (make_store_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
- EVAL1 EVAL2 H3 H4 MINJ3 VINJ1' VINJ2)
- as [tm4 [tv [EVAL [MINJ4 [VINJ4 NEXTBLOCK]]]]].
- exists f3; exists te3; exists tm4; exists tv.
- rewrite <- H6. intuition.
- eapply inject_incr_trans; eauto.
- assert (val_inject f3 v1 tv1). eapply val_inject_incr; eauto.
- unfold storev in H4; destruct v1; try discriminate.
- inversion H5.
- rewrite NEXTBLOCK. replace (nextblock m3) with (nextblock m2).
- eapply match_callstack_mapped; eauto. congruence.
- generalize (store_inv _ _ _ _ _ _ H4). simpl; symmetry; tauto.
-Qed.
-
-Lemma sig_transl_function:
- forall f tf, transl_function gce f = Some tf -> tf.(fn_sig) = f.(Csharpminor.fn_sig).
-Proof.
- intros f tf. unfold transl_function.
- destruct (build_compilenv gce f).
- case (zle z Int.max_signed); intros.
- monadInv H. subst tf; reflexivity.
- congruence.
-Qed.
-
Lemma transl_expr_Ecall_correct:
forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem)
(sig : signature) (a : Csharpminor.expr) (bl : Csharpminor.exprlist)
- (m1 m2 m3 : mem) (vf : val) (vargs : list val) (vres : val)
- (f : Csharpminor.function),
- Csharpminor.eval_expr prog le e m a m1 vf ->
- eval_expr_prop le e m a m1 vf ->
- Csharpminor.eval_exprlist prog le e m1 bl m2 vargs ->
- eval_exprlist_prop le e m1 bl m2 vargs ->
+ (t1: trace) (m1: mem) (t2: trace) (m2: mem) (t3: trace) (m3: mem)
+ (vf : val) (vargs : list val) (vres : val)
+ (f : Csharpminor.fundef) (t: trace),
+ Csharpminor.eval_expr prog le e m a t1 m1 vf ->
+ eval_expr_prop le e m a t1 m1 vf ->
+ Csharpminor.eval_exprlist prog le e m1 bl t2 m2 vargs ->
+ eval_exprlist_prop le e m1 bl t2 m2 vargs ->
Genv.find_funct ge vf = Some f ->
- Csharpminor.fn_sig f = sig ->
- Csharpminor.eval_funcall prog m2 f vargs m3 vres ->
- eval_funcall_prop m2 f vargs m3 vres ->
- eval_expr_prop le e m (Csharpminor.Ecall sig a bl) m3 vres.
+ Csharpminor.funsig f = sig ->
+ Csharpminor.eval_funcall prog m2 f vargs t3 m3 vres ->
+ eval_funcall_prop m2 f vargs t3 m3 vres ->
+ t = t1 ** t2 ** t3 ->
+ eval_expr_prop le e m (Csharpminor.Ecall sig a bl) t m3 vres.
Proof.
intros;red;intros. monadInv TR. subst ta.
- generalize (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH).
+ exploit H0; eauto.
intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]].
- assert (LINJ1: val_list_inject f2 le tle). eapply val_list_inject_incr; eauto.
- generalize (H2 _ _ _ _ _ _ _ _ _ _ EQ0 LINJ1 MINJ1 MATCH1).
+ exploit H2.
+ eauto. eapply val_list_inject_incr; eauto. eauto. eauto.
intros [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]].
assert (tv1 = vf).
elim (Genv.find_funct_inv H3). intros bf VF. rewrite VF in H3.
rewrite Genv.find_funct_find_funct_ptr in H3.
generalize (Genv.find_funct_ptr_inv H3). intro.
assert (match_globalenvs f2). eapply match_callstack_match_globalenvs; eauto.
- generalize (mg_functions _ H8 _ H7). intro.
+ generalize (mg_functions _ H9 _ H8). intro.
rewrite VF in VINJ1. inversion VINJ1. subst vf.
decEq. congruence.
subst ofs2. replace x with 0. reflexivity. congruence.
subst tv1. elim (functions_translated _ _ H3). intros tf [FIND TRF].
- generalize (H6 _ _ _ _ _ TRF MINJ2 MATCH2 VINJ2).
+ exploit H6; eauto.
intros [f4 [tm4 [tres [EVAL3 [VINJ3 [MINJ3 [INCR3 MATCH3]]]]]]].
exists f4; exists te3; exists tm4; exists tres. intuition.
- eapply eval_Ecall; eauto. rewrite <- H4. apply sig_transl_function; auto.
+ eapply eval_Ecall; eauto.
+ rewrite <- H4. apply sig_preserved; auto.
apply inject_incr_trans with f2; auto.
apply inject_incr_trans with f3; auto.
Qed.
Lemma transl_expr_Econdition_true_correct:
forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem)
- (a b c : Csharpminor.expr) (m1 : mem) (v1 : val) (m2 : mem)
- (v2 : val),
- Csharpminor.eval_expr prog le e m a m1 v1 ->
- eval_expr_prop le e m a m1 v1 ->
+ (a b c : Csharpminor.expr) (t1: trace) (m1 : mem) (v1 : val)
+ (t2: trace) (m2 : mem) (v2 : val) (t: trace),
+ Csharpminor.eval_expr prog le e m a t1 m1 v1 ->
+ eval_expr_prop le e m a t1 m1 v1 ->
Val.is_true v1 ->
- Csharpminor.eval_expr prog le e m1 b m2 v2 ->
- eval_expr_prop le e m1 b m2 v2 ->
- eval_expr_prop le e m (Csharpminor.Econdition a b c) m2 v2.
+ Csharpminor.eval_expr prog le e m1 b t2 m2 v2 ->
+ eval_expr_prop le e m1 b t2 m2 v2 ->
+ t = t1 ** t2 ->
+ eval_expr_prop le e m (Csharpminor.Econdition a b c) t m2 v2.
Proof.
intros; red; intros. monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH)
- as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]].
- assert (LINJ1: val_list_inject f2 le tle). eapply val_list_inject_incr; eauto.
- destruct (H3 _ _ _ _ _ _ _ _ _ _ EQ0 LINJ1 MINJ1 MATCH1)
- as [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]].
+ exploit H3.
+ eauto. eapply val_list_inject_incr; eauto. eauto. eauto.
+ intros [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]].
exists f3; exists te3; exists tm3; exists tv2.
intuition.
- rewrite <- H5. eapply eval_conditionalexpr_true; eauto.
+ rewrite <- H6. subst t; eapply eval_conditionalexpr_true; eauto.
inversion VINJ1; subst v1 tv1; simpl in H1; simpl; contradiction || auto.
eapply inject_incr_trans; eauto.
Qed.
Lemma transl_expr_Econdition_false_correct:
forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem)
- (a b c : Csharpminor.expr) (m1 : mem) (v1 : val) (m2 : mem)
- (v2 : val),
- Csharpminor.eval_expr prog le e m a m1 v1 ->
- eval_expr_prop le e m a m1 v1 ->
+ (a b c : Csharpminor.expr) (t1: trace) (m1 : mem) (v1 : val)
+ (t2: trace) (m2 : mem) (v2 : val) (t: trace),
+ Csharpminor.eval_expr prog le e m a t1 m1 v1 ->
+ eval_expr_prop le e m a t1 m1 v1 ->
Val.is_false v1 ->
- Csharpminor.eval_expr prog le e m1 c m2 v2 ->
- eval_expr_prop le e m1 c m2 v2 ->
- eval_expr_prop le e m (Csharpminor.Econdition a b c) m2 v2.
+ Csharpminor.eval_expr prog le e m1 c t2 m2 v2 ->
+ eval_expr_prop le e m1 c t2 m2 v2 ->
+ t = t1 ** t2 ->
+ eval_expr_prop le e m (Csharpminor.Econdition a b c) t m2 v2.
Proof.
intros; red; intros. monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH)
- as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]].
- assert (LINJ1: val_list_inject f2 le tle). eapply val_list_inject_incr; eauto.
- destruct (H3 _ _ _ _ _ _ _ _ _ _ EQ1 LINJ1 MINJ1 MATCH1)
- as [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]].
+ exploit H3.
+ eauto. eapply val_list_inject_incr; eauto. eauto. eauto.
+ intros [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]].
exists f3; exists te3; exists tm3; exists tv2.
intuition.
- rewrite <- H5. eapply eval_conditionalexpr_false; eauto.
+ rewrite <- H6. subst t; eapply eval_conditionalexpr_false; eauto.
inversion VINJ1; subst v1 tv1; simpl in H1; simpl; contradiction || auto.
eapply inject_incr_trans; eauto.
Qed.
Lemma transl_expr_Elet_correct:
forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem)
- (a b : Csharpminor.expr) (m1 : mem) (v1 : val) (m2 : mem) (v2 : val),
- Csharpminor.eval_expr prog le e m a m1 v1 ->
- eval_expr_prop le e m a m1 v1 ->
- Csharpminor.eval_expr prog (v1 :: le) e m1 b m2 v2 ->
- eval_expr_prop (v1 :: le) e m1 b m2 v2 ->
- eval_expr_prop le e m (Csharpminor.Elet a b) m2 v2.
+ (a b : Csharpminor.expr) (t1: trace) (m1 : mem) (v1 : val)
+ (t2: trace) (m2 : mem) (v2 : val) (t: trace),
+ Csharpminor.eval_expr prog le e m a t1 m1 v1 ->
+ eval_expr_prop le e m a t1 m1 v1 ->
+ Csharpminor.eval_expr prog (v1 :: le) e m1 b t2 m2 v2 ->
+ eval_expr_prop (v1 :: le) e m1 b t2 m2 v2 ->
+ t = t1 ** t2 ->
+ eval_expr_prop le e m (Csharpminor.Elet a b) t m2 v2.
Proof.
intros; red; intros. monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH)
- as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]].
- assert (LINJ1: val_list_inject f2 (v1 :: le) (tv1 :: tle)).
- constructor. auto. eapply val_list_inject_incr; eauto.
- destruct (H2 _ _ _ _ _ _ _ _ _ _ EQ0 LINJ1 MINJ1 MATCH1)
- as [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]].
+ exploit H2.
+ eauto.
+ constructor. eauto. eapply val_list_inject_incr; eauto.
+ eauto. eauto.
+ intros [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]].
exists f3; exists te3; exists tm3; exists tv2.
intuition.
subst ta; eapply eval_Elet; eauto.
@@ -2089,19 +2061,46 @@ Lemma transl_expr_Eletvar_correct:
forall (le : list val) (e : Csharpminor.env) (m : mem) (n : nat)
(v : val),
nth_error le n = Some v ->
- eval_expr_prop le e m (Csharpminor.Eletvar n) m v.
+ eval_expr_prop le e m (Csharpminor.Eletvar n) E0 m v.
Proof.
intros; red; intros. monadInv TR.
- destruct (val_list_inject_nth _ _ _ LINJ _ _ H)
- as [tv [A B]].
+ exploit val_list_inject_nth; eauto. intros [tv [A B]].
exists f1; exists te1; exists tm1; exists tv.
intuition.
subst ta. eapply eval_Eletvar; auto.
Qed.
+Lemma transl_expr_Ealloc_correct:
+ forall (le: list val) (e: Csharpminor.env) (m1: mem) (a: Csharpminor.expr)
+ (t: trace) (m2: mem) (n: int) (m3: mem) (b: block),
+ Csharpminor.eval_expr prog le e m1 a t m2 (Vint n) ->
+ eval_expr_prop le e m1 a t m2 (Vint n) ->
+ Mem.alloc m2 0 (Int.signed n) = (m3, b) ->
+ eval_expr_prop le e m1 (Csharpminor.Ealloc a) t m3 (Vptr b Int.zero).
+Proof.
+ intros; red; intros. monadInv TR.
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ inversion VINJ1. subst tv1 i.
+ caseEq (alloc tm2 0 (Int.signed n)). intros tm3 tb TALLOC.
+ assert (LB: Int.min_signed <= 0). compute. congruence.
+ assert (HB: Int.signed n <= Int.max_signed).
+ generalize (Int.signed_range n); omega.
+ exploit alloc_parallel_inject; eauto.
+ intros [MINJ3 INCR3].
+ exists (extend_inject b (Some (tb, 0)) f2);
+ exists te2; exists tm3; exists (Vptr tb Int.zero).
+ split. subst ta; econstructor; eauto.
+ split. econstructor. unfold extend_inject, eq_block. rewrite zeq_true. reflexivity.
+ reflexivity.
+ split. assumption.
+ split. eapply inject_incr_trans; eauto.
+ eapply match_callstack_alloc; eauto.
+Qed.
+
Lemma transl_exprlist_Enil_correct:
forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem),
- eval_exprlist_prop le e m Csharpminor.Enil m nil.
+ eval_exprlist_prop le e m Csharpminor.Enil E0 m nil.
Proof.
intros; red; intros. monadInv TR.
exists f1; exists te1; exists tm1; exists (@nil val).
@@ -2110,50 +2109,55 @@ Qed.
Lemma transl_exprlist_Econs_correct:
forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem)
- (a : Csharpminor.expr) (bl : Csharpminor.exprlist) (m1 : mem)
- (v : val) (m2 : mem) (vl : list val),
- Csharpminor.eval_expr prog le e m a m1 v ->
- eval_expr_prop le e m a m1 v ->
- Csharpminor.eval_exprlist prog le e m1 bl m2 vl ->
- eval_exprlist_prop le e m1 bl m2 vl ->
- eval_exprlist_prop le e m (Csharpminor.Econs a bl) m2 (v :: vl).
+ (a : Csharpminor.expr) (bl : Csharpminor.exprlist)
+ (t1: trace) (m1 : mem) (v : val)
+ (t2: trace) (m2 : mem) (vl : list val) (t: trace),
+ Csharpminor.eval_expr prog le e m a t1 m1 v ->
+ eval_expr_prop le e m a t1 m1 v ->
+ Csharpminor.eval_exprlist prog le e m1 bl t2 m2 vl ->
+ eval_exprlist_prop le e m1 bl t2 m2 vl ->
+ t = t1 ** t2 ->
+ eval_exprlist_prop le e m (Csharpminor.Econs a bl) t m2 (v :: vl).
Proof.
intros; red; intros. monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH)
- as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
- assert (LINJ2: val_list_inject f2 le tle). eapply val_list_inject_incr; eauto.
- destruct (H2 _ _ _ _ _ _ _ _ _ _ EQ0 LINJ2 MINJ2 MATCH2)
- as [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]].
- assert (VINJ1': val_inject f3 v tv1). eapply val_inject_incr; eauto.
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H2.
+ eauto. eapply val_list_inject_incr; eauto. eauto. eauto.
+ intros [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]].
exists f3; exists te3; exists tm3; exists (tv1 :: tv2).
intuition. subst tal; econstructor; eauto.
+ constructor. eapply val_inject_incr; eauto. auto.
eapply inject_incr_trans; eauto.
Qed.
-Lemma transl_funcall_correct:
+Lemma transl_funcall_internal_correct:
forall (m : mem) (f : Csharpminor.function) (vargs : list val)
- (e : Csharpminor.env) (m1 : mem) (lb : list block) (m2 m3 : mem)
- (out : Csharpminor.outcome) (vres : val),
+ (e : Csharpminor.env) (m1 : mem) (lb : list block) (m2: mem)
+ (t: trace) (m3 : mem) (out : Csharpminor.outcome) (vres : val),
list_norepet (fn_params_names f ++ fn_vars_names f) ->
alloc_variables empty_env m (fn_variables f) e m1 lb ->
bind_parameters e m1 (Csharpminor.fn_params f) vargs m2 ->
- Csharpminor.exec_stmt prog e m2 (Csharpminor.fn_body f) m3 out ->
- exec_stmt_prop e m2 (Csharpminor.fn_body f) m3 out ->
+ Csharpminor.exec_stmt prog e m2 (Csharpminor.fn_body f) t m3 out ->
+ exec_stmt_prop e m2 (Csharpminor.fn_body f) t m3 out ->
Csharpminor.outcome_result_value out (sig_res (Csharpminor.fn_sig f)) vres ->
- eval_funcall_prop m f vargs (free_list m3 lb) vres.
+ eval_funcall_prop m (Internal f) vargs t (free_list m3 lb) vres.
Proof.
intros; red. intros tfn f1 tm; intros.
- unfold transl_function in TR.
+ generalize TR; clear TR.
+ unfold transl_fundef, transf_partial_fundef.
+ caseEq (transl_function gce f); try congruence.
+ intros tf TR EQ. inversion EQ; clear EQ; subst tfn.
+ unfold transl_function in TR.
caseEq (build_compilenv gce f); intros cenv stacksize CENV.
rewrite CENV in TR.
destruct (zle stacksize Int.max_signed); try discriminate.
monadInv TR. clear TR.
caseEq (alloc tm 0 stacksize). intros tm1 sp ALLOC.
- destruct (function_entry_ok _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
- H0 H1 MATCH CENV z ALLOC ARGSINJ MINJ H)
- as [f2 [te2 [tm2 [STOREPARAM [MINJ2 [INCR12 [MATCH2 BLOCKS]]]]]]].
- destruct (H3 _ _ _ _ _ _ _ _ _ EQ MINJ2 MATCH2)
- as [f3 [te3 [tm3 [tout [EXECBODY [OUTINJ [MINJ3 [INCR23 MATCH3]]]]]]]].
+ exploit function_entry_ok; eauto.
+ intros [f2 [te2 [tm2 [STOREPARAM [MINJ2 [INCR12 [MATCH2 BLOCKS]]]]]]].
+ red in H3; exploit H3; eauto.
+ intros [f3 [te3 [tm3 [tout [EXECBODY [OUTINJ [MINJ3 [INCR23 MATCH3]]]]]]]].
assert (exists tvres,
outcome_result_value tout f.(Csharpminor.fn_sig).(sig_res) tvres /\
val_inject f3 vres tvres).
@@ -2167,13 +2171,14 @@ Proof.
destruct (sig_res (Csharpminor.fn_sig f)); intro.
exists v2; split. auto. subst vres; auto.
contradiction.
- elim H5; clear H5; intros tvres [TOUT VINJRES].
+ destruct H5 as [tvres [TOUT VINJRES]].
exists f3; exists (Mem.free tm3 sp); exists tvres.
(* execution *)
split. rewrite <- H6; econstructor; simpl; eauto.
- apply exec_Sseq_continue with te2 tm2.
+ apply exec_Sseq_continue with E0 te2 tm2 t.
exact STOREPARAM.
eexact EXECBODY.
+ traceEq.
(* val_inject *)
split. assumption.
(* mem_inject *)
@@ -2190,9 +2195,22 @@ Proof.
intros. elim (BLOCKS b); intros B1 B2. generalize (B2 H7). omega.
Qed.
+Lemma transl_funcall_external_correct:
+ forall (m : mem) (ef : external_function) (vargs : list val)
+ (t : trace) (vres : val),
+ event_match ef vargs t vres ->
+ eval_funcall_prop m (External ef) vargs t m vres.
+Proof.
+ intros; red; intros.
+ simpl in TR. inversion TR; clear TR; subst tfn.
+ exploit event_match_inject; eauto. intros [A B].
+ exists f1; exists tm1; exists vres; intuition.
+ constructor; auto.
+Qed.
+
Lemma transl_stmt_Sskip_correct:
forall (e : Csharpminor.env) (m : mem),
- exec_stmt_prop e m Csharpminor.Sskip m Csharpminor.Out_normal.
+ exec_stmt_prop e m Csharpminor.Sskip E0 m Csharpminor.Out_normal.
Proof.
intros; red; intros. monadInv TR.
exists f1; exists te1; exists tm1; exists Out_normal.
@@ -2201,33 +2219,90 @@ Qed.
Lemma transl_stmt_Sexpr_correct:
forall (e : Csharpminor.env) (m : mem) (a : Csharpminor.expr)
- (m1 : mem) (v : val),
- Csharpminor.eval_expr prog nil e m a m1 v ->
- eval_expr_prop nil e m a m1 v ->
- exec_stmt_prop e m (Csharpminor.Sexpr a) m1 Csharpminor.Out_normal.
+ (t: trace) (m1 : mem) (v : val),
+ Csharpminor.eval_expr prog nil e m a t m1 v ->
+ eval_expr_prop nil e m a t m1 v ->
+ exec_stmt_prop e m (Csharpminor.Sexpr a) t m1 Csharpminor.Out_normal.
Proof.
intros; red; intros. monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ (val_nil_inject f1) MINJ MATCH)
- as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
exists f2; exists te2; exists tm2; exists Out_normal.
intuition. subst ts. econstructor; eauto.
constructor.
Qed.
+Lemma transl_stmt_Sassign_correct:
+ forall (e : Csharpminor.env) (m : mem)
+ (id : ident) (a : Csharpminor.expr) (t: trace) (m1 : mem) (b : block)
+ (chunk : memory_chunk) (v : val) (m2 : mem),
+ Csharpminor.eval_expr prog nil e m a t m1 v ->
+ eval_expr_prop nil e m a t m1 v ->
+ eval_var_ref prog e id b chunk ->
+ store chunk m1 b 0 v = Some m2 ->
+ exec_stmt_prop e m (Csharpminor.Sassign id a) t m2 Csharpminor.Out_normal.
+Proof.
+ intros; red; intros. monadInv TR; intro EQ0.
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR12 MATCH1]]]]]]]].
+ exploit var_set_correct; eauto.
+ intros [te3 [tm3 [EVAL2 [MINJ2 MATCH2]]]].
+ exists f2; exists te3; exists tm3; exists Out_normal.
+ intuition. constructor.
+Qed.
+
+Lemma transl_stmt_Sstore_correct:
+ forall (e : Csharpminor.env) (m : mem)
+ (chunk : memory_chunk) (a b : Csharpminor.expr) (t1: trace) (m1 : mem)
+ (v1 : val) (t2: trace) (m2 : mem) (v2 : val)
+ (t3: trace) (m3 : mem),
+ Csharpminor.eval_expr prog nil e m a t1 m1 v1 ->
+ eval_expr_prop nil e m a t1 m1 v1 ->
+ Csharpminor.eval_expr prog nil e m1 b t2 m2 v2 ->
+ eval_expr_prop nil e m1 b t2 m2 v2 ->
+ storev chunk m2 v1 v2 = Some m3 ->
+ t3 = t1 ** t2 ->
+ exec_stmt_prop e m (Csharpminor.Sstore chunk a b) t3 m3 Csharpminor.Out_normal.
+Proof.
+ intros; red; intros. monadInv TR.
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H2.
+ eauto.
+ eapply val_list_inject_incr; eauto.
+ eauto. eauto.
+ intros [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]].
+ exploit make_store_correct.
+ eexact EVAL1. eexact EVAL2. eauto. eauto.
+ eapply val_inject_incr; eauto. eauto.
+ intros [tm4 [EVAL [MINJ4 NEXTBLOCK]]].
+ exists f3; exists te3; exists tm4; exists Out_normal.
+ rewrite <- H6. subst t3. intuition.
+ constructor.
+ eapply inject_incr_trans; eauto.
+ assert (val_inject f3 v1 tv1). eapply val_inject_incr; eauto.
+ unfold storev in H3; destruct v1; try discriminate.
+ inversion H4.
+ rewrite NEXTBLOCK. replace (nextblock m3) with (nextblock m2).
+ eapply match_callstack_mapped; eauto. congruence.
+ exploit store_inv; eauto. simpl; symmetry; tauto.
+Qed.
+
Lemma transl_stmt_Sseq_continue_correct:
forall (e : Csharpminor.env) (m : mem) (s1 s2 : Csharpminor.stmt)
- (m1 m2 : mem) (out : Csharpminor.outcome),
- Csharpminor.exec_stmt prog e m s1 m1 Csharpminor.Out_normal ->
- exec_stmt_prop e m s1 m1 Csharpminor.Out_normal ->
- Csharpminor.exec_stmt prog e m1 s2 m2 out ->
- exec_stmt_prop e m1 s2 m2 out ->
- exec_stmt_prop e m (Csharpminor.Sseq s1 s2) m2 out.
+ (t1 t2: trace) (m1 m2 : mem) (t: trace) (out : Csharpminor.outcome),
+ Csharpminor.exec_stmt prog e m s1 t1 m1 Csharpminor.Out_normal ->
+ exec_stmt_prop e m s1 t1 m1 Csharpminor.Out_normal ->
+ Csharpminor.exec_stmt prog e m1 s2 t2 m2 out ->
+ exec_stmt_prop e m1 s2 t2 m2 out ->
+ t = t1 ** t2 ->
+ exec_stmt_prop e m (Csharpminor.Sseq s1 s2) t m2 out.
Proof.
intros; red; intros; monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ EQ MINJ MATCH)
- as [f2 [te2 [tm2 [tout1 [EXEC1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
- destruct (H2 _ _ _ _ _ _ _ _ _ EQ0 MINJ2 MATCH2)
- as [f3 [te3 [tm3 [tout2 [EXEC2 [OINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tout1 [EXEC1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H2; eauto.
+ intros [f3 [te3 [tm3 [tout2 [EXEC2 [OINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]].
exists f3; exists te3; exists tm3; exists tout2.
intuition. subst ts; eapply exec_Sseq_continue; eauto.
inversion OINJ1. subst tout1. auto.
@@ -2236,15 +2311,15 @@ Qed.
Lemma transl_stmt_Sseq_stop_correct:
forall (e : Csharpminor.env) (m : mem) (s1 s2 : Csharpminor.stmt)
- (m1 : mem) (out : Csharpminor.outcome),
- Csharpminor.exec_stmt prog e m s1 m1 out ->
- exec_stmt_prop e m s1 m1 out ->
+ (t1: trace) (m1 : mem) (out : Csharpminor.outcome),
+ Csharpminor.exec_stmt prog e m s1 t1 m1 out ->
+ exec_stmt_prop e m s1 t1 m1 out ->
out <> Csharpminor.Out_normal ->
- exec_stmt_prop e m (Csharpminor.Sseq s1 s2) m1 out.
+ exec_stmt_prop e m (Csharpminor.Sseq s1 s2) t1 m1 out.
Proof.
intros; red; intros; monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ EQ MINJ MATCH)
- as [f2 [te2 [tm2 [tout1 [EXEC1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tout1 [EXEC1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
exists f2; exists te2; exists tm2; exists tout1.
intuition. subst ts; eapply exec_Sseq_stop; eauto.
inversion OINJ1; subst out tout1; congruence.
@@ -2252,64 +2327,70 @@ Qed.
Lemma transl_stmt_Sifthenelse_true_correct:
forall (e : Csharpminor.env) (m : mem) (a : Csharpminor.expr)
- (sl1 sl2 : Csharpminor.stmt) (m1 : mem) (v1 : val) (m2 : mem)
- (out : Csharpminor.outcome),
- Csharpminor.eval_expr prog nil e m a m1 v1 ->
- eval_expr_prop nil e m a m1 v1 ->
+ (sl1 sl2 : Csharpminor.stmt)
+ (t1: trace) (m1 : mem) (v1 : val) (t2: trace) (m2 : mem)
+ (out : Csharpminor.outcome) (t: trace),
+ Csharpminor.eval_expr prog nil e m a t1 m1 v1 ->
+ eval_expr_prop nil e m a t1 m1 v1 ->
Val.is_true v1 ->
- Csharpminor.exec_stmt prog e m1 sl1 m2 out ->
- exec_stmt_prop e m1 sl1 m2 out ->
- exec_stmt_prop e m (Csharpminor.Sifthenelse a sl1 sl2) m2 out.
+ Csharpminor.exec_stmt prog e m1 sl1 t2 m2 out ->
+ exec_stmt_prop e m1 sl1 t2 m2 out ->
+ t = t1 ** t2 ->
+ exec_stmt_prop e m (Csharpminor.Sifthenelse a sl1 sl2) t m2 out.
Proof.
intros; red; intros. monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ (val_nil_inject f1) MINJ MATCH)
- as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
- destruct (H3 _ _ _ _ _ _ _ _ _ EQ0 MINJ2 MATCH2)
- as [f3 [te3 [tm3 [tout [EVAL2 [OINJ [MINJ3 [INCR3 MATCH3]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H3; eauto.
+ intros [f3 [te3 [tm3 [tout [EVAL2 [OINJ [MINJ3 [INCR3 MATCH3]]]]]]]].
exists f3; exists te3; exists tm3; exists tout.
intuition.
- subst ts. eapply exec_ifthenelse_true; eauto.
+ subst ts t. eapply exec_ifthenelse_true; eauto.
inversion VINJ1; subst v1 tv1; simpl in H1; simpl; contradiction || auto.
eapply inject_incr_trans; eauto.
Qed.
Lemma transl_stmt_Sifthenelse_false_correct:
forall (e : Csharpminor.env) (m : mem) (a : Csharpminor.expr)
- (sl1 sl2 : Csharpminor.stmt) (m1 : mem) (v1 : val) (m2 : mem)
- (out : Csharpminor.outcome),
- Csharpminor.eval_expr prog nil e m a m1 v1 ->
- eval_expr_prop nil e m a m1 v1 ->
+ (sl1 sl2 : Csharpminor.stmt)
+ (t1: trace) (m1 : mem) (v1 : val) (t2: trace) (m2 : mem)
+ (out : Csharpminor.outcome) (t: trace),
+ Csharpminor.eval_expr prog nil e m a t1 m1 v1 ->
+ eval_expr_prop nil e m a t1 m1 v1 ->
Val.is_false v1 ->
- Csharpminor.exec_stmt prog e m1 sl2 m2 out ->
- exec_stmt_prop e m1 sl2 m2 out ->
- exec_stmt_prop e m (Csharpminor.Sifthenelse a sl1 sl2) m2 out.
+ Csharpminor.exec_stmt prog e m1 sl2 t2 m2 out ->
+ exec_stmt_prop e m1 sl2 t2 m2 out ->
+ t = t1 ** t2 ->
+ exec_stmt_prop e m (Csharpminor.Sifthenelse a sl1 sl2) t m2 out.
Proof.
intros; red; intros. monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ (val_nil_inject f1) MINJ MATCH)
- as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
- destruct (H3 _ _ _ _ _ _ _ _ _ EQ1 MINJ2 MATCH2)
- as [f3 [te3 [tm3 [tout [EVAL2 [OINJ [MINJ3 [INCR3 MATCH3]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H3; eauto.
+ intros [f3 [te3 [tm3 [tout [EVAL2 [OINJ [MINJ3 [INCR3 MATCH3]]]]]]]].
exists f3; exists te3; exists tm3; exists tout.
intuition.
- subst ts. eapply exec_ifthenelse_false; eauto.
+ subst ts t. eapply exec_ifthenelse_false; eauto.
inversion VINJ1; subst v1 tv1; simpl in H1; simpl; contradiction || auto.
eapply inject_incr_trans; eauto.
Qed.
Lemma transl_stmt_Sloop_loop_correct:
forall (e : Csharpminor.env) (m : mem) (sl : Csharpminor.stmt)
- (m1 m2 : mem) (out : Csharpminor.outcome),
- Csharpminor.exec_stmt prog e m sl m1 Csharpminor.Out_normal ->
- exec_stmt_prop e m sl m1 Csharpminor.Out_normal ->
- Csharpminor.exec_stmt prog e m1 (Csharpminor.Sloop sl) m2 out ->
- exec_stmt_prop e m1 (Csharpminor.Sloop sl) m2 out ->
- exec_stmt_prop e m (Csharpminor.Sloop sl) m2 out.
+ (t1: trace) (m1: mem) (t2: trace) (m2 : mem)
+ (out : Csharpminor.outcome) (t: trace),
+ Csharpminor.exec_stmt prog e m sl t1 m1 Csharpminor.Out_normal ->
+ exec_stmt_prop e m sl t1 m1 Csharpminor.Out_normal ->
+ Csharpminor.exec_stmt prog e m1 (Csharpminor.Sloop sl) t2 m2 out ->
+ exec_stmt_prop e m1 (Csharpminor.Sloop sl) t2 m2 out ->
+ t = t1 ** t2 ->
+ exec_stmt_prop e m (Csharpminor.Sloop sl) t m2 out.
Proof.
intros; red; intros. monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ EQ MINJ MATCH)
- as [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
- destruct (H2 _ _ _ _ _ _ _ _ _ TR MINJ2 MATCH2)
- as [f3 [te3 [tm3 [tout2 [EVAL2 [OINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H2; eauto.
+ intros [f3 [te3 [tm3 [tout2 [EVAL2 [OINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]].
exists f3; exists te3; exists tm3; exists tout2.
intuition.
subst ts. eapply exec_Sloop_loop; eauto.
@@ -2317,18 +2398,17 @@ Proof.
eapply inject_incr_trans; eauto.
Qed.
-
Lemma transl_stmt_Sloop_exit_correct:
forall (e : Csharpminor.env) (m : mem) (sl : Csharpminor.stmt)
- (m1 : mem) (out : Csharpminor.outcome),
- Csharpminor.exec_stmt prog e m sl m1 out ->
- exec_stmt_prop e m sl m1 out ->
+ (t1: trace) (m1 : mem) (out : Csharpminor.outcome),
+ Csharpminor.exec_stmt prog e m sl t1 m1 out ->
+ exec_stmt_prop e m sl t1 m1 out ->
out <> Csharpminor.Out_normal ->
- exec_stmt_prop e m (Csharpminor.Sloop sl) m1 out.
+ exec_stmt_prop e m (Csharpminor.Sloop sl) t1 m1 out.
Proof.
intros; red; intros. monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ EQ MINJ MATCH)
- as [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
exists f2; exists te2; exists tm2; exists tout1.
intuition. subst ts; eapply exec_Sloop_stop; eauto.
inversion OINJ1; subst out tout1; congruence.
@@ -2336,15 +2416,15 @@ Qed.
Lemma transl_stmt_Sblock_correct:
forall (e : Csharpminor.env) (m : mem) (sl : Csharpminor.stmt)
- (m1 : mem) (out : Csharpminor.outcome),
- Csharpminor.exec_stmt prog e m sl m1 out ->
- exec_stmt_prop e m sl m1 out ->
- exec_stmt_prop e m (Csharpminor.Sblock sl) m1
+ (t1: trace) (m1 : mem) (out : Csharpminor.outcome),
+ Csharpminor.exec_stmt prog e m sl t1 m1 out ->
+ exec_stmt_prop e m sl t1 m1 out ->
+ exec_stmt_prop e m (Csharpminor.Sblock sl) t1 m1
(Csharpminor.outcome_block out).
Proof.
intros; red; intros. monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ EQ MINJ MATCH)
- as [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]].
exists f2; exists te2; exists tm2; exists (outcome_block tout1).
intuition. subst ts; eapply exec_Sblock; eauto.
inversion OINJ1; subst out tout1; simpl.
@@ -2356,7 +2436,7 @@ Qed.
Lemma transl_stmt_Sexit_correct:
forall (e : Csharpminor.env) (m : mem) (n : nat),
- exec_stmt_prop e m (Csharpminor.Sexit n) m (Csharpminor.Out_exit n).
+ exec_stmt_prop e m (Csharpminor.Sexit n) E0 m (Csharpminor.Out_exit n).
Proof.
intros; red; intros. monadInv TR.
exists f1; exists te1; exists tm1; exists (Out_exit n).
@@ -2366,15 +2446,15 @@ Qed.
Lemma transl_stmt_Sswitch_correct:
forall (e : Csharpminor.env) (m : mem)
(a : Csharpminor.expr) (cases : list (int * nat)) (default : nat)
- (m1 : mem) (n : int),
- Csharpminor.eval_expr prog nil e m a m1 (Vint n) ->
- eval_expr_prop nil e m a m1 (Vint n) ->
- exec_stmt_prop e m (Csharpminor.Sswitch a cases default) m1
+ (t1 : trace) (m1 : mem) (n : int),
+ Csharpminor.eval_expr prog nil e m a t1 m1 (Vint n) ->
+ eval_expr_prop nil e m a t1 m1 (Vint n) ->
+ exec_stmt_prop e m (Csharpminor.Sswitch a cases default) t1 m1
(Csharpminor.Out_exit (Csharpminor.switch_target n default cases)).
Proof.
intros; red; intros. monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ (val_nil_inject f1) MINJ MATCH)
- as [f2 [te2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]].
exists f2; exists te2; exists tm2;
exists (Out_exit (switch_target n default cases)). intuition.
subst ts. constructor. inversion VINJ1. subst tv1. assumption.
@@ -2383,7 +2463,7 @@ Qed.
Lemma transl_stmt_Sreturn_none_correct:
forall (e : Csharpminor.env) (m : mem),
- exec_stmt_prop e m (Csharpminor.Sreturn None) m
+ exec_stmt_prop e m (Csharpminor.Sreturn None) E0 m
(Csharpminor.Out_return None).
Proof.
intros; red; intros. monadInv TR.
@@ -2393,15 +2473,15 @@ Qed.
Lemma transl_stmt_Sreturn_some_correct:
forall (e : Csharpminor.env) (m : mem) (a : Csharpminor.expr)
- (m1 : mem) (v : val),
- Csharpminor.eval_expr prog nil e m a m1 v ->
- eval_expr_prop nil e m a m1 v ->
- exec_stmt_prop e m (Csharpminor.Sreturn (Some a)) m1
+ (t1: trace) (m1 : mem) (v : val),
+ Csharpminor.eval_expr prog nil e m a t1 m1 v ->
+ eval_expr_prop nil e m a t1 m1 v ->
+ exec_stmt_prop e m (Csharpminor.Sreturn (Some a)) t1 m1
(Csharpminor.Out_return (Some v)).
Proof.
intros; red; intros; monadInv TR.
- destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ (val_nil_inject f1) MINJ MATCH)
- as [f2 [te2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]].
+ exploit H0; eauto.
+ intros [f2 [te2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]].
exists f2; exists te2; exists tm2; exists (Out_return (Some tv1)).
intuition. subst ts; econstructor; eauto. constructor; auto.
Qed.
@@ -2410,9 +2490,9 @@ Qed.
evaluation derivation, using the lemmas above for each case. *)
Lemma transl_function_correct:
- forall m1 f vargs m2 vres,
- Csharpminor.eval_funcall prog m1 f vargs m2 vres ->
- eval_funcall_prop m1 f vargs m2 vres.
+ forall m1 f vargs t m2 vres,
+ Csharpminor.eval_funcall prog m1 f vargs t m2 vres ->
+ eval_funcall_prop m1 f vargs t m2 vres.
Proof
(eval_funcall_ind4 prog
eval_expr_prop
@@ -2421,21 +2501,23 @@ Proof
exec_stmt_prop
transl_expr_Evar_correct
- transl_expr_Eassign_correct
transl_expr_Eaddrof_correct
transl_expr_Eop_correct
transl_expr_Eload_correct
- transl_expr_Estore_correct
transl_expr_Ecall_correct
transl_expr_Econdition_true_correct
transl_expr_Econdition_false_correct
transl_expr_Elet_correct
transl_expr_Eletvar_correct
+ transl_expr_Ealloc_correct
transl_exprlist_Enil_correct
transl_exprlist_Econs_correct
- transl_funcall_correct
+ transl_funcall_internal_correct
+ transl_funcall_external_correct
transl_stmt_Sskip_correct
transl_stmt_Sexpr_correct
+ transl_stmt_Sassign_correct
+ transl_stmt_Sstore_correct
transl_stmt_Sseq_continue_correct
transl_stmt_Sseq_stop_correct
transl_stmt_Sifthenelse_true_correct
@@ -2472,11 +2554,11 @@ Qed.
follows. *)
Theorem transl_program_correct:
- forall n,
- Csharpminor.exec_program prog (Vint n) ->
- exec_program tprog (Vint n).
+ forall t n,
+ Csharpminor.exec_program prog t (Vint n) ->
+ exec_program tprog t (Vint n).
Proof.
- intros n [b [fn [m [FINDS [FINDF [SIG EVAL]]]]]].
+ intros t n [b [fn [m [FINDS [FINDF [SIG EVAL]]]]]].
elim (function_ptr_translated _ _ FINDF). intros tfn [TFIND TR].
set (m0 := Genv.init_mem (program_of_program prog)) in *.
set (f := fun b => if zlt b m0.(nextblock) then Some(b, 0) else None).
@@ -2488,26 +2570,25 @@ Proof.
split. auto.
constructor. compute. split; congruence. left; auto.
intros; omega.
- generalize (Genv.initmem_undef (program_of_program prog) b0). fold m0. intros [lo [hi EQ]].
- rewrite EQ. simpl. constructor.
+ generalize (Genv.initmem_block_init (program_of_program prog) b0). fold m0. intros [idata EQ].
+ rewrite EQ. simpl. apply Mem.contents_init_data_inject.
destruct (zlt b1 (nextblock m0)); try discriminate.
destruct (zlt b2 (nextblock m0)); try discriminate.
left; congruence.
assert (MATCH0: match_callstack f nil m0.(nextblock) m0.(nextblock) m0).
constructor. unfold f; apply match_globalenvs_init.
fold ge in EVAL.
- destruct (transl_function_correct _ _ _ _ _ EVAL
- _ _ _ _ _ TR MINJ0 MATCH0 (val_nil_inject f))
- as [f1 [tm1 [tres [TEVAL [VINJ [MINJ1 [INCR MATCH1]]]]]]].
+ exploit transl_function_correct; eauto.
+ intros [f1 [tm1 [tres [TEVAL [VINJ [MINJ1 [INCR MATCH1]]]]]]].
exists b; exists tfn; exists tm1.
split. fold tge. rewrite <- FINDS.
replace (prog_main prog) with (AST.prog_main tprog). fold ge. apply symbols_preserved.
transitivity (AST.prog_main (program_of_program prog)).
- apply transform_partial_program_main with (transl_function gce). assumption.
+ apply transform_partial_program_main with (transl_fundef gce). assumption.
reflexivity.
split. assumption.
- split. rewrite <- SIG. apply sig_transl_function; auto.
- rewrite (Genv.init_mem_transf_partial (transl_function gce) _ TRANSL).
+ split. rewrite <- SIG. apply sig_preserved; auto.
+ rewrite (Genv.init_mem_transf_partial (transl_fundef gce) _ TRANSL).
inversion VINJ; subst tres. assumption.
Qed.
diff --git a/backend/Coloring.v b/backend/Coloring.v
index 1a34a12..0a2487c 100644
--- a/backend/Coloring.v
+++ b/backend/Coloring.v
@@ -150,6 +150,12 @@ Definition add_edges_instr
(add_interf_op res live
(add_interf_call
(Regset.remove res live) destroyed_at_call_regs g)))
+ | Ialloc arg res s =>
+ add_pref_mreg arg loc_alloc_argument
+ (add_pref_mreg res loc_alloc_result
+ (add_interf_op res live
+ (add_interf_call
+ (Regset.remove res live) destroyed_at_call_regs g)))
| Ireturn (Some r) =>
add_pref_mreg r (loc_result sig) g
| _ => g
diff --git a/backend/Coloringproof.v b/backend/Coloringproof.v
index 39b208e..54d24cc 100644
--- a/backend/Coloringproof.v
+++ b/backend/Coloringproof.v
@@ -332,6 +332,10 @@ Proof.
eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl].
eapply graph_incl_trans; [idtac|apply add_interf_op_incl].
apply add_interf_call_incl.
+ eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl].
+ eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl].
+ eapply graph_incl_trans; [idtac|apply add_interf_op_incl].
+ apply add_interf_call_incl.
destruct o.
apply add_pref_mreg_incl.
apply graph_incl_refl.
@@ -370,6 +374,15 @@ Definition correct_interf_instr
/\ (forall r,
Regset.mem r live = true ->
r <> res -> interfere r res g)
+ | Ialloc arg res s =>
+ (forall r mr,
+ Regset.mem r live = true ->
+ In mr destroyed_at_call_regs ->
+ r <> res ->
+ interfere_mreg r mr g)
+ /\ (forall r,
+ Regset.mem r live = true ->
+ r <> res -> interfere r res g)
| _ =>
True
end.
@@ -389,6 +402,9 @@ Proof.
intros [A B]. split.
intros. eapply interfere_mreg_incl; eauto.
intros. eapply interfere_incl; eauto.
+ intros [A B]. split.
+ intros. eapply interfere_mreg_incl; eauto.
+ intros. eapply interfere_incl; eauto.
Qed.
Lemma add_edges_instr_correct:
@@ -417,6 +433,19 @@ Proof.
eapply graph_incl_trans; [idtac|apply add_prefs_call_incl].
apply add_pref_mreg_incl.
apply add_interf_op_correct; auto.
+
+ split; intros.
+ apply interfere_mreg_incl with
+ (add_interf_call (Regset.remove r0 live) destroyed_at_call_regs g).
+ eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl].
+ eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl].
+ apply add_interf_op_incl.
+ apply add_interf_call_correct; auto.
+ rewrite Regset.mem_remove_other; auto.
+
+ eapply interfere_incl.
+ eapply graph_incl_trans; apply add_pref_mreg_incl.
+ apply add_interf_op_correct; auto.
Qed.
Lemma add_edges_instrs_incl_aux:
@@ -541,7 +570,7 @@ Proof.
then false else true)).
red. unfold OrderedRegReg.eq. unfold OrderedReg.eq.
intros x y [EQ1 EQ2]. rewrite EQ1; rewrite EQ2; auto.
- generalize (SetRegReg.for_all_2 H1 H H0).
+ generalize (SetRegReg.for_all_2 _ _ H1 H _ H0).
simpl. case (Loc.eq (coloring r1) (coloring r2)); intro.
intro; discriminate. auto.
Qed.
@@ -558,7 +587,7 @@ Proof.
then false else true)).
red. unfold OrderedRegMreg.eq. unfold OrderedReg.eq.
intros x y [EQ1 EQ2]. rewrite EQ1; rewrite EQ2; auto.
- generalize (SetRegMreg.for_all_2 H1 H H0).
+ generalize (SetRegMreg.for_all_2 _ _ H1 H _ H0).
simpl. case (Loc.eq (coloring r1) (R mr2)); intro.
intro; discriminate. auto.
Qed.
@@ -702,6 +731,14 @@ Definition correct_alloc_instr
/\ (forall r,
Regset.mem r live!!pc = true ->
r <> res -> alloc r <> alloc res)
+ | Ialloc arg res s =>
+ (forall r,
+ Regset.mem r live!!pc = true ->
+ r <> res ->
+ ~(In (alloc r) Conventions.destroyed_at_call))
+ /\ (forall r,
+ Regset.mem r live!!pc = true ->
+ r <> res -> alloc r <> alloc res)
| _ =>
True
end.
@@ -780,6 +817,14 @@ Proof.
generalize (A r0 mr H IN H0). intro.
generalize (ALL2 _ _ H2). contradiction.
auto.
+ intros [A B]. split.
+ intros; red; intros.
+ unfold destroyed_at_call in H1.
+ generalize (list_in_map_inv R _ _ H1).
+ intros [mr [EQ IN]].
+ generalize (A r1 mr H IN H0). intro.
+ generalize (ALL2 _ _ H2). contradiction.
+ auto.
Qed.
Lemma regalloc_correct_1:
diff --git a/backend/Constprop.v b/backend/Constprop.v
index b1c5a2b..3820311 100644
--- a/backend/Constprop.v
+++ b/backend/Constprop.v
@@ -195,7 +195,9 @@ Definition eval_static_operation (op: operation) (vl: list approx) :=
| Ofloatconst n, nil => F n
| Oaddrsymbol s n, nil => S s n
| Ocast8signed, I n1 :: nil => I(Int.cast8signed n)
+ | Ocast8unsigned, I n1 :: nil => I(Int.cast8unsigned n)
| Ocast16signed, I n1 :: nil => I(Int.cast16signed n)
+ | Ocast16unsigned, I n1 :: nil => I(Int.cast16unsigned n)
| Oadd, I n1 :: I n2 :: nil => I(Int.add n1 n2)
| Oadd, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 n2)
| Oaddimm n, I n1 :: nil => I (Int.add n1 n)
@@ -379,6 +381,12 @@ Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx),
| eval_static_operation_case47:
forall c vl,
eval_static_operation_cases (Ocmp c) (vl)
+ | eval_static_operation_case48:
+ forall n1,
+ eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil)
+ | eval_static_operation_case49:
+ forall n1,
+ eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil)
| eval_static_operation_default:
forall (op: operation) (vl: list approx),
eval_static_operation_cases op vl.
@@ -475,6 +483,10 @@ Definition eval_static_operation_match (op: operation) (vl: list approx) :=
eval_static_operation_case46 n1
| Ocmp c, vl =>
eval_static_operation_case47 c vl
+ | Ocast8unsigned, I n1 :: nil =>
+ eval_static_operation_case48 n1
+ | Ocast16unsigned, I n1 :: nil =>
+ eval_static_operation_case49 n1
| op, vl =>
eval_static_operation_default op vl
end.
@@ -574,6 +586,10 @@ Definition eval_static_operation (op: operation) (vl: list approx) :=
| None => Unknown
| Some b => I(if b then Int.one else Int.zero)
end
+ | eval_static_operation_case48 n1 =>
+ I(Int.cast8unsigned n1)
+ | eval_static_operation_case49 n1 =>
+ I(Int.cast16unsigned n1)
| eval_static_operation_default op vl =>
Unknown
end.
@@ -603,6 +619,8 @@ Definition transfer (f: function) (pc: node) (before: D.t) :=
before
| Icall sig ros args res s =>
D.set res Unknown before
+ | Ialloc arg res s =>
+ D.set res Unknown before
| Icond cond args ifso ifnot =>
before
| Ireturn optarg =>
@@ -986,6 +1004,8 @@ Definition transf_instr (approx: D.t) (instr: instruction) :=
| inr s => ros
end in
Icall sig ros' args res s
+ | Ialloc arg res s =>
+ Ialloc arg res s
| Icond cond args s1 s2 =>
match eval_static_condition cond (approx_regs args approx) with
| Some b =>
@@ -1028,5 +1048,7 @@ Definition transf_function (f: function) : function :=
(transf_code_wf f approxs f.(fn_code_wf))
end.
+Definition transf_fundef := AST.transf_fundef transf_function.
+
Definition transf_program (p: program) : program :=
- transform_program transf_function p.
+ transform_program transf_fundef p.
diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v
index 080aa74..38ba38b 100644
--- a/backend/Constpropproof.v
+++ b/backend/Constpropproof.v
@@ -6,6 +6,7 @@ Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
+Require Import Events.
Require Import Mem.
Require Import Globalenvs.
Require Import Op.
@@ -144,11 +145,12 @@ Proof.
case (eval_static_operation_match op al); intros;
InvVLMA; simpl in *; FuncInv; try congruence.
- replace v with v0. auto. congruence.
-
destruct (Genv.find_symbol ge s). exists b. intuition congruence.
congruence.
+ rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence.
+ rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence.
+
exists b. split. auto. congruence.
exists b. split. auto. congruence.
exists b. split. auto. congruence.
@@ -178,12 +180,17 @@ Proof.
replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)).
injection H0; intro; subst v. simpl. congruence. discriminate. congruence.
+ rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence.
+
caseEq (eval_static_condition c vl0).
intros. generalize (eval_static_condition_correct _ _ _ _ H H1).
intro. rewrite H2 in H0.
destruct b; injection H0; intro; subst v; simpl; auto.
intros; simpl; auto.
+ rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence.
+ rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence.
+
auto.
Qed.
@@ -193,8 +200,8 @@ Qed.
the static approximation returned by the transfer function. *)
Lemma transfer_correct:
- forall f c sp pc rs m pc' rs' m' ra,
- exec_instr ge c sp pc rs m pc' rs' m' ->
+ forall f c sp pc rs m t pc' rs' m' ra,
+ exec_instr ge c sp pc rs m t pc' rs' m' ->
c = f.(fn_code) ->
regs_match_approx ra rs ->
regs_match_approx (transfer f pc ra) rs'.
@@ -208,6 +215,8 @@ Proof.
apply regs_match_approx_update; auto. simpl; auto.
(* Icall *)
apply regs_match_approx_update; auto. simpl; auto.
+ (* Ialloc *)
+ apply regs_match_approx_update; auto. simpl; auto.
Qed.
(** The correctness of the static analysis follows from the results
@@ -217,8 +226,8 @@ Qed.
Lemma analyze_correct_1:
forall f approxs,
analyze f = Some approxs ->
- forall c sp pc rs m pc' rs' m',
- exec_instr ge c sp pc rs m pc' rs' m' ->
+ forall c sp pc rs m t pc' rs' m',
+ exec_instr ge c sp pc rs m t pc' rs' m' ->
c = f.(fn_code) ->
regs_match_approx approxs!!pc rs ->
regs_match_approx approxs!!pc' rs'.
@@ -228,7 +237,7 @@ Proof.
eapply DS.fixpoint_solution.
unfold analyze in H. eexact H.
elim (fn_code_wf f pc); intro. auto.
- generalize (exec_instr_present _ _ _ _ _ _ _ _ _ H0).
+ generalize (exec_instr_present _ _ _ _ _ _ _ _ _ _ H0).
rewrite H1. intro. contradiction.
eapply successors_correct. rewrite <- H1. eauto.
eapply transfer_correct; eauto.
@@ -237,8 +246,8 @@ Qed.
Lemma analyze_correct_2:
forall f approxs,
analyze f = Some approxs ->
- forall c sp pc rs m pc' rs' m',
- exec_instrs ge c sp pc rs m pc' rs' m' ->
+ forall c sp pc rs m t pc' rs' m',
+ exec_instrs ge c sp pc rs m t pc' rs' m' ->
c = f.(fn_code) ->
regs_match_approx approxs!!pc rs ->
regs_match_approx approxs!!pc' rs'.
@@ -638,19 +647,28 @@ Let tge := Genv.globalenv tprog.
Lemma symbols_preserved:
forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
-Proof (Genv.find_symbol_transf transf_function prog).
+Proof (Genv.find_symbol_transf transf_fundef prog).
Lemma functions_translated:
- forall (v: val) (f: RTL.function),
+ forall (v: val) (f: RTL.fundef),
Genv.find_funct ge v = Some f ->
- Genv.find_funct tge v = Some (transf_function f).
-Proof (@Genv.find_funct_transf _ _ transf_function prog).
+ Genv.find_funct tge v = Some (transf_fundef f).
+Proof (@Genv.find_funct_transf _ _ transf_fundef prog).
Lemma function_ptr_translated:
- forall (v: block) (f: RTL.function),
+ forall (v: block) (f: RTL.fundef),
Genv.find_funct_ptr ge v = Some f ->
- Genv.find_funct_ptr tge v = Some (transf_function f).
-Proof (@Genv.find_funct_ptr_transf _ _ transf_function prog).
+ Genv.find_funct_ptr tge v = Some (transf_fundef f).
+Proof (@Genv.find_funct_ptr_transf _ _ transf_fundef prog).
+
+Lemma sig_translated:
+ forall (f: RTL.fundef),
+ funsig (transf_fundef f) = funsig f.
+Proof.
+ intro. case f; intros; simpl.
+ unfold transf_function. case (analyze f0); intros; reflexivity.
+ reflexivity.
+Qed.
(** The proof of semantic preservation is a simulation argument
based on diagrams of the following form:
@@ -676,30 +694,30 @@ Proof (@Genv.find_funct_ptr_transf _ _ transf_function prog).
Definition exec_instr_prop
(c: code) (sp: val)
- (pc: node) (rs: regset) (m: mem)
+ (pc: node) (rs: regset) (m: mem) (t: trace)
(pc': node) (rs': regset) (m': mem) : Prop :=
- exec_instr tge c sp pc rs m pc' rs' m' /\
+ exec_instr tge c sp pc rs m t pc' rs' m' /\
forall f approxs
(CF: c = f.(RTL.fn_code))
(ANL: analyze f = Some approxs)
(MATCH: regs_match_approx ge approxs!!pc rs),
- exec_instr tge (transf_code approxs c) sp pc rs m pc' rs' m'.
+ exec_instr tge (transf_code approxs c) sp pc rs m t pc' rs' m'.
Definition exec_instrs_prop
(c: code) (sp: val)
- (pc: node) (rs: regset) (m: mem)
+ (pc: node) (rs: regset) (m: mem) (t: trace)
(pc': node) (rs': regset) (m': mem) : Prop :=
- exec_instrs tge c sp pc rs m pc' rs' m' /\
+ exec_instrs tge c sp pc rs m t pc' rs' m' /\
forall f approxs
(CF: c = f.(RTL.fn_code))
(ANL: analyze f = Some approxs)
(MATCH: regs_match_approx ge approxs!!pc rs),
- exec_instrs tge (transf_code approxs c) sp pc rs m pc' rs' m'.
+ exec_instrs tge (transf_code approxs c) sp pc rs m t pc' rs' m'.
Definition exec_function_prop
- (f: RTL.function) (args: list val) (m: mem)
+ (f: RTL.fundef) (args: list val) (m: mem) (t: trace)
(res: val) (m': mem) : Prop :=
- exec_function tge (transf_function f) args m res m'.
+ exec_function tge (transf_fundef f) args m t res m'.
Ltac TransfInstr :=
match goal with
@@ -716,9 +734,9 @@ Ltac TransfInstr :=
evaluation derivation of the original code. *)
Lemma transf_funct_correct:
- forall f args m res m',
- exec_function ge f args m res m' ->
- exec_function_prop f args m res m'.
+ forall f args m t res m',
+ exec_function ge f args m t res m' ->
+ exec_function_prop f args m t res m'.
Proof.
apply (exec_function_ind_3 ge
exec_instr_prop exec_instrs_prop exec_function_prop);
@@ -773,13 +791,13 @@ Proof.
rewrite ASR; simpl. congruence.
intro. eapply exec_Istore; eauto.
(* Icall *)
- assert (find_function tge ros rs = Some (transf_function f)).
+ assert (find_function tge ros rs = Some (transf_fundef f)).
generalize H0; unfold find_function; destruct ros.
apply functions_translated.
rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
apply function_ptr_translated. congruence.
- assert (sig = fn_sig (transf_function f)).
- rewrite H1. unfold transf_function. destruct (analyze f); reflexivity.
+ assert (funsig (transf_fundef f) = sig).
+ generalize (sig_translated f). congruence.
split; [idtac| intros; TransfInstr].
eapply exec_Icall; eauto.
set (ros' :=
@@ -803,6 +821,11 @@ Proof.
generalize H4. simpl. rewrite A. rewrite B. subst i0.
rewrite Genv.find_funct_find_funct_ptr. auto.
+ (* Ialloc *)
+ split; [idtac|intros; TransfInstr].
+ eapply exec_Ialloc; eauto.
+ intros. eapply exec_Ialloc; eauto.
+
(* Icond, true *)
split; [idtac| intros; TransfInstr].
eapply exec_Icond_true; eauto.
@@ -844,37 +867,38 @@ Proof.
(* trans *)
elim H0; intros. elim H2; intros.
split.
- apply exec_trans with pc2 rs2 m2; auto.
- intros; apply exec_trans with pc2 rs2 m2.
- eapply H4; eauto. eapply H6; eauto.
- eapply analyze_correct_2; eauto.
+ apply exec_trans with t1 pc2 rs2 m2 t2; auto.
+ intros; apply exec_trans with t1 pc2 rs2 m2 t2.
+ eapply H5; eauto. eapply H7; eauto.
+ eapply analyze_correct_2; eauto. auto.
- (* function *)
+ (* internal function *)
elim H1; intros.
- unfold transf_function.
+ simpl. unfold transf_function.
caseEq (analyze f).
intros approxs ANL.
- eapply exec_funct; simpl; eauto.
+ eapply exec_funct_internal; simpl; eauto.
eapply H5. reflexivity. auto.
apply analyze_correct_3; auto.
TransfInstr; auto.
- intros. eapply exec_funct; eauto.
+ intros. eapply exec_funct_internal; eauto.
+ (* external function *)
+ unfold transf_function; simpl. apply exec_funct_external; auto.
Qed.
(** The preservation of the observable behavior of the program then
follows. *)
Theorem transf_program_correct:
- forall (r: val),
- exec_program prog r -> exec_program tprog r.
+ forall (t: trace) (r: val),
+ exec_program prog t r -> exec_program tprog t r.
Proof.
- intros r [b [f [m [SYMB [FIND [SIG EXEC]]]]]].
- red. exists b. exists (transf_function f). exists m.
+ intros t r [b [f [m [SYMB [FIND [SIG EXEC]]]]]].
+ red. exists b. exists (transf_fundef f). exists m.
split. change (prog_main tprog) with (prog_main prog).
rewrite symbols_preserved. auto.
split. apply function_ptr_translated; auto.
- split. unfold transf_function.
- rewrite <- SIG. destruct (analyze f); reflexivity.
+ split. generalize (sig_translated f). congruence.
apply transf_funct_correct.
unfold tprog, transf_program. rewrite Genv.init_mem_transf.
exact EXEC.
diff --git a/backend/Conventions.v b/backend/Conventions.v
index 99cc933..5b4222d 100644
--- a/backend/Conventions.v
+++ b/backend/Conventions.v
@@ -19,12 +19,11 @@ Require Import Locations.
of callee- and caller-save registers.
*)
-Definition destroyed_at_call_regs :=
- R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 ::
- F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil.
+Definition int_caller_save_regs :=
+ R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil.
-Definition destroyed_at_call :=
- List.map R destroyed_at_call_regs.
+Definition float_caller_save_regs :=
+ F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil.
Definition int_callee_save_regs :=
R13 :: R14 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 ::
@@ -34,6 +33,12 @@ Definition float_callee_save_regs :=
F14 :: F15 :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 ::
F23 :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 :: nil.
+Definition destroyed_at_call_regs :=
+ int_caller_save_regs ++ float_caller_save_regs.
+
+Definition destroyed_at_call :=
+ List.map R destroyed_at_call_regs.
+
Definition temporaries :=
R IT1 :: R IT2 :: R IT3 :: R FT1 :: R FT2 :: R FT3 :: nil.
@@ -298,6 +303,18 @@ Proof.
simpl; OrEq.
Qed.
+(** The result location is not a callee-save register. *)
+
+Lemma loc_result_not_callee_save:
+ forall (s: signature),
+ ~(In (loc_result s) int_callee_save_regs \/ In (loc_result s) float_callee_save_regs).
+Proof.
+ intros. generalize (loc_result_acceptable s).
+ generalize (int_callee_save_not_destroyed (loc_result s)).
+ generalize (float_callee_save_not_destroyed (loc_result s)).
+ tauto.
+Qed.
+
(** ** Location of function arguments *)
(** The PowerPC ABI states the following convention for passing arguments
@@ -316,11 +333,6 @@ Qed.
These conventions are somewhat baroque, but they are mandated by the ABI.
*)
-Definition drop1 (x: list mreg) :=
- match x with nil => nil | hd :: tl => tl end.
-Definition drop2 (x: list mreg) :=
- match x with nil => nil | hd :: nil => nil | hd1 :: hd2 :: tl => tl end.
-
Fixpoint loc_arguments_rec
(tyl: list typ) (iregl: list mreg) (fregl: list mreg)
(ofs: Z) {struct tyl} : list loc :=
@@ -331,13 +343,13 @@ Fixpoint loc_arguments_rec
| nil => S (Outgoing ofs Tint)
| ireg :: _ => R ireg
end ::
- loc_arguments_rec tys (drop1 iregl) fregl (ofs + 1)
+ loc_arguments_rec tys (list_drop1 iregl) fregl (ofs + 1)
| Tfloat :: tys =>
match fregl with
| nil => S (Outgoing ofs Tfloat)
| freg :: _ => R freg
end ::
- loc_arguments_rec tys (drop2 iregl) (drop1 fregl) (ofs + 2)
+ loc_arguments_rec tys (list_drop2 iregl) (list_drop1 fregl) (ofs + 2)
end.
Definition int_param_regs :=
@@ -374,18 +386,6 @@ Definition loc_argument_acceptable (l: loc) : Prop :=
| _ => False
end.
-Remark drop1_incl:
- forall x l, In x (drop1 l) -> In x l.
-Proof.
- intros. destruct l. elim H. simpl in H. auto with coqlib.
-Qed.
-Remark drop2_incl:
- forall x l, In x (drop2 l) -> In x l.
-Proof.
- intros. destruct l. elim H. destruct l. elim H.
- simpl in H. auto with coqlib.
-Qed.
-
Remark loc_arguments_rec_charact:
forall tyl iregl fregl ofs l,
In l (loc_arguments_rec tyl iregl fregl ofs) ->
@@ -400,12 +400,12 @@ Proof.
destruct a; elim H; intros.
destruct iregl; subst l. omega. left; auto with coqlib.
generalize (IHtyl _ _ _ _ H0).
- destruct l. intros [A|B]. left; apply drop1_incl; auto. tauto.
+ destruct l. intros [A|B]. left; apply list_drop1_incl; auto. tauto.
destruct s; try contradiction. omega.
destruct fregl; subst l. omega. right; auto with coqlib.
generalize (IHtyl _ _ _ _ H0).
- destruct l. intros [A|B]. left; apply drop2_incl; auto.
- right; apply drop1_incl; auto.
+ destruct l. intros [A|B]. left; apply list_drop2_incl; auto.
+ right; apply list_drop1_incl; auto.
destruct s; try contradiction. omega.
Qed.
@@ -425,18 +425,6 @@ Hint Resolve loc_arguments_acceptable: locs.
(** Arguments are parwise disjoint (in the sense of [Loc.norepet]). *)
-Remark drop1_norepet:
- forall l, list_norepet l -> list_norepet (drop1 l).
-Proof.
- intros. destruct l; simpl. constructor. inversion H. auto.
-Qed.
-Remark drop2_norepet:
- forall l, list_norepet l -> list_norepet (drop2 l).
-Proof.
- intros. destruct l; simpl. constructor.
- destruct l; simpl. constructor. inversion H. inversion H3. auto.
-Qed.
-
Remark loc_arguments_rec_notin_reg:
forall tyl iregl fregl ofs r,
~(In r iregl) -> ~(In r fregl) ->
@@ -446,10 +434,10 @@ Proof.
auto.
destruct a; simpl; split.
destruct iregl. auto. red; intro; subst m. apply H. auto with coqlib.
- apply IHtyl. red; intro. apply H. apply drop1_incl; auto. auto.
+ apply IHtyl. red; intro. apply H. apply list_drop1_incl; auto. auto.
destruct fregl. auto. red; intro; subst m. apply H0. auto with coqlib.
- apply IHtyl. red; intro. apply H. apply drop2_incl; auto.
- red; intro. apply H0. apply drop1_incl; auto.
+ apply IHtyl. red; intro. apply H. apply list_drop2_incl; auto.
+ red; intro. apply H0. apply list_drop1_incl; auto.
Qed.
Remark loc_arguments_rec_notin_local:
@@ -494,16 +482,16 @@ Proof.
apply loc_arguments_rec_notin_outgoing. simpl; omega.
apply loc_arguments_rec_notin_reg. simpl. inversion H. auto.
apply list_disjoint_notin with (m :: iregl); auto with coqlib.
- apply IHtyl. apply drop1_norepet; auto. auto.
- red; intros. apply H1. apply drop1_incl; auto. auto.
+ apply IHtyl. apply list_drop1_norepet; auto. auto.
+ red; intros. apply H1. apply list_drop1_incl; auto. auto.
destruct fregl.
apply loc_arguments_rec_notin_outgoing. simpl; omega.
apply loc_arguments_rec_notin_reg. simpl.
- red; intro. apply (H1 m m). apply drop2_incl; auto.
+ red; intro. apply (H1 m m). apply list_drop2_incl; auto.
auto with coqlib. auto.
simpl. inversion H0. auto.
- apply IHtyl. apply drop2_norepet; auto. apply drop1_norepet; auto.
- red; intros. apply H1. apply drop2_incl; auto. apply drop1_incl; auto.
+ apply IHtyl. apply list_drop2_norepet; auto. apply list_drop1_norepet; auto.
+ red; intros. apply H1. apply list_drop2_incl; auto. apply list_drop1_incl; auto.
intro. unfold loc_arguments. apply H.
unfold int_param_regs. NoRepet.
@@ -601,11 +589,11 @@ Proof.
destruct a; simpl; apply (f_equal2 (@cons typ)).
destruct iregl. reflexivity. simpl. apply H. auto with coqlib.
apply IHtyl.
- intros. apply H. apply drop1_incl. auto. auto.
+ intros. apply H. apply list_drop1_incl. auto. auto.
destruct fregl. reflexivity. simpl. apply H0. auto with coqlib.
apply IHtyl.
- intros. apply H. apply drop2_incl. auto.
- intros. apply H0. apply drop1_incl. auto.
+ intros. apply H. apply list_drop2_incl. auto.
+ intros. apply H0. apply list_drop1_incl. auto.
intros. unfold loc_arguments. apply H.
intro; simpl. ElimOrEq; reflexivity.
@@ -688,3 +676,30 @@ Proof.
intros; simpl. tauto.
Qed.
+(** ** Location of arguments to external functions *)
+
+Definition loc_external_arguments (s: signature) : list mreg :=
+ List.map
+ (fun l => match l with R r => r | S _ => IT1 end)
+ (loc_arguments s).
+
+Definition sig_external_ok (s: signature) : Prop :=
+ forall sl, ~In (S sl) (loc_arguments s).
+
+Lemma loc_external_arguments_loc_arguments:
+ forall s,
+ sig_external_ok s ->
+ loc_arguments s = List.map R (loc_external_arguments s).
+Proof.
+ intros. unfold loc_external_arguments.
+ rewrite list_map_compose.
+ transitivity (List.map (fun x => x) (loc_arguments s)).
+ symmetry; apply list_map_identity.
+ apply list_map_exten; intros.
+ destruct x. auto. elim (H _ H0).
+Qed.
+
+(** ** Location of argument and result of dynamic allocation *)
+
+Definition loc_alloc_argument := R3.
+Definition loc_alloc_result := R3.
diff --git a/backend/Csharpminor.v b/backend/Csharpminor.v
index 49fd3df..246ebf5 100644
--- a/backend/Csharpminor.v
+++ b/backend/Csharpminor.v
@@ -7,13 +7,14 @@ Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
(** Abstract syntax *)
-(** Cminor is a low-level imperative language structured in expressions,
+(** Csharpminor is a low-level imperative language structured in expressions,
statements, functions and programs. Expressions include
- reading and writing local variables, reading and writing store locations,
+ reading global or local variables, reading store locations,
arithmetic operations, function calls, and conditional expressions
(similar to [e1 ? e2 : e3] in C). The [Elet] and [Eletvar] constructs
enable sharing the computations of subexpressions. De Bruijn notation
@@ -67,20 +68,20 @@ Inductive operation : Set :=
Inductive expr : Set :=
| Evar : ident -> expr (**r reading a scalar variable *)
| Eaddrof : ident -> expr (**r taking the address of a variable *)
- | Eassign : ident -> expr -> expr (**r assignment to a scalar variable *)
| Eop : operation -> exprlist -> expr (**r arithmetic operation *)
| Eload : memory_chunk -> expr -> expr (**r memory read *)
- | Estore : memory_chunk -> expr -> expr -> expr (**r memory write *)
| Ecall : signature -> expr -> exprlist -> expr (**r function call *)
| Econdition : expr -> expr -> expr -> expr (**r conditional expression *)
| Elet : expr -> expr -> expr (**r let binding *)
| Eletvar : nat -> expr (**r reference to a let-bound variable *)
+ | Ealloc : expr -> expr (**r memory allocation *)
with exprlist : Set :=
| Enil: exprlist
| Econs: expr -> exprlist -> exprlist.
-(** Statements include expression evaluation, an if/then/else conditional,
+(** Statements include expression evaluation, variable assignment,
+ memory stores, an if/then/else conditional,
infinite loops, blocks and early block exits, and early function returns.
[Sexit n] terminates prematurely the execution of the [n+1] enclosing
[Sblock] statements. *)
@@ -88,6 +89,8 @@ with exprlist : Set :=
Inductive stmt : Set :=
| Sskip: stmt
| Sexpr: expr -> stmt
+ | Sassign : ident -> expr -> stmt
+ | Sstore : memory_chunk -> expr -> expr -> stmt
| Sseq: stmt -> stmt -> stmt
| Sifthenelse: expr -> stmt -> stmt -> stmt
| Sloop: stmt -> stmt
@@ -117,12 +120,20 @@ Record function : Set := mkfunction {
fn_body: stmt
}.
+Definition fundef := AST.fundef function.
+
Record program : Set := mkprogram {
- prog_funct: list (ident * function);
+ prog_funct: list (ident * fundef);
prog_main: ident;
- prog_vars: list (ident * var_kind)
+ prog_vars: list (ident * var_kind * list init_data)
}.
+Definition funsig (fd: fundef) :=
+ match fd with
+ | Internal f => f.(fn_sig)
+ | External ef => ef.(ef_sig)
+ end.
+
(** * Operational semantics *)
(** The operational semantics for Csharpminor is given in big-step operational
@@ -164,7 +175,7 @@ Fixpoint switch_target (n: int) (dfl: nat) (cases: list (int * nat))
- [env]: local environments, map local variables to memory blocks + var info;
- [lenv]: let environments, map de Bruijn indices to values.
*)
-Definition genv := Genv.t function.
+Definition genv := Genv.t fundef.
Definition gvarenv := PTree.t var_kind.
Definition env := PTree.t (block * var_kind).
Definition empty_env : env := PTree.empty (block * var_kind).
@@ -176,11 +187,11 @@ Definition sizeof (lv: var_kind) : Z :=
| Varray sz => Zmax 0 sz
end.
-Definition program_of_program (p: program): AST.program function :=
+Definition program_of_program (p: program): AST.program fundef :=
AST.mkprogram
p.(prog_funct)
p.(prog_main)
- (List.map (fun id_vi => (fst id_vi, sizeof (snd id_vi))) p.(prog_vars)).
+ (List.map (fun x => match x with (id, k, init) => (id, init) end) p.(prog_vars)).
Definition fn_variables (f: function) :=
List.map
@@ -195,7 +206,7 @@ Definition fn_vars_names (f: function) :=
Definition global_var_env (p: program): gvarenv :=
List.fold_left
- (fun gve id_vi => PTree.set (fst id_vi) (snd id_vi) gve)
+ (fun gve x => match x with (id, k, init) => PTree.set id k gve end)
p.(prog_vars) (PTree.empty var_kind).
(** Evaluation of operator applications. *)
@@ -270,22 +281,6 @@ Definition eval_operation (op: operation) (vl: list val) (m: mem): option val :=
| _, _ => None
end.
-(** ``Casting'' a value to a memory chunk. The value is truncated and
- zero- or sign-extended as dictated by the memory chunk. *)
-
-Definition cast (chunk: memory_chunk) (v: val) : option val :=
- match chunk, v with
- | Mint8signed, Vint n => Some (Vint (Int.cast8signed n))
- | Mint8unsigned, Vint n => Some (Vint (Int.cast8unsigned n))
- | Mint16signed, Vint n => Some (Vint (Int.cast16signed n))
- | Mint16unsigned, Vint n => Some (Vint (Int.cast16unsigned n))
- | Mint32, Vint n => Some(Vint n)
- | Mint32, Vptr b ofs => Some(Vptr b ofs)
- | Mfloat32, Vfloat f => Some(Vfloat(Float.singleoffloat f))
- | Mfloat64, Vfloat f => Some(Vfloat f)
- | _, _ => None
- end.
-
(** Allocation of local variables at function entry. Each variable is
bound to the reference to a fresh block of the appropriate size. *)
@@ -312,10 +307,9 @@ Inductive bind_parameters: env ->
forall e m,
bind_parameters e m nil nil m
| bind_parameters_cons:
- forall e m id chunk params v1 v2 vl b m1 m2,
+ forall e m id chunk params v1 vl b m1 m2,
PTree.get id e = Some (b, Vscalar chunk) ->
- cast chunk v1 = Some v2 ->
- Mem.store chunk m b 0 v2 = Some m1 ->
+ Mem.store chunk m b 0 v1 = Some m1 ->
bind_parameters e m1 params vl m2 ->
bind_parameters e m ((id, chunk) :: params) (v1 :: vl) m2.
@@ -364,69 +358,64 @@ Inductive eval_var_ref: env -> ident -> block -> memory_chunk -> Prop :=
Inductive eval_expr:
letenv -> env ->
- mem -> expr -> mem -> val -> Prop :=
+ mem -> expr -> trace -> mem -> val -> Prop :=
| eval_Evar:
forall le e m id b chunk v,
eval_var_ref e id b chunk ->
Mem.load chunk m b 0 = Some v ->
- eval_expr le e m (Evar id) m v
- | eval_Eassign:
- forall le e m id a m1 b chunk v1 v2 m2,
- eval_expr le e m a m1 v1 ->
- eval_var_ref e id b chunk ->
- cast chunk v1 = Some v2 ->
- Mem.store chunk m1 b 0 v2 = Some m2 ->
- eval_expr le e m (Eassign id a) m2 v2
+ eval_expr le e m (Evar id) E0 m v
| eval_Eaddrof:
forall le e m id b,
eval_var_addr e id b ->
- eval_expr le e m (Eaddrof id) m (Vptr b Int.zero)
+ eval_expr le e m (Eaddrof id) E0 m (Vptr b Int.zero)
| eval_Eop:
- forall le e m op al m1 vl v,
- eval_exprlist le e m al m1 vl ->
+ forall le e m op al t m1 vl v,
+ eval_exprlist le e m al t m1 vl ->
eval_operation op vl m1 = Some v ->
- eval_expr le e m (Eop op al) m1 v
+ eval_expr le e m (Eop op al) t m1 v
| eval_Eload:
- forall le e m chunk a m1 v1 v,
- eval_expr le e m a m1 v1 ->
+ forall le e m chunk a t m1 v1 v,
+ eval_expr le e m a t m1 v1 ->
Mem.loadv chunk m1 v1 = Some v ->
- eval_expr le e m (Eload chunk a) m1 v
- | eval_Estore:
- forall le e m chunk a b m1 v1 m2 v2 m3 v3,
- eval_expr le e m a m1 v1 ->
- eval_expr le e m1 b m2 v2 ->
- cast chunk v2 = Some v3 ->
- Mem.storev chunk m2 v1 v3 = Some m3 ->
- eval_expr le e m (Estore chunk a b) m3 v3
+ eval_expr le e m (Eload chunk a) t m1 v
| eval_Ecall:
- forall le e m sig a bl m1 m2 m3 vf vargs vres f,
- eval_expr le e m a m1 vf ->
- eval_exprlist le e m1 bl m2 vargs ->
+ forall le e m sig a bl t1 m1 t2 m2 t3 m3 vf vargs vres f t,
+ eval_expr le e m a t1 m1 vf ->
+ eval_exprlist le e m1 bl t2 m2 vargs ->
Genv.find_funct ge vf = Some f ->
- f.(fn_sig) = sig ->
- eval_funcall m2 f vargs m3 vres ->
- eval_expr le e m (Ecall sig a bl) m3 vres
+ funsig f = sig ->
+ eval_funcall m2 f vargs t3 m3 vres ->
+ t = t1 ** t2 ** t3 ->
+ eval_expr le e m (Ecall sig a bl) t m3 vres
| eval_Econdition_true:
- forall le e m a b c m1 v1 m2 v2,
- eval_expr le e m a m1 v1 ->
+ forall le e m a b c t1 m1 v1 t2 m2 v2 t,
+ eval_expr le e m a t1 m1 v1 ->
Val.is_true v1 ->
- eval_expr le e m1 b m2 v2 ->
- eval_expr le e m (Econdition a b c) m2 v2
+ eval_expr le e m1 b t2 m2 v2 ->
+ t = t1 ** t2 ->
+ eval_expr le e m (Econdition a b c) t m2 v2
| eval_Econdition_false:
- forall le e m a b c m1 v1 m2 v2,
- eval_expr le e m a m1 v1 ->
+ forall le e m a b c t1 m1 v1 t2 m2 v2 t,
+ eval_expr le e m a t1 m1 v1 ->
Val.is_false v1 ->
- eval_expr le e m1 c m2 v2 ->
- eval_expr le e m (Econdition a b c) m2 v2
+ eval_expr le e m1 c t2 m2 v2 ->
+ t = t1 ** t2 ->
+ eval_expr le e m (Econdition a b c) t m2 v2
| eval_Elet:
- forall le e m a b m1 v1 m2 v2,
- eval_expr le e m a m1 v1 ->
- eval_expr (v1::le) e m1 b m2 v2 ->
- eval_expr le e m (Elet a b) m2 v2
+ forall le e m a b t1 m1 v1 t2 m2 v2 t,
+ eval_expr le e m a t1 m1 v1 ->
+ eval_expr (v1::le) e m1 b t2 m2 v2 ->
+ t = t1 ** t2 ->
+ eval_expr le e m (Elet a b) t m2 v2
| eval_Eletvar:
forall le e m n v,
nth_error le n = Some v ->
- eval_expr le e m (Eletvar n) m v
+ eval_expr le e m (Eletvar n) E0 m v
+ | eval_Ealloc:
+ forall le e m a t m1 n m2 b,
+ eval_expr le e m a t m1 (Vint n) ->
+ Mem.alloc m1 0 (Int.signed n) = (m2, b) ->
+ eval_expr le e m (Ealloc a) t m2 (Vptr b Int.zero)
(** Evaluation of a list of expressions:
[eval_exprlist prg le al m a m' vl]
@@ -437,32 +426,37 @@ Inductive eval_expr:
with eval_exprlist:
letenv -> env ->
- mem -> exprlist ->
+ mem -> exprlist -> trace ->
mem -> list val -> Prop :=
| eval_Enil:
forall le e m,
- eval_exprlist le e m Enil m nil
+ eval_exprlist le e m Enil E0 m nil
| eval_Econs:
- forall le e m a bl m1 v m2 vl,
- eval_expr le e m a m1 v ->
- eval_exprlist le e m1 bl m2 vl ->
- eval_exprlist le e m (Econs a bl) m2 (v :: vl)
+ forall le e m a bl t1 m1 v t2 m2 vl t,
+ eval_expr le e m a t1 m1 v ->
+ eval_exprlist le e m1 bl t2 m2 vl ->
+ t = t1 ** t2 ->
+ eval_exprlist le e m (Econs a bl) t m2 (v :: vl)
(** Evaluation of a function invocation: [eval_funcall prg m f args m' res]
means that the function [f], applied to the arguments [args] in
memory state [m], returns the value [res] in modified memory state [m'].
*)
with eval_funcall:
- mem -> function -> list val ->
+ mem -> fundef -> list val -> trace ->
mem -> val -> Prop :=
- | eval_funcall_intro:
- forall m f vargs e m1 lb m2 m3 out vres,
+ | eval_funcall_internal:
+ forall m f vargs e m1 lb m2 t m3 out vres,
list_norepet (fn_params_names f ++ fn_vars_names f) ->
alloc_variables empty_env m (fn_variables f) e m1 lb ->
bind_parameters e m1 f.(fn_params) vargs m2 ->
- exec_stmt e m2 f.(fn_body) m3 out ->
+ exec_stmt e m2 f.(fn_body) t m3 out ->
outcome_result_value out f.(fn_sig).(sig_res) vres ->
- eval_funcall m f vargs (Mem.free_list m3 lb) vres
+ eval_funcall m (Internal f) vargs t (Mem.free_list m3 lb) vres
+ | eval_funcall_external:
+ forall m ef vargs t vres,
+ event_match ef vargs t vres ->
+ eval_funcall m (External ef) vargs t m vres
(** Execution of a statement: [exec_stmt prg e m s m' out]
means that statement [s] executes with outcome [out].
@@ -470,66 +464,83 @@ with eval_funcall:
with exec_stmt:
env ->
- mem -> stmt ->
+ mem -> stmt -> trace ->
mem -> outcome -> Prop :=
| exec_Sskip:
forall e m,
- exec_stmt e m Sskip m Out_normal
+ exec_stmt e m Sskip E0 m Out_normal
| exec_Sexpr:
- forall e m a m1 v,
- eval_expr nil e m a m1 v ->
- exec_stmt e m (Sexpr a) m1 Out_normal
+ forall e m a t m1 v,
+ eval_expr nil e m a t m1 v ->
+ exec_stmt e m (Sexpr a) t m1 Out_normal
+ | eval_Sassign:
+ forall e m id a t m1 b chunk v m2,
+ eval_expr nil e m a t m1 v ->
+ eval_var_ref e id b chunk ->
+ Mem.store chunk m1 b 0 v = Some m2 ->
+ exec_stmt e m (Sassign id a) t m2 Out_normal
+ | eval_Sstore:
+ forall e m chunk a b t1 m1 v1 t2 m2 v2 t3 m3,
+ eval_expr nil e m a t1 m1 v1 ->
+ eval_expr nil e m1 b t2 m2 v2 ->
+ Mem.storev chunk m2 v1 v2 = Some m3 ->
+ t3 = t1 ** t2 ->
+ exec_stmt e m (Sstore chunk a b) t3 m3 Out_normal
| exec_Sseq_continue:
- forall e m s1 s2 m1 m2 out,
- exec_stmt e m s1 m1 Out_normal ->
- exec_stmt e m1 s2 m2 out ->
- exec_stmt e m (Sseq s1 s2) m2 out
+ forall e m s1 s2 t1 t2 m1 m2 t out,
+ exec_stmt e m s1 t1 m1 Out_normal ->
+ exec_stmt e m1 s2 t2 m2 out ->
+ t = t1 ** t2 ->
+ exec_stmt e m (Sseq s1 s2) t m2 out
| exec_Sseq_stop:
- forall e m s1 s2 m1 out,
- exec_stmt e m s1 m1 out ->
+ forall e m s1 s2 t1 m1 out,
+ exec_stmt e m s1 t1 m1 out ->
out <> Out_normal ->
- exec_stmt e m (Sseq s1 s2) m1 out
+ exec_stmt e m (Sseq s1 s2) t1 m1 out
| exec_Sifthenelse_true:
- forall e m a sl1 sl2 m1 v1 m2 out,
- eval_expr nil e m a m1 v1 ->
+ forall e m a sl1 sl2 t1 m1 v1 t2 m2 out t,
+ eval_expr nil e m a t1 m1 v1 ->
Val.is_true v1 ->
- exec_stmt e m1 sl1 m2 out ->
- exec_stmt e m (Sifthenelse a sl1 sl2) m2 out
+ exec_stmt e m1 sl1 t2 m2 out ->
+ t = t1 ** t2 ->
+ exec_stmt e m (Sifthenelse a sl1 sl2) t m2 out
| exec_Sifthenelse_false:
- forall e m a sl1 sl2 m1 v1 m2 out,
- eval_expr nil e m a m1 v1 ->
+ forall e m a sl1 sl2 t1 m1 v1 t2 m2 out t,
+ eval_expr nil e m a t1 m1 v1 ->
Val.is_false v1 ->
- exec_stmt e m1 sl2 m2 out ->
- exec_stmt e m (Sifthenelse a sl1 sl2) m2 out
+ exec_stmt e m1 sl2 t2 m2 out ->
+ t = t1 ** t2 ->
+ exec_stmt e m (Sifthenelse a sl1 sl2) t m2 out
| exec_Sloop_loop:
- forall e m sl m1 m2 out,
- exec_stmt e m sl m1 Out_normal ->
- exec_stmt e m1 (Sloop sl) m2 out ->
- exec_stmt e m (Sloop sl) m2 out
+ forall e m sl t1 m1 t2 m2 out t,
+ exec_stmt e m sl t1 m1 Out_normal ->
+ exec_stmt e m1 (Sloop sl) t2 m2 out ->
+ t = t1 ** t2 ->
+ exec_stmt e m (Sloop sl) t m2 out
| exec_Sloop_stop:
- forall e m sl m1 out,
- exec_stmt e m sl m1 out ->
+ forall e m sl t1 m1 out,
+ exec_stmt e m sl t1 m1 out ->
out <> Out_normal ->
- exec_stmt e m (Sloop sl) m1 out
+ exec_stmt e m (Sloop sl) t1 m1 out
| exec_Sblock:
- forall e m sl m1 out,
- exec_stmt e m sl m1 out ->
- exec_stmt e m (Sblock sl) m1 (outcome_block out)
+ forall e m sl t1 m1 out,
+ exec_stmt e m sl t1 m1 out ->
+ exec_stmt e m (Sblock sl) t1 m1 (outcome_block out)
| exec_Sexit:
forall e m n,
- exec_stmt e m (Sexit n) m (Out_exit n)
+ exec_stmt e m (Sexit n) E0 m (Out_exit n)
| exec_Sswitch:
- forall e m a cases default m1 n,
- eval_expr nil e m a m1 (Vint n) ->
+ forall e m a cases default t1 m1 n,
+ eval_expr nil e m a t1 m1 (Vint n) ->
exec_stmt e m (Sswitch a cases default)
- m1 (Out_exit (switch_target n default cases))
+ t1 m1 (Out_exit (switch_target n default cases))
| exec_Sreturn_none:
forall e m,
- exec_stmt e m (Sreturn None) m (Out_return None)
+ exec_stmt e m (Sreturn None) E0 m (Out_return None)
| exec_Sreturn_some:
- forall e m a m1 v,
- eval_expr nil e m a m1 v ->
- exec_stmt e m (Sreturn (Some a)) m1 (Out_return (Some v)).
+ forall e m a t1 m1 v,
+ eval_expr nil e m a t1 m1 v ->
+ exec_stmt e m (Sreturn (Some a)) t1 m1 (Out_return (Some v)).
Scheme eval_expr_ind4 := Minimality for eval_expr Sort Prop
with eval_exprlist_ind4 := Minimality for eval_exprlist Sort Prop
@@ -542,12 +553,11 @@ End RELSEM.
holds if the application of [p]'s main function to no arguments
in the initial memory state for [p] eventually returns value [r]. *)
-Definition exec_program (p: program) (r: val) : Prop :=
+Definition exec_program (p: program) (t: trace) (r: val) : Prop :=
let ge := Genv.globalenv (program_of_program p) in
let m0 := Genv.init_mem (program_of_program p) in
exists b, exists f, exists m,
Genv.find_symbol ge p.(prog_main) = Some b /\
Genv.find_funct_ptr ge b = Some f /\
- f.(fn_sig) = mksignature nil (Some Tint) /\
- eval_funcall p m0 f nil m r.
-
+ funsig f = mksignature nil (Some Tint) /\
+ eval_funcall p m0 f nil t m r.
diff --git a/backend/Events.v b/backend/Events.v
new file mode 100644
index 0000000..a0559fd
--- /dev/null
+++ b/backend/Events.v
@@ -0,0 +1,103 @@
+(** Representation of (traces of) observable events. *)
+
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+
+Inductive eventval: Set :=
+ | EVint: int -> eventval
+ | EVfloat: float -> eventval.
+
+Parameter trace: Set.
+Parameter E0: trace.
+Parameter Eextcall: ident -> list eventval -> eventval -> trace.
+Parameter Eapp: trace -> trace -> trace.
+
+Infix "**" := Eapp (at level 60, right associativity).
+
+Axiom E0_left: forall t, E0 ** t = t.
+Axiom E0_right: forall t, t ** E0 = t.
+Axiom Eapp_assoc: forall t1 t2 t3, (t1 ** t2) ** t3 = t1 ** (t2 ** t3).
+
+Hint Rewrite E0_left E0_right Eapp_assoc: trace_rewrite.
+
+Ltac substTraceHyp :=
+ match goal with
+ | [ H: (@eq trace ?x ?y) |- _ ] =>
+ subst x || clear H
+ end.
+
+Ltac decomposeTraceEq :=
+ match goal with
+ | [ |- (_ ** _) = (_ ** _) ] =>
+ apply (f_equal2 Eapp); auto; decomposeTraceEq
+ | _ =>
+ auto
+ end.
+
+Ltac traceEq :=
+ repeat substTraceHyp; autorewrite with trace_rewrite; decomposeTraceEq.
+
+Inductive eventval_match: eventval -> typ -> val -> Prop :=
+ | ev_match_int:
+ forall i, eventval_match (EVint i) Tint (Vint i)
+ | ev_match_float:
+ forall f, eventval_match (EVfloat f) Tfloat (Vfloat f).
+
+Inductive eventval_list_match: list eventval -> list typ -> list val -> Prop :=
+ | evl_match_nil:
+ eventval_list_match nil nil nil
+ | evl_match_cons:
+ forall ev1 evl ty1 tyl v1 vl,
+ eventval_match ev1 ty1 v1 ->
+ eventval_list_match evl tyl vl ->
+ eventval_list_match (ev1::evl) (ty1::tyl) (v1::vl).
+
+Inductive event_match:
+ external_function -> list val -> trace -> val -> Prop :=
+ event_match_intro:
+ forall ef vargs vres eargs eres,
+ eventval_list_match eargs (sig_args ef.(ef_sig)) vargs ->
+ eventval_match eres (proj_sig_res ef.(ef_sig)) vres ->
+ event_match ef vargs (Eextcall ef.(ef_id) eargs eres) vres.
+
+Require Import Mem.
+
+Section EVENT_MATCH_INJECT.
+
+Variable f: meminj.
+
+Remark eventval_match_inject:
+ forall ev ty v1, eventval_match ev ty v1 ->
+ forall v2, val_inject f v1 v2 ->
+ eventval_match ev ty v2.
+Proof.
+ induction 1; intros; inversion H; constructor.
+Qed.
+
+Remark eventval_list_match_inject:
+ forall evl tyl vl1, eventval_list_match evl tyl vl1 ->
+ forall vl2, val_list_inject f vl1 vl2 ->
+ eventval_list_match evl tyl vl2.
+Proof.
+ induction 1; intros.
+ inversion H; constructor.
+ inversion H1; constructor.
+ eapply eventval_match_inject; eauto.
+ eauto.
+Qed.
+
+Lemma event_match_inject:
+ forall ef args1 t res args2,
+ event_match ef args1 t res ->
+ val_list_inject f args1 args2 ->
+ event_match ef args2 t res /\ val_inject f res res.
+Proof.
+ intros. inversion H; subst.
+ split. constructor. eapply eventval_list_match_inject; eauto. auto.
+ inversion H2; constructor.
+Qed.
+
+End EVENT_MATCH_INJECT.
diff --git a/backend/Globalenvs.v b/backend/Globalenvs.v
index 55afc35..036fd8f 100644
--- a/backend/Globalenvs.v
+++ b/backend/Globalenvs.v
@@ -70,15 +70,20 @@ Module Type GENV.
(forall id f, In (id, f) (prog_funct p) -> P f) ->
find_funct (globalenv p) v = Some f ->
P f.
+ Hypothesis find_funct_ptr_symbol_inversion:
+ forall (F: Set) (p: program F) (id: ident) (b: block) (f: F),
+ find_symbol (globalenv p) id = Some b ->
+ find_funct_ptr (globalenv p) b = Some f ->
+ In (id, f) p.(prog_funct).
+
Hypothesis initmem_nullptr:
forall (F: Set) (p: program F),
let m := init_mem p in
valid_block m nullptr /\
m.(blocks) nullptr = empty_block 0 0.
- Hypothesis initmem_undef:
+ Hypothesis initmem_block_init:
forall (F: Set) (p: program F) (b: block),
- exists lo, exists hi,
- (init_mem p).(blocks) b = empty_block lo hi.
+ exists id, (init_mem p).(blocks) b = block_init_data id.
Hypothesis find_funct_ptr_inv:
forall (F: Set) (p: program F) (b: block) (f: F),
find_funct_ptr (globalenv p) b = Some f -> b < 0.
@@ -206,12 +211,12 @@ Definition add_functs (init: genv) (fns: list (ident * funct)) : genv :=
List.fold_right add_funct init fns.
Definition add_globals
- (init: genv * mem) (vars: list (ident * Z)) : genv * mem :=
+ (init: genv * mem) (vars: list (ident * list init_data)) : genv * mem :=
List.fold_right
- (fun (id_sz: ident * Z) (g_st: genv * mem) =>
- let (id, sz) := id_sz in
+ (fun (id_init: ident * list init_data) (g_st: genv * mem) =>
+ let (id, init) := id_init in
let (g, st) := g_st in
- let (st', b) := Mem.alloc st 0 sz in
+ let (st', b) := Mem.alloc_init_data st init in
(add_symbol id b g, st'))
init vars.
@@ -229,7 +234,7 @@ Lemma functions_globalenv:
forall (p: program funct),
functions (globalenv p) = functions (add_functs empty p.(prog_funct)).
Proof.
- assert (forall (init: genv * mem) (vars: list (ident * Z)),
+ assert (forall init vars,
functions (fst (add_globals init vars)) = functions (fst init)).
induction vars; simpl.
reflexivity.
@@ -248,11 +253,11 @@ Lemma initmem_nullptr:
m.(blocks) nullptr = mkblock 0 0 (fun y => Undef) (undef_undef_outside 0 0).
Proof.
assert
- (forall (init: genv * mem),
+ (forall init,
let m1 := snd init in
0 < m1.(nextblock) ->
m1.(blocks) nullptr = mkblock 0 0 (fun y => Undef) (undef_undef_outside 0 0) ->
- forall (vars: list (ident * Z)),
+ forall vars,
let m2 := snd (add_globals init vars) in
0 < m2.(nextblock) /\
m2.(blocks) nullptr = mkblock 0 0 (fun y => Undef) (undef_undef_outside 0 0)).
@@ -268,23 +273,21 @@ Proof.
unfold valid_block. apply H. simpl. omega. reflexivity.
Qed.
-Lemma initmem_undef:
+Lemma initmem_block_init:
forall (p: program funct) (b: block),
- exists lo, exists hi,
- (init_mem p).(blocks) b = empty_block lo hi.
+ exists id, (init_mem p).(blocks) b = block_init_data id.
Proof.
assert (forall g0 vars g1 m b,
add_globals (g0, Mem.empty) vars = (g1, m) ->
- exists lo, exists hi,
- m.(blocks) b = empty_block lo hi).
+ exists id, m.(blocks) b = block_init_data id).
induction vars; simpl.
intros. inversion H. unfold Mem.empty; simpl.
- exists 0; exists 0. auto.
+ exists (@nil init_data). symmetry. apply Mem.block_init_data_empty.
destruct a. caseEq (add_globals (g0, Mem.empty) vars). intros g1 m1 EQ.
intros g m b EQ1. injection EQ1; intros EQ2 EQ3; clear EQ1.
rewrite <- EQ2; simpl. unfold update.
case (zeq b (nextblock m1)); intro.
- exists 0; exists z; auto.
+ exists l; auto.
eauto.
intros. caseEq (globalenv_initmem p).
intros g m EQ. unfold init_mem; rewrite EQ; simpl.
@@ -372,6 +375,59 @@ Proof.
intros. eapply find_funct_ptr_prop; eauto.
Qed.
+Lemma find_funct_ptr_symbol_inversion:
+ forall (F: Set) (p: program F) (id: ident) (b: block) (f: F),
+ find_symbol (globalenv p) id = Some b ->
+ find_funct_ptr (globalenv p) b = Some f ->
+ In (id, f) p.(prog_funct).
+Proof.
+ intros until f.
+ assert (forall fns,
+ let g := add_functs (empty F) fns in
+ PTree.get id g.(symbols) = Some b ->
+ b > g.(nextfunction)).
+ induction fns; simpl.
+ rewrite PTree.gempty. congruence.
+ rewrite PTree.gsspec. case (peq id (fst a)); intro.
+ intro EQ. inversion EQ. unfold Zpred. omega.
+ intros. generalize (IHfns H). unfold Zpred; omega.
+ assert (forall fns,
+ let g := add_functs (empty F) fns in
+ PTree.get id g.(symbols) = Some b ->
+ ZMap.get b g.(functions) = Some f ->
+ In (id, f) fns).
+ induction fns; simpl.
+ rewrite ZMap.gi. congruence.
+ set (g := add_functs (empty F) fns).
+ rewrite PTree.gsspec. rewrite ZMap.gsspec.
+ case (peq id (fst a)); intro.
+ intro EQ. inversion EQ. unfold ZIndexed.eq. rewrite zeq_true.
+ intro EQ2. left. destruct a. simpl in *. congruence.
+ intro. unfold ZIndexed.eq. rewrite zeq_false. intro. eauto.
+ generalize (H _ H0). fold g. unfold block. omega.
+ assert (forall g0 m0, b < 0 ->
+ forall vars g m,
+ @add_globals F (g0, m0) vars = (g, m) ->
+ PTree.get id g.(symbols) = Some b ->
+ PTree.get id g0.(symbols) = Some b).
+ induction vars; simpl.
+ intros. inversion H2. auto.
+ destruct a. caseEq (add_globals (g0, m0) vars).
+ intros g1 m1 EQ g m EQ1. injection EQ1; simpl; clear EQ1.
+ unfold add_symbol; intros A B. rewrite <- B. simpl.
+ rewrite PTree.gsspec. case (peq id i); intros.
+ assert (b > 0). injection H2; intros. rewrite <- H3. apply nextblock_pos.
+ omegaContradiction.
+ eauto.
+ intros.
+ generalize (find_funct_ptr_inv _ _ H3). intro.
+ pose (g := add_functs (empty F) (prog_funct p)).
+ apply H0.
+ apply H1 with Mem.empty (prog_vars p) (globalenv p) (init_mem p).
+ auto. unfold globalenv, init_mem. rewrite <- surjective_pairing.
+ reflexivity. assumption. rewrite <- functions_globalenv. assumption.
+Qed.
+
(* Global environments and program transformations. *)
Section TRANSF_PROGRAM_PARTIAL.
@@ -420,7 +476,7 @@ Proof.
Qed.
Lemma mem_add_globals_transf:
- forall (g1: genv A) (g2: genv B) (m: mem) (vars: list (ident * Z)),
+ forall (g1: genv A) (g2: genv B) (m: mem) (vars: list (ident * list init_data)),
snd (add_globals (g1, m) vars) = snd (add_globals (g2, m) vars).
Proof.
induction vars; simpl.
@@ -433,7 +489,7 @@ Qed.
Lemma symbols_add_globals_transf:
forall (g1: genv A) (g2: genv B) (m: mem),
symbols g1 = symbols g2 ->
- forall (vars: list (ident * Z)),
+ forall (vars: list (ident * list init_data)),
symbols (fst (add_globals (g1, m) vars)) =
symbols (fst (add_globals (g2, m) vars)).
Proof.
diff --git a/backend/InterfGraph.v b/backend/InterfGraph.v
index 37248f5..78112c3 100644
--- a/backend/InterfGraph.v
+++ b/backend/InterfGraph.v
@@ -1,7 +1,8 @@
(** Representation of interference graphs for register allocation. *)
Require Import Coqlib.
-Require Import FSet.
+Require Import FSets.
+Require Import FSetAVL.
Require Import Maps.
Require Import Ordered.
Require Import Registers.
@@ -39,10 +40,14 @@ Module OrderedRegReg := OrderedPair(OrderedReg)(OrderedReg).
Module OrderedMreg := OrderedIndexed(IndexedMreg).
Module OrderedRegMreg := OrderedPair(OrderedReg)(OrderedMreg).
+(*
Module SetDepRegReg := FSetAVL.Make(OrderedRegReg).
Module SetRegReg := NodepOfDep(SetDepRegReg).
Module SetDepRegMreg := FSetAVL.Make(OrderedRegMreg).
Module SetRegMreg := NodepOfDep(SetDepRegMreg).
+*)
+Module SetRegReg := FSetAVL.Make(OrderedRegReg).
+Module SetRegMreg := FSetAVL.Make(OrderedRegMreg).
Record graph: Set := mkgraph {
interf_reg_reg: SetRegReg.t;
@@ -197,12 +202,15 @@ Qed.
(** [all_interf_regs g] returns the set of pseudo-registers that
are nodes of [g]. *)
+Definition add_intf2 (r1r2: reg * reg) (u: Regset.t) : Regset.t :=
+ Regset.add (fst r1r2) (Regset.add (snd r1r2) u).
+Definition add_intf1 (r1m2: reg * mreg) (u: Regset.t) : Regset.t :=
+ Regset.add (fst r1m2) u.
+
Definition all_interf_regs (g: graph) : Regset.t :=
- SetRegReg.fold
- (fun r1r2 u => Regset.add (fst r1r2) (Regset.add (snd r1r2) u))
+ SetRegReg.fold _ add_intf2
g.(interf_reg_reg)
- (SetRegMreg.fold
- (fun r1m2 u => Regset.add (fst r1m2) u)
+ (SetRegMreg.fold _ add_intf1
g.(interf_reg_mreg)
Regset.empty).
@@ -215,53 +223,63 @@ Proof.
rewrite Regset.mem_add_other; auto.
Qed.
-Lemma all_interf_regs_correct_aux_1:
- forall l u r,
- Regset.mem r u = true ->
- Regset.mem r
- (List.fold_right
- (fun r1r2 u => Regset.add (fst r1r2) (Regset.add (snd r1r2) u))
- u l) = true.
+Lemma in_setregreg_fold:
+ forall g r1 r2 u,
+ SetRegReg.In (r1, r2) g \/ Regset.mem r1 u = true /\ Regset.mem r2 u = true ->
+ Regset.mem r1 (SetRegReg.fold _ add_intf2 g u) = true /\
+ Regset.mem r2 (SetRegReg.fold _ add_intf2 g u) = true.
Proof.
- induction l; simpl; intros.
- auto.
- apply mem_add_tail. apply mem_add_tail. auto.
+ set (add_intf2' := fun u r1r2 => add_intf2 r1r2 u).
+ assert (forall l r1 r2 u,
+ InA OrderedRegReg.eq (r1,r2) l \/ Regset.mem r1 u = true /\ Regset.mem r2 u = true ->
+ Regset.mem r1 (List.fold_left add_intf2' l u) = true /\
+ Regset.mem r2 (List.fold_left add_intf2' l u) = true).
+ induction l; intros; simpl.
+ elim H; intro. inversion H0. auto.
+ apply IHl. destruct a as [a1 a2].
+ elim H; intro. inversion H0; subst.
+ red in H2. simpl in H2. destruct H2. red in H1. red in H2. subst r1 r2.
+ right; unfold add_intf2', add_intf2; simpl; split.
+ apply Regset.mem_add_same. apply mem_add_tail. apply Regset.mem_add_same.
+ tauto.
+ right; unfold add_intf2', add_intf2; simpl; split;
+ apply mem_add_tail; apply mem_add_tail; tauto.
+
+ intros. rewrite SetRegReg.fold_1. apply H.
+ intuition. left. apply SetRegReg.elements_1. auto.
Qed.
-Lemma all_interf_regs_correct_aux_2:
- forall l u r1 r2,
- InList OrderedRegReg.eq (r1, r2) l ->
- let u' :=
- List.fold_right
- (fun r1r2 u => Regset.add (fst r1r2) (Regset.add (snd r1r2) u))
- u l in
- Regset.mem r1 u' = true /\ Regset.mem r2 u' = true.
+Lemma in_setregreg_fold':
+ forall g r u,
+ Regset.mem r u = true ->
+ Regset.mem r (SetRegReg.fold _ add_intf2 g u) = true.
Proof.
- induction l; simpl; intros.
- inversion H.
- inversion H. elim H1. simpl. unfold OrderedReg.eq.
- intros; subst r1; subst r2.
- split. apply Regset.mem_add_same.
- apply mem_add_tail. apply Regset.mem_add_same.
- generalize (IHl u r1 r2 H1). intros [A B].
- split; repeat rewrite mem_add_tail; auto.
+ intros. exploit in_setregreg_fold. eauto.
+ intros [A B]. eauto.
Qed.
-Lemma all_interf_regs_correct_aux_3:
- forall l u r1 r2,
- InList OrderedRegMreg.eq (r1, r2) l ->
- let u' :=
- List.fold_right
- (fun r1r2 u => Regset.add (fst r1r2) u)
- u l in
- Regset.mem r1 u' = true.
+Lemma in_setregmreg_fold:
+ forall g r1 mr2 u,
+ SetRegMreg.In (r1, mr2) g \/ Regset.mem r1 u = true ->
+ Regset.mem r1 (SetRegMreg.fold _ add_intf1 g u) = true.
Proof.
- induction l; simpl; intros.
- inversion H.
- inversion H. elim H1. simpl. unfold OrderedReg.eq.
- intros; subst r1.
+ set (add_intf1' := fun u r1mr2 => add_intf1 r1mr2 u).
+ assert (forall l r1 mr2 u,
+ InA OrderedRegMreg.eq (r1,mr2) l \/ Regset.mem r1 u = true ->
+ Regset.mem r1 (List.fold_left add_intf1' l u) = true).
+ induction l; intros; simpl.
+ elim H; intro. inversion H0. auto.
+ apply IHl with mr2. destruct a as [a1 a2].
+ elim H; intro. inversion H0; subst.
+ red in H2. simpl in H2. destruct H2. red in H1. red in H2. subst r1 mr2.
+ right; unfold add_intf1', add_intf1; simpl.
apply Regset.mem_add_same.
- apply mem_add_tail. apply IHl with r2. auto.
+ tauto.
+ right; unfold add_intf1', add_intf1; simpl.
+ apply mem_add_tail; auto.
+
+ intros. rewrite SetRegMreg.fold_1. apply H with mr2.
+ intuition. left. apply SetRegMreg.elements_1. auto.
Qed.
Lemma all_interf_regs_correct_1:
@@ -271,16 +289,7 @@ Lemma all_interf_regs_correct_1:
Regset.mem r2 (all_interf_regs g) = true.
Proof.
intros. unfold all_interf_regs.
- generalize (SetRegReg.fold_1
- g.(interf_reg_reg)
- (SetRegMreg.fold
- (fun (r1m2 : SetDepRegMreg.elt) (u : Regset.t) =>
- Regset.add (fst r1m2) u) (interf_reg_mreg g) Regset.empty)
- (fun (r1r2 : SetDepRegReg.elt) (u : Regset.t) =>
- Regset.add (fst r1r2) (Regset.add (snd r1r2) u))).
- intros [l [UN [INEQ EQ]]].
- rewrite EQ. apply all_interf_regs_correct_aux_2.
- elim (INEQ (r1, r2)); intros. auto.
+ apply in_setregreg_fold. tauto.
Qed.
Lemma all_interf_regs_correct_2:
@@ -289,22 +298,6 @@ Lemma all_interf_regs_correct_2:
Regset.mem r1 (all_interf_regs g) = true.
Proof.
intros. unfold all_interf_regs.
- generalize (SetRegReg.fold_1
- g.(interf_reg_reg)
- (SetRegMreg.fold
- (fun (r1m2 : SetDepRegMreg.elt) (u : Regset.t) =>
- Regset.add (fst r1m2) u) (interf_reg_mreg g) Regset.empty)
- (fun (r1r2 : SetDepRegReg.elt) (u : Regset.t) =>
- Regset.add (fst r1r2) (Regset.add (snd r1r2) u))).
- intros [l [UN [INEQ EQ]]].
- rewrite EQ. apply all_interf_regs_correct_aux_1.
- generalize (SetRegMreg.fold_1
- g.(interf_reg_mreg)
- Regset.empty
- (fun (r1r2 : SetDepRegMreg.elt) (u : Regset.t) =>
- Regset.add (fst r1r2) u)).
- change (PTree.t unit) with Regset.t.
- intros [l' [UN' [INEQ' EQ']]].
- rewrite EQ'. apply all_interf_regs_correct_aux_3 with mr2.
- elim (INEQ' (r1, mr2)); intros. auto.
+ apply in_setregreg_fold'. eapply in_setregmreg_fold. eauto.
Qed.
+
diff --git a/backend/Kildall.v b/backend/Kildall.v
index 10b2e1d..0210b73 100644
--- a/backend/Kildall.v
+++ b/backend/Kildall.v
@@ -1,6 +1,7 @@
(** Solvers for dataflow inequations. *)
Require Import Coqlib.
+Require Import Iteration.
Require Import Maps.
Require Import Lattice.
@@ -40,128 +41,6 @@ sets [X(n) = top] for all merge points [n], that is, program points having
several predecessors. This solver is useful when least upper bounds of
approximations do not exist or are too expensive to compute. *)
-(** * Bounded iteration *)
-
-(** The three solvers proceed iteratively, increasing the value of one of
- the unknowns [X(n)] at each iteration until a solution is reached.
- This section defines the general form of iteration used. *)
-
-Section BOUNDED_ITERATION.
-
-Variables A B: Set.
-Variable step: A -> B + A.
-
-(** The [step] parameter represents one step of the iteration. From a
- current iteration state [a: A], it either returns a value of type [B],
- meaning that iteration is over and that this [B] value is the final
- result of the iteration, or a value [a' : A] which is the next state
- of the iteration.
-
- The naive way to define the iteration is:
-<<
-Fixpoint iterate (a: A) : B :=
- match step a with
- | inl b => b
- | inr a' => iterate a'
- end.
->>
- However, this is a general recursion, not guaranteed to terminate,
- and therefore not expressible in Coq. The standard way to work around
- this difficulty is to use Noetherian recursion (Coq module [Wf]).
- This requires that we equip the type [A] with a well-founded ordering [<]
- (no infinite ascending chains) and we demand that [step] satisfies
- [step a = inr a' -> a < a']. For the types [A] that are of interest to us
- in this development, it is however very painful to define adequate
- well-founded orderings, even though we know our iterations always
- terminate.
-
- Instead, we choose to bound the number of iterations by an arbitrary
- constant. [iterate] then becomes a function that can fail,
- of type [A -> option B]. The [None] result denotes failure to reach
- a result in the number of iterations prescribed, or, in other terms,
- failure to find a solution to the dataflow problem. The compiler
- passes that exploit dataflow analysis (the [Constprop], [CSE] and
- [Allocation] passes) will, in this case, either fail ([Allocation])
- or turn off the optimization pass ([Constprop] and [CSE]).
-
- Since we know (informally) that our computations terminate, we can
- take a very large constant as the maximal number of iterations.
- Failure will therefore never happen in practice, but of
- course our proofs also cover the failure case and show that
- nothing bad happens in this hypothetical case either. *)
-
-Definition num_iterations := 1000000000000%positive.
-
-(** The simple definition of bounded iteration is:
-<<
-Fixpoint iterate (niter: nat) (a: A) {struct niter} : option B :=
- match niter with
- | O => None
- | S niter' =>
- match step a with
- | inl b => b
- | inr a' => iterate niter' a'
- end
- end.
->>
- This function is structural recursive over the parameter [niter]
- (number of iterations), represented here as a Peano integer (type [nat]).
- However, we want to use very large values of [niter]. As Peano integers,
- these values would be much too large to fit in memory. Therefore,
- we must express iteration counts as a binary integer (type [positive]).
- However, Peano induction over type [positive] is not structural recursion,
- so we cannot define [iterate] as a Coq fixpoint and must use
- Noetherian recursion instead. *)
-
-Definition iter_step (x: positive)
- (next: forall y, Plt y x -> A -> option B)
- (s: A) : option B :=
- match peq x xH with
- | left EQ => None
- | right NOTEQ =>
- match step s with
- | inl res => Some res
- | inr s' => next (Ppred x) (Ppred_Plt x NOTEQ) s'
- end
- end.
-
-Definition iterate: positive -> A -> option B :=
- Fix Plt_wf (fun _ => A -> option B) iter_step.
-
-(** We then prove the expected unrolling equations for [iterate]. *)
-
-Remark unroll_iterate:
- forall x, iterate x = iter_step x (fun y _ => iterate y).
-Proof.
- unfold iterate; apply (Fix_eq Plt_wf (fun _ => A -> option B) iter_step).
- intros. unfold iter_step. apply extensionality. intro s.
- case (peq x xH); intro. auto.
- rewrite H. auto.
-Qed.
-
-Lemma iterate_base:
- forall s, iterate 1%positive s = None.
-Proof.
- intro; rewrite unroll_iterate; unfold iter_step.
- case (peq 1 1); congruence.
-Qed.
-
-Lemma iterate_step:
- forall x s,
- iterate (Psucc x) s =
- match step s with
- | inl res => Some res
- | inr s' => iterate x s'
- end.
-Proof.
- intro; rewrite unroll_iterate; unfold iter_step; intros.
- case (peq (Psucc x) 1); intro.
- destruct x; simpl in e; discriminate.
- rewrite Ppred_succ. auto.
-Qed.
-
-End BOUNDED_ITERATION.
-
(** * Solving forward dataflow problems using Kildall's algorithm *)
(** A forward dataflow solver has the following generic interface.
@@ -316,7 +195,7 @@ Definition step (s: state) : PMap.t L.t + state :=
the start state. *)
Definition fixpoint : option (PMap.t L.t) :=
- iterate _ _ step num_iterations start_state.
+ PrimIter.iterate _ _ step start_state.
(** ** Monotonicity properties *)
@@ -361,33 +240,24 @@ Proof.
apply propagate_succ_incr. auto.
Qed.
-Lemma iterate_incr:
- forall n st res,
- iterate _ _ step n st = Some res ->
- in_incr st.(st_in) res.
-Proof.
- intro n; pattern n. apply positive_Peano_ind; intros until res.
- rewrite iterate_base. congruence.
- rewrite iterate_step. unfold step.
- destruct st.(st_wrk); intros.
- injection H0; intro; subst res.
- red; intros; apply L.ge_refl.
- apply in_incr_trans with
- (propagate_succ_list (mkstate (st_in st) l)
- (transf p (st_in st)!!p)
- (successors p)).(st_in).
- change (st_in st) with (st_in (mkstate (st_in st) l)).
- apply propagate_succ_list_incr.
- apply H. auto.
-Qed.
-
Lemma fixpoint_incr:
forall res,
fixpoint = Some res -> in_incr (start_state_in entrypoints) res.
Proof.
unfold fixpoint; intros.
change (start_state_in entrypoints) with start_state.(st_in).
- apply iterate_incr with num_iterations; auto.
+ 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 st.(st_wrk) as [ | n rem ].
+ auto.
+ 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.
+
+ eauto. apply in_incr_refl.
Qed.
(** ** Correctness invariant *)
@@ -563,30 +433,8 @@ Qed.
(** ** Correctness of the solution returned by [iterate]. *)
(** As a consequence of the [good_state] invariant, the result of
- [iterate], if defined, is a solution of the dataflow inequations,
- since [st_wrk] is empty when [iterate] terminates. *)
-
-Lemma iterate_solution:
- forall niter st res n s,
- good_state st ->
- iterate _ _ step niter st = Some res ->
- Plt n topnode -> In s (successors n) ->
- L.ge res!!s (transf n res!!n).
-Proof.
- intro niter; pattern niter; apply positive_Peano_ind; intros until s.
- rewrite iterate_base. congruence.
- intro GS. rewrite iterate_step.
- unfold step; caseEq (st.(st_wrk)).
- intros. injection H1; intros; subst res.
- elim (GS n H2); intro.
- rewrite H0 in H4. elim H4.
- auto.
- intros. apply H with
- (propagate_succ_list (mkstate st.(st_in) l)
- (transf p st.(st_in)!!p) (successors p)).
- apply step_state_good; auto.
- auto. auto. auto.
-Qed.
+ [fixpoint], if defined, is a solution of the dataflow inequations,
+ since [st_wrk] is empty when the iteration terminates. *)
Theorem fixpoint_solution:
forall res n s,
@@ -594,10 +442,20 @@ Theorem fixpoint_solution:
Plt n topnode -> In s (successors n) ->
L.ge res!!s (transf n res!!n).
Proof.
- unfold fixpoint. intros.
- apply iterate_solution with num_iterations start_state.
- apply start_state_good.
- auto. auto. auto.
+ assert (forall res, fixpoint = Some res ->
+ forall n s, Plt n topnode -> In s (successors n) ->
+ L.ge res!!s (transf n res!!n)).
+ unfold fixpoint. intros res PI. pattern res.
+ eapply (PrimIter.iterate_prop _ _ step good_state).
+
+ intros st GOOD. unfold step.
+ caseEq (st.(st_wrk)).
+ intros. elim (GOOD n H0); intro.
+ rewrite H in H2. contradiction.
+ auto.
+ intros n rem WRK. apply step_state_good; auto.
+
+ eauto. apply start_state_good. eauto.
Qed.
(** As a consequence of the monotonicity property, the result of
@@ -936,8 +794,7 @@ Definition basic_block_list (bb: bbmap) : list positive :=
Definition fixpoint : option result :=
let bb := basic_block_map in
- iterate _ _ (step bb) num_iterations
- (mkstate (PMap.init L.top) (basic_block_list bb)).
+ PrimIter.iterate _ _ (step bb) (mkstate (PMap.init L.top) (basic_block_list bb)).
(** ** Properties of predecessors and multiple-predecessors nodes *)
@@ -1121,23 +978,6 @@ Proof.
right. assumption.
Qed.
-Lemma analyze_invariant:
- forall res count st,
- iterate _ _ (step basic_block_map) count st = Some res ->
- state_invariant st ->
- state_invariant (mkstate res nil).
-Proof.
- intros until count. pattern count.
- apply positive_Peano_ind; intros until st.
- rewrite iterate_base. congruence.
- rewrite iterate_step. unfold step at 1. case st; intros r w; simpl.
- case w.
- intros. replace res with r. auto. congruence.
- intros pc wl. case (plt pc topnode); intros.
- eapply H. eauto. apply propagate_successors_invariant; auto.
- eapply H. eauto. eapply discard_top_worklist_invariant; eauto.
-Qed.
-
Lemma initial_state_invariant:
state_invariant (mkstate (PMap.init L.top) (basic_block_list basic_block_map)).
Proof.
@@ -1146,6 +986,27 @@ Proof.
right. intros. repeat rewrite PMap.gi. apply L.top_ge.
Qed.
+Lemma analyze_invariant:
+ forall res,
+ fixpoint = Some res ->
+ state_invariant (mkstate res nil).
+Proof.
+ unfold fixpoint; intros. pattern res.
+ eapply (PrimIter.iterate_prop _ _ (step basic_block_map)
+ state_invariant).
+
+ intros st INV. destruct st as [stin stwrk].
+ unfold step. simpl. caseEq stwrk.
+ intro. congruence.
+
+ intros pc rem WRK. case (plt pc topnode); intro.
+ apply propagate_successors_invariant; auto. congruence.
+ eapply discard_top_worklist_invariant; eauto. congruence.
+
+ eauto. apply initial_state_invariant.
+Qed.
+
+
(** ** Correctness of the returned solution *)
Theorem fixpoint_solution:
@@ -1154,10 +1015,9 @@ Theorem fixpoint_solution:
Plt n topnode -> In s (successors n) ->
L.ge res!!s (transf n res!!n).
Proof.
- unfold fixpoint.
intros.
assert (state_invariant (mkstate res nil)).
- eapply analyze_invariant; eauto. apply initial_state_invariant.
+ eapply analyze_invariant; eauto.
elim H2; simpl; intros.
elim (H4 n H0); intros.
contradiction.
@@ -1169,10 +1029,9 @@ Theorem fixpoint_entry:
fixpoint = Some res ->
res!!entrypoint = L.top.
Proof.
- unfold fixpoint.
intros.
assert (state_invariant (mkstate res nil)).
- eapply analyze_invariant; eauto. apply initial_state_invariant.
+ eapply analyze_invariant; eauto.
elim H0; simpl; intros.
apply H1. unfold basic_block_map, is_basic_block_head.
fold predecessors.
@@ -1201,28 +1060,21 @@ Proof.
auto. apply H0.
Qed.
-Lemma analyze_P:
- forall bb res count st,
- iterate _ _ (step bb) count st = Some res ->
- Pstate st ->
- (forall pc, P res!!pc).
-Proof.
- intros until count; pattern count; apply positive_Peano_ind; intros until st.
- rewrite iterate_base. congruence.
- rewrite iterate_step; unfold step at 1; destruct st.(st_wrk).
- intros. inversion H0. apply H1.
- destruct (plt p topnode).
- intros. eapply H. eauto.
- apply propagate_successors_P. apply Ptransf. apply H1.
- red; intro; simpl. apply H1.
- intros. eauto.
-Qed.
-
Theorem fixpoint_invariant:
forall res pc, fixpoint = Some res -> P res!!pc.
Proof.
- intros. unfold fixpoint in H. eapply analyze_P; eauto.
- red; intro; simpl. rewrite PMap.gi. apply Ptop.
+ unfold fixpoint; intros. pattern res.
+ eapply (PrimIter.iterate_prop _ _ (step basic_block_map) Pstate).
+
+ intros st PS. unfold step. destruct (st.(st_wrk)).
+ apply PS.
+ assert (PS2: Pstate (mkstate st.(st_in) l)).
+ red; intro; simpl. apply PS.
+ case (plt p topnode); intro.
+ apply propagate_successors_P. auto. auto.
+ auto.
+
+ eauto. red; intro; simpl. rewrite PMap.gi. apply Ptop.
Qed.
End Solver.
diff --git a/backend/LTL.v b/backend/LTL.v
index 2c36cba..f20ba3f 100644
--- a/backend/LTL.v
+++ b/backend/LTL.v
@@ -9,6 +9,7 @@ Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Values.
+Require Import Events.
Require Import Mem.
Require Import Globalenvs.
Require Import Op.
@@ -39,6 +40,7 @@ Inductive block: Set :=
| Bload: memory_chunk -> addressing -> list mreg -> mreg -> block -> block
| Bstore: memory_chunk -> addressing -> list mreg -> mreg -> block -> block
| Bcall: signature -> mreg + ident -> block -> block
+ | Balloc: block -> block
| Bgoto: node -> block
| Bcond: condition -> list mreg -> node -> node -> block
| Breturn: block.
@@ -60,11 +62,19 @@ Record function: Set := mkfunction {
forall (pc: node), Plt pc (Psucc fn_entrypoint) \/ fn_code!pc = None
}.
-Definition program := AST.program function.
+Definition fundef := AST.fundef function.
+
+Definition program := AST.program fundef.
+
+Definition funsig (fd: fundef) :=
+ match fd with
+ | Internal f => f.(fn_sig)
+ | External ef => ef.(ef_sig)
+ end.
(** * Operational semantics *)
-Definition genv := Genv.t function.
+Definition genv := Genv.t fundef.
Definition locset := Locmap.t.
Section RELSEM.
@@ -117,7 +127,7 @@ Definition return_regs (caller callee: locset) : locset :=
Variable ge: genv.
-Definition find_function (ros: mreg + ident) (rs: locset) : option function :=
+Definition find_function (ros: mreg + ident) (rs: locset) : option fundef :=
match ros with
| inl r => Genv.find_funct ge (rs (R r))
| inr symb =>
@@ -166,104 +176,119 @@ Inductive outcome: Set :=
| Return: outcome.
Inductive exec_instr: val ->
- block -> locset -> mem ->
+ block -> locset -> mem -> trace ->
block -> locset -> mem -> Prop :=
| exec_Bgetstack:
forall sp sl r b rs m,
exec_instr sp (Bgetstack sl r b) rs m
- b (Locmap.set (R r) (rs (S sl)) rs) m
+ E0 b (Locmap.set (R r) (rs (S sl)) rs) m
| exec_Bsetstack:
forall sp r sl b rs m,
exec_instr sp (Bsetstack r sl b) rs m
- b (Locmap.set (S sl) (rs (R r)) rs) m
+ E0 b (Locmap.set (S sl) (rs (R r)) rs) m
| exec_Bop:
forall sp op args res b rs m v,
eval_operation ge sp op (reglist args rs) = Some v ->
exec_instr sp (Bop op args res b) rs m
- b (Locmap.set (R res) v rs) m
+ E0 b (Locmap.set (R res) v rs) m
| exec_Bload:
forall sp chunk addr args dst b rs m a v,
eval_addressing ge sp addr (reglist args rs) = Some a ->
loadv chunk m a = Some v ->
exec_instr sp (Bload chunk addr args dst b) rs m
- b (Locmap.set (R dst) v rs) m
+ E0 b (Locmap.set (R dst) v rs) m
| exec_Bstore:
forall sp chunk addr args src b rs m m' a,
eval_addressing ge sp addr (reglist args rs) = Some a ->
storev chunk m a (rs (R src)) = Some m' ->
exec_instr sp (Bstore chunk addr args src b) rs m
- b rs m'
+ E0 b rs m'
| exec_Bcall:
- forall sp sig ros b rs m f rs' m',
+ forall sp sig ros b rs m t f rs' m',
find_function ros rs = Some f ->
- sig = f.(fn_sig) ->
- exec_function f rs m rs' m' ->
+ sig = funsig f ->
+ exec_function f rs m t rs' m' ->
exec_instr sp (Bcall sig ros b) rs m
- b (return_regs rs rs') m'
+ t b (return_regs rs rs') m'
+ | exec_Balloc:
+ forall sp b rs m sz m' blk,
+ rs (R Conventions.loc_alloc_argument) = Vint sz ->
+ Mem.alloc m 0 (Int.signed sz) = (m', blk) ->
+ exec_instr sp (Balloc b) rs m E0 b
+ (Locmap.set (R Conventions.loc_alloc_result)
+ (Vptr blk Int.zero) rs) m'
with exec_instrs: val ->
- block -> locset -> mem ->
+ block -> locset -> mem -> trace ->
block -> locset -> mem -> Prop :=
| exec_refl:
forall sp b rs m,
- exec_instrs sp b rs m b rs m
+ exec_instrs sp b rs m E0 b rs m
| exec_one:
- forall sp b1 rs1 m1 b2 rs2 m2,
- exec_instr sp b1 rs1 m1 b2 rs2 m2 ->
- exec_instrs sp b1 rs1 m1 b2 rs2 m2
+ forall sp b1 rs1 m1 t b2 rs2 m2,
+ exec_instr sp b1 rs1 m1 t b2 rs2 m2 ->
+ exec_instrs sp b1 rs1 m1 t b2 rs2 m2
| exec_trans:
- forall sp b1 rs1 m1 b2 rs2 m2 b3 rs3 m3,
- exec_instrs sp b1 rs1 m1 b2 rs2 m2 ->
- exec_instrs sp b2 rs2 m2 b3 rs3 m3 ->
- exec_instrs sp b1 rs1 m1 b3 rs3 m3
+ forall sp b1 rs1 m1 t t1 b2 rs2 m2 t2 b3 rs3 m3,
+ exec_instrs sp b1 rs1 m1 t1 b2 rs2 m2 ->
+ exec_instrs sp b2 rs2 m2 t2 b3 rs3 m3 ->
+ t = t1 ** t2 ->
+ exec_instrs sp b1 rs1 m1 t b3 rs3 m3
with exec_block: val ->
- block -> locset -> mem ->
+ block -> locset -> mem -> trace ->
outcome -> locset -> mem -> Prop :=
| exec_Bgoto:
- forall sp b rs m s rs' m',
- exec_instrs sp b rs m (Bgoto s) rs' m' ->
- exec_block sp b rs m (Cont s) rs' m'
+ forall sp b rs m t s rs' m',
+ exec_instrs sp b rs m t (Bgoto s) rs' m' ->
+ exec_block sp b rs m t (Cont s) rs' m'
| exec_Bcond_true:
- forall sp b rs m cond args ifso ifnot rs' m',
- exec_instrs sp b rs m (Bcond cond args ifso ifnot) rs' m' ->
+ forall sp b rs m t cond args ifso ifnot rs' m',
+ exec_instrs sp b rs m t (Bcond cond args ifso ifnot) rs' m' ->
eval_condition cond (reglist args rs') = Some true ->
- exec_block sp b rs m (Cont ifso) rs' m'
+ exec_block sp b rs m t (Cont ifso) rs' m'
| exec_Bcond_false:
- forall sp b rs m cond args ifso ifnot rs' m',
- exec_instrs sp b rs m (Bcond cond args ifso ifnot) rs' m' ->
+ forall sp b rs m t cond args ifso ifnot rs' m',
+ exec_instrs sp b rs m t (Bcond cond args ifso ifnot) rs' m' ->
eval_condition cond (reglist args rs') = Some false ->
- exec_block sp b rs m (Cont ifnot) rs' m'
+ exec_block sp b rs m t (Cont ifnot) rs' m'
| exec_Breturn:
- forall sp b rs m rs' m',
- exec_instrs sp b rs m Breturn rs' m' ->
- exec_block sp b rs m Return rs' m'
+ forall sp b rs m t rs' m',
+ exec_instrs sp b rs m t Breturn rs' m' ->
+ exec_block sp b rs m t Return rs' m'
with exec_blocks: code -> val ->
- node -> locset -> mem ->
+ node -> locset -> mem -> trace ->
outcome -> locset -> mem -> Prop :=
| exec_blocks_refl:
forall c sp pc rs m,
- exec_blocks c sp pc rs m (Cont pc) rs m
+ exec_blocks c sp pc rs m E0 (Cont pc) rs m
| exec_blocks_one:
- forall c sp pc b m rs out rs' m',
+ forall c sp pc b m rs t out rs' m',
c!pc = Some b ->
- exec_block sp b rs m out rs' m' ->
- exec_blocks c sp pc rs m out rs' m'
+ exec_block sp b rs m t out rs' m' ->
+ exec_blocks c sp pc rs m t out rs' m'
| exec_blocks_trans:
- forall c sp pc1 rs1 m1 pc2 rs2 m2 out rs3 m3,
- exec_blocks c sp pc1 rs1 m1 (Cont pc2) rs2 m2 ->
- exec_blocks c sp pc2 rs2 m2 out rs3 m3 ->
- exec_blocks c sp pc1 rs1 m1 out rs3 m3
+ forall c sp pc1 rs1 m1 t t1 pc2 rs2 m2 t2 out rs3 m3,
+ exec_blocks c sp pc1 rs1 m1 t1 (Cont pc2) rs2 m2 ->
+ exec_blocks c sp pc2 rs2 m2 t2 out rs3 m3 ->
+ t = t1 ** t2 ->
+ exec_blocks c sp pc1 rs1 m1 t out rs3 m3
-with exec_function: function -> locset -> mem ->
+with exec_function: fundef -> locset -> mem -> trace ->
locset -> mem -> Prop :=
- | exec_funct:
- forall f rs m m1 stk rs2 m2,
+ | exec_funct_internal:
+ forall f rs m m1 stk t rs2 m2,
alloc m 0 f.(fn_stacksize) = (m1, stk) ->
exec_blocks f.(fn_code) (Vptr stk Int.zero)
- f.(fn_entrypoint) (call_regs rs) m1 Return rs2 m2 ->
- exec_function f rs m rs2 (free m2 stk).
+ f.(fn_entrypoint) (call_regs rs) m1 t Return rs2 m2 ->
+ exec_function (Internal f) rs m t rs2 (free m2 stk)
+ | exec_funct_external:
+ forall ef args res rs1 rs2 m t,
+ event_match ef args t res ->
+ args = List.map rs1 (Conventions.loc_arguments ef.(ef_sig)) ->
+ rs2 = Locmap.set (R (Conventions.loc_result ef.(ef_sig))) res rs1 ->
+ exec_function (External ef) rs1 m t rs2 m.
End RELSEM.
@@ -272,15 +297,15 @@ End RELSEM.
main function, to be found in the machine register dictated
by the calling conventions. *)
-Definition exec_program (p: program) (r: val) : Prop :=
+Definition exec_program (p: program) (t: trace) (r: val) : Prop :=
let ge := Genv.globalenv p in
let m0 := Genv.init_mem p in
exists b, exists f, exists rs, exists m,
Genv.find_symbol ge p.(prog_main) = Some b /\
Genv.find_funct_ptr ge b = Some f /\
- f.(fn_sig) = mksignature nil (Some Tint) /\
- exec_function ge f (Locmap.init Vundef) m0 rs m /\
- rs (R (Conventions.loc_result f.(fn_sig))) = r.
+ funsig f = mksignature nil (Some Tint) /\
+ exec_function ge f (Locmap.init Vundef) m0 t rs m /\
+ rs (R (Conventions.loc_result (funsig f))) = r.
(** We remark that the [exec_blocks] relation is stable if
the control-flow graph is extended by adding new basic blocks
@@ -293,9 +318,9 @@ Variable c1 c2: code.
Hypothesis EXT: forall pc, c2!pc = c1!pc \/ c1!pc = None.
Lemma exec_blocks_extends:
- forall sp pc1 rs1 m1 out rs2 m2,
- exec_blocks ge c1 sp pc1 rs1 m1 out rs2 m2 ->
- exec_blocks ge c2 sp pc1 rs1 m1 out rs2 m2.
+ forall sp pc1 rs1 m1 t out rs2 m2,
+ exec_blocks ge c1 sp pc1 rs1 m1 t out rs2 m2 ->
+ exec_blocks ge c2 sp pc1 rs1 m1 t out rs2 m2.
Proof.
induction 1.
apply exec_blocks_refl.
@@ -319,6 +344,7 @@ Fixpoint successors_aux (b: block) : list node :=
| Bload chunk addr args dst b => successors_aux b
| Bstore chunk addr args src b => successors_aux b
| Bcall sig ros b => successors_aux b
+ | Balloc b => successors_aux b
| Bgoto n => n :: nil
| Bcond cond args ifso ifnot => ifso :: ifnot :: nil
| Breturn => nil
@@ -331,8 +357,8 @@ Definition successors (f: function) (pc: node) : list node :=
end.
Lemma successors_aux_invariant:
- forall ge sp b rs m b' rs' m',
- exec_instrs ge sp b rs m b' rs' m' ->
+ forall ge sp b rs m t b' rs' m',
+ exec_instrs ge sp b rs m t b' rs' m' ->
successors_aux b = successors_aux b'.
Proof.
induction 1; simpl; intros.
@@ -342,16 +368,16 @@ Proof.
Qed.
Lemma successors_correct:
- forall ge f sp pc rs m pc' rs' m' b,
+ forall ge f sp pc rs m t pc' rs' m' b,
f.(fn_code)!pc = Some b ->
- exec_block ge sp b rs m (Cont pc') rs' m' ->
+ exec_block ge sp b rs m t (Cont pc') rs' m' ->
In pc' (successors f pc).
Proof.
intros. unfold successors. rewrite H. inversion H0.
- rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ H6); simpl.
+ rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ _ H7); simpl.
tauto.
- rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ H2); simpl.
+ rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ _ H2); simpl.
tauto.
- rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ H2); simpl.
+ rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ _ H2); simpl.
tauto.
Qed.
diff --git a/backend/LTLtyping.v b/backend/LTLtyping.v
index 3f13ac3..3450814 100644
--- a/backend/LTLtyping.v
+++ b/backend/LTLtyping.v
@@ -73,6 +73,10 @@ Inductive wt_block : block -> Prop :=
match ros with inl r => mreg_type r = Tint | _ => True end ->
wt_block b ->
wt_block (Bcall sig ros b)
+ | wt_Balloc:
+ forall b,
+ wt_block b ->
+ wt_block (Balloc b)
| wt_Bgoto:
forall lbl,
wt_block (Bgoto lbl)
@@ -88,6 +92,14 @@ End WT_BLOCK.
Definition wt_function (f: function) : Prop :=
forall pc b, f.(fn_code)!pc = Some b -> wt_block f b.
+Inductive wt_fundef: fundef -> Prop :=
+ | wt_fundef_external: forall ef,
+ Conventions.sig_external_ok ef.(ef_sig) ->
+ wt_fundef (External ef)
+ | wt_function_internal: forall f,
+ wt_function f ->
+ wt_fundef (Internal f).
+
Definition wt_program (p: program) : Prop :=
- forall i f, In (i, f) (prog_funct p) -> wt_function f.
+ forall i f, In (i, f) (prog_funct p) -> wt_fundef f.
diff --git a/backend/Linear.v b/backend/Linear.v
index f4ed045..2520f5b 100644
--- a/backend/Linear.v
+++ b/backend/Linear.v
@@ -11,6 +11,7 @@ Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
@@ -37,6 +38,7 @@ Inductive instruction: Set :=
| Lload: memory_chunk -> addressing -> list mreg -> mreg -> instruction
| Lstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction
| Lcall: signature -> mreg + ident -> instruction
+ | Lalloc: instruction
| Llabel: label -> instruction
| Lgoto: label -> instruction
| Lcond: condition -> list mreg -> label -> instruction
@@ -50,9 +52,17 @@ Record function: Set := mkfunction {
fn_code: code
}.
-Definition program := AST.program function.
+Definition fundef := AST.fundef function.
-Definition genv := Genv.t function.
+Definition program := AST.program fundef.
+
+Definition funsig (fd: fundef) :=
+ match fd with
+ | Internal f => f.(fn_sig)
+ | External ef => ef.(ef_sig)
+ end.
+
+Definition genv := Genv.t fundef.
Definition locset := Locmap.t.
(** * Operational semantics *)
@@ -88,7 +98,7 @@ Section RELSEM.
Variable ge: genv.
-Definition find_function (ros: mreg + ident) (rs: locset) : option function :=
+Definition find_function (ros: mreg + ident) (rs: locset) : option fundef :=
match ros with
| inl r => Genv.find_funct ge (rs (R r))
| inr symb =>
@@ -106,84 +116,99 @@ Definition find_function (ros: mreg + ident) (rs: locset) : option function :=
[ls'] and [m'] are the final location state and memory state. *)
Inductive exec_instr: function -> val ->
- code -> locset -> mem ->
+ code -> locset -> mem -> trace ->
code -> locset -> mem -> Prop :=
| exec_Lgetstack:
forall f sp sl r b rs m,
exec_instr f sp (Lgetstack sl r :: b) rs m
- b (Locmap.set (R r) (rs (S sl)) rs) m
+ E0 b (Locmap.set (R r) (rs (S sl)) rs) m
| exec_Lsetstack:
forall f sp r sl b rs m,
exec_instr f sp (Lsetstack r sl :: b) rs m
- b (Locmap.set (S sl) (rs (R r)) rs) m
+ E0 b (Locmap.set (S sl) (rs (R r)) rs) m
| exec_Lop:
forall f sp op args res b rs m v,
eval_operation ge sp op (reglist args rs) = Some v ->
exec_instr f sp (Lop op args res :: b) rs m
- b (Locmap.set (R res) v rs) m
+ E0 b (Locmap.set (R res) v rs) m
| exec_Lload:
forall f sp chunk addr args dst b rs m a v,
eval_addressing ge sp addr (reglist args rs) = Some a ->
loadv chunk m a = Some v ->
exec_instr f sp (Lload chunk addr args dst :: b) rs m
- b (Locmap.set (R dst) v rs) m
+ E0 b (Locmap.set (R dst) v rs) m
| exec_Lstore:
forall f sp chunk addr args src b rs m m' a,
eval_addressing ge sp addr (reglist args rs) = Some a ->
storev chunk m a (rs (R src)) = Some m' ->
exec_instr f sp (Lstore chunk addr args src :: b) rs m
- b rs m'
+ E0 b rs m'
| exec_Lcall:
- forall f sp sig ros b rs m f' rs' m',
+ forall f sp sig ros b rs m t f' rs' m',
find_function ros rs = Some f' ->
- sig = f'.(fn_sig) ->
- exec_function f' rs m rs' m' ->
+ sig = funsig f' ->
+ exec_function f' rs m t rs' m' ->
exec_instr f sp (Lcall sig ros :: b) rs m
- b (return_regs rs rs') m'
+ t b (return_regs rs rs') m'
+ | exec_Lalloc:
+ forall f sp b rs m sz m' blk,
+ rs (R Conventions.loc_alloc_argument) = Vint sz ->
+ Mem.alloc m 0 (Int.signed sz) = (m', blk) ->
+ exec_instr f sp (Lalloc :: b) rs m
+ E0 b (Locmap.set (R Conventions.loc_alloc_result)
+ (Vptr blk Int.zero) rs) m'
| exec_Llabel:
forall f sp lbl b rs m,
exec_instr f sp (Llabel lbl :: b) rs m
- b rs m
+ E0 b rs m
| exec_Lgoto:
forall f sp lbl b rs m b',
find_label lbl f.(fn_code) = Some b' ->
exec_instr f sp (Lgoto lbl :: b) rs m
- b' rs m
+ E0 b' rs m
| exec_Lcond_true:
forall f sp cond args lbl b rs m b',
eval_condition cond (reglist args rs) = Some true ->
find_label lbl f.(fn_code) = Some b' ->
exec_instr f sp (Lcond cond args lbl :: b) rs m
- b' rs m
+ E0 b' rs m
| exec_Lcond_false:
forall f sp cond args lbl b rs m,
eval_condition cond (reglist args rs) = Some false ->
exec_instr f sp (Lcond cond args lbl :: b) rs m
- b rs m
+ E0 b rs m
with exec_instrs: function -> val ->
- code -> locset -> mem ->
+ code -> locset -> mem -> trace ->
code -> locset -> mem -> Prop :=
| exec_refl:
forall f sp b rs m,
- exec_instrs f sp b rs m b rs m
+ exec_instrs f sp b rs m E0 b rs m
| exec_one:
- forall f sp b1 rs1 m1 b2 rs2 m2,
- exec_instr f sp b1 rs1 m1 b2 rs2 m2 ->
- exec_instrs f sp b1 rs1 m1 b2 rs2 m2
+ forall f sp b1 rs1 m1 t b2 rs2 m2,
+ exec_instr f sp b1 rs1 m1 t b2 rs2 m2 ->
+ exec_instrs f sp b1 rs1 m1 t b2 rs2 m2
| exec_trans:
- forall f sp b1 rs1 m1 b2 rs2 m2 b3 rs3 m3,
- exec_instrs f sp b1 rs1 m1 b2 rs2 m2 ->
- exec_instrs f sp b2 rs2 m2 b3 rs3 m3 ->
- exec_instrs f sp b1 rs1 m1 b3 rs3 m3
-
-with exec_function: function -> locset -> mem -> locset -> mem -> Prop :=
- | exec_funct:
- forall f rs m m1 stk rs2 m2 b,
+ forall f sp b1 rs1 m1 t1 b2 rs2 m2 t2 b3 rs3 m3 t,
+ exec_instrs f sp b1 rs1 m1 t1 b2 rs2 m2 ->
+ exec_instrs f sp b2 rs2 m2 t2 b3 rs3 m3 ->
+ t = t1 ** t2 ->
+ exec_instrs f sp b1 rs1 m1 t b3 rs3 m3
+
+with exec_function: fundef -> locset -> mem -> trace -> locset -> mem -> Prop :=
+ | exec_funct_internal:
+ forall f rs m t m1 stk rs2 m2 b,
alloc m 0 f.(fn_stacksize) = (m1, stk) ->
exec_instrs f (Vptr stk Int.zero)
- f.(fn_code) (call_regs rs) m1 (Lreturn :: b) rs2 m2 ->
- exec_function f rs m rs2 (free m2 stk).
+ f.(fn_code) (call_regs rs) m1
+ t (Lreturn :: b) rs2 m2 ->
+ exec_function (Internal f) rs m t rs2 (free m2 stk)
+ | exec_funct_external:
+ forall ef args res rs1 rs2 m t,
+ event_match ef args t res ->
+ args = List.map rs1 (Conventions.loc_arguments ef.(ef_sig)) ->
+ rs2 = Locmap.set (R (Conventions.loc_result ef.(ef_sig))) res rs1 ->
+ exec_function (External ef) rs1 m t rs2 m.
Scheme exec_instr_ind3 := Minimality for exec_instr Sort Prop
with exec_instrs_ind3 := Minimality for exec_instrs Sort Prop
@@ -191,13 +216,13 @@ Scheme exec_instr_ind3 := Minimality for exec_instr Sort Prop
End RELSEM.
-Definition exec_program (p: program) (r: val) : Prop :=
+Definition exec_program (p: program) (t: trace) (r: val) : Prop :=
let ge := Genv.globalenv p in
let m0 := Genv.init_mem p in
exists b, exists f, exists rs, exists m,
Genv.find_symbol ge p.(prog_main) = Some b /\
Genv.find_funct_ptr ge b = Some f /\
- f.(fn_sig) = mksignature nil (Some Tint) /\
- exec_function ge f (Locmap.init Vundef) m0 rs m /\
- rs (R (Conventions.loc_result f.(fn_sig))) = r.
+ funsig f = mksignature nil (Some Tint) /\
+ exec_function ge f (Locmap.init Vundef) m0 t rs m /\
+ rs (R (Conventions.loc_result (funsig f))) = r.
diff --git a/backend/Linearize.v b/backend/Linearize.v
index af70b0f..f5b2a9e 100644
--- a/backend/Linearize.v
+++ b/backend/Linearize.v
@@ -148,6 +148,8 @@ Fixpoint linearize_block (b: block) (k: code) {struct b} : code :=
Lstore chunk addr args src :: linearize_block b k
| Bcall sig ros b =>
Lcall sig ros :: linearize_block b k
+ | Balloc b =>
+ Lalloc :: linearize_block b k
| Bgoto s =>
Lgoto s :: k
| Bcond cond args s1 s2 =>
@@ -208,5 +210,8 @@ Definition cleanup_function (f: Linear.function) : Linear.function :=
Definition transf_function (f: LTL.function) : Linear.function :=
cleanup_function (linearize_function f).
+Definition transf_fundef (f: LTL.fundef) : Linear.fundef :=
+ AST.transf_fundef transf_function f.
+
Definition transf_program (p: LTL.program) : Linear.program :=
- transform_program transf_function p.
+ transform_program transf_fundef p.
diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v
index b80acb4..22bf19c 100644
--- a/backend/Linearizeproof.v
+++ b/backend/Linearizeproof.v
@@ -6,6 +6,7 @@ Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
@@ -25,19 +26,25 @@ Let tge := Genv.globalenv tprog.
Lemma functions_translated:
forall v f,
Genv.find_funct ge v = Some f ->
- Genv.find_funct tge v = Some (transf_function f).
-Proof (@Genv.find_funct_transf _ _ transf_function prog).
+ Genv.find_funct tge v = Some (transf_fundef f).
+Proof (@Genv.find_funct_transf _ _ transf_fundef prog).
Lemma function_ptr_translated:
forall v f,
Genv.find_funct_ptr ge v = Some f ->
- Genv.find_funct_ptr tge v = Some (transf_function f).
-Proof (@Genv.find_funct_ptr_transf _ _ transf_function prog).
+ Genv.find_funct_ptr tge v = Some (transf_fundef f).
+Proof (@Genv.find_funct_ptr_transf _ _ transf_fundef prog).
Lemma symbols_preserved:
forall id,
Genv.find_symbol tge id = Genv.find_symbol ge id.
-Proof (@Genv.find_symbol_transf _ _ transf_function prog).
+Proof (@Genv.find_symbol_transf _ _ transf_fundef prog).
+
+Lemma sig_preserved:
+ forall f, funsig (transf_fundef f) = LTL.funsig f.
+Proof.
+ destruct f; reflexivity.
+Qed.
(** * Correctness of reachability analysis *)
@@ -80,9 +87,9 @@ Qed.
[pc] is reachable, then [pc'] is reachable. *)
Lemma reachable_correct_1:
- forall f sp pc rs m pc' rs' m' b,
+ forall f sp pc rs m t pc' rs' m' b,
f.(LTL.fn_code)!pc = Some b ->
- exec_block ge sp b rs m (Cont pc') rs' m' ->
+ exec_block ge sp b rs m t (Cont pc') rs' m' ->
(reachable f)!!pc = true ->
(reachable f)!!pc' = true.
Proof.
@@ -92,8 +99,8 @@ Proof.
Qed.
Lemma reachable_correct_2:
- forall c sp pc rs m out rs' m',
- exec_blocks ge c sp pc rs m out rs' m' ->
+ forall c sp pc rs m t out rs' m',
+ exec_blocks ge c sp pc rs m t out rs' m' ->
forall f pc',
c = f.(LTL.fn_code) ->
out = Cont pc' ->
@@ -236,18 +243,19 @@ Lemma starts_with_correct:
starts_with lbl c1 = true ->
find_label lbl c2 = Some c3 ->
exec_instrs tge f sp (cleanup_code c1) ls m
- (cleanup_code c3) ls m.
+ E0 (cleanup_code c3) ls m.
Proof.
induction c1.
simpl; intros; discriminate.
simpl starts_with. destruct a; try (intros; discriminate).
- intros. apply exec_trans with (cleanup_code c1) ls m.
+ intros. apply exec_trans with E0 (cleanup_code c1) ls m E0.
simpl.
constructor. constructor.
destruct (peq lbl l).
subst l. replace c3 with c1. constructor.
apply find_label_unique with lbl c2; auto.
apply IHc1 with c2; auto. eapply is_tail_cons_left; eauto.
+ traceEq.
Qed.
(** Code cleanup preserves the labeling of the code. *)
@@ -273,13 +281,13 @@ Qed.
or one transitions in the cleaned-up code. *)
Lemma cleanup_code_correct_1:
- forall f sp c1 ls1 m1 c2 ls2 m2,
- exec_instr tge f sp c1 ls1 m1 c2 ls2 m2 ->
+ forall f sp c1 ls1 m1 t c2 ls2 m2,
+ exec_instr tge f sp c1 ls1 m1 t c2 ls2 m2 ->
is_tail c1 f.(fn_code) ->
unique_labels f.(fn_code) ->
exec_instrs tge (cleanup_function f) sp
(cleanup_code c1) ls1 m1
- (cleanup_code c2) ls2 m2.
+ t (cleanup_code c2) ls2 m2.
Proof.
induction 1; simpl; intros;
try (apply exec_one; econstructor; eauto; fail).
@@ -310,8 +318,8 @@ Proof.
Qed.
Lemma is_tail_exec_instr:
- forall f sp c1 ls1 m1 c2 ls2 m2,
- exec_instr tge f sp c1 ls1 m1 c2 ls2 m2 ->
+ forall f sp c1 ls1 m1 t c2 ls2 m2,
+ exec_instr tge f sp c1 ls1 m1 t c2 ls2 m2 ->
is_tail c1 f.(fn_code) -> is_tail c2 f.(fn_code).
Proof.
induction 1; intros;
@@ -321,8 +329,8 @@ Proof.
Qed.
Lemma is_tail_exec_instrs:
- forall f sp c1 ls1 m1 c2 ls2 m2,
- exec_instrs tge f sp c1 ls1 m1 c2 ls2 m2 ->
+ forall f sp c1 ls1 m1 t c2 ls2 m2,
+ exec_instrs tge f sp c1 ls1 m1 t c2 ls2 m2 ->
is_tail c1 f.(fn_code) -> is_tail c2 f.(fn_code).
Proof.
induction 1; intros.
@@ -335,31 +343,32 @@ Qed.
to zero, one or several transitions in the cleaned-up code. *)
Lemma cleanup_code_correct_2:
- forall f sp c1 ls1 m1 c2 ls2 m2,
- exec_instrs tge f sp c1 ls1 m1 c2 ls2 m2 ->
+ forall f sp c1 ls1 m1 t c2 ls2 m2,
+ exec_instrs tge f sp c1 ls1 m1 t c2 ls2 m2 ->
is_tail c1 f.(fn_code) ->
unique_labels f.(fn_code) ->
exec_instrs tge (cleanup_function f) sp
(cleanup_code c1) ls1 m1
- (cleanup_code c2) ls2 m2.
+ t (cleanup_code c2) ls2 m2.
Proof.
induction 1; simpl; intros.
apply exec_refl.
eapply cleanup_code_correct_1; eauto.
- apply exec_trans with (cleanup_code b2) rs2 m2.
+ apply exec_trans with t1 (cleanup_code b2) rs2 m2 t2.
auto.
apply IHexec_instrs2; auto.
eapply is_tail_exec_instrs; eauto.
+ auto.
Qed.
Lemma cleanup_function_correct:
- forall f ls1 m1 ls2 m2,
- exec_function tge f ls1 m1 ls2 m2 ->
+ forall f ls1 m1 t ls2 m2,
+ exec_function tge (Internal f) ls1 m1 t ls2 m2 ->
unique_labels f.(fn_code) ->
- exec_function tge (cleanup_function f) ls1 m1 ls2 m2.
+ exec_function tge (Internal (cleanup_function f)) ls1 m1 t ls2 m2.
Proof.
- induction 1; intro.
- generalize (cleanup_code_correct_2 _ _ _ _ _ _ _ _ H0 (is_tail_refl _) H1).
+ intros. inversion H; subst.
+ generalize (cleanup_code_correct_2 _ _ _ _ _ _ _ _ _ H3 (is_tail_refl _) H0).
simpl. intro.
econstructor; eauto.
Qed.
@@ -479,8 +488,8 @@ Definition valid_outcome (f: LTL.function) (out: outcome) :=
(** Auxiliary lemma used to establish the [valid_outcome] property. *)
Lemma exec_blocks_valid_outcome:
- forall c sp pc ls1 m1 out ls2 m2,
- exec_blocks ge c sp pc ls1 m1 out ls2 m2 ->
+ forall c sp pc ls1 m1 t out ls2 m2,
+ exec_blocks ge c sp pc ls1 m1 t out ls2 m2 ->
forall f,
c = f.(LTL.fn_code) ->
(reachable f)!!pc = true ->
@@ -514,34 +523,34 @@ Inductive cont_for_outcome: LTL.function -> outcome -> code -> Prop :=
Definition exec_instr_prop
(sp: val) (b1: block) (ls1: locset) (m1: mem)
- (b2: block) (ls2: locset) (m2: mem) : Prop :=
+ (t: trace) (b2: block) (ls2: locset) (m2: mem) : Prop :=
forall f k,
exec_instr tge (linearize_function f) sp
(linearize_block b1 k) ls1 m1
- (linearize_block b2 k) ls2 m2.
+ t (linearize_block b2 k) ls2 m2.
Definition exec_instrs_prop
(sp: val) (b1: block) (ls1: locset) (m1: mem)
- (b2: block) (ls2: locset) (m2: mem) : Prop :=
+ (t: trace) (b2: block) (ls2: locset) (m2: mem) : Prop :=
forall f k,
exec_instrs tge (linearize_function f) sp
(linearize_block b1 k) ls1 m1
- (linearize_block b2 k) ls2 m2.
+ t (linearize_block b2 k) ls2 m2.
Definition exec_block_prop
(sp: val) (b: block) (ls1: locset) (m1: mem)
- (out: outcome) (ls2: locset) (m2: mem): Prop :=
+ (t: trace) (out: outcome) (ls2: locset) (m2: mem): Prop :=
forall f k,
valid_outcome f out ->
exists k',
exec_instrs tge (linearize_function f) sp
(linearize_block b k) ls1 m1
- k' ls2 m2
+ t k' ls2 m2
/\ cont_for_outcome f out k'.
Definition exec_blocks_prop
(c: LTL.code) (sp: val) (pc: node) (ls1: locset) (m1: mem)
- (out: outcome) (ls2: locset) (m2: mem): Prop :=
+ (t: trace) (out: outcome) (ls2: locset) (m2: mem): Prop :=
forall f k,
c = f.(LTL.fn_code) ->
(reachable f)!!pc = true ->
@@ -550,12 +559,13 @@ Definition exec_blocks_prop
exists k',
exec_instrs tge (linearize_function f) sp
k ls1 m1
- k' ls2 m2
+ t k' ls2 m2
/\ cont_for_outcome f out k'.
Definition exec_function_prop
- (f: LTL.function) (ls1: locset) (m1: mem) (ls2: locset) (m2: mem): Prop :=
- exec_function tge (transf_function f) ls1 m1 ls2 m2.
+ (f: LTL.fundef) (ls1: locset) (m1: mem) (t: trace)
+ (ls2: locset) (m2: mem): Prop :=
+ exec_function tge (transf_fundef f) ls1 m1 t ls2 m2.
Scheme exec_instr_ind5 := Minimality for LTL.exec_instr Sort Prop
with exec_instrs_ind5 := Minimality for LTL.exec_instrs Sort Prop
@@ -567,9 +577,9 @@ Scheme exec_instr_ind5 := Minimality for LTL.exec_instr Sort Prop
derivation. *)
Lemma transf_function_correct:
- forall f ls1 m1 ls2 m2,
- LTL.exec_function ge f ls1 m1 ls2 m2 ->
- exec_function_prop f ls1 m1 ls2 m2.
+ forall f ls1 m1 t ls2 m2,
+ LTL.exec_function ge f ls1 m1 t ls2 m2 ->
+ exec_function_prop f ls1 m1 t ls2 m2.
Proof.
apply (exec_function_ind5 ge
exec_instr_prop
@@ -596,27 +606,29 @@ Proof.
exact symbols_preserved.
auto.
(* call *)
- apply exec_Lcall with (transf_function f).
+ apply exec_Lcall with (transf_fundef f).
generalize H. destruct ros; simpl.
intro; apply functions_translated; auto.
rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
intro; apply function_ptr_translated; auto. congruence.
- rewrite H0; reflexivity.
+ generalize (sig_preserved f). congruence.
apply H2.
+ (* alloc *)
+ eapply exec_Lalloc; eauto.
(* instr_refl *)
apply exec_refl.
(* instr_one *)
apply exec_one. apply H0.
(* instr_trans *)
- apply exec_trans with (linearize_block b2 k) rs2 m2.
- apply H0. apply H2.
+ apply exec_trans with t1 (linearize_block b2 k) rs2 m2 t2.
+ apply H0. apply H2. auto.
(* goto *)
elim H1. intros REACH [b2 AT2].
generalize (H0 f k). simpl. intro.
elim (find_label_lin f s b2 AT2 REACH). intros k2 FIND.
exists (linearize_block b2 k2).
split.
- eapply exec_trans. eexact H2. constructor. constructor. auto.
+ eapply exec_trans. eexact H2. constructor. constructor. auto. traceEq.
constructor. auto.
(* cond, true *)
elim H2. intros REACH [b2 AT2].
@@ -628,10 +640,10 @@ Proof.
eapply exec_trans. eexact H3.
eapply exec_trans. apply exec_one. apply exec_Lcond_false.
change false with (negb true). apply eval_negate_condition. auto.
- apply exec_one. apply exec_Lgoto. auto.
+ apply exec_one. apply exec_Lgoto. auto. reflexivity. traceEq.
eapply exec_trans. eexact H3.
apply exec_one. apply exec_Lcond_true.
- auto. auto.
+ auto. auto. traceEq.
constructor; auto.
(* cond, false *)
elim H2. intros REACH [b2 AT2].
@@ -643,10 +655,10 @@ Proof.
eapply exec_trans. eexact H3.
apply exec_one. apply exec_Lcond_true.
change true with (negb false). apply eval_negate_condition. auto.
- auto.
+ auto. traceEq.
eapply exec_trans. eexact H3.
eapply exec_trans. apply exec_one. apply exec_Lcond_false. auto.
- apply exec_one. apply exec_Lgoto. auto.
+ apply exec_one. apply exec_Lgoto. auto. reflexivity. traceEq.
constructor; auto.
(* return *)
exists (Lreturn :: k). split.
@@ -663,11 +675,11 @@ Proof.
eapply reachable_correct_2. eexact H. auto. auto. auto.
assert (valid_outcome f (Cont pc2)).
eapply exec_blocks_valid_outcome; eauto.
- generalize (H0 f k H3 H4 H5 H8). intros [k1 [EX1 CFO2]].
+ generalize (H0 f k H4 H5 H6 H9). intros [k1 [EX1 CFO2]].
inversion CFO2.
- generalize (H2 f k1 H3 H7 H11 H6). intros [k2 [EX2 CFO3]].
+ generalize (H2 f k1 H4 H8 H12 H7). intros [k2 [EX2 CFO3]].
exists k2. split. eapply exec_trans; eauto. auto.
- (* function -- TA-DA! *)
+ (* internal function -- TA-DA! *)
assert (REACH0: (reachable f)!!(fn_entrypoint f) = true).
apply reachable_entrypoint.
assert (VO2: valid_outcome f Return). simpl; auto.
@@ -687,25 +699,27 @@ Proof.
inversion CO. subst k'.
unfold transf_function. apply cleanup_function_correct.
econstructor. eauto. rewrite EQ. eapply exec_trans.
- apply exec_one. constructor. eauto.
+ apply exec_one. constructor. eauto. traceEq.
apply unique_labels_lin_function.
+ (* external function *)
+ econstructor; eauto.
Qed.
End LINEARIZATION.
Theorem transf_program_correct:
- forall (p: LTL.program) (r: val),
- LTL.exec_program p r ->
- Linear.exec_program (transf_program p) r.
+ forall (p: LTL.program) (t: trace) (r: val),
+ LTL.exec_program p t r ->
+ Linear.exec_program (transf_program p) t r.
Proof.
- intros p r [b [f [ls [m [FIND1 [FIND2 [SIG [EX RES]]]]]]]].
- red. exists b; exists (transf_function f); exists ls; exists m.
+ intros p t r [b [f [ls [m [FIND1 [FIND2 [SIG [EX RES]]]]]]]].
+ red. exists b; exists (transf_fundef f); exists ls; exists m.
split. change (prog_main (transf_program p)) with (prog_main p).
rewrite symbols_preserved; auto.
split. apply function_ptr_translated. auto.
- split. auto.
+ split. generalize (sig_preserved f); congruence.
split. apply transf_function_correct.
unfold transf_program. rewrite Genv.init_mem_transf. auto.
- exact RES.
+ rewrite sig_preserved. exact RES.
Qed.
diff --git a/backend/Linearizetyping.v b/backend/Linearizetyping.v
index 6cebca8..66926e9 100644
--- a/backend/Linearizetyping.v
+++ b/backend/Linearizetyping.v
@@ -274,6 +274,8 @@ Proof.
(* call *)
constructor; auto.
eapply size_arguments_bound; eauto.
+ (* alloc *)
+ constructor.
(* goto *)
constructor.
(* cond *)
@@ -327,14 +329,24 @@ Proof.
apply cleanup_function_conservation_2; auto.
Qed.
+Lemma wt_transf_fundef:
+ forall f,
+ LTLtyping.wt_fundef f ->
+ wt_fundef (transf_fundef f).
+Proof.
+ induction 1; simpl.
+ constructor; assumption.
+ constructor; apply wt_transf_function; assumption.
+Qed.
+
Lemma program_typing_preserved:
forall (p: LTL.program),
LTLtyping.wt_program p ->
Lineartyping.wt_program (transf_program p).
Proof.
intros; red; intros.
- generalize (transform_program_function transf_function p i f H0).
+ generalize (transform_program_function transf_fundef p i f H0).
intros [f0 [IN TR]].
- subst f. apply wt_transf_function; auto.
+ subst f. apply wt_transf_fundef; auto.
apply (H i f0 IN).
Qed.
diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v
index 0b13b40..bf41908 100644
--- a/backend/Lineartyping.v
+++ b/backend/Lineartyping.v
@@ -38,6 +38,7 @@ Definition regs_of_instr (i: instruction) : list mreg :=
| Lstore chunk addr args src => src :: args
| Lcall sig (inl fn) => fn :: nil
| Lcall sig (inr _) => nil
+ | Lalloc => nil
| Llabel lbl => nil
| Lgoto lbl => nil
| Lcond cond args lbl => args
@@ -231,6 +232,8 @@ Inductive wt_instr : instruction -> Prop :=
size_arguments sig <= bound_outgoing b ->
match ros with inl r => mreg_type r = Tint | _ => True end ->
wt_instr (Lcall sig ros)
+ | wt_Lalloc:
+ wt_instr Lalloc
| wt_Llabel:
forall lbl,
wt_instr (Llabel lbl)
@@ -249,6 +252,14 @@ End WT_INSTR.
Definition wt_function (f: function) : Prop :=
forall instr, In instr f.(fn_code) -> wt_instr f instr.
+Inductive wt_fundef: fundef -> Prop :=
+ | wt_fundef_external: forall ef,
+ Conventions.sig_external_ok ef.(ef_sig) ->
+ wt_fundef (External ef)
+ | wt_function_internal: forall f,
+ wt_function f ->
+ wt_fundef (Internal f).
+
Definition wt_program (p: program) : Prop :=
- forall i f, In (i, f) (prog_funct p) -> wt_function f.
+ forall i f, In (i, f) (prog_funct p) -> wt_fundef f.
diff --git a/backend/Mach.v b/backend/Mach.v
index f953798..1a9a94a 100644
--- a/backend/Mach.v
+++ b/backend/Mach.v
@@ -10,9 +10,11 @@ Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
+Require Conventions.
(** * Abstract syntax *)
@@ -43,6 +45,7 @@ Inductive instruction: Set :=
| Mload: memory_chunk -> addressing -> list mreg -> mreg -> instruction
| Mstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction
| Mcall: signature -> mreg + ident -> instruction
+ | Malloc: instruction
| Mlabel: label -> instruction
| Mgoto: label -> instruction
| Mcond: condition -> list mreg -> label -> instruction
@@ -56,9 +59,17 @@ Record function: Set := mkfunction
fn_stacksize: Z;
fn_framesize: Z }.
-Definition program := AST.program function.
+Definition fundef := AST.fundef function.
-Definition genv := Genv.t function.
+Definition program := AST.program fundef.
+
+Definition funsig (fd: fundef) :=
+ match fd with
+ | Internal f => f.(fn_sig)
+ | External ef => ef.(ef_sig)
+ end.
+
+Definition genv := Genv.t fundef.
(** * Dynamic semantics *)
@@ -122,7 +133,7 @@ Section RELSEM.
Variable ge: genv.
-Definition find_function (ros: mreg + ident) (rs: regset) : option function :=
+Definition find_function (ros: mreg + ident) (rs: regset) : option fundef :=
match ros with
| inl r => Genv.find_funct ge (rs r)
| inr symb =>
@@ -141,95 +152,104 @@ Definition find_function (ros: mreg + ident) (rs: regset) : option function :=
Inductive exec_instr:
function -> val ->
- code -> regset -> mem ->
+ code -> regset -> mem -> trace ->
code -> regset -> mem -> Prop :=
| exec_Mlabel:
forall f sp lbl c rs m,
exec_instr f sp
(Mlabel lbl :: c) rs m
- c rs m
+ E0 c rs m
| exec_Mgetstack:
forall f sp ofs ty dst c rs m v,
load_stack m sp ty ofs = Some v ->
exec_instr f sp
(Mgetstack ofs ty dst :: c) rs m
- c (rs#dst <- v) m
+ E0 c (rs#dst <- v) m
| exec_Msetstack:
forall f sp src ofs ty c rs m m',
store_stack m sp ty ofs (rs src) = Some m' ->
exec_instr f sp
(Msetstack src ofs ty :: c) rs m
- c rs m'
+ E0 c rs m'
| exec_Mgetparam:
forall f sp parent ofs ty dst c rs m v,
load_stack m sp Tint (Int.repr 0) = Some parent ->
load_stack m parent ty ofs = Some v ->
exec_instr f sp
(Mgetparam ofs ty dst :: c) rs m
- c (rs#dst <- v) m
+ E0 c (rs#dst <- v) m
| exec_Mop:
forall f sp op args res c rs m v,
eval_operation ge sp op rs##args = Some v ->
exec_instr f sp
(Mop op args res :: c) rs m
- c (rs#res <- v) m
+ E0 c (rs#res <- v) m
| exec_Mload:
forall f sp chunk addr args dst c rs m a v,
eval_addressing ge sp addr rs##args = Some a ->
Mem.loadv chunk m a = Some v ->
exec_instr f sp
(Mload chunk addr args dst :: c) rs m
- c (rs#dst <- v) m
+ E0 c (rs#dst <- v) m
| exec_Mstore:
forall f sp chunk addr args src c rs m m' a,
eval_addressing ge sp addr rs##args = Some a ->
Mem.storev chunk m a (rs src) = Some m' ->
exec_instr f sp
(Mstore chunk addr args src :: c) rs m
- c rs m'
+ E0 c rs m'
| exec_Mcall:
- forall f sp sig ros c rs m f' rs' m',
+ forall f sp sig ros c rs m f' t rs' m',
find_function ros rs = Some f' ->
- exec_function f' sp rs m rs' m' ->
+ exec_function f' sp rs m t rs' m' ->
exec_instr f sp
(Mcall sig ros :: c) rs m
- c rs' m'
+ t c rs' m'
+ | exec_Malloc:
+ forall f sp c rs m sz m' blk,
+ rs (Conventions.loc_alloc_argument) = Vint sz ->
+ Mem.alloc m 0 (Int.signed sz) = (m', blk) ->
+ exec_instr f sp
+ (Malloc :: c) rs m
+ E0 c (rs#Conventions.loc_alloc_result <-
+ (Vptr blk Int.zero)) m'
| exec_Mgoto:
forall f sp lbl c rs m c',
find_label lbl f.(fn_code) = Some c' ->
exec_instr f sp
(Mgoto lbl :: c) rs m
- c' rs m
+ E0 c' rs m
| exec_Mcond_true:
forall f sp cond args lbl c rs m c',
eval_condition cond rs##args = Some true ->
find_label lbl f.(fn_code) = Some c' ->
exec_instr f sp
(Mcond cond args lbl :: c) rs m
- c' rs m
+ E0 c' rs m
| exec_Mcond_false:
forall f sp cond args lbl c rs m,
eval_condition cond rs##args = Some false ->
exec_instr f sp
(Mcond cond args lbl :: c) rs m
- c rs m
+ E0 c rs m
with exec_instrs:
function -> val ->
- code -> regset -> mem ->
+ code -> regset -> mem -> trace ->
code -> regset -> mem -> Prop :=
| exec_refl:
forall f sp c rs m,
- exec_instrs f sp c rs m c rs m
+ exec_instrs f sp c rs m E0 c rs m
| exec_one:
- forall f sp c rs m c' rs' m',
- exec_instr f sp c rs m c' rs' m' ->
- exec_instrs f sp c rs m c' rs' m'
+ forall f sp c rs m t c' rs' m',
+ exec_instr f sp c rs m t c' rs' m' ->
+ exec_instrs f sp c rs m t c' rs' m'
| exec_trans:
- forall f sp c1 rs1 m1 c2 rs2 m2 c3 rs3 m3,
- exec_instrs f sp c1 rs1 m1 c2 rs2 m2 ->
- exec_instrs f sp c2 rs2 m2 c3 rs3 m3 ->
- exec_instrs f sp c1 rs1 m1 c3 rs3 m3
+ forall f sp c1 rs1 m1 t1 c2 rs2 m2 t2 c3 rs3 m3 t3,
+ exec_instrs f sp c1 rs1 m1 t1 c2 rs2 m2 ->
+ exec_instrs f sp c2 rs2 m2 t2 c3 rs3 m3 ->
+ t3 = t1 ** t2 ->
+ exec_instrs f sp c1 rs1 m1 t3 c3 rs3 m3
(** In addition to reserving the word at offset 0 in the activation
record for maintaining the linking of activation records,
@@ -252,9 +272,9 @@ with exec_instrs:
with exec_function_body:
function -> val -> val ->
- regset -> mem -> regset -> mem -> Prop :=
+ regset -> mem -> trace -> regset -> mem -> Prop :=
| exec_funct_body:
- forall f parent ra rs m rs' m1 m2 m3 m4 stk c,
+ forall f parent ra rs m t rs' m1 m2 m3 m4 stk c,
Mem.alloc m (- f.(fn_framesize))
(align_16_top (- f.(fn_framesize)) f.(fn_stacksize))
= (m1, stk) ->
@@ -263,19 +283,25 @@ with exec_function_body:
store_stack m2 sp Tint (Int.repr 4) ra = Some m3 ->
exec_instrs f sp
f.(fn_code) rs m3
- (Mreturn :: c) rs' m4 ->
+ t (Mreturn :: c) rs' m4 ->
load_stack m4 sp Tint (Int.repr 0) = Some parent ->
load_stack m4 sp Tint (Int.repr 4) = Some ra ->
- exec_function_body f parent ra rs m rs' (Mem.free m4 stk)
+ exec_function_body f parent ra rs m t rs' (Mem.free m4 stk)
with exec_function:
- function -> val -> regset -> mem -> regset -> mem -> Prop :=
- | exec_funct:
- forall f parent rs m rs' m',
+ fundef -> val -> regset -> mem -> trace -> regset -> mem -> Prop :=
+ | exec_funct_internal:
+ forall f parent rs m t rs' m',
(forall ra,
Val.has_type ra Tint ->
- exec_function_body f parent ra rs m rs' m') ->
- exec_function f parent rs m rs' m'.
+ exec_function_body f parent ra rs m t rs' m') ->
+ exec_function (Internal f) parent rs m t rs' m'
+ | exec_funct_external:
+ forall ef parent args res rs1 rs2 m t,
+ event_match ef args t res ->
+ args = rs1##(Conventions.loc_external_arguments ef.(ef_sig)) ->
+ rs2 = (rs1#(Conventions.loc_result ef.(ef_sig)) <- res) ->
+ exec_function (External ef) parent rs1 m t rs2 m.
Scheme exec_instr_ind4 := Minimality for exec_instr Sort Prop
with exec_instrs_ind4 := Minimality for exec_instrs Sort Prop
@@ -284,12 +310,13 @@ Scheme exec_instr_ind4 := Minimality for exec_instr Sort Prop
End RELSEM.
-Definition exec_program (p: program) (r: val) : Prop :=
+Definition exec_program (p: program) (t: trace) (r: val) : Prop :=
let ge := Genv.globalenv p in
let m0 := Genv.init_mem p in
exists b, exists f, exists rs, exists m,
Genv.find_symbol ge p.(prog_main) = Some b /\
Genv.find_funct_ptr ge b = Some f /\
- exec_function ge f (Vptr Mem.nullptr Int.zero) (Regmap.init Vundef) m0 rs m /\
+ exec_function ge f (Vptr Mem.nullptr Int.zero) (Regmap.init Vundef) m0
+ t rs m /\
rs R3 = r.
diff --git a/backend/Machabstr.v b/backend/Machabstr.v
index 25458dc..8d5d72a 100644
--- a/backend/Machabstr.v
+++ b/backend/Machabstr.v
@@ -7,6 +7,7 @@ Require Import Mem.
Require Import Integers.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
@@ -99,117 +100,132 @@ Variable ge: genv.
Inductive exec_instr:
function -> val -> frame ->
- code -> regset -> frame -> mem ->
+ code -> regset -> frame -> mem -> trace ->
code -> regset -> frame -> mem -> Prop :=
| exec_Mlabel:
forall f sp parent lbl c rs fr m,
exec_instr f sp parent
(Mlabel lbl :: c) rs fr m
- c rs fr m
+ E0 c rs fr m
| exec_Mgetstack:
forall f sp parent ofs ty dst c rs fr m v,
get_slot fr ty (Int.signed ofs) v ->
exec_instr f sp parent
(Mgetstack ofs ty dst :: c) rs fr m
- c (rs#dst <- v) fr m
+ E0 c (rs#dst <- v) fr m
| exec_Msetstack:
forall f sp parent src ofs ty c rs fr m fr',
set_slot fr ty (Int.signed ofs) (rs src) fr' ->
exec_instr f sp parent
(Msetstack src ofs ty :: c) rs fr m
- c rs fr' m
+ E0 c rs fr' m
| exec_Mgetparam:
forall f sp parent ofs ty dst c rs fr m v,
get_slot parent ty (Int.signed ofs) v ->
exec_instr f sp parent
(Mgetparam ofs ty dst :: c) rs fr m
- c (rs#dst <- v) fr m
+ E0 c (rs#dst <- v) fr m
| exec_Mop:
forall f sp parent op args res c rs fr m v,
eval_operation ge sp op rs##args = Some v ->
exec_instr f sp parent
(Mop op args res :: c) rs fr m
- c (rs#res <- v) fr m
+ E0 c (rs#res <- v) fr m
| exec_Mload:
forall f sp parent chunk addr args dst c rs fr m a v,
eval_addressing ge sp addr rs##args = Some a ->
Mem.loadv chunk m a = Some v ->
exec_instr f sp parent
(Mload chunk addr args dst :: c) rs fr m
- c (rs#dst <- v) fr m
+ E0 c (rs#dst <- v) fr m
| exec_Mstore:
forall f sp parent chunk addr args src c rs fr m m' a,
eval_addressing ge sp addr rs##args = Some a ->
Mem.storev chunk m a (rs src) = Some m' ->
exec_instr f sp parent
(Mstore chunk addr args src :: c) rs fr m
- c rs fr m'
+ E0 c rs fr m'
| exec_Mcall:
- forall f sp parent sig ros c rs fr m f' rs' m',
+ forall f sp parent sig ros c rs fr m t f' rs' m',
find_function ge ros rs = Some f' ->
- exec_function f' fr rs m rs' m' ->
+ exec_function f' fr rs m t rs' m' ->
exec_instr f sp parent
(Mcall sig ros :: c) rs fr m
- c rs' fr m'
+ t c rs' fr m'
+ | exec_Malloc:
+ forall f sp parent c rs fr m sz m' blk,
+ rs (Conventions.loc_alloc_argument) = Vint sz ->
+ Mem.alloc m 0 (Int.signed sz) = (m', blk) ->
+ exec_instr f sp parent
+ (Malloc :: c) rs fr m
+ E0 c (rs#Conventions.loc_alloc_result <-
+ (Vptr blk Int.zero)) fr m'
| exec_Mgoto:
forall f sp parent lbl c rs fr m c',
find_label lbl f.(fn_code) = Some c' ->
exec_instr f sp parent
(Mgoto lbl :: c) rs fr m
- c' rs fr m
+ E0 c' rs fr m
| exec_Mcond_true:
forall f sp parent cond args lbl c rs fr m c',
eval_condition cond rs##args = Some true ->
find_label lbl f.(fn_code) = Some c' ->
exec_instr f sp parent
(Mcond cond args lbl :: c) rs fr m
- c' rs fr m
+ E0 c' rs fr m
| exec_Mcond_false:
forall f sp parent cond args lbl c rs fr m,
eval_condition cond rs##args = Some false ->
exec_instr f sp parent
(Mcond cond args lbl :: c) rs fr m
- c rs fr m
+ E0 c rs fr m
with exec_instrs:
function -> val -> frame ->
- code -> regset -> frame -> mem ->
+ code -> regset -> frame -> mem -> trace ->
code -> regset -> frame -> mem -> Prop :=
| exec_refl:
forall f sp parent c rs fr m,
- exec_instrs f sp parent c rs fr m c rs fr m
+ exec_instrs f sp parent c rs fr m E0 c rs fr m
| exec_one:
- forall f sp parent c rs fr m c' rs' fr' m',
- exec_instr f sp parent c rs fr m c' rs' fr' m' ->
- exec_instrs f sp parent c rs fr m c' rs' fr' m'
+ forall f sp parent c rs fr m t c' rs' fr' m',
+ exec_instr f sp parent c rs fr m t c' rs' fr' m' ->
+ exec_instrs f sp parent c rs fr m t c' rs' fr' m'
| exec_trans:
- forall f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 c3 rs3 fr3 m3,
- exec_instrs f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 ->
- exec_instrs f sp parent c2 rs2 fr2 m2 c3 rs3 fr3 m3 ->
- exec_instrs f sp parent c1 rs1 fr1 m1 c3 rs3 fr3 m3
+ forall f sp parent c1 rs1 fr1 m1 t1 c2 rs2 fr2 m2 t2 c3 rs3 fr3 m3 t3,
+ exec_instrs f sp parent c1 rs1 fr1 m1 t1 c2 rs2 fr2 m2 ->
+ exec_instrs f sp parent c2 rs2 fr2 m2 t2 c3 rs3 fr3 m3 ->
+ t3 = t1 ** t2 ->
+ exec_instrs f sp parent c1 rs1 fr1 m1 t3 c3 rs3 fr3 m3
with exec_function_body:
function -> frame -> val -> val ->
- regset -> mem -> regset -> mem -> Prop :=
+ regset -> mem -> trace -> regset -> mem -> Prop :=
| exec_funct_body:
- forall f parent link ra rs m rs' m1 m2 stk fr1 fr2 fr3 c,
+ forall f parent link ra rs m t rs' m1 m2 stk fr1 fr2 fr3 c,
Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) ->
set_slot (init_frame f) Tint 0 link fr1 ->
set_slot fr1 Tint 4 ra fr2 ->
exec_instrs f (Vptr stk (Int.repr (-f.(fn_framesize)))) parent
f.(fn_code) rs fr2 m1
- (Mreturn :: c) rs' fr3 m2 ->
- exec_function_body f parent link ra rs m rs' (Mem.free m2 stk)
+ t (Mreturn :: c) rs' fr3 m2 ->
+ exec_function_body f parent link ra rs m t rs' (Mem.free m2 stk)
with exec_function:
- function -> frame -> regset -> mem -> regset -> mem -> Prop :=
- | exec_funct:
- forall f parent rs m rs' m',
+ fundef -> frame -> regset -> mem -> trace -> regset -> mem -> Prop :=
+ | exec_funct_internal:
+ forall f parent rs m t rs' m',
(forall link ra,
Val.has_type link Tint ->
Val.has_type ra Tint ->
- exec_function_body f parent link ra rs m rs' m') ->
- exec_function f parent rs m rs' m'.
+ exec_function_body f parent link ra rs m t rs' m') ->
+ exec_function (Internal f) parent rs m t rs' m'
+ | exec_funct_external:
+ forall ef parent args res rs1 rs2 m t,
+ event_match ef args t res ->
+ args = rs1##(Conventions.loc_external_arguments ef.(ef_sig)) ->
+ rs2 = (rs1#(Conventions.loc_result ef.(ef_sig)) <- res) ->
+ exec_function (External ef) parent rs1 m t rs2 m.
Scheme exec_instr_ind4 := Minimality for exec_instr Sort Prop
with exec_instrs_ind4 := Minimality for exec_instrs Sort Prop
@@ -222,134 +238,155 @@ Scheme exec_instr_ind4 := Minimality for exec_instr Sort Prop
by the [Scheme] command above. *)
Lemma exec_mutual_induction:
- forall (P
+ forall
+ (P
P0 : function ->
val ->
frame ->
code ->
regset ->
- frame -> mem -> code -> regset -> frame -> mem -> Prop)
+ frame ->
+ mem -> trace -> code -> regset -> frame -> mem -> Prop)
(P1 : function ->
- frame -> val -> val -> regset -> mem -> regset -> mem -> Prop)
- (P2 : function -> frame -> regset -> mem -> regset -> mem -> Prop),
+ frame ->
+ val -> val -> regset -> mem -> trace -> regset -> mem -> Prop)
+ (P2 : fundef ->
+ frame -> regset -> mem -> trace -> regset -> mem -> Prop),
(forall (f : function) (sp : val) (parent : frame) (lbl : label)
(c : list instruction) (rs : regset) (fr : frame) (m : mem),
- P f sp parent (Mlabel lbl :: c) rs fr m c rs fr m) ->
- (forall (f : function) (sp : val) (parent : frame) (ofs : int)
+ P f sp parent (Mlabel lbl :: c) rs fr m E0 c rs fr m) ->
+ (forall (f0 : function) (sp : val) (parent : frame) (ofs : int)
(ty : typ) (dst : mreg) (c : list instruction) (rs : regset)
(fr : frame) (m : mem) (v : val),
get_slot fr ty (Int.signed ofs) v ->
- P f sp parent (Mgetstack ofs ty dst :: c) rs fr m c rs # dst <- v fr
- m) ->
- (forall (f : function) (sp : val) (parent : frame) (src : mreg)
+ P f0 sp parent (Mgetstack ofs ty dst :: c) rs fr m E0 c rs # dst <- v
+ fr m) ->
+ (forall (f1 : function) (sp : val) (parent : frame) (src : mreg)
(ofs : int) (ty : typ) (c : list instruction) (rs : mreg -> val)
(fr : frame) (m : mem) (fr' : frame),
set_slot fr ty (Int.signed ofs) (rs src) fr' ->
- P f sp parent (Msetstack src ofs ty :: c) rs fr m c rs fr' m) ->
- (forall (f : function) (sp : val) (parent : frame) (ofs : int)
+ P f1 sp parent (Msetstack src ofs ty :: c) rs fr m E0 c rs fr' m) ->
+ (forall (f2 : function) (sp : val) (parent : frame) (ofs : int)
(ty : typ) (dst : mreg) (c : list instruction) (rs : regset)
(fr : frame) (m : mem) (v : val),
get_slot parent ty (Int.signed ofs) v ->
- P f sp parent (Mgetparam ofs ty dst :: c) rs fr m c rs # dst <- v fr
- m) ->
- (forall (f : function) (sp : val) (parent : frame) (op : operation)
+ P f2 sp parent (Mgetparam ofs ty dst :: c) rs fr m E0 c rs # dst <- v
+ fr m) ->
+ (forall (f3 : function) (sp : val) (parent : frame) (op : operation)
(args : list mreg) (res : mreg) (c : list instruction)
(rs : mreg -> val) (fr : frame) (m : mem) (v : val),
eval_operation ge sp op rs ## args = Some v ->
- P f sp parent (Mop op args res :: c) rs fr m c rs # res <- v fr m) ->
- (forall (f : function) (sp : val) (parent : frame)
+ P f3 sp parent (Mop op args res :: c) rs fr m E0 c rs # res <- v fr m) ->
+ (forall (f4 : function) (sp : val) (parent : frame)
(chunk : memory_chunk) (addr : addressing) (args : list mreg)
(dst : mreg) (c : list instruction) (rs : mreg -> val) (fr : frame)
(m : mem) (a v : val),
eval_addressing ge sp addr rs ## args = Some a ->
loadv chunk m a = Some v ->
- P f sp parent (Mload chunk addr args dst :: c) rs fr m c
+ P f4 sp parent (Mload chunk addr args dst :: c) rs fr m E0 c
rs # dst <- v fr m) ->
- (forall (f : function) (sp : val) (parent : frame)
+ (forall (f5 : function) (sp : val) (parent : frame)
(chunk : memory_chunk) (addr : addressing) (args : list mreg)
(src : mreg) (c : list instruction) (rs : mreg -> val) (fr : frame)
(m m' : mem) (a : val),
eval_addressing ge sp addr rs ## args = Some a ->
storev chunk m a (rs src) = Some m' ->
- P f sp parent (Mstore chunk addr args src :: c) rs fr m c rs fr m') ->
- (forall (f : function) (sp : val) (parent : frame) (sig : signature)
+ P f5 sp parent (Mstore chunk addr args src :: c) rs fr m E0 c rs fr
+ m') ->
+ (forall (f6 : function) (sp : val) (parent : frame) (sig : signature)
(ros : mreg + ident) (c : list instruction) (rs : regset)
- (fr : frame) (m : mem) (f' : function) (rs' : regset) (m' : mem),
+ (fr : frame) (m : mem) (t : trace) (f' : fundef) (rs' : regset)
+ (m' : mem),
find_function ge ros rs = Some f' ->
- exec_function f' fr rs m rs' m' ->
- P2 f' fr rs m rs' m' ->
- P f sp parent (Mcall sig ros :: c) rs fr m c rs' fr m') ->
- (forall (f : function) (sp : val) (parent : frame) (lbl : label)
- (c : list instruction) (rs : regset) (fr : frame) (m : mem)
- (c' : code),
- find_label lbl (fn_code f) = Some c' ->
- P f sp parent (Mgoto lbl :: c) rs fr m c' rs fr m) ->
- (forall (f : function) (sp : val) (parent : frame)
- (cond : condition) (args : list mreg) (lbl : label)
+ exec_function f' fr rs m t rs' m' ->
+ P2 f' fr rs m t rs' m' ->
+ P f6 sp parent (Mcall sig ros :: c) rs fr m t c rs' fr m') ->
+ (forall (f7 : function) (sp : val) (parent : frame)
(c : list instruction) (rs : mreg -> val) (fr : frame) (m : mem)
+ (sz : int) (m' : mem) (blk : block),
+ rs Conventions.loc_alloc_argument = Vint sz ->
+ alloc m 0 (Int.signed sz) = (m', blk) ->
+ P f7 sp parent (Malloc :: c) rs fr m E0 c
+ rs # Conventions.loc_alloc_result <- (Vptr blk Int.zero) fr m') ->
+ (forall (f7 : function) (sp : val) (parent : frame) (lbl : label)
+ (c : list instruction) (rs : regset) (fr : frame) (m : mem)
(c' : code),
+ find_label lbl (fn_code f7) = Some c' ->
+ P f7 sp parent (Mgoto lbl :: c) rs fr m E0 c' rs fr m) ->
+ (forall (f8 : function) (sp : val) (parent : frame) (cond : condition)
+ (args : list mreg) (lbl : label) (c : list instruction)
+ (rs : mreg -> val) (fr : frame) (m : mem) (c' : code),
eval_condition cond rs ## args = Some true ->
- find_label lbl (fn_code f) = Some c' ->
- P f sp parent (Mcond cond args lbl :: c) rs fr m c' rs fr m) ->
- (forall (f : function) (sp : val) (parent : frame)
- (cond : condition) (args : list mreg) (lbl : label)
- (c : list instruction) (rs : mreg -> val) (fr : frame) (m : mem),
+ find_label lbl (fn_code f8) = Some c' ->
+ P f8 sp parent (Mcond cond args lbl :: c) rs fr m E0 c' rs fr m) ->
+ (forall (f9 : function) (sp : val) (parent : frame) (cond : condition)
+ (args : list mreg) (lbl : label) (c : list instruction)
+ (rs : mreg -> val) (fr : frame) (m : mem),
eval_condition cond rs ## args = Some false ->
- P f sp parent (Mcond cond args lbl :: c) rs fr m c rs fr m) ->
- (forall (f : function) (sp : val) (parent : frame) (c : code)
+ P f9 sp parent (Mcond cond args lbl :: c) rs fr m E0 c rs fr m) ->
+ (forall (f10 : function) (sp : val) (parent : frame) (c : code)
(rs : regset) (fr : frame) (m : mem),
- P0 f sp parent c rs fr m c rs fr m) ->
- (forall (f : function) (sp : val) (parent : frame) (c : code)
- (rs : regset) (fr : frame) (m : mem) (c' : code) (rs' : regset)
- (fr' : frame) (m' : mem),
- exec_instr f sp parent c rs fr m c' rs' fr' m' ->
- P f sp parent c rs fr m c' rs' fr' m' ->
- P0 f sp parent c rs fr m c' rs' fr' m') ->
- (forall (f : function) (sp : val) (parent : frame) (c1 : code)
- (rs1 : regset) (fr1 : frame) (m1 : mem) (c2 : code) (rs2 : regset)
- (fr2 : frame) (m2 : mem) (c3 : code) (rs3 : regset) (fr3 : frame)
- (m3 : mem),
- exec_instrs f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 ->
- P0 f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 ->
- exec_instrs f sp parent c2 rs2 fr2 m2 c3 rs3 fr3 m3 ->
- P0 f sp parent c2 rs2 fr2 m2 c3 rs3 fr3 m3 ->
- P0 f sp parent c1 rs1 fr1 m1 c3 rs3 fr3 m3) ->
- (forall (f : function) (parent : frame) (link ra : val) (rs : regset)
- (m : mem) (rs' : regset) (m1 m2 : mem) (stk : block)
- (fr1 fr2 fr3 : frame) (c : list instruction),
- alloc m 0 (fn_stacksize f) = (m1, stk) ->
- set_slot (init_frame f) Tint 0 link fr1 ->
+ P0 f10 sp parent c rs fr m E0 c rs fr m) ->
+ (forall (f11 : function) (sp : val) (parent : frame) (c : code)
+ (rs : regset) (fr : frame) (m : mem) (t : trace) (c' : code)
+ (rs' : regset) (fr' : frame) (m' : mem),
+ exec_instr f11 sp parent c rs fr m t c' rs' fr' m' ->
+ P f11 sp parent c rs fr m t c' rs' fr' m' ->
+ P0 f11 sp parent c rs fr m t c' rs' fr' m') ->
+ (forall (f12 : function) (sp : val) (parent : frame) (c1 : code)
+ (rs1 : regset) (fr1 : frame) (m1 : mem) (t1 : trace) (c2 : code)
+ (rs2 : regset) (fr2 : frame) (m2 : mem) (t2 : trace) (c3 : code)
+ (rs3 : regset) (fr3 : frame) (m3 : mem) (t3 : trace),
+ exec_instrs f12 sp parent c1 rs1 fr1 m1 t1 c2 rs2 fr2 m2 ->
+ P0 f12 sp parent c1 rs1 fr1 m1 t1 c2 rs2 fr2 m2 ->
+ exec_instrs f12 sp parent c2 rs2 fr2 m2 t2 c3 rs3 fr3 m3 ->
+ P0 f12 sp parent c2 rs2 fr2 m2 t2 c3 rs3 fr3 m3 ->
+ t3 = t1 ** t2 -> P0 f12 sp parent c1 rs1 fr1 m1 t3 c3 rs3 fr3 m3) ->
+ (forall (f13 : function) (parent : frame) (link ra : val)
+ (rs : regset) (m : mem) (t : trace) (rs' : regset) (m1 m2 : mem)
+ (stk : block) (fr1 fr2 fr3 : frame) (c : list instruction),
+ alloc m 0 (fn_stacksize f13) = (m1, stk) ->
+ set_slot (init_frame f13) Tint 0 link fr1 ->
set_slot fr1 Tint 4 ra fr2 ->
- exec_instrs f (Vptr stk (Int.repr (-f.(fn_framesize)))) parent (fn_code f) rs fr2 m1 (Mreturn :: c) rs' fr3
- m2 ->
- P0 f (Vptr stk (Int.repr (-f.(fn_framesize)))) parent (fn_code f) rs fr2 m1 (Mreturn :: c) rs' fr3 m2 ->
- P1 f parent link ra rs m rs' (free m2 stk)) ->
- (forall (f : function) (parent : frame) (rs : regset) (m : mem)
- (rs' : regset) (m' : mem),
+ exec_instrs f13 (Vptr stk (Int.repr (- fn_framesize f13))) parent
+ (fn_code f13) rs fr2 m1 t (Mreturn :: c) rs' fr3 m2 ->
+ P0 f13 (Vptr stk (Int.repr (- fn_framesize f13))) parent
+ (fn_code f13) rs fr2 m1 t (Mreturn :: c) rs' fr3 m2 ->
+ P1 f13 parent link ra rs m t rs' (free m2 stk)) ->
+ (forall (f14 : function) (parent : frame) (rs : regset) (m : mem)
+ (t : trace) (rs' : regset) (m' : mem),
(forall link ra : val,
Val.has_type link Tint ->
Val.has_type ra Tint ->
- exec_function_body f parent link ra rs m rs' m') ->
+ exec_function_body f14 parent link ra rs m t rs' m') ->
(forall link ra : val,
Val.has_type link Tint ->
- Val.has_type ra Tint -> P1 f parent link ra rs m rs' m') ->
- P2 f parent rs m rs' m') ->
- (forall (f15 : function) (sp : val) (f16 : frame) (c : code)
- (r : regset) (f17 : frame) (m : mem) (c0 : code) (r0 : regset)
- (f18 : frame) (m0 : mem),
- exec_instr f15 sp f16 c r f17 m c0 r0 f18 m0 ->
- P f15 sp f16 c r f17 m c0 r0 f18 m0)
- /\ (forall (f15 : function) (sp : val) (f16 : frame) (c : code)
- (r : regset) (f17 : frame) (m : mem) (c0 : code) (r0 : regset)
- (f18 : frame) (m0 : mem),
- exec_instrs f15 sp f16 c r f17 m c0 r0 f18 m0 ->
- P0 f15 sp f16 c r f17 m c0 r0 f18 m0)
- /\ (forall (f15 : function) (f16 : frame) (v1 v2 : val) (r : regset) (m : mem)
- (r0 : regset) (m0 : mem),
- exec_function_body f15 f16 v1 v2 r m r0 m0 -> P1 f15 f16 v1 v2 r m r0 m0)
- /\ (forall (f15 : function) (f16 : frame) (r : regset) (m : mem)
+ Val.has_type ra Tint -> P1 f14 parent link ra rs m t rs' m') ->
+ P2 (Internal f14) parent rs m t rs' m') ->
+ (forall (ef : external_function) (parent : frame) (args : list val)
+ (res : val) (rs1 : mreg -> val) (rs2 : RegEq.t -> val) (m : mem)
+ (t0 : trace),
+ event_match ef args t0 res ->
+ args = rs1 ## (Conventions.loc_external_arguments (ef_sig ef)) ->
+ rs2 = rs1 # (Conventions.loc_result (ef_sig ef)) <- res ->
+ P2 (External ef) parent rs1 m t0 rs2 m) ->
+ (forall (f16 : function) (v : val) (f17 : frame) (c : code)
+ (r : regset) (f18 : frame) (m : mem) (t : trace) (c0 : code)
+ (r0 : regset) (f19 : frame) (m0 : mem),
+ exec_instr f16 v f17 c r f18 m t c0 r0 f19 m0 ->
+ P f16 v f17 c r f18 m t c0 r0 f19 m0)
+ /\ (forall (f16 : function) (v : val) (f17 : frame) (c : code)
+ (r : regset) (f18 : frame) (m : mem) (t : trace) (c0 : code)
+ (r0 : regset) (f19 : frame) (m0 : mem),
+ exec_instrs f16 v f17 c r f18 m t c0 r0 f19 m0 ->
+ P0 f16 v f17 c r f18 m t c0 r0 f19 m0)
+ /\ (forall (f16 : function) (f17 : frame) (v v0 : val) (r : regset)
+ (m : mem) (t : trace) (r0 : regset) (m0 : mem),
+ exec_function_body f16 f17 v v0 r m t r0 m0 ->
+ P1 f16 f17 v v0 r m t r0 m0)
+ /\ (forall (f16 : fundef) (f17 : frame) (r : regset) (m : mem) (t : trace)
(r0 : regset) (m0 : mem),
- exec_function f15 f16 r m r0 m0 -> P2 f15 f16 r m r0 m0).
+ exec_function f16 f17 r m t r0 m0 -> P2 f16 f17 r m t r0 m0).
Proof.
intros. split. apply (exec_instr_ind4 P P0 P1 P2); assumption.
split. apply (exec_instrs_ind4 P P0 P1 P2); assumption.
@@ -359,13 +396,12 @@ Qed.
End RELSEM.
-Definition exec_program (p: program) (r: val) : Prop :=
+Definition exec_program (p: program) (t: trace) (r: val) : Prop :=
let ge := Genv.globalenv p in
let m0 := Genv.init_mem p in
exists b, exists f, exists rs, exists m,
Genv.find_symbol ge p.(prog_main) = Some b /\
Genv.find_funct_ptr ge b = Some f /\
- f.(fn_sig) = mksignature nil (Some Tint) /\
- exec_function ge f empty_frame (Regmap.init Vundef) m0 rs m /\
- rs (Conventions.loc_result f.(fn_sig)) = r.
+ exec_function ge f empty_frame (Regmap.init Vundef) m0 t rs m /\
+ rs R3 = r.
diff --git a/backend/Machabstr2mach.v b/backend/Machabstr2mach.v
index 8549cef..0513cbe 100644
--- a/backend/Machabstr2mach.v
+++ b/backend/Machabstr2mach.v
@@ -6,6 +6,7 @@ Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
@@ -757,6 +758,36 @@ Proof.
exists ms'. split. auto. eapply callstack_store_aux; eauto.
Qed.
+(** Allocations of heap blocks can be performed in parallel in
+ both semantics, preserving [callstack_invariant]. *)
+
+Lemma callstack_alloc:
+ forall cs mm ms lo hi mm' blk,
+ callstack_invariant cs mm ms ->
+ Mem.alloc mm lo hi = (mm', blk) ->
+ exists ms',
+ Mem.alloc ms lo hi = (ms', blk) /\
+ callstack_invariant cs mm' ms'.
+Proof.
+ intros. inversion H.
+ caseEq (alloc ms lo hi). intros ms' blk' ALLOC'.
+ injection H0; intros. injection ALLOC'; intros.
+ assert (blk' = blk). congruence. rewrite H5 in H3. rewrite H5.
+ exists ms'; split. auto.
+ constructor.
+ (* frame *)
+ intros; eapply frame_match_alloc; eauto.
+ (* linked *)
+ auto.
+ (* others *)
+ intros. rewrite <- H2; rewrite <- H4; simpl.
+ rewrite H1; rewrite H3. unfold update. case (zeq b blk); auto.
+ (* next *)
+ rewrite <- H2; rewrite <- H4; simpl; congruence.
+ (* dom *)
+ eapply callstack_dom_incr; eauto. rewrite <- H4; simpl. omega.
+Qed.
+
(** At function entry, a new frame is pushed on the call stack,
and memory blocks are allocated in both semantics. Moreover,
the back link to the caller's activation record is set up
@@ -905,7 +936,7 @@ Let ge := Genv.globalenv p.
Definition exec_instr_prop
(f: function) (sp: val) (parent: frame)
- (c: code) (rs: regset) (fr: frame) (mm: mem)
+ (c: code) (rs: regset) (fr: frame) (mm: mem) (t: trace)
(c': code) (rs': regset) (fr': frame) (mm': mem) : Prop :=
forall ms stk base pstk pbase cs
(WTF: wt_function f)
@@ -916,12 +947,12 @@ Definition exec_instr_prop
(CSI: callstack_invariant ((fr, stk, base) :: (parent, pstk, pbase) :: cs) mm ms)
(SP: sp = Vptr stk base),
exists ms',
- exec_instr ge f sp c rs ms c' rs' ms' /\
+ exec_instr ge f sp c rs ms t c' rs' ms' /\
callstack_invariant ((fr', stk, base) :: (parent, pstk, pbase) :: cs) mm' ms'.
Definition exec_instrs_prop
(f: function) (sp: val) (parent: frame)
- (c: code) (rs: regset) (fr: frame) (mm: mem)
+ (c: code) (rs: regset) (fr: frame) (mm: mem) (t: trace)
(c': code) (rs': regset) (fr': frame) (mm': mem) : Prop :=
forall ms stk base pstk pbase cs
(WTF: wt_function f)
@@ -932,12 +963,12 @@ Definition exec_instrs_prop
(CSI: callstack_invariant ((fr, stk, base) :: (parent, pstk, pbase) :: cs) mm ms)
(SP: sp = Vptr stk base),
exists ms',
- exec_instrs ge f sp c rs ms c' rs' ms' /\
+ exec_instrs ge f sp c rs ms t c' rs' ms' /\
callstack_invariant ((fr', stk, base) :: (parent, pstk, pbase) :: cs) mm' ms'.
Definition exec_function_body_prop
(f: function) (parent: frame) (link ra: val)
- (rs: regset) (mm: mem)
+ (rs: regset) (mm: mem) (t: trace)
(rs': regset) (mm': mem) : Prop :=
forall ms pstk pbase cs
(WTF: wt_function f)
@@ -947,26 +978,26 @@ Definition exec_function_body_prop
(LINK: link = Vptr pstk pbase)
(CSI: callstack_invariant ((parent, pstk, pbase) :: cs) mm ms),
exists ms',
- exec_function_body ge f (Vptr pstk pbase) ra rs ms rs' ms' /\
+ exec_function_body ge f (Vptr pstk pbase) ra rs ms t rs' ms' /\
callstack_invariant ((parent, pstk, pbase) :: cs) mm' ms'.
Definition exec_function_prop
- (f: function) (parent: frame)
- (rs: regset) (mm: mem)
+ (f: fundef) (parent: frame)
+ (rs: regset) (mm: mem) (t: trace)
(rs': regset) (mm': mem) : Prop :=
forall ms pstk pbase cs
- (WTF: wt_function f)
+ (WTF: wt_fundef f)
(WTRS: wt_regset rs)
(WTPA: wt_frame parent)
(CSI: callstack_invariant ((parent, pstk, pbase) :: cs) mm ms),
exists ms',
- exec_function ge f (Vptr pstk pbase) rs ms rs' ms' /\
+ exec_function ge f (Vptr pstk pbase) rs ms t rs' ms' /\
callstack_invariant ((parent, pstk, pbase) :: cs) mm' ms'.
Lemma exec_function_equiv:
- forall f parent rs mm rs' mm',
- Machabstr.exec_function ge f parent rs mm rs' mm' ->
- exec_function_prop f parent rs mm rs' mm'.
+ forall f parent rs mm t rs' mm',
+ Machabstr.exec_function ge f parent rs mm t rs' mm' ->
+ exec_function_prop f parent rs mm t rs' mm'.
Proof.
apply (Machabstr.exec_function_ind4 ge
exec_instr_prop
@@ -1009,16 +1040,22 @@ Proof.
auto.
(* Mcall *)
red in H1.
- assert (WTF': wt_function f').
+ assert (WTF': wt_fundef f').
destruct ros; simpl in H.
- apply (Genv.find_funct_prop wt_function wt_p H).
+ apply (Genv.find_funct_prop wt_fundef wt_p H).
destruct (Genv.find_symbol ge i); try discriminate.
- apply (Genv.find_funct_ptr_prop wt_function wt_p H).
+ apply (Genv.find_funct_ptr_prop wt_fundef wt_p H).
generalize (H1 _ _ _ _ WTF' WTRS WTFR CSI).
intros [ms' [EXF CSI']].
exists ms'. split. apply exec_Mcall with f'; auto.
rewrite SP. auto.
auto.
+ (* Malloc *)
+ generalize (callstack_alloc _ _ _ _ _ _ _ CSI H0).
+ intros [ms' [ALLOC' CSI']].
+ exists ms'; split.
+ eapply exec_Malloc; eauto.
+ auto.
(* Mgoto *)
exists ms. split. constructor; auto. auto.
(* Mcond *)
@@ -1033,7 +1070,7 @@ Proof.
exists ms'. split. apply exec_one; auto. auto.
(* trans *)
generalize (subject_reduction_instrs p wt_p
- _ _ _ _ _ _ _ _ _ _ _ H WTF INCL WTRS WTFR WTPA).
+ _ _ _ _ _ _ _ _ _ _ _ _ H WTF INCL WTRS WTFR WTPA).
intros [INCL2 [WTRS2 WTFR2]].
generalize (H0 _ _ _ _ _ _ WTF INCL WTRS WTFR WTPA CSI SP).
intros [ms1 [EX1 CSI1]].
@@ -1069,7 +1106,7 @@ Proof.
generalize (H3 _ _ _ _ _ _ WTF (incl_refl _) WTRS WTFR2 WTPA
CSI3 (refl_equal _)).
intros [ms4 [EXEC CSI4]].
- generalize (exec_instrs_link_invariant _ _ _ _ _ _ _ _ _ _ _ _
+ generalize (exec_instrs_link_invariant _ _ _ _ _ _ _ _ _ _ _ _ _
H2 WTF (incl_refl _)).
intros [INCL LINKINV].
exists (free ms4 stk). split.
@@ -1082,39 +1119,42 @@ Proof.
apply LINKINV. rewrite FOUR. omega. eapply slot_gss; eauto. auto.
eapply callstack_function_return; eauto.
- (* function *)
+ (* internal function *)
+ inversion WTF. subst f0.
generalize (H0 (Vptr pstk pbase) Vzero I I
- ms pstk pbase cs WTF WTRS WTPA I (refl_equal _) CSI).
+ ms pstk pbase cs H2 WTRS WTPA I (refl_equal _) CSI).
intros [ms' [EXEC CSI']].
exists ms'. split. constructor. intros.
generalize (H0 (Vptr pstk pbase) ra I H1
- ms pstk pbase cs WTF WTRS WTPA H1 (refl_equal _) CSI).
+ ms pstk pbase cs H2 WTRS WTPA H1 (refl_equal _) CSI).
intros [ms1 [EXEC1 CSI1]].
rewrite (callstack_exten _ _ _ _ CSI' CSI1). auto.
auto.
+
+ (* external function *)
+ exists ms; split. econstructor; eauto. auto.
Qed.
End SIMULATION.
Theorem exec_program_equiv:
- forall p r,
+ forall p t r,
wt_program p ->
- Machabstr.exec_program p r ->
- Mach.exec_program p r.
+ Machabstr.exec_program p t r ->
+ Mach.exec_program p t r.
Proof.
- intros p r WTP [fptr [f [rs [mm [FINDPTR [FINDF [SIG [EXEC RES]]]]]]]].
- assert (WTF: wt_function f).
- apply (Genv.find_funct_ptr_prop wt_function WTP FINDF).
+ intros p t r WTP [fptr [f [rs [mm [FINDPTR [FINDF [EXEC RES]]]]]]].
+ assert (WTF: wt_fundef f).
+ apply (Genv.find_funct_ptr_prop wt_fundef WTP FINDF).
assert (WTRS: wt_regset (Regmap.init Vundef)).
red; intros. rewrite Regmap.gi; simpl; auto.
assert (WTFR: wt_frame empty_frame).
red; intros. simpl. auto.
generalize (exec_function_equiv p WTP
f empty_frame
- (Regmap.init Vundef) (Genv.init_mem p) rs mm
+ (Regmap.init Vundef) (Genv.init_mem p) t rs mm
EXEC (Genv.init_mem p) nullptr Int.zero nil
WTF WTRS WTFR (callstack_init p)).
intros [ms' [EXEC' CSI]].
- red. exists fptr; exists f; exists rs; exists ms'.
- intuition. rewrite SIG in RES. exact RES.
+ red. exists fptr; exists f; exists rs; exists ms'. tauto.
Qed.
diff --git a/backend/Machtyping.v b/backend/Machtyping.v
index 987269b..92f283b 100644
--- a/backend/Machtyping.v
+++ b/backend/Machtyping.v
@@ -7,6 +7,7 @@ Require Import Mem.
Require Import Integers.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
@@ -57,6 +58,8 @@ Inductive wt_instr : instruction -> Prop :=
forall sig ros,
match ros with inl r => mreg_type r = Tint | inr s => True end ->
wt_instr (Mcall sig ros)
+ | wt_Malloc:
+ wt_instr Malloc
| wt_Mgoto:
forall lbl,
wt_instr (Mgoto lbl)
@@ -78,8 +81,16 @@ Record wt_function (f: function) : Prop := mk_wt_function {
f.(fn_framesize) <= -Int.min_signed
}.
+Inductive wt_fundef: fundef -> Prop :=
+ | wt_fundef_external: forall ef,
+ Conventions.sig_external_ok ef.(ef_sig) ->
+ wt_fundef (External ef)
+ | wt_function_internal: forall f,
+ wt_function f ->
+ wt_fundef (Internal f).
+
Definition wt_program (p: program) : Prop :=
- forall i f, In (i, f) (prog_funct p) -> wt_function f.
+ forall i f, In (i, f) (prog_funct p) -> wt_fundef f.
(** * Type soundness *)
@@ -89,8 +100,8 @@ Require Import Machabstr.
of Mach: for a well-typed Mach program, if a transition is taken
from a state where registers hold values of their static types,
registers in the final state hold values of their static types
- as well. This is a progress theorem for our type system.
- It is used in the proof of implcation from the abstract Mach
+ as well. This is a subject reduction theorem for our type system.
+ It is used in the proof of implication from the abstract Mach
semantics to the concrete Mach semantics (file [Machabstr2mach]).
*)
@@ -183,6 +194,14 @@ Proof.
apply incl_tl; auto.
Qed.
+Lemma wt_event_match:
+ forall ef args t res,
+ event_match ef args t res ->
+ Val.has_type res (proj_sig_res ef.(ef_sig)).
+Proof.
+ induction 1. inversion H0; exact I.
+Qed.
+
Section SUBJECT_REDUCTION.
Variable p: program.
@@ -191,7 +210,7 @@ Let ge := Genv.globalenv p.
Definition exec_instr_prop
(f: function) (sp: val) (parent: frame)
- (c1: code) (rs1: regset) (fr1: frame) (m1: mem)
+ (c1: code) (rs1: regset) (fr1: frame) (m1: mem) (t: trace)
(c2: code) (rs2: regset) (fr2: frame) (m2: mem) :=
forall (WTF: wt_function f)
(INCL: incl c1 f.(fn_code))
@@ -201,7 +220,7 @@ Definition exec_instr_prop
incl c2 f.(fn_code) /\ wt_regset rs2 /\ wt_frame fr2.
Definition exec_function_body_prop
(f: function) (parent: frame) (link ra: val)
- (rs1: regset) (m1: mem) (rs2: regset) (m2: mem) :=
+ (rs1: regset) (m1: mem) (t: trace) (rs2: regset) (m2: mem) :=
forall (WTF: wt_function f)
(WTRS: wt_regset rs1)
(WTPA: wt_frame parent)
@@ -209,26 +228,26 @@ Definition exec_function_body_prop
(WTRA: Val.has_type ra Tint),
wt_regset rs2.
Definition exec_function_prop
- (f: function) (parent: frame)
- (rs1: regset) (m1: mem) (rs2: regset) (m2: mem) :=
- forall (WTF: wt_function f)
+ (f: fundef) (parent: frame)
+ (rs1: regset) (m1: mem) (t: trace) (rs2: regset) (m2: mem) :=
+ forall (WTF: wt_fundef f)
(WTRS: wt_regset rs1)
(WTPA: wt_frame parent),
wt_regset rs2.
Lemma subject_reduction:
- (forall f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2,
- exec_instr ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 ->
- exec_instr_prop f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2)
-/\ (forall f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2,
- exec_instrs ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 ->
- exec_instr_prop f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2)
-/\ (forall f parent link ra rs1 m1 rs2 m2,
- exec_function_body ge f parent link ra rs1 m1 rs2 m2 ->
- exec_function_body_prop f parent link ra rs1 m1 rs2 m2)
-/\ (forall f parent rs1 m1 rs2 m2,
- exec_function ge f parent rs1 m1 rs2 m2 ->
- exec_function_prop f parent rs1 m1 rs2 m2).
+ (forall f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2,
+ exec_instr ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 ->
+ exec_instr_prop f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2)
+/\ (forall f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2,
+ exec_instrs ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 ->
+ exec_instr_prop f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2)
+/\ (forall f parent link ra rs1 m1 t rs2 m2,
+ exec_function_body ge f parent link ra rs1 m1 t rs2 m2 ->
+ exec_function_body_prop f parent link ra rs1 m1 t rs2 m2)
+/\ (forall f parent rs1 m1 t rs2 m2,
+ exec_function ge f parent rs1 m1 t rs2 m2 ->
+ exec_function_prop f parent rs1 m1 t rs2 m2).
Proof.
apply exec_mutual_induction; red; intros;
try (generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))); intro;
@@ -249,7 +268,7 @@ Proof.
subst args; subst op. simpl in H.
replace v with Vundef. simpl; auto. congruence.
replace (mreg_type res) with (snd (type_of_operation op)).
- apply type_of_operation_sound with function ge rs##args sp; auto.
+ apply type_of_operation_sound with fundef ge rs##args sp; auto.
rewrite <- H6; reflexivity.
apply wt_setreg; auto. inversion H1. rewrite H7.
@@ -257,11 +276,13 @@ Proof.
apply H1; auto.
destruct ros; simpl in H.
- apply (Genv.find_funct_prop wt_function wt_p H).
+ apply (Genv.find_funct_prop wt_fundef wt_p H).
destruct (Genv.find_symbol ge i).
- apply (Genv.find_funct_ptr_prop wt_function wt_p H).
+ apply (Genv.find_funct_ptr_prop wt_fundef wt_p H).
discriminate.
+ apply wt_setreg; auto. exact I.
+
apply incl_find_label with lbl; auto.
apply incl_find_label with lbl; auto.
@@ -277,26 +298,34 @@ Proof.
generalize (H3 WTF (incl_refl _) WTRS WTFR2 WTPA).
tauto.
- apply (H0 Vzero Vzero). exact I. exact I. auto. auto. auto.
+ apply (H0 Vzero Vzero). exact I. exact I.
+ inversion WTF; auto. auto. auto.
exact I. exact I.
+
+ rewrite H1. apply wt_setreg; auto.
+ generalize (wt_event_match _ _ _ _ H).
+ unfold proj_sig_res, Conventions.loc_result.
+ destruct (sig_res (ef_sig ef)).
+ destruct t; simpl; auto.
+ simpl; auto.
Qed.
Lemma subject_reduction_instr:
- forall f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2,
- exec_instr ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 ->
- exec_instr_prop f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2.
+ forall f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2,
+ exec_instr ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 ->
+ exec_instr_prop f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2.
Proof (proj1 subject_reduction).
Lemma subject_reduction_instrs:
- forall f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2,
- exec_instrs ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 ->
- exec_instr_prop f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2.
+ forall f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2,
+ exec_instrs ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 ->
+ exec_instr_prop f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2.
Proof (proj1 (proj2 subject_reduction)).
Lemma subject_reduction_function:
- forall f parent rs1 m1 rs2 m2,
- exec_function ge f parent rs1 m1 rs2 m2 ->
- exec_function_prop f parent rs1 m1 rs2 m2.
+ forall f parent rs1 m1 t rs2 m2,
+ exec_function ge f parent rs1 m1 t rs2 m2 ->
+ exec_function_prop f parent rs1 m1 t rs2 m2.
Proof (proj2 (proj2 (proj2 subject_reduction))).
End SUBJECT_REDUCTION.
@@ -335,8 +364,8 @@ Proof.
Qed.
Lemma exec_instr_link_invariant:
- forall ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2,
- exec_instr ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 ->
+ forall ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2,
+ exec_instr ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 ->
wt_function f ->
incl c1 f.(fn_code) ->
incl c2 f.(fn_code) /\ link_invariant fr1 fr2.
@@ -351,8 +380,8 @@ Proof.
Qed.
Lemma exec_instrs_link_invariant:
- forall ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2,
- exec_instrs ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 ->
+ forall ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2,
+ exec_instrs ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 ->
wt_function f ->
incl c1 f.(fn_code) ->
incl c2 f.(fn_code) /\ link_invariant fr1 fr2.
@@ -360,8 +389,8 @@ Proof.
induction 1; intros.
split. auto. apply link_invariant_refl.
eapply exec_instr_link_invariant; eauto.
- generalize (IHexec_instrs1 H1 H2); intros [A B].
- generalize (IHexec_instrs2 H1 A); intros [C D].
+ generalize (IHexec_instrs1 H2 H3); intros [A B].
+ generalize (IHexec_instrs2 H2 A); intros [C D].
split. auto. red; auto.
Qed.
diff --git a/backend/Main.v b/backend/Main.v
index 80a0577..95dc4e6 100644
--- a/backend/Main.v
+++ b/backend/Main.v
@@ -78,34 +78,34 @@ Notation "a @@ b" :=
The translation of a Cminor function to a PPC function is as follows. *)
-Definition transf_cminor_function (f: Cminor.function) : option PPC.code :=
+Definition transf_cminor_fundef (f: Cminor.fundef) : option PPC.fundef :=
Some f
- @@@ RTLgen.transl_function
- @@ Constprop.transf_function
- @@ CSE.transf_function
- @@@ Allocation.transf_function
- @@ Tunneling.tunnel_function
- @@ Linearize.transf_function
- @@@ Stacking.transf_function
- @@@ PPCgen.transf_function.
+ @@@ RTLgen.transl_fundef
+ @@ Constprop.transf_fundef
+ @@ CSE.transf_fundef
+ @@@ Allocation.transf_fundef
+ @@ Tunneling.tunnel_fundef
+ @@ Linearize.transf_fundef
+ @@@ Stacking.transf_fundef
+ @@@ PPCgen.transf_fundef.
(** And here is the translation for Csharpminor functions. *)
-Definition transf_csharpminor_function
- (gce: Cminorgen.compilenv) (f: Csharpminor.function) : option PPC.code :=
+Definition transf_csharpminor_fundef
+ (gce: Cminorgen.compilenv) (f: Csharpminor.fundef) : option PPC.fundef :=
Some f
- @@@ Cminorgen.transl_function gce
- @@@ transf_cminor_function.
+ @@@ Cminorgen.transl_fundef gce
+ @@@ transf_cminor_fundef.
(** The corresponding translations for whole program follow. *)
Definition transf_cminor_program (p: Cminor.program) : option PPC.program :=
- transform_partial_program transf_cminor_function p.
+ transform_partial_program transf_cminor_fundef p.
Definition transf_csharpminor_program (p: Csharpminor.program) : option PPC.program :=
let gce := Cminorgen.build_global_compilenv p in
transform_partial_program
- (transf_csharpminor_function gce)
+ (transf_csharpminor_fundef gce)
(Csharpminor.program_of_program p).
(** * Equivalence with whole program transformations *)
@@ -194,7 +194,7 @@ Qed.
Lemma transf_cminor_program_equiv:
forall p, transf_cminor_program2 p = transf_cminor_program p.
Proof.
- intro. unfold transf_cminor_program, transf_cminor_program2, transf_cminor_function.
+ intro. unfold transf_cminor_program, transf_cminor_program2, transf_cminor_fundef.
simpl.
unfold RTLgen.transl_program,
Constprop.transf_program, RTL.program.
@@ -223,7 +223,7 @@ Lemma transf_csharpminor_program_equiv:
forall p, transf_csharpminor_program2 p = transf_csharpminor_program p.
Proof.
intros.
- unfold transf_csharpminor_program2, transf_csharpminor_program, transf_csharpminor_function.
+ unfold transf_csharpminor_program2, transf_csharpminor_program, transf_csharpminor_fundef.
simpl.
replace transf_cminor_program2 with transf_cminor_program.
unfold transf_cminor_program, Cminorgen.transl_program, Cminor.program, PPC.program.
@@ -237,10 +237,10 @@ Qed.
composes the semantic preservation results for each pass. *)
Lemma transf_cminor_program2_correct:
- forall p tp n,
+ forall p tp t n,
transf_cminor_program2 p = Some tp ->
- Cminor.exec_program p (Vint n) ->
- PPC.exec_program tp (Vint n).
+ Cminor.exec_program p t (Vint n) ->
+ PPC.exec_program tp t (Vint n).
Proof.
intros until n.
unfold transf_cminor_program2.
@@ -274,10 +274,10 @@ Proof.
Qed.
Lemma transf_csharpminor_program2_correct:
- forall p tp n,
+ forall p tp t n,
transf_csharpminor_program2 p = Some tp ->
- Csharpminor.exec_program p (Vint n) ->
- PPC.exec_program tp (Vint n).
+ Csharpminor.exec_program p t (Vint n) ->
+ PPC.exec_program tp t (Vint n).
Proof.
intros until n; unfold transf_csharpminor_program2; simpl.
caseEq (Cminorgen.transl_program p).
@@ -291,20 +291,20 @@ Qed.
(** It follows that the whole compiler is semantic-preserving. *)
Theorem transf_cminor_program_correct:
- forall p tp n,
+ forall p tp t n,
transf_cminor_program p = Some tp ->
- Cminor.exec_program p (Vint n) ->
- PPC.exec_program tp (Vint n).
+ Cminor.exec_program p t (Vint n) ->
+ PPC.exec_program tp t (Vint n).
Proof.
intros. apply transf_cminor_program2_correct with p.
rewrite transf_cminor_program_equiv. assumption. assumption.
Qed.
Theorem transf_csharpminor_program_correct:
- forall p tp n,
+ forall p tp t n,
transf_csharpminor_program p = Some tp ->
- Csharpminor.exec_program p (Vint n) ->
- PPC.exec_program tp (Vint n).
+ Csharpminor.exec_program p t (Vint n) ->
+ PPC.exec_program tp t (Vint n).
Proof.
intros. apply transf_csharpminor_program2_correct with p.
rewrite transf_csharpminor_program_equiv. assumption. assumption.
diff --git a/backend/Mem.v b/backend/Mem.v
index 26d4c49..7af696e 100644
--- a/backend/Mem.v
+++ b/backend/Mem.v
@@ -619,6 +619,88 @@ Qed.
Hint Resolve store_in_bounds store_inv.
+(** Build a block filled with the given initialization data. *)
+
+Fixpoint contents_init_data (pos: Z) (id: list init_data) {struct id}: contentmap :=
+ match id with
+ | nil => (fun y => Undef)
+ | Init_int8 n :: id' =>
+ store_contents Size8 (contents_init_data (pos + 1) id') pos (Vint n)
+ | Init_int16 n :: id' =>
+ store_contents Size16 (contents_init_data (pos + 2) id') pos (Vint n)
+ | Init_int32 n :: id' =>
+ store_contents Size32 (contents_init_data (pos + 4) id') pos (Vint n)
+ | Init_float32 f :: id' =>
+ store_contents Size32 (contents_init_data (pos + 4) id') pos (Vfloat f)
+ | Init_float64 f :: id' =>
+ store_contents Size64 (contents_init_data (pos + 8) id') pos (Vfloat f)
+ | Init_space n :: id' =>
+ contents_init_data (pos + Zmax n 0) id'
+ end.
+
+Definition size_init_data (id: init_data) : Z :=
+ match id with
+ | Init_int8 _ => 1
+ | Init_int16 _ => 2
+ | Init_int32 _ => 4
+ | Init_float32 _ => 4
+ | Init_float64 _ => 8
+ | Init_space n => Zmax n 0
+ end.
+
+Definition size_init_data_list (id: list init_data): Z :=
+ List.fold_right (fun id sz => size_init_data id + sz) 0 id.
+
+Remark size_init_data_list_pos:
+ forall id, size_init_data_list id >= 0.
+Proof.
+ induction id; simpl.
+ omega.
+ assert (size_init_data a >= 0). destruct a; simpl; try omega.
+ generalize (Zmax2 z 0). omega. omega.
+Qed.
+
+Remark contents_init_data_undef_outside:
+ forall id pos x,
+ x < pos \/ x >= pos + size_init_data_list id ->
+ contents_init_data pos id x = Undef.
+Proof.
+ induction id; simpl; intros.
+ auto.
+ generalize (size_init_data_list_pos id); intro.
+ assert (forall n delta dt,
+ delta = 1 + Z_of_nat n ->
+ x < pos \/ x >= pos + (delta + size_init_data_list id) ->
+ setN n pos dt (contents_init_data (pos + delta) id) x = Undef).
+ intros. unfold setN. rewrite update_o.
+ transitivity (contents_init_data (pos + delta) id x).
+ apply set_cont_outside. omega.
+ apply IHid. omega. omega.
+ unfold size_init_data in H; destruct a;
+ try (apply H1; [reflexivity|assumption]).
+ apply IHid. generalize (Zmax2 z 0). omega.
+Qed.
+
+Definition block_init_data (id: list init_data) : block_contents :=
+ mkblock 0 (size_init_data_list id)
+ (contents_init_data 0 id)
+ (contents_init_data_undef_outside id 0).
+
+Definition alloc_init_data (m: mem) (id: list init_data) : mem * block :=
+ (mkmem (update m.(nextblock)
+ (block_init_data id)
+ m.(blocks))
+ (Zsucc m.(nextblock))
+ (succ_nextblock_pos m),
+ m.(nextblock)).
+
+Remark block_init_data_empty:
+ block_init_data nil = empty_block 0 0.
+Proof.
+ unfold block_init_data, empty_block. simpl.
+ decEq. apply proof_irrelevance.
+Qed.
+
(** * Properties of the memory operations *)
(** ** Properties related to block validity *)
@@ -2032,6 +2114,32 @@ Proof.
apply free_first_list_inject. auto.
Qed.
+Lemma contents_init_data_inject:
+ forall id, contentmap_inject (contents_init_data 0 id) (contents_init_data 0 id) 0 (size_init_data_list id) 0.
+Proof.
+ intro id0.
+ set (sz0 := size_init_data_list id0).
+ assert (forall id pos,
+ 0 <= pos -> pos + size_init_data_list id <= sz0 ->
+ contentmap_inject (contents_init_data pos id) (contents_init_data pos id) 0 sz0 0).
+ induction id; simpl; intros.
+ red; intros; constructor.
+ assert (forall n dt,
+ size_init_data a = 1 + Z_of_nat n ->
+ content_inject dt dt ->
+ contentmap_inject (setN n pos dt (contents_init_data (pos + size_init_data a) id))
+ (setN n pos dt (contents_init_data (pos + size_init_data a) id))
+ 0 sz0 0).
+ intros. set (pos' := pos) in |- * at 3. replace pos' with (pos + 0).
+ apply setN_inject. apply IHid. omega. omega. auto. auto.
+ generalize (size_init_data_list_pos id). omega. unfold pos'; omega.
+ destruct a;
+ try (apply H1; [reflexivity|repeat constructor]).
+ apply IHid. generalize (Zmax2 z 0). omega. simpl in H0; omega.
+
+ apply H. omega. unfold sz0. omega.
+Qed.
+
End MEM_INJECT.
Hint Resolve val_inject_int val_inject_float val_inject_ptr val_inject_undef.
@@ -2251,3 +2359,27 @@ Proof.
right. intros. omega. left. auto.
apply mi_no_overlap0; auto.
Qed.
+
+Lemma alloc_parallel_inject:
+ forall f m1 m2 lo hi m1' m2' b1 b2,
+ mem_inject f m1 m2 ->
+ alloc m1 lo hi = (m1', b1) ->
+ alloc m2 lo hi = (m2', b2) ->
+ Int.min_signed <= lo -> hi <= Int.max_signed ->
+ mem_inject (extend_inject b1 (Some(b2,0)) f) m1' m2' /\
+ inject_incr f (extend_inject b1 (Some(b2,0)) f).
+Proof.
+ intros.
+ generalize (low_bound_alloc _ _ b2 _ _ _ H1). rewrite zeq_true; intro LOW.
+ generalize (high_bound_alloc _ _ b2 _ _ _ H1). rewrite zeq_true; intro HIGH.
+ eapply alloc_mapped_inject; eauto.
+ eapply alloc_right_inject; eauto.
+ eapply valid_new_block; eauto.
+ compute. intuition congruence.
+ rewrite LOW; auto.
+ rewrite HIGH; auto.
+ rewrite LOW; omega.
+ rewrite HIGH; omega.
+ intros. elim (mi_mappedblocks _ _ _ H _ _ _ H4); intros.
+ injection H1; intros. rewrite H7 in H5. omegaContradiction.
+Qed.
diff --git a/backend/Op.v b/backend/Op.v
index e0dcfa4..efd0d9c 100644
--- a/backend/Op.v
+++ b/backend/Op.v
@@ -46,7 +46,9 @@ Inductive operation : Set :=
| Oundef: operation (**r set [rd] to undefined value *)
(*c Integer arithmetic: *)
| Ocast8signed: operation (**r [rd] is 8-bit sign extension of [r1] *)
+ | Ocast8unsigned: operation (**r [rd] is 8-bit zero extension of [r1] *)
| Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *)
+ | Ocast16unsigned: operation (**r [rd] is 16-bit zero extension of [r1] *)
| Oadd: operation (**r [rd = r1 + r2] *)
| Oaddimm: int -> operation (**r [rd = r1 + n] *)
| Osub: operation (**r [rd = r1 - r2] *)
@@ -166,8 +168,10 @@ Definition eval_operation
end
| Oaddrstack ofs, nil => offset_sp sp ofs
| Oundef, nil => Some Vundef
- | Ocast8signed, Vint n1 :: nil => Some (Vint (Int.cast8signed n1))
- | Ocast16signed, Vint n1 :: nil => Some (Vint (Int.cast16signed n1))
+ | Ocast8signed, v1 :: nil => Some (Val.cast8signed v1)
+ | Ocast8unsigned, v1 :: nil => Some (Val.cast8unsigned v1)
+ | Ocast16signed, v1 :: nil => Some (Val.cast16signed v1)
+ | Ocast16unsigned, v1 :: nil => Some (Val.cast16unsigned v1)
| Oadd, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.add n1 n2))
| Oadd, Vint n1 :: Vptr b2 n2 :: nil => Some (Vptr b2 (Int.add n2 n1))
| Oadd, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.add n1 n2))
@@ -215,8 +219,8 @@ Definition eval_operation
Some (Vfloat (Float.add (Float.mul f1 f2) f3))
| Omulsubf, Vfloat f1 :: Vfloat f2 :: Vfloat f3 :: nil =>
Some (Vfloat (Float.sub (Float.mul f1 f2) f3))
- | Osingleoffloat, Vfloat f1 :: nil =>
- Some (Vfloat (Float.singleoffloat f1))
+ | Osingleoffloat, v1 :: nil =>
+ Some (Val.singleoffloat v1)
| Ointoffloat, Vfloat f1 :: nil =>
Some (Vint (Float.intoffloat f1))
| Ofloatofint, Vint n1 :: nil =>
@@ -396,7 +400,9 @@ Definition type_of_operation (op: operation) : list typ * typ :=
| Oaddrstack _ => (nil, Tint)
| Oundef => (nil, Tint) (* treated specially *)
| Ocast8signed => (Tint :: nil, Tint)
+ | Ocast8unsigned => (Tint :: nil, Tint)
| Ocast16signed => (Tint :: nil, Tint)
+ | Ocast16unsigned => (Tint :: nil, Tint)
| Oadd => (Tint :: Tint :: nil, Tint)
| Oaddimm _ => (Tint :: nil, Tint)
| Osub => (Tint :: Tint :: nil, Tint)
@@ -476,6 +482,10 @@ Proof.
destruct (Genv.find_symbol genv i); simplify_eq H1; intro; subst v; exact I.
simpl. unfold offset_sp in H1. destruct sp; try discriminate.
inversion H1. exact I.
+ destruct v0; exact I.
+ destruct v0; exact I.
+ destruct v0; exact I.
+ destruct v0; exact I.
destruct (eq_block b b0). injection H1; intro; subst v; exact I.
discriminate.
destruct (Int.eq i0 Int.zero). discriminate.
@@ -492,6 +502,7 @@ Proof.
injection H1; intro; subst v; exact I. discriminate.
destruct (Int.ltu i0 (Int.repr 32)).
injection H1; intro; subst v; exact I. discriminate.
+ destruct v0; exact I.
destruct (eval_condition c vl).
destruct b; injection H1; intro; subst v; exact I.
discriminate.
@@ -550,7 +561,9 @@ Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val :
| Oaddrstack ofs, nil => Val.add sp (Vint ofs)
| Oundef, nil => Vundef
| Ocast8signed, v1::nil => Val.cast8signed v1
+ | Ocast8unsigned, v1::nil => Val.cast8unsigned v1
| Ocast16signed, v1::nil => Val.cast16signed v1
+ | Ocast16unsigned, v1::nil => Val.cast16unsigned v1
| Oadd, v1::v2::nil => Val.add v1 v2
| Oaddimm n, v1::nil => Val.add v1 (Vint n)
| Osub, v1::v2::nil => Val.sub v1 v2
diff --git a/backend/PPC.v b/backend/PPC.v
index 64bd90a..37f882b 100644
--- a/backend/PPC.v
+++ b/backend/PPC.v
@@ -7,6 +7,7 @@ Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
(** * Abstract syntax *)
@@ -85,6 +86,7 @@ Inductive instruction : Set :=
| Paddi: ireg -> ireg -> constant -> instruction (**r add immediate *)
| Paddis: ireg -> ireg -> constant -> instruction (**r add immediate high *)
| Paddze: ireg -> ireg -> instruction (**r add Carry bit *)
+ | Pallocblock: instruction (**r allocate new heap block *)
| Pallocframe: Z -> Z -> instruction (**r allocate new stack frame *)
| Pand_: ireg -> ireg -> ireg -> instruction (**r bitwise and *)
| Pandc: ireg -> ireg -> ireg -> instruction (**r bitwise and-complement *)
@@ -260,6 +262,12 @@ lbl: .long 0x43300000, 0x00000000
Again, our memory model cannot comprehend that this operation
frees (logically) the current stack frame.
+- [Pallocheap]: in the formal semantics, this pseudo-instruction
+ allocates a heap block of size the contents of [GPR3], and leaves
+ a pointer to this block in [GPR3]. In the generated assembly code,
+ it is turned into a call to the allocation function of the run-time
+ system.
+
- [Piundef] and [Pfundef]: set an integer or float register (respectively)
to the [Vundef] value. Expand to nothing, as the PowerPC processor has
no notion of ``undefined value''. These two pseudo-instructions are used
@@ -277,7 +285,8 @@ lbl: .long 0x43300000, 0x00000000
*)
Definition code := list instruction.
-Definition program := AST.program code.
+Definition fundef := AST.fundef code.
+Definition program := AST.program fundef.
(** * Operational semantics *)
@@ -317,7 +326,7 @@ Module Pregmap := EMap(PregEq).
[Vzero] or [Vone]. *)
Definition regset := Pregmap.t val.
-Definition genv := Genv.t code.
+Definition genv := Genv.t fundef.
Notation "a # b" := (a b) (at level 1, only parsing).
Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level).
@@ -540,6 +549,14 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_high cst)))) m
| Paddze rd r1 =>
OK (nextinstr (rs#rd <- (Val.add rs#r1 rs#CARRY))) m
+ | Pallocblock =>
+ match rs#GPR3 with
+ | Vint n =>
+ let (m', b) := Mem.alloc m 0 (Int.signed n) in
+ OK (nextinstr (rs#GPR3 <- (Vptr b Int.zero)
+ #LR <- (Val.add rs#PC Vone))) m'
+ | _ => Error
+ end
| Pallocframe lo hi =>
let (m1, stk) := Mem.alloc m lo hi in
let sp := Vptr stk (Int.repr lo) in
@@ -735,36 +752,84 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
OK (nextinstr rs) m
end.
+(** Calling conventions for external functions. These are compatible with
+ the calling conventions in module [Conventions], except that
+ we use PPC registers instead of locations. *)
+
+Fixpoint loc_external_arguments_rec
+ (tyl: list typ) (iregl: list ireg) (fregl: list freg)
+ {struct tyl} : list preg :=
+ match tyl with
+ | nil => nil
+ | Tint :: tys =>
+ match iregl with
+ | nil => IR GPR11 (* should not happen *)
+ | ireg :: _ => IR ireg
+ end ::
+ loc_external_arguments_rec tys (list_drop1 iregl) fregl
+ | Tfloat :: tys =>
+ match fregl with
+ | nil => IR GPR11 (* should not happen *)
+ | freg :: _ => FR freg
+ end ::
+ loc_external_arguments_rec tys (list_drop2 iregl) (list_drop1 fregl)
+ end.
+
+Definition int_param_regs :=
+ GPR3 :: GPR4 :: GPR5 :: GPR6 :: GPR7 :: GPR8 :: GPR9 :: GPR10 :: nil.
+Definition float_param_regs :=
+ FPR1 :: FPR2 :: FPR3 :: FPR4 :: FPR5 :: FPR6 :: FPR7 :: FPR8 :: FPR9 :: FPR10 :: nil.
+
+Definition loc_external_arguments (s: signature) : list preg :=
+ loc_external_arguments_rec s.(sig_args) int_param_regs float_param_regs.
+
+Definition loc_external_result (s: signature) : preg :=
+ match s.(sig_res) with
+ | None => GPR3
+ | Some Tint => GPR3
+ | Some Tfloat => FPR1
+ end.
+
(** Execution of the instruction at [rs#PC]. *)
-Inductive exec_step: regset -> mem -> regset -> mem -> Prop :=
- | exec_step_intro:
+Inductive exec_step: regset -> mem -> trace -> regset -> mem -> Prop :=
+ | exec_step_internal:
forall b ofs c i rs m rs' m',
rs PC = Vptr b ofs ->
- Genv.find_funct_ptr ge b = Some c ->
+ Genv.find_funct_ptr ge b = Some (Internal c) ->
find_instr (Int.unsigned ofs) c = Some i ->
exec_instr c i rs m = OK rs' m' ->
- exec_step rs m rs' m'.
+ exec_step rs m E0 rs' m'
+ | exec_step_external:
+ forall b ef args res rs m t rs',
+ rs PC = Vptr b Int.zero ->
+ Genv.find_funct_ptr ge b = Some (External ef) ->
+ event_match ef args t res ->
+ args = List.map (fun r => rs#r) (loc_external_arguments ef.(ef_sig)) ->
+ rs' = (rs#(loc_external_result ef.(ef_sig)) <- res
+ #PC <- (rs LR)) ->
+ exec_step rs m t rs' m.
(** Execution of zero, one or several instructions starting at [rs#PC]. *)
-Inductive exec_steps: regset -> mem -> regset -> mem -> Prop :=
+Inductive exec_steps: regset -> mem -> trace -> regset -> mem -> Prop :=
| exec_refl:
forall rs m,
- exec_steps rs m rs m
+ exec_steps rs m E0 rs m
| exec_one:
- forall rs m rs' m',
- exec_step rs m rs' m' ->
- exec_steps rs m rs' m'
+ forall rs m t rs' m',
+ exec_step rs m t rs' m' ->
+ exec_steps rs m t rs' m'
| exec_trans:
- forall rs1 m1 rs2 m2 rs3 m3,
- exec_steps rs1 m1 rs2 m2 ->
- exec_steps rs2 m2 rs3 m3 ->
- exec_steps rs1 m1 rs3 m3.
+ forall rs1 m1 t1 rs2 m2 t2 rs3 m3 t3,
+ exec_steps rs1 m1 t1 rs2 m2 ->
+ exec_steps rs2 m2 t2 rs3 m3 ->
+ t3 = t1 ** t2 ->
+ exec_steps rs1 m1 t3 rs3 m3.
End RELSEM.
-Definition exec_program (p: program) (r: val) : Prop :=
+Definition exec_program (p: program) (t: trace) (r: val) : Prop :=
let ge := Genv.globalenv p in
let m0 := Genv.init_mem p in
let rs0 :=
@@ -772,4 +837,4 @@ Definition exec_program (p: program) (r: val) : Prop :=
# LR <- Vzero
# GPR1 <- (Vptr Mem.nullptr Int.zero) in
exists rs, exists m,
- exec_steps ge rs0 m0 rs m /\ rs#PC = Vzero /\ rs#GPR3 = r.
+ exec_steps ge rs0 m0 t rs m /\ rs#PC = Vzero /\ rs#GPR3 = r.
diff --git a/backend/PPCgen.v b/backend/PPCgen.v
index dc8ed40..6cf0699 100644
--- a/backend/PPCgen.v
+++ b/backend/PPCgen.v
@@ -275,8 +275,12 @@ Definition transl_op
end
| Ocast8signed, a1 :: nil =>
Pextsb (ireg_of r) (ireg_of a1) :: k
+ | Ocast8unsigned, a1 :: nil =>
+ Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 255) :: k
| Ocast16signed, a1 :: nil =>
Pextsh (ireg_of r) (ireg_of a1) :: k
+ | Ocast16unsigned, a1 :: nil =>
+ Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 65535) :: k
| Oadd, a1 :: a2 :: nil =>
Padd (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
| Oaddimm n, a1 :: nil =>
@@ -470,6 +474,8 @@ Definition transl_instr (i: Mach.instruction) (k: code) :=
Pmtctr (ireg_of r) :: Pbctrl :: k
| Mcall sig (inr symb) =>
Pbl symb :: k
+ | Malloc =>
+ Pallocblock :: k
| Mlabel lbl =>
Plabel lbl :: k
| Mgoto lbl =>
@@ -504,11 +510,14 @@ Fixpoint code_size (c: code) : Z :=
| instr :: c' => code_size c' + 1
end.
-Definition transf_function (f: Mach.function) :=
+Definition transf_function (f: Mach.function) : option PPC.code :=
let c := transl_function f in
if zlt Int.max_unsigned (code_size c)
then None
else Some c.
+Definition transf_fundef (f: Mach.fundef) : option PPC.fundef :=
+ transf_partial_fundef transf_function f.
+
Definition transf_program (p: Mach.program) : option PPC.program :=
- transform_partial_program transf_function p.
+ transform_partial_program transf_fundef p.
diff --git a/backend/PPCgenproof.v b/backend/PPCgenproof.v
index 99aa4c8..3264999 100644
--- a/backend/PPCgenproof.v
+++ b/backend/PPCgenproof.v
@@ -7,6 +7,7 @@ Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
@@ -29,53 +30,44 @@ Lemma symbols_preserved:
forall id, Genv.find_symbol tge id = Genv.find_symbol ge id.
Proof.
intros. unfold ge, tge.
- apply Genv.find_symbol_transf_partial with transf_function.
+ apply Genv.find_symbol_transf_partial with transf_fundef.
exact TRANSF.
Qed.
Lemma functions_translated:
forall f b,
Genv.find_funct_ptr ge b = Some f ->
- Genv.find_funct_ptr tge b = Some (transl_function f).
+ exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = Some tf.
Proof.
intros.
- generalize (Genv.find_funct_ptr_transf_partial
- transf_function TRANSF H).
- intros [A B].
- unfold tge. change code with (list instruction). rewrite A.
- generalize B. unfold transf_function.
- case (zlt Int.max_unsigned (code_size (transl_function f))); intro.
- tauto. auto.
+ generalize (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF H).
+ case (transf_fundef f).
+ intros f' [A B]. exists f'; split. assumption. auto.
+ tauto.
Qed.
-Lemma functions_translated_2:
- forall f v,
- Genv.find_funct ge v = Some f ->
- Genv.find_funct tge v = Some (transl_function f).
+Lemma functions_transl:
+ forall f b,
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
+ Genv.find_funct_ptr tge b = Some (Internal (transl_function f)).
Proof.
intros.
- generalize (Genv.find_funct_transf_partial
- transf_function TRANSF H).
- intros [A B].
- unfold tge. change code with (list instruction). rewrite A.
- generalize B. unfold transf_function.
+ destruct (functions_translated _ _ H) as [tf [A B]].
+ rewrite A. generalize B. unfold transf_fundef, transf_partial_fundef, transf_function.
case (zlt Int.max_unsigned (code_size (transl_function f))); intro.
- tauto. auto.
+ congruence. auto.
Qed.
-Lemma functions_translated_no_overflow:
+Lemma functions_transl_no_overflow:
forall b f,
- Genv.find_funct_ptr ge b = Some f ->
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
code_size (transl_function f) <= Int.max_unsigned.
Proof.
- intros.
- generalize (Genv.find_funct_ptr_transf_partial
- transf_function TRANSF H).
- intros [A B].
- generalize B.
- unfold transf_function.
+ intros.
+ destruct (functions_translated _ _ H) as [tf [A B]].
+ generalize B. unfold transf_fundef, transf_partial_fundef, transf_function.
case (zlt Int.max_unsigned (code_size (transl_function f))); intro.
- tauto. intro. omega.
+ congruence. intro; omega.
Qed.
(** * Properties of control flow *)
@@ -180,7 +172,7 @@ Qed.
Inductive transl_code_at_pc: val -> Mach.function -> Mach.code -> Prop :=
transl_code_at_pc_intro:
forall b ofs f c,
- Genv.find_funct_ptr ge b = Some f ->
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
code_tail (Int.unsigned ofs) (transl_function f) = transl_code c ->
transl_code_at_pc (Vptr b ofs) f c.
@@ -194,19 +186,20 @@ Lemma exec_straight_steps_1:
code_size fn <= Int.max_unsigned ->
forall b ofs,
rs#PC = Vptr b ofs ->
- Genv.find_funct_ptr tge b = Some fn ->
+ Genv.find_funct_ptr tge b = Some (Internal fn) ->
code_tail (Int.unsigned ofs) fn = c ->
- exec_steps tge rs m rs' m'.
+ exec_steps tge rs m E0 rs' m'.
Proof.
induction 1.
intros. apply exec_refl.
- intros. apply exec_trans with rs2 m2.
+ intros. apply exec_trans with E0 rs2 m2 E0.
apply exec_one; econstructor; eauto.
rewrite find_instr_tail. rewrite H5. auto.
apply IHexec_straight with b (Int.add ofs Int.one).
auto. rewrite H0. rewrite H3. reflexivity.
auto.
apply code_tail_next_int with i; auto.
+ traceEq.
Qed.
Lemma exec_straight_steps_2:
@@ -215,7 +208,7 @@ Lemma exec_straight_steps_2:
code_size fn <= Int.max_unsigned ->
forall b ofs,
rs#PC = Vptr b ofs ->
- Genv.find_funct_ptr tge b = Some fn ->
+ Genv.find_funct_ptr tge b = Some (Internal fn) ->
code_tail (Int.unsigned ofs) fn = c ->
exists ofs',
rs'#PC = Vptr b ofs'
@@ -233,11 +226,11 @@ Lemma exec_straight_steps:
transl_code_at_pc (rs PC) f c ->
exec_straight tge (transl_function f)
(transl_code c) rs m (transl_code c') rs' m' ->
- exec_steps tge rs m rs' m' /\ transl_code_at_pc (rs' PC) f c'.
+ exec_steps tge rs m E0 rs' m' /\ transl_code_at_pc (rs' PC) f c'.
Proof.
intros. inversion H.
- generalize (functions_translated_no_overflow _ _ H2). intro.
- generalize (functions_translated _ _ H2). intro.
+ generalize (functions_transl_no_overflow _ _ H2). intro.
+ generalize (functions_transl _ _ H2). intro.
split. eapply exec_straight_steps_1; eauto.
generalize (exec_straight_steps_2 _ _ _ _ _ _ _
H0 H6 _ _ (sym_equal H1) H7 H3).
@@ -490,7 +483,7 @@ End TRANSL_LABEL.
Lemma find_label_goto_label:
forall f lbl rs m c' b ofs,
- Genv.find_funct_ptr ge b = Some f ->
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
rs PC = Vptr b ofs ->
Mach.find_label lbl f.(fn_code) = Some c' ->
exists rs',
@@ -509,7 +502,7 @@ Proof.
split. rewrite Pregmap.gss. constructor. auto.
rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in B.
auto. omega.
- generalize (functions_translated_no_overflow _ _ H).
+ generalize (functions_transl_no_overflow _ _ H).
omega.
intros. apply Pregmap.gso; auto.
Qed.
@@ -575,7 +568,7 @@ Qed.
Definition exec_instr_prop
(f: Mach.function) (sp: val)
- (c1: Mach.code) (ms1: Mach.regset) (m1: mem)
+ (c1: Mach.code) (ms1: Mach.regset) (m1: mem) (t: trace)
(c2: Mach.code) (ms2: Mach.regset) (m2: mem) :=
forall rs1
(WTF: wt_function f)
@@ -584,36 +577,36 @@ Definition exec_instr_prop
(AG: agree ms1 sp rs1),
exists rs2,
agree ms2 sp rs2
- /\ exec_steps tge rs1 m1 rs2 m2
+ /\ exec_steps tge rs1 m1 t rs2 m2
/\ transl_code_at_pc (rs2 PC) f c2.
Definition exec_function_body_prop
(f: Mach.function) (parent: val) (ra: val)
- (ms1: Mach.regset) (m1: mem)
+ (ms1: Mach.regset) (m1: mem) (t: trace)
(ms2: Mach.regset) (m2: mem) :=
forall rs1
(WTRA: Val.has_type ra Tint)
(RALR: rs1 LR = ra)
(WTF: wt_function f)
- (AT: Genv.find_funct ge (rs1 PC) = Some f)
+ (AT: Genv.find_funct ge (rs1 PC) = Some (Internal f))
(AG: agree ms1 parent rs1),
exists rs2,
agree ms2 parent rs2
- /\ exec_steps tge rs1 m1 rs2 m2
+ /\ exec_steps tge rs1 m1 t rs2 m2
/\ rs2 PC = rs1 LR.
Definition exec_function_prop
- (f: Mach.function) (parent: val)
- (ms1: Mach.regset) (m1: mem)
+ (f: Mach.fundef) (parent: val)
+ (ms1: Mach.regset) (m1: mem) (t: trace)
(ms2: Mach.regset) (m2: mem) :=
forall rs1
- (WTF: wt_function f)
+ (WTF: wt_fundef f)
(AT: Genv.find_funct ge (rs1 PC) = Some f)
(AG: agree ms1 parent rs1)
(WTRA: Val.has_type (rs1 LR) Tint),
exists rs2,
agree ms2 parent rs2
- /\ exec_steps tge rs1 m1 rs2 m2
+ /\ exec_steps tge rs1 m1 t rs2 m2
/\ rs2 PC = rs1 LR.
(** We show each case of the inductive proof of simulation as a separate
@@ -622,7 +615,7 @@ Definition exec_function_prop
Lemma exec_Mlabel_prop:
forall (f : function) (sp : val) (lbl : Mach.label)
(c : list Mach.instruction) (rs : Mach.regset) (m : mem),
- exec_instr_prop f sp (Mlabel lbl :: c) rs m c rs m.
+ exec_instr_prop f sp (Mlabel lbl :: c) rs m E0 c rs m.
Proof.
intros; red; intros.
assert (exec_straight tge (transl_function f)
@@ -637,7 +630,7 @@ Lemma exec_Mgetstack_prop:
forall (f : function) (sp : val) (ofs : int) (ty : typ) (dst : mreg)
(c : list Mach.instruction) (ms : Mach.regset) (m : mem) (v : val),
load_stack m sp ty ofs = Some v ->
- exec_instr_prop f sp (Mgetstack ofs ty dst :: c) ms m c (Regmap.set dst v ms) m.
+ exec_instr_prop f sp (Mgetstack ofs ty dst :: c) ms m E0 c (Regmap.set dst v ms) m.
Proof.
intros; red; intros.
unfold load_stack in H.
@@ -661,7 +654,7 @@ Lemma exec_Msetstack_prop:
forall (f : function) (sp : val) (src : mreg) (ofs : int) (ty : typ)
(c : list Mach.instruction) (ms : mreg -> val) (m m' : mem),
store_stack m sp ty ofs (ms src) = Some m' ->
- exec_instr_prop f sp (Msetstack src ofs ty :: c) ms m c ms m'.
+ exec_instr_prop f sp (Msetstack src ofs ty :: c) ms m E0 c ms m'.
Proof.
intros; red; intros.
unfold store_stack in H.
@@ -684,7 +677,7 @@ Lemma exec_Mgetparam_prop:
(m : mem) (v : val),
load_stack m sp Tint (Int.repr 0) = Some parent ->
load_stack m parent ty ofs = Some v ->
- exec_instr_prop f sp (Mgetparam ofs ty dst :: c) ms m c (Regmap.set dst v ms) m.
+ exec_instr_prop f sp (Mgetparam ofs ty dst :: c) ms m E0 c (Regmap.set dst v ms) m.
Proof.
intros; red; intros.
set (rs2 := nextinstr (rs1#GPR2 <- parent)).
@@ -723,7 +716,7 @@ Lemma exec_straight_exec_prop:
/\ agree ms' sp rs2) ->
(exists rs2,
agree ms' sp rs2
- /\ exec_steps tge rs1 m1 rs2 m2
+ /\ exec_steps tge rs1 m1 E0 rs2 m2
/\ transl_code_at_pc (rs2 PC) f c2).
Proof.
intros until ms'. intros TRANS1 [rs2 [EX AG]].
@@ -736,7 +729,7 @@ Lemma exec_Mop_prop:
(res : mreg) (c : list Mach.instruction) (ms: Mach.regset)
(m : mem) (v: val),
eval_operation ge sp op ms ## args = Some v ->
- exec_instr_prop f sp (Mop op args res :: c) ms m c (Regmap.set res v ms) m.
+ exec_instr_prop f sp (Mop op args res :: c) ms m E0 c (Regmap.set res v ms) m.
Proof.
intros; red; intros.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
@@ -753,7 +746,7 @@ Lemma exec_Mload_prop:
(a v : val),
eval_addressing ge sp addr ms ## args = Some a ->
loadv chunk m a = Some v ->
- exec_instr_prop f sp (Mload chunk addr args dst :: c) ms m c (Regmap.set dst v ms) m.
+ exec_instr_prop f sp (Mload chunk addr args dst :: c) ms m E0 c (Regmap.set dst v ms) m.
Proof.
intros; red; intros.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
@@ -801,7 +794,7 @@ Lemma exec_Mstore_prop:
(a : val),
eval_addressing ge sp addr ms ## args = Some a ->
storev chunk m a (ms src) = Some m' ->
- exec_instr_prop f sp (Mstore chunk addr args src :: c) ms m c ms m'.
+ exec_instr_prop f sp (Mstore chunk addr args src :: c) ms m E0 c ms m'.
Proof.
intros; red; intros.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
@@ -820,23 +813,23 @@ Hypothesis wt_prog: wt_program prog.
Lemma exec_Mcall_prop:
forall (f : function) (sp : val) (sig : signature)
(mos : mreg + ident) (c : list Mach.instruction) (ms : Mach.regset)
- (m : mem) (f' : function) (ms' : Mach.regset) (m' : mem),
+ (m : mem) (f' : Mach.fundef) (t: trace) (ms' : Mach.regset) (m' : mem),
find_function ge mos ms = Some f' ->
- exec_function ge f' sp ms m ms' m' ->
- exec_function_prop f' sp ms m ms' m' ->
- exec_instr_prop f sp (Mcall sig mos :: c) ms m c ms' m'.
+ exec_function ge f' sp ms m t ms' m' ->
+ exec_function_prop f' sp ms m t ms' m' ->
+ exec_instr_prop f sp (Mcall sig mos :: c) ms m t c ms' m'.
Proof.
intros; red; intros.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
intro WTI. inversion WTI.
inversion AT.
- assert (WTF': wt_function f').
+ assert (WTF': wt_fundef f').
destruct mos; simpl in H.
- apply (Genv.find_funct_prop wt_function wt_prog H).
+ apply (Genv.find_funct_prop wt_fundef wt_prog H).
destruct (Genv.find_symbol ge i); try discriminate.
- apply (Genv.find_funct_ptr_prop wt_function wt_prog H).
+ apply (Genv.find_funct_ptr_prop wt_fundef wt_prog H).
assert (NOOV: code_size (transl_function f) <= Int.max_unsigned).
- eapply functions_translated_no_overflow; eauto.
+ eapply functions_transl_no_overflow; eauto.
destruct mos; simpl in H; simpl transl_code in H7.
(* Indirect call *)
generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1.
@@ -853,19 +846,19 @@ Proof.
generalize (H1 rs3 WTF' TFIND AG3 WTRA).
intros [rs4 [AG4 [EXF' PC4]]].
exists rs4. split. auto. split.
- apply exec_trans with rs2 m. apply exec_one. econstructor.
- eauto. apply functions_translated. eexact H6.
+ apply exec_trans with E0 rs2 m t. apply exec_one. econstructor.
+ eauto. apply functions_transl. eexact H6.
rewrite find_instr_tail. rewrite H7. reflexivity.
simpl. rewrite <- (ireg_val ms sp rs1); auto.
- apply exec_trans with rs3 m. apply exec_one. econstructor.
+ apply exec_trans with E0 rs3 m t. apply exec_one. econstructor.
unfold rs2, nextinstr. rewrite Pregmap.gss.
rewrite Pregmap.gso. rewrite <- H5. simpl. reflexivity.
- discriminate. apply functions_translated. eexact H6.
+ discriminate. apply functions_transl. eexact H6.
rewrite find_instr_tail. rewrite CT1. reflexivity.
simpl. replace (rs2 CTR) with (ms m0). reflexivity.
unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss.
auto. discriminate.
- exact EXF'.
+ exact EXF'. traceEq. traceEq.
rewrite PC4. unfold rs3. rewrite Pregmap.gso. rewrite Pregmap.gss.
unfold rs2, nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso.
rewrite <- H5. simpl. constructor. auto. auto.
@@ -888,23 +881,36 @@ Proof.
generalize (H1 rs2 WTF' TFIND AG2 WTRA).
intros [rs3 [AG3 [EXF' PC3]]].
exists rs3. split. auto. split.
- apply exec_trans with rs2 m. apply exec_one. econstructor.
- eauto. apply functions_translated. eexact H6.
+ apply exec_trans with E0 rs2 m t. apply exec_one. econstructor.
+ eauto. apply functions_transl. eexact H6.
rewrite find_instr_tail. rewrite H7. reflexivity.
- simpl. reflexivity.
- exact EXF'.
+ simpl. reflexivity.
+ exact EXF'. traceEq.
rewrite PC3. unfold rs2. rewrite Pregmap.gso. rewrite Pregmap.gss.
rewrite <- H5. simpl. constructor. auto. auto.
discriminate.
intro FINDS. rewrite FINDS in H. discriminate.
Qed.
+Lemma exec_Malloc_prop:
+ forall (f : function) (sp : val) (c : list Mach.instruction)
+ (ms : Mach.regset) (m : mem) (sz : int) (m' : mem) (blk : block),
+ ms Conventions.loc_alloc_argument = Vint sz ->
+ Mem.alloc m 0 (Int.signed sz) = (m', blk) ->
+ exec_instr_prop f sp (Malloc :: c) ms m E0 c
+ (Regmap.set Conventions.loc_alloc_result (Vptr blk Int.zero) ms) m'.
+Proof.
+ intros; red; intros.
+ eapply exec_straight_exec_prop; eauto.
+ simpl. eapply transl_alloc_correct; eauto.
+Qed.
+
Lemma exec_Mgoto_prop:
forall (f : function) (sp : val) (lbl : Mach.label)
(c : list Mach.instruction) (ms : Mach.regset) (m : mem)
(c' : Mach.code),
Mach.find_label lbl (fn_code f) = Some c' ->
- exec_instr_prop f sp (Mgoto lbl :: c) ms m c' ms m.
+ exec_instr_prop f sp (Mgoto lbl :: c) ms m E0 c' ms m.
Proof.
intros; red; intros.
inversion AT.
@@ -912,7 +918,7 @@ Proof.
intros [rs2 [GOTO [AT2 INV]]].
exists rs2. split. apply agree_exten_2 with rs1; auto.
split. inversion AT. apply exec_one. econstructor; eauto.
- apply functions_translated; eauto.
+ apply functions_transl; eauto.
rewrite find_instr_tail. rewrite H7. simpl. reflexivity.
simpl. rewrite GOTO. auto. auto.
Qed.
@@ -923,7 +929,7 @@ Lemma exec_Mcond_true_prop:
(ms: Mach.regset) (m : mem) (c' : Mach.code),
eval_condition cond ms ## args = Some true ->
Mach.find_label lbl (fn_code f) = Some c' ->
- exec_instr_prop f sp (Mcond cond args lbl :: c) ms m c' ms m.
+ exec_instr_prop f sp (Mcond cond args lbl :: c) ms m E0 c' ms m.
Proof.
intros; red; intros.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
@@ -936,8 +942,8 @@ Proof.
cond args k1 ms sp rs1 m true H2 AG H).
simpl. intros [rs2 [EX [RES AG2]]].
inversion AT.
- generalize (functions_translated _ _ H6); intro FN.
- generalize (functions_translated_no_overflow _ _ H6); intro NOOV.
+ generalize (functions_transl _ _ H6); intro FN.
+ generalize (functions_transl_no_overflow _ _ H6); intro NOOV.
simpl in H7.
generalize (exec_straight_steps_2 _ _ _ _ _ _ _ EX
NOOV _ _ (sym_equal H5) FN H7).
@@ -955,7 +961,7 @@ Proof.
apply exec_one. econstructor; eauto.
rewrite find_instr_tail. rewrite CT2. unfold k1. rewrite ISSET. reflexivity.
simpl. rewrite RES. simpl. auto.
- auto.
+ traceEq. auto.
Qed.
Lemma exec_Mcond_false_prop:
@@ -963,7 +969,7 @@ Lemma exec_Mcond_false_prop:
(args : list mreg) (lbl : Mach.label) (c : list Mach.instruction)
(ms : Mach.regset) (m : mem),
eval_condition cond ms ## args = Some false ->
- exec_instr_prop f sp (Mcond cond args lbl :: c) ms m c ms m.
+ exec_instr_prop f sp (Mcond cond args lbl :: c) ms m E0 c ms m.
Proof.
intros; red; intros.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
@@ -989,8 +995,8 @@ Proof.
Qed.
Lemma exec_instr_incl:
- forall f sp c rs m c' rs' m',
- Mach.exec_instr ge f sp c rs m c' rs' m' ->
+ forall f sp c rs m t c' rs' m',
+ Mach.exec_instr ge f sp c rs m t c' rs' m' ->
incl c f.(fn_code) -> incl c' f.(fn_code).
Proof.
induction 1; intros; eauto with coqlib.
@@ -999,8 +1005,8 @@ Proof.
Qed.
Lemma exec_instrs_incl:
- forall f sp c rs m c' rs' m',
- Mach.exec_instrs ge f sp c rs m c' rs' m' ->
+ forall f sp c rs m t c' rs' m',
+ Mach.exec_instrs ge f sp c rs m t c' rs' m' ->
incl c f.(fn_code) -> incl c' f.(fn_code).
Proof.
induction 1; intros.
@@ -1011,7 +1017,7 @@ Qed.
Lemma exec_refl_prop:
forall (f : function) (sp : val) (c : Mach.code) (ms : Mach.regset)
- (m : mem), exec_instr_prop f sp c ms m c ms m.
+ (m : mem), exec_instr_prop f sp c ms m E0 c ms m.
Proof.
intros; red; intros.
exists rs1. split. auto. split. apply exec_refl. auto.
@@ -1019,28 +1025,29 @@ Qed.
Lemma exec_one_prop:
forall (f : function) (sp : val) (c : Mach.code) (ms : Mach.regset)
- (m : mem) (c' : Mach.code) (ms' : Mach.regset) (m' : mem),
- Mach.exec_instr ge f sp c ms m c' ms' m' ->
- exec_instr_prop f sp c ms m c' ms' m' ->
- exec_instr_prop f sp c ms m c' ms' m'.
+ (m : mem) (t: trace) (c' : Mach.code) (ms' : Mach.regset) (m' : mem),
+ Mach.exec_instr ge f sp c ms m t c' ms' m' ->
+ exec_instr_prop f sp c ms m t c' ms' m' ->
+ exec_instr_prop f sp c ms m t c' ms' m'.
Proof.
auto.
Qed.
Lemma exec_trans_prop:
forall (f : function) (sp : val) (c1 : Mach.code) (ms1 : Mach.regset)
- (m1 : mem) (c2 : Mach.code) (ms2 : Mach.regset) (m2 : mem)
- (c3 : Mach.code) (ms3 : Mach.regset) (m3 : mem),
- exec_instrs ge f sp c1 ms1 m1 c2 ms2 m2 ->
- exec_instr_prop f sp c1 ms1 m1 c2 ms2 m2 ->
- exec_instrs ge f sp c2 ms2 m2 c3 ms3 m3 ->
- exec_instr_prop f sp c2 ms2 m2 c3 ms3 m3 ->
- exec_instr_prop f sp c1 ms1 m1 c3 ms3 m3.
+ (m1 : mem) (t1: trace) (c2 : Mach.code) (ms2 : Mach.regset) (m2 : mem)
+ (t2: trace) (c3 : Mach.code) (ms3 : Mach.regset) (m3 : mem) (t3: trace),
+ exec_instrs ge f sp c1 ms1 m1 t1 c2 ms2 m2 ->
+ exec_instr_prop f sp c1 ms1 m1 t1 c2 ms2 m2 ->
+ exec_instrs ge f sp c2 ms2 m2 t2 c3 ms3 m3 ->
+ exec_instr_prop f sp c2 ms2 m2 t2 c3 ms3 m3 ->
+ t3 = t1 ** t2 ->
+ exec_instr_prop f sp c1 ms1 m1 t3 c3 ms3 m3.
Proof.
intros; red; intros.
generalize (H0 rs1 WTF INCL AT AG).
intros [rs2 [AG2 [EX2 AT2]]].
- generalize (exec_instrs_incl _ _ _ _ _ _ _ _ H INCL). intro INCL2.
+ generalize (exec_instrs_incl _ _ _ _ _ _ _ _ _ H INCL). intro INCL2.
generalize (H2 rs2 WTF INCL2 AT2 AG2).
intros [rs3 [AG3 [EX3 AT3]]].
exists rs3. split. auto. split. eapply exec_trans; eauto. auto.
@@ -1048,23 +1055,23 @@ Qed.
Lemma exec_function_body_prop_:
forall (f : function) (parent ra : val) (ms : Mach.regset) (m : mem)
- (ms' : Mach.regset) (m1 m2 m3 m4 : mem) (stk : block)
+ (t: trace) (ms' : Mach.regset) (m1 m2 m3 m4 : mem) (stk : block)
(c : list Mach.instruction),
alloc m (- fn_framesize f)
(align_16_top (- fn_framesize f) (fn_stacksize f)) = (m1, stk) ->
let sp := Vptr stk (Int.repr (- fn_framesize f)) in
store_stack m1 sp Tint (Int.repr 0) parent = Some m2 ->
store_stack m2 sp Tint (Int.repr 4) ra = Some m3 ->
- exec_instrs ge f sp (fn_code f) ms m3 (Mreturn :: c) ms' m4 ->
- exec_instr_prop f sp (fn_code f) ms m3 (Mreturn :: c) ms' m4 ->
+ exec_instrs ge f sp (fn_code f) ms m3 t (Mreturn :: c) ms' m4 ->
+ exec_instr_prop f sp (fn_code f) ms m3 t (Mreturn :: c) ms' m4 ->
load_stack m4 sp Tint (Int.repr 0) = Some parent ->
load_stack m4 sp Tint (Int.repr 4) = Some ra ->
- exec_function_body_prop f parent ra ms m ms' (free m4 stk).
+ exec_function_body_prop f parent ra ms m t ms' (free m4 stk).
Proof.
intros; red; intros.
generalize (Genv.find_funct_inv AT). intros [b EQPC].
generalize AT. rewrite EQPC. rewrite Genv.find_funct_find_funct_ptr. intro FN.
- generalize (functions_translated_no_overflow _ _ FN); intro NOOV.
+ generalize (functions_transl_no_overflow _ _ FN); intro NOOV.
set (rs2 := nextinstr (rs1#GPR1 <- sp #GPR2 <- Vundef)).
set (rs3 := nextinstr (rs2#GPR2 <- ra)).
set (rs4 := nextinstr rs3).
@@ -1132,18 +1139,18 @@ Proof.
elim AG7; auto. auto with ppcgen. auto with ppcgen.
unfold rs9; auto with ppcgen.
(* execution *)
- split. apply exec_trans with rs4 m3.
+ split. apply exec_trans with E0 rs4 m3 t.
eapply exec_straight_steps_1; eauto.
- apply functions_translated; auto.
- apply exec_trans with rs5 m4. assumption.
+ apply functions_transl; auto.
+ apply exec_trans with t rs5 m4 E0. assumption.
inversion AT5.
- apply exec_trans with rs8 (free m4 stk).
+ apply exec_trans with E0 rs8 (free m4 stk) E0.
eapply exec_straight_steps_1; eauto.
- apply functions_translated; auto.
+ apply functions_transl; auto.
apply exec_one. econstructor.
change rs8#PC with (Val.add (Val.add (Val.add rs5#PC Vone) Vone) Vone).
rewrite <- H8. simpl. reflexivity.
- apply functions_translated; eauto.
+ apply functions_transl; eauto.
assert (code_tail (Int.unsigned (Int.add (Int.add (Int.add ofs Int.one) Int.one) Int.one))
(transl_function f) = Pblr :: transl_code c).
eapply code_tail_next_int; auto.
@@ -1153,35 +1160,62 @@ Proof.
rewrite find_instr_tail. rewrite H13.
reflexivity.
reflexivity.
+ traceEq. traceEq. traceEq.
(* LR preservation *)
change rs9#PC with ra. auto.
Qed.
-Lemma exec_function_prop_:
+Lemma exec_function_internal_prop:
forall (f : function) (parent : val) (ms : Mach.regset) (m : mem)
- (ms' : Mach.regset) (m' : mem),
+ (t: trace) (ms' : Mach.regset) (m' : mem),
(forall ra : val,
Val.has_type ra Tint ->
- exec_function_body ge f parent ra ms m ms' m') ->
+ exec_function_body ge f parent ra ms m t ms' m') ->
(forall ra : val, Val.has_type ra Tint ->
- exec_function_body_prop f parent ra ms m ms' m') ->
- exec_function_prop f parent ms m ms' m'.
+ exec_function_body_prop f parent ra ms m t ms' m') ->
+ exec_function_prop (Internal f) parent ms m t ms' m'.
Proof.
intros; red; intros.
- apply (H0 rs1#LR WTRA rs1 WTRA (refl_equal _) WTF AT AG).
+ inversion WTF. subst f0.
+ apply (H0 rs1#LR WTRA rs1 WTRA (refl_equal _) H2 AT AG).
+Qed.
+
+Lemma exec_function_external_prop:
+ forall (ef : external_function) (parent : val) (args : list val)
+ (res : val) (ms1 ms2: Mach.regset) (m : mem)
+ (t : trace),
+ event_match ef args t res ->
+ args = ms1 ## (Conventions.loc_external_arguments (ef_sig ef)) ->
+ ms2 = Regmap.set (Conventions.loc_result (ef_sig ef)) res ms1 ->
+ exec_function_prop (External ef) parent ms1 m t ms2 m.
+Proof.
+ intros; red; intros.
+ destruct (Genv.find_funct_inv AT) as [b EQ].
+ rewrite EQ in AT. rewrite Genv.find_funct_find_funct_ptr in AT.
+ exists (rs1#(loc_external_result (ef_sig ef)) <- res #PC <- (rs1 LR)).
+ split. rewrite loc_external_result_match. rewrite H1. auto with ppcgen.
+ split. apply exec_one. eapply exec_step_external; eauto.
+ destruct (functions_translated _ _ AT) as [tf [A B]].
+ simpl in B. congruence.
+ rewrite H0. rewrite loc_external_arguments_match.
+ rewrite list_map_compose. apply list_map_exten; intros.
+ symmetry; eapply preg_val; eauto.
+ reflexivity.
Qed.
(** We then conclude by induction on the structure of the Mach
execution derivation. *)
Theorem transf_function_correct:
- forall f parent ms m ms' m',
- Mach.exec_function ge f parent ms m ms' m' ->
- exec_function_prop f parent ms m ms' m'.
+ forall f parent ms m t ms' m',
+ Mach.exec_function ge f parent ms m t ms' m' ->
+ exec_function_prop f parent ms m t ms' m'.
Proof
(Mach.exec_function_ind4 ge
- exec_instr_prop exec_instr_prop
- exec_function_body_prop exec_function_prop
+ exec_instr_prop
+ exec_instr_prop
+ exec_function_body_prop
+ exec_function_prop
exec_Mlabel_prop
exec_Mgetstack_prop
@@ -1191,6 +1225,7 @@ Proof
exec_Mload_prop
exec_Mstore_prop
exec_Mcall_prop
+ exec_Malloc_prop
exec_Mgoto_prop
exec_Mcond_true_prop
exec_Mcond_false_prop
@@ -1198,21 +1233,22 @@ Proof
exec_one_prop
exec_trans_prop
exec_function_body_prop_
- exec_function_prop_).
+ exec_function_internal_prop
+ exec_function_external_prop).
End PRESERVATION.
Theorem transf_program_correct:
- forall (p: Mach.program) (tp: PPC.program) (r: val),
+ forall (p: Mach.program) (tp: PPC.program) (t: trace) (r: val),
wt_program p ->
transf_program p = Some tp ->
- Mach.exec_program p r ->
- PPC.exec_program tp r.
+ Mach.exec_program p t r ->
+ PPC.exec_program tp t r.
Proof.
intros.
destruct H1 as [fptr [f [ms [m [FINDS [FINDF [EX RES]]]]]]].
- assert (WTF: wt_function f).
- apply (Genv.find_funct_ptr_prop wt_function H FINDF).
+ assert (WTF: wt_fundef f).
+ apply (Genv.find_funct_ptr_prop wt_fundef H FINDF).
set (ge := Genv.globalenv p) in *.
set (ms0 := Regmap.init Vundef) in *.
set (tge := Genv.globalenv tp).
@@ -1232,7 +1268,7 @@ Proof.
assert (WTRA: Val.has_type (rs0 LR) Tint).
exact I.
generalize (transf_function_correct p tp H0 H
- _ _ _ _ _ _ EX rs0 WTF AT AG WTRA).
+ _ _ _ _ _ _ _ EX rs0 WTF AT AG WTRA).
intros [rs [AG' [EX' RPC]]].
red. exists rs; exists m.
split. rewrite (Genv.init_mem_transf_partial _ _ H0). exact EX'.
diff --git a/backend/PPCgenproof1.v b/backend/PPCgenproof1.v
index 30eb336..4a9ac94 100644
--- a/backend/PPCgenproof1.v
+++ b/backend/PPCgenproof1.v
@@ -14,6 +14,7 @@ Require Import Mach.
Require Import Machtyping.
Require Import PPC.
Require Import PPCgen.
+Require Conventions.
(** * Properties of low half/high half decomposition *)
@@ -430,6 +431,75 @@ Proof.
Qed.
Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: ppcgen.
+(** Connection between Mach and PPC calling conventions for external
+ functions. *)
+
+Lemma loc_external_result_match:
+ forall sg,
+ PPC.loc_external_result sg = preg_of (Conventions.loc_result sg).
+Proof.
+ intros. destruct sg as [sargs sres].
+ destruct sres. destruct t; reflexivity. reflexivity.
+Qed.
+
+Remark list_map_drop1:
+ forall (A B: Set) (f: A -> B) (l: list A), list_drop1 (map f l) = map f (list_drop1 l).
+Proof.
+ intros; destruct l; reflexivity.
+Qed.
+
+Remark list_map_drop2:
+ forall (A B: Set) (f: A -> B) (l: list A), list_drop2 (map f l) = map f (list_drop2 l).
+Proof.
+ intros; destruct l. reflexivity. destruct l; reflexivity.
+Qed.
+
+Lemma loc_external_arguments_rec_match:
+ forall tyl iregl fregl ofs,
+ (forall r, In r iregl -> mreg_type r = Tint) ->
+ (forall r, In r fregl -> mreg_type r = Tfloat) ->
+ PPC.loc_external_arguments_rec tyl (map ireg_of iregl) (map freg_of fregl) =
+ List.map
+ (fun l => preg_of (match l with R r => r | S _ => IT1 end))
+ (Conventions.loc_arguments_rec tyl iregl fregl ofs).
+Proof.
+ induction tyl; intros; simpl.
+ auto.
+ destruct a; simpl; apply (f_equal2 (@cons preg)).
+ destruct iregl; simpl.
+ reflexivity. unfold preg_of; rewrite (H m); auto with coqlib.
+ rewrite list_map_drop1. apply IHtyl.
+ intros; apply H; apply list_drop1_incl; auto.
+ assumption.
+ destruct fregl; simpl.
+ reflexivity. unfold preg_of; rewrite (H0 m); auto with coqlib.
+ rewrite list_map_drop1. rewrite list_map_drop2. apply IHtyl.
+ intros; apply H; apply list_drop2_incl; auto.
+ intros; apply H0; apply list_drop1_incl; auto.
+Qed.
+
+Ltac ElimOrEq :=
+ match goal with
+ | |- (?x = ?y) \/ _ -> _ =>
+ let H := fresh in
+ (intro H; elim H; clear H;
+ [intro H; rewrite <- H; clear H | ElimOrEq])
+ | |- False -> _ =>
+ let H := fresh in (intro H; contradiction)
+ end.
+
+Lemma loc_external_arguments_match:
+ forall sg,
+ PPC.loc_external_arguments sg = List.map preg_of (Conventions.loc_external_arguments sg).
+Proof.
+ intros. destruct sg as [sgargs sgres]; unfold loc_external_arguments, Conventions.loc_external_arguments.
+ rewrite list_map_compose. unfold Conventions.loc_arguments.
+ rewrite <- loc_external_arguments_rec_match.
+ reflexivity.
+ intro; simpl; ElimOrEq; reflexivity.
+ intro; simpl; ElimOrEq; reflexivity.
+Qed.
+
(** * Execution of straight-line code *)
Section STRAIGHTLINE.
@@ -1198,6 +1268,22 @@ Proof.
rewrite (sp_val ms sp rs). auto. auto.
(* Oundef again *)
congruence.
+ (* Ocast8unsigned *)
+ exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 255)))).
+ split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity.
+ replace (Val.cast8unsigned (ms m0))
+ with (Val.rolm (ms m0) Int.zero (Int.repr 255)).
+ auto with ppcgen.
+ unfold Val.rolm, Val.cast8unsigned. destruct (ms m0); auto.
+ rewrite Int.rolm_zero. rewrite Int.cast8unsigned_and. auto.
+ (* Ocast16unsigned *)
+ exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 65535)))).
+ split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity.
+ replace (Val.cast16unsigned (ms m0))
+ with (Val.rolm (ms m0) Int.zero (Int.repr 65535)).
+ auto with ppcgen.
+ unfold Val.rolm, Val.cast16unsigned. destruct (ms m0); auto.
+ rewrite Int.rolm_zero. rewrite Int.cast16unsigned_and. auto.
(* Oaddimm *)
generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m
(ireg_of_not_GPR2 m0)).
@@ -1562,5 +1648,31 @@ Proof.
auto. auto.
Qed.
+(** Translation of allocations *)
+
+Lemma transl_alloc_correct:
+ forall ms sp rs sz m m' blk k,
+ agree ms sp rs ->
+ ms Conventions.loc_alloc_argument = Vint sz ->
+ Mem.alloc m 0 (Int.signed sz) = (m', blk) ->
+ let ms' := Regmap.set Conventions.loc_alloc_result (Vptr blk Int.zero) ms in
+ exists rs',
+ exec_straight (Pallocblock :: k) rs m k rs' m'
+ /\ agree ms' sp rs'.
+Proof.
+ intros.
+ pose (rs' := nextinstr (rs#GPR3 <- (Vptr blk Int.zero) #LR <- (Val.add rs#PC Vone))).
+ exists rs'; split.
+ apply exec_straight_one. unfold exec_instr.
+ generalize (preg_val _ _ _ Conventions.loc_alloc_argument H).
+ unfold preg_of; intro. simpl in H2. rewrite <- H2. rewrite H0.
+ rewrite H1. reflexivity.
+ reflexivity.
+ unfold ms', rs'. apply agree_nextinstr. apply agree_set_other.
+ change (IR GPR3) with (preg_of Conventions.loc_alloc_result).
+ apply agree_set_mreg. auto.
+ simpl. tauto.
+Qed.
+
End STRAIGHTLINE.
diff --git a/backend/Parallelmove.v b/backend/Parallelmove.v
index f95416e..b2ec930 100644
--- a/backend/Parallelmove.v
+++ b/backend/Parallelmove.v
@@ -1,2529 +1,290 @@
-(** Translation of parallel moves into sequences of individual moves *)
+Require Import Coqlib.
+Require Parmov.
+Require Import Values.
+Require Import Events.
+Require Import AST.
+Require Import Locations.
+Require Import Conventions.
-(** The ``parallel move'' problem, also known as ``parallel assignment'',
- is the following. We are given a list of (source, destination) pairs
- of locations. The goal is to find a sequence of elementary
- moves ([loc <- loc] assignments) such that, at the end of the sequence,
- location [dst] contains the value of location [src] at the beginning of
- the sequence, for each ([src], [dst]) pairs in the given problem.
- Moreover, other locations should keep their values, except one register
- of each type, which can be used as temporaries in the generated sequences.
+Definition temp_for (l: loc) : loc :=
+ match Loc.type l with Tint => R IT2 | Tfloat => R FT2 end.
- The parallel move problem is trivial if the sources and destinations do
- not overlap. For instance,
-<<
- (R1, R2) <- (R3, R4) becomes R1 <- R3; R2 <- R4
->>
- However, arbitrary overlap is allowed between sources and destinations.
- This requires some care in ordering the individual moves, as in
-<<
- (R1, R2) <- (R3, R1) becomes R2 <- R1; R1 <- R3
->>
- Worse, cycles (permutations) can require the use of temporaries, as in
-<<
- (R1, R2, R3) <- (R2, R3, R1) becomes T <- R1; R1 <- R2; R2 <- R3; R3 <- T;
->>
- An amazing fact is that for any parallel move problem, at most one temporary
- (or in our case one integer temporary and one float temporary) is needed.
+Definition parmove (srcs dsts: list loc) :=
+ Parmov.parmove2 loc temp_for Loc.eq srcs dsts.
- The development in this section was contributed by Laurence Rideau and
- Bernard Serpette. It is described in their paper
- ``Coq à la conquête des moulins'', JFLA 2005,
- #<A HREF="http://www-sop.inria.fr/lemme/Laurence.Rideau/RideauSerpetteJFLA05.ps">#
- http://www-sop.inria.fr/lemme/Laurence.Rideau/RideauSerpetteJFLA05.ps
- #</A>#
-*)
+Definition moves := (list (loc * loc))%type.
-Require Omega.
-Require Import Wf_nat.
-Require Import Conventions.
-Require Import Coqlib.
-Require Import Bool_nat.
-Require Import TheoryList.
-Require Import Bool.
-Require Import Arith.
-Require Import Peano_dec.
-Require Import EqNat.
-Require Import Values.
-Require Import LTL.
-Require Import EqNat.
-Require Import Locations.
-Require Import AST.
-
-Section pmov.
-
-Ltac caseEq name := generalize (refl_equal name); pattern name at -1; case name.
-Hint Resolve beq_nat_eq .
-
-Lemma neq_is_neq: forall (x y : nat), x <> y -> beq_nat x y = false.
-Proof.
-unfold not; intros.
-caseEq (beq_nat x y); auto.
-intro.
-elim H; auto.
-Qed.
-Hint Resolve neq_is_neq .
-
-Lemma app_nil: forall (A : Set) (l : list A), l ++ nil = l.
-Proof.
-intros A l; induction l as [|a l Hrecl]; auto; simpl; rewrite Hrecl; auto.
-Qed.
-
-Lemma app_cons:
- forall (A : Set) (l1 l2 : list A) (a : A), (a :: l1) ++ l2 = a :: (l1 ++ l2).
-Proof.
-auto.
-Qed.
-
-Lemma app_app:
- forall (A : Set) (l1 l2 l3 : list A), l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
-Proof.
-intros A l1; induction l1 as [|a l1 Hrecl1]; simpl; auto; intros;
- rewrite Hrecl1; auto.
-Qed.
-
-Lemma app_rewrite:
- forall (A : Set) (l : list A) (x : A),
- (exists y : A , exists r : list A , l ++ (x :: nil) = y :: r ).
-Proof.
-intros A l x; induction l as [|a l Hrecl].
-exists x; exists (nil (A:=A)); auto.
-inversion Hrecl; inversion H.
-exists a; exists (l ++ (x :: nil)); auto.
-Qed.
-
-Lemma app_rewrite2:
- forall (A : Set) (l l2 : list A) (x : A),
- (exists y : A , exists r : list A , l ++ (x :: l2) = y :: r ).
-Proof.
-intros A l l2 x; induction l as [|a l Hrecl].
-exists x; exists l2; auto.
-inversion Hrecl; inversion H.
-exists a; exists (l ++ (x :: l2)); auto.
-Qed.
-
-Lemma app_rewriter:
- forall (A : Set) (l : list A) (x : A),
- (exists y : A , exists r : list A , x :: l = r ++ (y :: nil) ).
-Proof.
-intros A l x; induction l as [|a l Hrecl].
-exists x; exists (nil (A:=A)); auto.
-inversion Hrecl; inversion H.
-generalize H0; case x1; simpl; intros; inversion H1.
-exists a; exists (x0 :: nil); simpl; auto.
-exists x0; exists (a0 :: (a :: l0)); simpl; auto.
-Qed.
-Hint Resolve app_rewriter .
-
-Definition Reg := loc.
-
-Definition T :=
- fun (r : loc) =>
- match Loc.type r with Tint => R IT2 | Tfloat => R FT2 end.
-
-Definition notemporary := fun (r : loc) => forall x, Loc.diff r (T x).
-
-Definition Move := (Reg * Reg)%type.
-
-Definition Moves := list Move.
-
-Definition State := ((Moves * Moves) * Moves)%type.
-
-Definition StateToMove (r : State) : Moves :=
- match r with ((t, b), l) => t end.
-
-Definition StateBeing (r : State) : Moves :=
- match r with ((t, b), l) => b end.
-
-Definition StateDone (r : State) : Moves :=
- match r with ((t, b), l) => l end.
-
-Fixpoint noRead (p : Moves) (r : Reg) {struct p} : Prop :=
- match p with
- nil => True
- | (s, d) :: l => Loc.diff s r /\ noRead l r
- end.
-
-Lemma noRead_app:
- forall (l1 l2 : Moves) (r : Reg),
- noRead l1 r -> noRead l2 r -> noRead (l1 ++ l2) r.
-Proof.
-intros; induction l1 as [|a l1 Hrecl1]; simpl; auto.
-destruct a.
-elim H; intros; split; auto.
-Qed.
-
-Inductive step : State -> State -> Prop :=
- step_nop:
- forall (r : Reg) (t1 t2 l : Moves),
- step (t1 ++ ((r, r) :: t2), nil, l) (t1 ++ t2, nil, l)
- | step_start:
- forall (t1 t2 l : Moves) (m : Move),
- step (t1 ++ (m :: t2), nil, l) (t1 ++ t2, m :: nil, l)
- | step_push:
- forall (t1 t2 b l : Moves) (s d r : Reg),
- step
- (t1 ++ ((d, r) :: t2), (s, d) :: b, l)
- (t1 ++ t2, (d, r) :: ((s, d) :: b), l)
- | step_loop:
- forall (t b l : Moves) (s d r0 r0ounon : Reg),
- step
- (t, (s, r0ounon) :: (b ++ ((r0, d) :: nil)), l)
- (t, (s, r0ounon) :: (b ++ ((T r0, d) :: nil)), (r0, T r0) :: l)
- | step_pop:
- forall (t b l : Moves) (s0 d0 sn dn : Reg),
- noRead t dn ->
- Loc.diff dn s0 ->
- step
- (t, (sn, dn) :: (b ++ ((s0, d0) :: nil)), l)
- (t, b ++ ((s0, d0) :: nil), (sn, dn) :: l)
- | step_last:
- forall (t l : Moves) (s d : Reg),
- noRead t d -> step (t, (s, d) :: nil, l) (t, nil, (s, d) :: l) .
-Hint Resolve step_nop step_start step_push step_loop step_pop step_last .
-
-Fixpoint path (l : Moves) : Prop :=
- match l with
- nil => True
- | (s, d) :: l =>
- match l with
- nil => True
- | (ss, dd) :: l2 => s = dd /\ path l
- end
- end.
-
-Lemma path_pop: forall (m : Move) (l : Moves), path (m :: l) -> path l.
-Proof.
-simpl; intros m l; destruct m as [ms md]; case l; auto.
-intros m0; destruct m0; intros; inversion H; auto.
-Qed.
-
-Fixpoint noWrite (p : Moves) (r : Reg) {struct p} : Prop :=
- match p with
- nil => True
- | (s, d) :: l => Loc.diff d r /\ noWrite l r
- end.
-
-Lemma noWrite_pop:
- forall (p1 p2 : Moves) (m : Move) (r : Reg),
- noWrite (p1 ++ (m :: p2)) r -> noWrite (p1 ++ p2) r.
-Proof.
-intros; induction p1 as [|a p1 Hrecp1].
-generalize H; simpl; case m; intros; inversion H0; auto.
-generalize H; rewrite app_cons; rewrite app_cons.
-simpl; case a; intros.
-inversion H0; split; auto.
-Qed.
-
-Lemma noWrite_in:
- forall (p1 p2 : Moves) (r0 r1 r2 : Reg),
- noWrite (p1 ++ ((r1, r2) :: p2)) r0 -> Loc.diff r0 r2.
-Proof.
-intros; induction p1 as [|a p1 Hrecp1]; simpl; auto.
-generalize H; simpl; intros; inversion H0; auto.
-apply Loc.diff_sym; auto.
-generalize H; rewrite app_cons; simpl; case a; intros.
-apply Hrecp1; inversion H0; auto.
-Qed.
-
-Lemma noWrite_swap:
- forall (p : Moves) (m1 m2 : Move) (r : Reg),
- noWrite (m1 :: (m2 :: p)) r -> noWrite (m2 :: (m1 :: p)) r.
-Proof.
-intros p m1 m2 r; simpl; case m1; case m2.
-intros; inversion H; inversion H1; split; auto.
-Qed.
-
-Lemma noWrite_movFront:
- forall (p1 p2 : Moves) (m : Move) (r0 : Reg),
- noWrite (p1 ++ (m :: p2)) r0 -> noWrite (m :: (p1 ++ p2)) r0.
-Proof.
-intros p1 p2 m r0; induction p1 as [|a p1 Hrecp1]; auto.
-case a; intros r1 r2; rewrite app_cons; rewrite app_cons.
-intros; apply noWrite_swap; rewrite <- app_cons.
-simpl in H |-; inversion H; unfold noWrite; fold noWrite; auto.
-Qed.
-
-Lemma noWrite_insert:
- forall (p1 p2 : Moves) (m : Move) (r0 : Reg),
- noWrite (m :: (p1 ++ p2)) r0 -> noWrite (p1 ++ (m :: p2)) r0.
-Proof.
-intros p1 p2 m r0; induction p1 as [|a p1 Hrecp1].
-simpl; auto.
-destruct a; simpl.
-destruct m.
-intros [H1 [H2 H3]]; split; auto.
-apply Hrecp1.
-simpl; auto.
-Qed.
-
-Lemma noWrite_tmpLast:
- forall (t : Moves) (r s d : Reg),
- noWrite (t ++ ((s, d) :: nil)) r ->
- forall (x : Reg), noWrite (t ++ ((x, d) :: nil)) r.
-Proof.
-intros; induction t as [|a t Hrect].
-simpl; auto.
-generalize H; simpl; case a; intros; inversion H0; split; auto.
-Qed.
-
-Fixpoint simpleDest (p : Moves) : Prop :=
- match p with
- nil => True
- | (s, d) :: l => noWrite l d /\ simpleDest l
- end.
-
-Lemma simpleDest_Pop:
- forall (m : Move) (l1 l2 : Moves),
- simpleDest (l1 ++ (m :: l2)) -> simpleDest (l1 ++ l2).
-Proof.
-intros; induction l1 as [|a l1 Hrecl1].
-generalize H; simpl; case m; intros; inversion H0; auto.
-generalize H; rewrite app_cons; rewrite app_cons.
-simpl; case a; intros; inversion H0; split; auto.
-apply (noWrite_pop l1 l2 m); auto.
-Qed.
-
-Lemma simpleDest_pop:
- forall (m : Move) (l : Moves), simpleDest (m :: l) -> simpleDest l.
-Proof.
-intros m l; simpl; case m; intros _ r [X Y]; auto.
-Qed.
-
-Lemma simpleDest_right:
- forall (l1 l2 : Moves), simpleDest (l1 ++ l2) -> simpleDest l2.
-Proof.
-intros l1; induction l1 as [|a l1 Hrecl1]; auto.
-intros l2; rewrite app_cons; intros; apply Hrecl1.
-apply (simpleDest_pop a); auto.
-Qed.
-
-Lemma simpleDest_swap:
- forall (m1 m2 : Move) (l : Moves),
- simpleDest (m1 :: (m2 :: l)) -> simpleDest (m2 :: (m1 :: l)).
-Proof.
-intros m1 m2 l; simpl; case m1; case m2.
-intros _ r0 _ r2 [[X Y] [Z U]]; auto.
-(repeat split); auto.
-apply Loc.diff_sym; auto.
-Qed.
-
-Lemma simpleDest_pop2:
- forall (m1 m2 : Move) (l : Moves),
- simpleDest (m1 :: (m2 :: l)) -> simpleDest (m1 :: l).
-Proof.
-intros; apply (simpleDest_pop m2); apply simpleDest_swap; auto.
-Qed.
-
-Lemma simpleDest_movFront:
- forall (p1 p2 : Moves) (m : Move),
- simpleDest (p1 ++ (m :: p2)) -> simpleDest (m :: (p1 ++ p2)).
-Proof.
-intros p1 p2 m; induction p1 as [|a p1 Hrecp1].
-simpl; auto.
-rewrite app_cons; rewrite app_cons.
-case a; intros; simpl in H |-; inversion H.
-apply simpleDest_swap; simpl; auto.
-destruct m.
-cut (noWrite ((r1, r2) :: (p1 ++ p2)) r0).
-cut (simpleDest ((r1, r2) :: (p1 ++ p2))).
-intro; (repeat split); elim H3; elim H2; intros; auto.
-apply Hrecp1; auto.
-apply noWrite_movFront; auto.
-Qed.
-
-Lemma simpleDest_insert:
- forall (p1 p2 : Moves) (m : Move),
- simpleDest (m :: (p1 ++ p2)) -> simpleDest (p1 ++ (m :: p2)).
-Proof.
-intros p1 p2 m; induction p1 as [|a p1 Hrecp1].
-simpl; auto.
-rewrite app_cons; intros.
-simpl.
-destruct a as [a1 a2].
-split.
-destruct m; simpl in H |-.
-apply noWrite_insert.
-simpl; split; elim H; intros [H1 H2] [H3 H4]; auto.
-apply Loc.diff_sym; auto.
-apply Hrecp1.
-apply simpleDest_pop2 with (a1, a2); auto.
-Qed.
-
-Lemma simpleDest_movBack:
- forall (p1 p2 : Moves) (m : Move),
- simpleDest (p1 ++ (m :: p2)) -> simpleDest ((p1 ++ p2) ++ (m :: nil)).
-Proof.
-intros.
-apply (simpleDest_insert (p1 ++ p2) nil m).
-rewrite app_nil; apply simpleDest_movFront; auto.
-Qed.
-
-Lemma simpleDest_swap_app:
- forall (t1 t2 t3 : Moves) (m : Move),
- simpleDest (t1 ++ (m :: (t2 ++ t3))) -> simpleDest ((t1 ++ t2) ++ (m :: t3)).
-Proof.
-intros.
-apply (simpleDest_insert (t1 ++ t2) t3 m).
-rewrite <- app_app.
-apply simpleDest_movFront; auto.
-Qed.
-
-Lemma simpleDest_tmpLast:
- forall (t : Moves) (s d : Reg),
- simpleDest (t ++ ((s, d) :: nil)) ->
- forall (r : Reg), simpleDest (t ++ ((r, d) :: nil)).
-Proof.
-intros t s d; induction t as [|a t Hrect].
-simpl; auto.
-simpl; case a; intros; inversion H; split; auto.
-apply (noWrite_tmpLast t r0 s); auto.
-Qed.
-
-Fixpoint noTmp (b : Moves) : Prop :=
- match b with
- nil => True
- | (s, d) :: l =>
- (forall r, Loc.diff s (T r)) /\
- ((forall r, Loc.diff d (T r)) /\ noTmp l)
- end.
-
-Fixpoint noTmpLast (b : Moves) : Prop :=
- match b with
- nil => True
- | (s, d) :: nil => forall r, Loc.diff d (T r)
- | (s, d) :: l =>
- (forall r, Loc.diff s (T r)) /\
- ((forall r, Loc.diff d (T r)) /\ noTmpLast l)
- end.
-
-Lemma noTmp_app:
- forall (l1 l2 : Moves) (m : Move),
- noTmp l1 -> noTmpLast (m :: l2) -> noTmpLast (l1 ++ (m :: l2)).
-Proof.
-intros.
-induction l1 as [|a l1 Hrecl1].
-simpl; auto.
-simpl.
-caseEq (l1 ++ (m :: l2)); intro.
-destruct a.
-elim H; intros; auto.
-inversion H; auto.
-elim H3; auto.
-intros; destruct a as [a1 a2].
-elim H; intros H2 [H3 H4]; auto.
-(repeat split); auto.
-rewrite H1 in Hrecl1; apply Hrecl1; auto.
-Qed.
-
-Lemma noTmpLast_popBack:
- forall (t : Moves) (m : Move), noTmpLast (t ++ (m :: nil)) -> noTmp t.
-Proof.
-intros.
-induction t as [|a t Hrect].
-simpl; auto.
-destruct a as [a1 a2].
-rewrite app_cons in H.
-simpl.
-simpl in H |-.
-generalize H; caseEq (t ++ (m :: nil)); intros.
-destruct t; inversion H0.
-elim H1.
-intros H2 [H3 H4]; (repeat split); auto.
-rewrite <- H0 in H4.
-apply Hrect; auto.
-Qed.
-
-Fixpoint getsrc (p : Moves) : list Reg :=
- match p with
- nil => nil
- | (s, d) :: l => s :: getsrc l
- end.
-
-Fixpoint getdst (p : Moves) : list Reg :=
- match p with
- nil => nil
- | (s, d) :: l => d :: getdst l
- end.
-
-Fixpoint noOverlap_aux (r : Reg) (l : list Reg) {struct l} : Prop :=
- match l with
- nil => True
- | b :: m => (b = r \/ Loc.diff b r) /\ noOverlap_aux r m
- end.
-
-Definition noOverlap (p : Moves) : Prop :=
- forall l, In l (getsrc p) -> noOverlap_aux l (getdst p).
-
-Definition stepInv (r : State) : Prop :=
- path (StateBeing r) /\
- (simpleDest (StateToMove r ++ StateBeing r) /\
- (noOverlap (StateToMove r ++ StateBeing r) /\
- (noTmp (StateToMove r) /\ noTmpLast (StateBeing r)))).
-
-Definition Value := val.
-
-Definition Env := locset.
-
-Definition get (e : Env) (r : Reg) := Locmap.get r e.
-
-Definition update (e : Env) (r : Reg) (v : Value) : Env := Locmap.set r v e.
-
-Fixpoint sexec (p : Moves) (e : Env) {struct p} : Env :=
- match p with
- nil => e
- | (s, d) :: l => let e' := sexec l e in
- update e' d (get e' s)
- end.
-
-Fixpoint pexec (p : Moves) (e : Env) {struct p} : Env :=
- match p with
- nil => e
- | (s, d) :: l => update (pexec l e) d (get e s)
- end.
-
-Lemma get_update:
- forall (e : Env) (r1 r2 : Reg) (v : Value),
- get (update e r1 v) r2 =
- (if Loc.eq r1 r2 then v else if Loc.overlap r1 r2 then Vundef else get e r2).
-Proof.
-intros.
-unfold update, get, Locmap.get, Locmap.set; trivial.
-Qed.
-
-Lemma get_update_id:
- forall (e : Env) (r1 : Reg) (v : Value), get (update e r1 v) r1 = v.
-Proof.
-intros e r1 v; rewrite (get_update e r1 r1); auto.
-case (Loc.eq r1 r1); auto.
-intros H; elim H; trivial.
-Qed.
-
-Lemma get_update_diff:
- forall (e : Env) (r1 r2 : Reg) (v : Value),
- Loc.diff r1 r2 -> get (update e r1 v) r2 = get e r2.
-Proof.
-intros; unfold update, get, Locmap.get, Locmap.set.
-case (Loc.eq r1 r2); intro.
-absurd (r1 = r2); [apply Loc.diff_not_eq; trivial | trivial].
-caseEq (Loc.overlap r1 r2); intro; trivial.
-absurd (Loc.diff r1 r2); [apply Loc.overlap_not_diff; assumption | assumption].
-Qed.
-
-Lemma get_update_ndiff:
- forall (e : Env) (r1 r2 : Reg) (v : Value),
- r1 <> r2 -> not (Loc.diff r1 r2) -> get (update e r1 v) r2 = Vundef.
-Proof.
-intros; unfold update, get, Locmap.get, Locmap.set.
-case (Loc.eq r1 r2); intro.
-absurd (r1 = r2); assumption.
-caseEq (Loc.overlap r1 r2); intro; trivial.
-absurd (Loc.diff r1 r2); (try assumption).
-apply Loc.non_overlap_diff; assumption.
-Qed.
-
-Lemma pexec_swap:
- forall (m1 m2 : Move) (t : Moves),
- simpleDest (m1 :: (m2 :: t)) ->
- forall (e : Env) (r : Reg),
- get (pexec (m1 :: (m2 :: t)) e) r = get (pexec (m2 :: (m1 :: t)) e) r.
-Proof.
-intros; destruct m1 as [m1s m1d]; destruct m2 as [m2s m2d].
-generalize H; simpl; intros [[NEQ NW] [NW2 HSD]]; clear H.
-case (Loc.eq m1d r); case (Loc.eq m2d r); intros.
-absurd (m1d = m2d);
- [apply Loc.diff_not_eq; apply Loc.diff_sym; assumption |
- rewrite e0; rewrite e1; trivial].
-caseEq (Loc.overlap m2d r); intro.
-absurd (Loc.diff m2d m1d); [apply Loc.overlap_not_diff; rewrite e0 | idtac];
- (try assumption).
-subst m1d; rewrite get_update_id; rewrite get_update_diff;
- (try rewrite get_update_id); auto.
-caseEq (Loc.overlap m1d r); intro.
-absurd (Loc.diff m1d m2d);
- [apply Loc.overlap_not_diff; rewrite e0 | apply Loc.diff_sym]; assumption.
-subst m2d; (repeat rewrite get_update_id); rewrite get_update_diff;
- [rewrite get_update_id; trivial | apply Loc.diff_sym; trivial].
-caseEq (Loc.overlap m1d r); caseEq (Loc.overlap m2d r); intros.
-(repeat rewrite get_update_ndiff);
- (try (apply Loc.overlap_not_diff; assumption)); trivial.
-assert (~ Loc.diff m1d r);
- [apply Loc.overlap_not_diff; assumption |
- intros; rewrite get_update_ndiff; auto].
-rewrite get_update_diff;
- [rewrite get_update_ndiff; auto | apply Loc.non_overlap_diff; auto].
-cut (~ Loc.diff m2d r); [idtac | apply Loc.overlap_not_diff; auto].
-cut (Loc.diff m1d r); [idtac | apply Loc.non_overlap_diff; auto].
-intros; rewrite get_update_diff; auto.
-(repeat rewrite get_update_ndiff); auto.
-cut (Loc.diff m1d r); [idtac | apply Loc.non_overlap_diff; auto].
-cut (Loc.diff m2d r); [idtac | apply Loc.non_overlap_diff; auto].
-intros; (repeat rewrite get_update_diff); auto.
-Qed.
-
-Lemma pexec_add:
- forall (t1 t2 : Moves) (r : Reg) (e : Env),
- get (pexec t1 e) r = get (pexec t2 e) r ->
- forall (a : Move), get (pexec (a :: t1) e) r = get (pexec (a :: t2) e) r.
-Proof.
-intros.
-case a.
-simpl.
-intros a1 a2.
-unfold get, update, Locmap.set, Locmap.get.
-case (Loc.eq a2 r); case (Loc.overlap a2 r); auto.
-Qed.
-
-Lemma pexec_movBack:
- forall (t1 t2 : Moves) (m : Move),
- simpleDest (m :: (t1 ++ t2)) ->
- forall (e : Env) (r : Reg),
- get (pexec (m :: (t1 ++ t2)) e) r = get (pexec (t1 ++ (m :: t2)) e) r.
-Proof.
-intros t1 t2 m; induction t1 as [|a t1 Hrect1].
-simpl; auto.
-rewrite app_cons.
-intros; rewrite pexec_swap; auto; rewrite app_cons; auto.
-apply pexec_add.
-apply Hrect1.
-apply (simpleDest_pop2 m a); auto.
-Qed.
-
-Lemma pexec_movFront:
- forall (t1 t2 : Moves) (m : Move),
- simpleDest (t1 ++ (m :: t2)) ->
- forall (e : Env) (r : Reg),
- get (pexec (t1 ++ (m :: t2)) e) r = get (pexec (m :: (t1 ++ t2)) e) r.
-Proof.
-intros; rewrite <- pexec_movBack; eauto.
-apply simpleDest_movFront; auto.
-Qed.
-
-Lemma pexec_mov:
- forall (t1 t2 t3 : Moves) (m : Move),
- simpleDest ((t1 ++ (m :: t2)) ++ t3) ->
- forall (e : Env) (r : Reg),
- get (pexec ((t1 ++ (m :: t2)) ++ t3) e) r =
- get (pexec ((t1 ++ t2) ++ (m :: t3)) e) r.
-Proof.
-intros t1 t2 t3 m.
-rewrite <- app_app.
-rewrite app_cons.
-intros.
-rewrite pexec_movFront; auto.
-cut (simpleDest (m :: (t1 ++ (t2 ++ t3)))).
-rewrite app_app.
-rewrite <- pexec_movFront; auto.
-apply simpleDest_swap_app; auto.
-apply simpleDest_movFront; auto.
-Qed.
-
-Definition diff_dec:
- forall (x y : Reg), ({ Loc.diff x y }) + ({ not (Loc.diff x y) }).
-intros.
-case (Loc.eq x y).
-intros heq; right.
-red; intro; absurd (x = y); auto.
-apply Loc.diff_not_eq; auto.
-intro; caseEq (Loc.overlap x y).
-intro; right.
-apply Loc.overlap_not_diff; auto.
-intro; left; apply Loc.non_overlap_diff; auto.
-Defined.
-
-Lemma get_pexec_id_noWrite:
- forall (t : Moves) (d : Reg),
- noWrite t d ->
- forall (e : Env) (v : Value), v = get (pexec t (update e d v)) d.
-Proof.
-intros.
-induction t as [|a t Hrect].
-simpl.
-rewrite get_update_id; auto.
-generalize H; destruct a as [a1 a2]; simpl; intros [NEQ R].
-rewrite get_update_diff; auto.
-Qed.
-
-Lemma pexec_nop:
- forall (t : Moves) (r : Reg) (e : Env) (x : Reg),
- Loc.diff r x -> get (pexec ((r, r) :: t) e) x = get (pexec t e) x.
-Proof.
-intros.
-simpl.
-rewrite get_update_diff; auto.
-Qed.
-
-Lemma sD_nW: forall t r s, simpleDest ((s, r) :: t) -> noWrite t r.
-Proof.
-induction t.
-simpl; auto.
-simpl.
-destruct a.
-intros r1 r2 H; split; [try assumption | idtac].
-elim H;
- [intros H0 H1; elim H0; [intros H2 H3; (try clear H0 H); (try exact H2)]].
-elim H;
- [intros H0 H1; elim H0; [intros H2 H3; (try clear H0 H); (try exact H3)]].
-Qed.
-
-Lemma sD_pexec:
- forall (t : Moves) (s d : Reg),
- simpleDest ((s, d) :: t) -> forall (e : Env), get (pexec t e) d = get e d.
-Proof.
-intros.
-induction t as [|a t Hrect]; simpl; auto.
-destruct a as [a1 a2].
-simpl in H |-; elim H; intros [H0 H1] [H2 H3]; clear H.
-case (Loc.eq a2 d); intro.
-absurd (a2 = d); [apply Loc.diff_not_eq | trivial]; assumption.
-rewrite get_update_diff; (try assumption).
-apply Hrect.
-simpl; (split; assumption).
-Qed.
-
-Lemma noOverlap_nil: noOverlap nil.
-Proof.
-unfold noOverlap, noOverlap_aux, getsrc, getdst; trivial.
-Qed.
-
-Lemma getsrc_add:
- forall (m : Move) (l1 l2 : Moves) (l : Reg),
- In l (getsrc (l1 ++ l2)) -> In l (getsrc (l1 ++ (m :: l2))).
-Proof.
-intros m l1 l2 l; destruct m; induction l1; simpl; auto.
-destruct a; simpl; intros.
-elim H; intros H0; [left | right]; auto.
-Qed.
-
-Lemma getdst_add:
- forall (r1 r2 : Reg) (l1 l2 : Moves),
- getdst (l1 ++ ((r1, r2) :: l2)) = getdst l1 ++ (r2 :: getdst l2).
-Proof.
-intros r1 r2 l1 l2; induction l1; simpl; auto.
-destruct a; simpl; rewrite IHl1; auto.
-Qed.
-
-Lemma getdst_app:
- forall (l1 l2 : Moves), getdst (l1 ++ l2) = getdst l1 ++ getdst l2.
-Proof.
-intros; induction l1; simpl; auto.
-destruct a; simpl; rewrite IHl1; auto.
-Qed.
-
-Lemma noOverlap_auxpop:
- forall (x r : Reg) (l : list Reg),
- noOverlap_aux x (r :: l) -> noOverlap_aux x l.
-Proof.
-induction l; simpl; auto.
-intros [H1 [H2 H3]]; split; auto.
-Qed.
-
-Lemma noOverlap_auxPop:
- forall (x r : Reg) (l1 l2 : list Reg),
- noOverlap_aux x (l1 ++ (r :: l2)) -> noOverlap_aux x (l1 ++ l2).
-Proof.
-intros x r l1 l2; (try assumption).
-induction l1 as [|a l1 Hrecl1]; simpl app.
-intro; apply (noOverlap_auxpop x r); auto.
-(repeat rewrite app_cons); simpl.
-intros [H1 H2]; split; auto.
-Qed.
-
-Lemma noOverlap_pop:
- forall (m : Move) (l : Moves), noOverlap (m :: l) -> noOverlap l.
-Proof.
-induction l.
-intro; apply noOverlap_nil.
-unfold noOverlap; simpl; destruct m; destruct a; simpl; intros.
-elim (H l0); intros; (try assumption).
-elim H0; intros H1; right; [left | right]; assumption.
-Qed.
-
-Lemma noOverlap_Pop:
- forall (m : Move) (l1 l2 : Moves),
- noOverlap (l1 ++ (m :: l2)) -> noOverlap (l1 ++ l2).
-Proof.
-intros m l1 l2; induction l1 as [|a l1 Hrecl1]; simpl.
-simpl; apply noOverlap_pop.
-(repeat rewrite app_cons); unfold noOverlap; destruct a; simpl.
-intros H l H0; split.
-elim (H l); [intros H1 H2 | idtac]; auto.
-elim H0; [intros H3; left | intros H3; right; apply getsrc_add]; auto.
-unfold noOverlap in Hrecl1 |-.
-elim H0; intros H1; clear H0.
-destruct m; rewrite getdst_app; apply noOverlap_auxPop with ( r := r2 ).
-rewrite getdst_add in H.
-elim H with ( l := l ); [intros H0 H2; (try clear H); (try exact H2) | idtac].
-left; (try assumption).
-apply Hrecl1 with ( l := l ); auto.
-intros l0 H0; (try assumption).
-elim H with ( l := l0 ); [intros H2 H3; (try clear H); (try exact H3) | idtac];
- auto.
-Qed.
-
-Lemma noOverlap_right:
- forall (l1 l2 : Moves), noOverlap (l1 ++ l2) -> noOverlap l2.
-Proof.
-intros l1; induction l1 as [|a l1 Hrecl1]; auto.
-intros l2; rewrite app_cons; intros; apply Hrecl1.
-apply (noOverlap_pop a); auto.
-Qed.
-
-Lemma pexec_update:
- forall t e d r v,
- Loc.diff d r ->
- noRead t d -> get (pexec t (update e d v)) r = get (pexec t e) r.
-Proof.
-induction t; simpl.
-intros; rewrite get_update_diff; auto.
-destruct a as [a1 a2]; intros; case (Loc.eq a2 r); intro.
-subst a2; (repeat rewrite get_update_id).
-rewrite get_update_diff; auto; apply Loc.diff_sym; elim H0; auto.
-case (diff_dec a2 r); intro.
-(repeat rewrite get_update_diff); auto.
-apply IHt; auto.
-elim H0; auto.
-(repeat rewrite get_update_ndiff); auto.
-Qed.
-
-Lemma pexec_push:
- forall (t l : Moves) (s d : Reg),
- noRead t d ->
- simpleDest ((s, d) :: t) ->
- forall (e : Env) (r : Reg),
- r = d \/ Loc.diff d r ->
- get (pexec ((s, d) :: t) (sexec l e)) r =
- get (pexec t (sexec ((s, d) :: l) e)) r.
-Proof.
-intros; simpl.
-elim H1; intros e1.
-rewrite e1; rewrite get_update_id; auto.
-rewrite (sD_pexec t s d); auto; rewrite get_update_id; auto.
-rewrite pexec_update; auto.
-rewrite get_update_diff; auto.
-Qed.
-
-Definition exec (s : State) (e : Env) :=
- pexec (StateToMove s ++ StateBeing s) (sexec (StateDone s) e).
-
-Definition sameEnv (e1 e2 : Env) :=
- forall (r : Reg), notemporary r -> get e1 r = get e2 r.
-
-Definition NoOverlap (r : Reg) (s : State) :=
- noOverlap ((r, r) :: (StateToMove s ++ StateBeing s)).
-
-Lemma noOverlapaux_swap2:
- forall (l1 l2 : list Reg) (m l : Reg),
- noOverlap_aux l (l1 ++ (m :: l2)) -> noOverlap_aux l (m :: (l1 ++ l2)).
-Proof.
-intros l1 l2 m l; induction l1; simpl noOverlap_aux; auto.
-intros; elim H; intros H0 H1; (repeat split); auto.
-simpl in IHl1 |-.
-elim IHl1; [intros H2 H3; (try exact H2) | idtac]; auto.
-apply (noOverlap_auxpop l m).
-apply IHl1; auto.
-Qed.
-
-Lemma noTmp_noReadTmp: forall t, noTmp t -> forall s, noRead t (T s).
-Proof.
-induction t; simpl; auto.
-destruct a as [a1 a2]; intros.
-split; [idtac | apply IHt]; elim H; intros H1 [H2 H3]; auto.
-Qed.
-
-Lemma noRead_by_path:
- forall (b t : Moves) (r0 r1 r7 r8 : Reg),
- simpleDest ((r7, r8) :: (b ++ ((r0, r1) :: nil))) ->
- path (b ++ ((r0, r1) :: nil)) -> Loc.diff r8 r0 -> noRead b r8.
-Proof.
-intros; induction b as [|a b Hrecb]; simpl; auto.
-destruct a as [a1 a2]; generalize H H0; rewrite app_cons; intros; split.
-simpl in H3 |-; caseEq (b ++ ((r0, r1) :: nil)); intro.
-destruct b; inversion H4.
-intros l H4.
-rewrite H4 in H3.
-destruct m.
-rewrite H4 in H2; simpl in H2 |-.
-elim H3; [intros H5 H6; (try clear H3); (try exact H5)].
-rewrite H5.
-elim H2; intros [H3 [H7 H8]] [H9 [H10 H11]]; (try assumption).
-apply Hrecb.
-apply (simpleDest_pop (a1, a2)); apply simpleDest_swap; auto.
-apply (path_pop (a1, a2)); auto.
-Qed.
-
-Lemma noOverlap_swap:
- forall (m1 m2 : Move) (l : Moves),
- noOverlap (m1 :: (m2 :: l)) -> noOverlap (m2 :: (m1 :: l)).
-Proof.
-intros m1 m2 l; simpl; destruct m1 as [m1s m1d]; destruct m2 as [m2s m2d].
-unfold noOverlap; simpl; intros.
-assert (m1s = l0 \/ (m2s = l0 \/ In l0 (getsrc l))).
-elim H0; [intros H1 | intros [H1|H2]].
-right; left; (try assumption).
-left; (try assumption).
-right; right; (try assumption).
-(repeat split);
- (elim (H l0); [intros H2 H3; elim H3; [intros H4 H5] | idtac]; auto).
-Qed.
-
-Lemma getsrc_add1:
- forall (r1 r2 : Reg) (l1 l2 : Moves),
- getsrc (l1 ++ ((r1, r2) :: l2)) = getsrc l1 ++ (r1 :: getsrc l2).
-Proof.
-intros r1 r2 l1 l2; induction l1; simpl; auto.
-destruct a; simpl; rewrite IHl1; auto.
-Qed.
-
-Lemma getsrc_app:
- forall (l1 l2 : Moves), getsrc (l1 ++ l2) = getsrc l1 ++ getsrc l2.
-Proof.
-intros; induction l1; simpl; auto.
-destruct a; simpl; rewrite IHl1; auto.
-Qed.
-
-Lemma Ingetsrc_swap:
- forall (m : Move) (l1 l2 : Moves) (l : Reg),
- In l (getsrc (m :: (l1 ++ l2))) -> In l (getsrc (l1 ++ (m :: l2))).
-Proof.
-intros; destruct m as [m1 m2]; simpl; auto.
-simpl in H |-.
-elim H; intros H0; auto.
-rewrite H0; rewrite getsrc_add1; auto.
-apply (in_or_app (getsrc l1) (l :: getsrc l2)); auto.
-right; apply in_eq; auto.
-apply getsrc_add; auto.
-Qed.
-
-Lemma noOverlap_movFront:
- forall (p1 p2 : Moves) (m : Move),
- noOverlap (p1 ++ (m :: p2)) -> noOverlap (m :: (p1 ++ p2)).
-Proof.
-intros p1 p2 m; unfold noOverlap.
-destruct m; rewrite getdst_add; simpl getdst; rewrite getdst_app; intros.
-apply noOverlapaux_swap2.
-apply (H l); apply Ingetsrc_swap; auto.
-Qed.
-
-Lemma step_inv_loop_aux:
- forall (t l : Moves) (s d : Reg),
- simpleDest (t ++ ((s, d) :: nil)) ->
- noTmp t ->
- forall (e : Env) (r : Reg),
- notemporary r ->
- d = r \/ Loc.diff d r ->
- get (pexec (t ++ ((s, d) :: nil)) (sexec l e)) r =
- get (pexec (t ++ ((T s, d) :: nil)) (sexec ((s, T s) :: l) e)) r.
-Proof.
-intros; (repeat rewrite pexec_movFront); auto.
-(repeat rewrite app_nil); simpl; elim H2; intros e1.
-subst d; (repeat rewrite get_update_id); auto.
-(repeat rewrite get_update_diff); auto.
-rewrite pexec_update; auto.
-apply Loc.diff_sym; unfold notemporary in H1 |-; auto.
-apply noTmp_noReadTmp; auto.
-apply (simpleDest_tmpLast t s); auto.
-Qed.
-
-Lemma step_inv_loop:
- forall (t l : Moves) (s d : Reg),
- simpleDest (t ++ ((s, d) :: nil)) ->
- noTmpLast (t ++ ((s, d) :: nil)) ->
- forall (e : Env) (r : Reg),
- notemporary r ->
- d = r \/ Loc.diff d r ->
- get (pexec (t ++ ((s, d) :: nil)) (sexec l e)) r =
- get (pexec (t ++ ((T s, d) :: nil)) (sexec ((s, T s) :: l) e)) r.
-Proof.
-intros; apply step_inv_loop_aux; auto.
-apply (noTmpLast_popBack t (s, d)); auto.
-Qed.
-
-Definition sameExec (s1 s2 : State) :=
- forall (e : Env) (r : Reg),
- (let A :=
- getdst
- ((StateToMove s1 ++ StateBeing s1) ++ (StateToMove s2 ++ StateBeing s2))
- in
- notemporary r ->
- (forall x, In x A -> r = x \/ Loc.diff r x) ->
- get (exec s1 e) r = get (exec s2 e) r).
-
-Lemma get_noWrite:
- forall (t : Moves) (d : Reg),
- noWrite t d -> forall (e : Env), get e d = get (pexec t e) d.
-Proof.
-intros; induction t as [|a t Hrect]; simpl; auto.
-generalize H; destruct a as [a1 a2]; simpl; intros [NEQ R].
-unfold get, Locmap.get, update, Locmap.set.
-case (Loc.eq a2 d); intro; auto.
-absurd (a2 = d); auto; apply Loc.diff_not_eq; (try assumption).
-caseEq (Loc.overlap a2 d); intro.
-absurd (Loc.diff a2 d); auto; apply Loc.overlap_not_diff; auto.
-unfold get, Locmap.get in Hrect |-; apply Hrect; auto.
-Qed.
-
-Lemma step_sameExec:
- forall (r1 r2 : State), step r1 r2 -> stepInv r1 -> sameExec r1 r2.
-Proof.
-intros r1 r2 STEP; inversion STEP;
- unfold stepInv, sameExec, NoOverlap, exec, StateToMove, StateBeing, StateDone;
- (repeat rewrite app_nil); intros [P [SD [NO [TT TB]]]]; intros.
-rewrite pexec_movFront; simpl; auto.
-case (Loc.eq r r0); intros e0.
-subst r0; rewrite get_update_id; apply get_noWrite; apply sD_nW with r;
- apply simpleDest_movFront; auto.
-elim H2 with ( x := r );
- [intros H3; absurd (r = r0); auto |
- intros H3; rewrite get_update_diff; auto; apply Loc.diff_sym; auto | idtac].
-(repeat (rewrite getdst_app; simpl)); apply in_or_app; left; apply in_or_app;
- right; simpl; auto.
-(repeat rewrite pexec_movFront); auto.
-rewrite app_nil; auto.
-apply simpleDest_movBack; auto.
-apply pexec_mov; auto.
-repeat (rewrite <- app_cons; rewrite app_app).
-apply step_inv_loop; auto.
-repeat (rewrite <- app_app; rewrite app_cons; auto).
-repeat (rewrite <- app_app; rewrite app_cons; auto).
-apply noTmp_app; auto.
-elim H2 with ( x := d );
- [intros H3; left; auto | intros H3; right; apply Loc.diff_sym; auto
- | try clear H2].
-repeat (rewrite getdst_app; simpl).
-apply in_or_app; left; apply in_or_app; right; simpl; right; apply in_or_app;
- right; simpl; left; trivial.
-rewrite pexec_movFront; auto; apply pexec_push; auto.
-apply noRead_app; auto.
-apply noRead_app.
-apply (noRead_by_path b b s0 d0 sn dn); auto.
-apply (simpleDest_right t); auto.
-apply (path_pop (sn, dn)); auto.
-simpl; split; [apply Loc.diff_sym | idtac]; auto.
-apply simpleDest_movFront; auto.
-elim H4 with ( x := dn ); [intros H5 | intros H5 | try clear H4].
-left; (try assumption).
-right; apply Loc.diff_sym; (try assumption).
-repeat (rewrite getdst_app; simpl).
-apply in_or_app; left; apply in_or_app; right; simpl; left; trivial.
-rewrite pexec_movFront; auto.
-rewrite app_nil; auto.
-apply pexec_push; auto.
-rewrite <- (app_nil _ t).
-apply simpleDest_movFront; auto.
-elim (H3 d); (try intros H4).
-left; (try assumption).
-right; apply Loc.diff_sym; (try assumption).
-(repeat rewrite getdst_app); simpl; apply in_or_app; left; apply in_or_app;
- right; simpl; left; trivial.
-Qed.
-
-Lemma path_tmpLast:
- forall (s d : Reg) (l : Moves),
- path (l ++ ((s, d) :: nil)) -> path (l ++ ((T s, d) :: nil)).
-Proof.
-intros; induction l as [|a l Hrecl].
-simpl; auto.
-generalize H; (repeat rewrite app_cons).
-case a; generalize Hrecl; case l; intros; auto.
-destruct m; intros.
-inversion H0; split; auto.
-Qed.
-
-Lemma step_inv_path:
- forall (r1 r2 : State), step r1 r2 -> stepInv r1 -> path (StateBeing r2).
-Proof.
-intros r1 r2 STEP; inversion_clear STEP; unfold stepInv;
- unfold stepInv, sameExec, sameEnv, exec, StateToMove, StateBeing, StateDone;
- intros [P [SD [TT TB]]]; (try (simpl; auto; fail)).
-simpl; case m; auto.
-generalize P; rewrite <- app_cons; rewrite <- app_cons.
-apply (path_tmpLast r0).
-generalize P; apply path_pop.
-Qed.
-
-Lemma step_inv_simpleDest:
- forall (r1 r2 : State),
- step r1 r2 -> stepInv r1 -> simpleDest (StateToMove r2 ++ StateBeing r2).
-Proof.
-intros r1 r2 STEP; inversion_clear STEP; unfold stepInv;
- unfold stepInv, sameExec, sameEnv, exec, StateToMove, StateBeing, StateDone;
- (repeat rewrite app_nil); intros [P [SD [TT TB]]].
-apply (simpleDest_Pop (r, r)); assumption.
-apply simpleDest_movBack; assumption.
-apply simpleDest_insert; rewrite <- app_app; apply simpleDest_movFront.
-rewrite <- app_cons; rewrite app_app; auto.
-generalize SD; (repeat rewrite <- app_cons); (repeat rewrite app_app).
-generalize (simpleDest_tmpLast (t ++ ((s, r0ounon) :: b)) r0 d); auto.
-generalize SD; apply simpleDest_Pop.
-rewrite <- (app_nil _ t); generalize SD; apply simpleDest_Pop.
-Qed.
-
-Lemma noTmp_pop:
- forall (m : Move) (l1 l2 : Moves), noTmp (l1 ++ (m :: l2)) -> noTmp (l1 ++ l2).
-Proof.
-intros; induction l1 as [|a l1 Hrecl1]; generalize H.
-simpl; case m; intros; inversion H0; inversion H2; auto.
-rewrite app_cons; rewrite app_cons; simpl; case a.
-intros; inversion H0; inversion H2; auto.
-Qed.
-
-Lemma step_inv_noTmp:
- forall (r1 r2 : State), step r1 r2 -> stepInv r1 -> noTmp (StateToMove r2).
-Proof.
-intros r1 r2 STEP; inversion_clear STEP; unfold stepInv;
- unfold stepInv, sameExec, sameEnv, exec, StateToMove, StateBeing, StateDone;
- intros [P [SD [NO [TT TB]]]]; generalize TT; (try apply noTmp_pop); auto.
-Qed.
-
-Lemma noTmp_noTmpLast: forall (l : Moves), noTmp l -> noTmpLast l.
-Proof.
-intros; induction l as [|a l Hrecl]; (try (simpl; auto; fail)).
-generalize H; simpl; case a; generalize Hrecl; case l;
- (intros; inversion H0; inversion H2; auto).
-Qed.
-
-Lemma noTmpLast_pop:
- forall (m : Move) (l : Moves), noTmpLast (m :: l) -> noTmpLast l.
-Proof.
-intros m l; simpl; case m; case l.
-simpl; auto.
-intros; inversion H; inversion H1; auto.
-Qed.
-
-Lemma noTmpLast_Pop:
- forall (m : Move) (l1 l2 : Moves),
- noTmpLast (l1 ++ (m :: l2)) -> noTmpLast (l1 ++ l2).
-Proof.
-intros; induction l1 as [|a l1 Hrecl1]; generalize H.
-simpl; case m; case l2.
-simpl; auto.
-intros.
-elim H0; [intros H1 H2; elim H2; [intros H3 H4; (try exact H4)]].
-(repeat rewrite app_cons); simpl; case a.
-generalize Hrecl1; case l1.
-simpl; case m; case l2; intros; inversion H0; inversion H2; auto.
-intros m0 l R r r0; rewrite app_cons; rewrite app_cons.
-intros; inversion H0; inversion H2; auto.
-Qed.
-
-Lemma noTmpLast_push:
- forall (m : Move) (t1 t2 t3 : Moves),
- noTmp (t1 ++ (m :: t2)) -> noTmpLast t3 -> noTmpLast (m :: t3).
-Proof.
-intros; induction t1 as [|a t1 Hrect1]; generalize H.
-simpl; case m; intros r r0 [N1 [N2 NT]]; generalize H0; case t3; auto.
-rewrite app_cons; intros; apply Hrect1.
-generalize H1.
-simpl; case m; case a; intros; inversion H2; inversion H4; auto.
-Qed.
-
-Lemma noTmpLast_tmpLast:
- forall (s d : Reg) (l : Moves),
- noTmpLast (l ++ ((s, d) :: nil)) -> noTmpLast (l ++ ((T s, d) :: nil)).
+Definition exec_seq (m: moves) (e: Locmap.t) : Locmap.t :=
+ Parmov.exec_seq loc val Loc.eq m e.
+
+Lemma temp_for_charact:
+ forall l, temp_for l = R IT2 \/ temp_for l = R FT2.
Proof.
-intros; induction l as [|a l Hrecl].
-simpl; auto.
-generalize H; rewrite app_cons; rewrite app_cons; simpl.
-case a; generalize Hrecl; case l.
-simpl; auto.
-intros m l0 REC r r0; generalize REC; rewrite app_cons; rewrite app_cons.
-case m; intros; inversion H0; inversion H2; split; auto.
+ intro; unfold temp_for. destruct (Loc.type l); tauto.
Qed.
-
-Lemma step_inv_noTmpLast:
- forall (r1 r2 : State), step r1 r2 -> stepInv r1 -> noTmpLast (StateBeing r2).
-Proof.
-intros r1 r2 STEP; inversion_clear STEP; unfold stepInv;
- unfold stepInv, sameExec, sameEnv, exec, StateToMove, StateBeing, StateDone;
- intros [P [SD [NO [TT TB]]]]; auto.
-apply (noTmpLast_push m t1 t2); auto.
-apply (noTmpLast_push (d, r) t1 t2); auto.
-generalize TB; rewrite <- app_cons; rewrite <- app_cons; apply noTmpLast_tmpLast.
-apply (noTmpLast_pop (sn, dn)); auto.
-Qed.
-
-Lemma noOverlapaux_insert:
- forall (l1 l2 : list Reg) (r x : Reg),
- noOverlap_aux x (r :: (l1 ++ l2)) -> noOverlap_aux x (l1 ++ (r :: l2)).
-Proof.
-simpl; intros; induction l1; simpl; split.
-elim H; [intros H0 H1; (try exact H0)].
-elim H; [intros H0 H1; (try exact H1)].
-simpl in H |-.
-elim H;
- [intros H0 H1; elim H1; [intros H2 H3; (try clear H1 H); (try exact H2)]].
-apply IHl1.
-split.
-elim H; [intros H0 H1; (try exact H0)].
-rewrite app_cons in H.
-apply noOverlap_auxpop with ( r := a ).
-elim H; [intros H0 H1; (try exact H1)].
-Qed.
-
-Lemma Ingetsrc_swap2:
- forall (m : Move) (l1 l2 : Moves) (l : Reg),
- In l (getsrc (l1 ++ (m :: l2))) -> In l (getsrc (m :: (l1 ++ l2))).
-Proof.
-intros; destruct m as [m1 m2]; simpl; auto.
-induction l1; simpl.
-simpl in H |-; auto.
-destruct a; simpl.
-simpl in H |-.
-elim H; [intros H0 | intros H0; (try exact H0)].
-right; left; (try assumption).
-elim IHl1; intros; auto.
-Qed.
-
-Lemma noOverlap_insert:
- forall (p1 p2 : Moves) (m : Move),
- noOverlap (m :: (p1 ++ p2)) -> noOverlap (p1 ++ (m :: p2)).
-Proof.
-unfold noOverlap; destruct m; rewrite getdst_add; simpl getdst;
- rewrite getdst_app.
-intros.
-apply noOverlapaux_insert.
-generalize (H l); intros H1; lapply H1;
- [intros H2; (try clear H1); (try exact H2) | idtac].
-simpl getsrc.
-generalize (Ingetsrc_swap2 (r, r0)); simpl; (intros; auto).
-Qed.
-
-Lemma noOverlap_movBack:
- forall (p1 p2 : Moves) (m : Move),
- noOverlap (p1 ++ (m :: p2)) -> noOverlap ((p1 ++ p2) ++ (m :: nil)).
-Proof.
-intros.
-apply (noOverlap_insert (p1 ++ p2) nil m).
-rewrite app_nil; apply noOverlap_movFront; auto.
-Qed.
-
-Lemma noOverlap_movBack0:
- forall (t : Moves) (s d : Reg),
- noOverlap ((s, d) :: t) -> noOverlap (t ++ ((s, d) :: nil)).
-Proof.
-intros t s d H; (try assumption).
-apply noOverlap_insert.
-rewrite app_nil; auto.
-Qed.
-
-Lemma noOverlap_Front0:
- forall (t : Moves) (s d : Reg),
- noOverlap (t ++ ((s, d) :: nil)) -> noOverlap ((s, d) :: t).
-Proof.
-intros t s d H; (try assumption).
-cut ((s, d) :: t = (s, d) :: (t ++ nil)).
-intros e; rewrite e.
-apply noOverlap_movFront; auto.
-rewrite app_nil; auto.
-Qed.
-
-Lemma noTmpL_diff:
- forall (t : Moves) (s d : Reg),
- noTmpLast (t ++ ((s, d) :: nil)) -> notemporary d.
-Proof.
-intros t s d; unfold notemporary; induction t; (try (simpl; intros; auto; fail)).
-rewrite app_cons.
-intros; apply IHt.
-apply (noTmpLast_pop a); auto.
-Qed.
-
-Lemma noOverlap_aux_app:
- forall l1 l2 (r : Reg),
- noOverlap_aux r l1 -> noOverlap_aux r l2 -> noOverlap_aux r (l1 ++ l2).
-Proof.
-induction l1; simpl; auto.
-intros; split.
-elim H; [intros H1 H2; (try clear H); (try exact H1)].
-apply IHl1; auto.
-elim H; [intros H1 H2; (try clear H); (try exact H2)].
-Qed.
-
-Lemma noTmP_noOverlap_aux:
- forall t (r : Reg), noTmp t -> noOverlap_aux (T r) (getdst t).
-Proof.
-induction t; simpl; auto.
-destruct a; simpl; (intros; split).
-elim H; intros; elim H1; intros.
-right; apply H2.
-apply IHt; auto.
-elim H;
- [intros H0 H1; elim H1; [intros H2 H3; (try clear H1 H); (try exact H3)]].
-Qed.
-
-Lemma noTmp_append: forall l1 l2, noTmp l1 -> noTmp l2 -> noTmp (l1 ++ l2).
-Proof.
-induction l1; simpl; auto.
-destruct a.
-intros l2 [H1 [H2 H3]] H4.
-(repeat split); auto.
-Qed.
-
-Lemma step_inv_noOverlap:
- forall (r1 r2 : State),
- step r1 r2 -> stepInv r1 -> noOverlap (StateToMove r2 ++ StateBeing r2).
-Proof.
-intros r1 r2 STEP; inversion_clear STEP; unfold stepInv;
- unfold stepInv, sameExec, sameEnv, exec, StateToMove, StateBeing, StateDone;
- (repeat rewrite app_nil); intros [P [SD [NO [TT TB]]]];
- (try (generalize NO; apply noOverlap_Pop; auto; fail)).
-apply noOverlap_movBack; auto.
-apply noOverlap_insert; rewrite <- app_app; apply noOverlap_movFront;
- rewrite <- app_cons; rewrite app_app; auto.
-generalize NO; (repeat rewrite <- app_cons); (repeat rewrite app_app);
- (clear NO; intros NO); apply noOverlap_movBack0.
-assert (noOverlap ((r0, d) :: (t ++ ((s, r0ounon) :: b))));
- [apply noOverlap_Front0; auto | idtac].
-generalize H; unfold noOverlap; simpl; clear H; intros.
-elim H0; intros; [idtac | apply (H l0); (right; (try assumption))].
-split; [right; (try assumption) | idtac].
-generalize TB; simpl; caseEq (b ++ ((r0, d) :: nil)); intro.
-elim (app_eq_nil b ((r0, d) :: nil)); intros; auto; inversion H4.
-subst l0; intros; rewrite <- H1 in TB0.
-elim TB0; [intros H2 H3; elim H3; [intros H4 H5; (try clear H3 TB0)]].
-generalize (noTmpL_diff b r0 d); unfold notemporary; intro; apply H3; auto.
-rewrite <- H1; apply noTmP_noOverlap_aux; apply noTmp_append; auto;
- rewrite <- app_cons in TB; apply noTmpLast_popBack with (r0, d); auto.
-rewrite <- (app_nil _ t); apply (noOverlap_Pop (s, d)); assumption.
-Qed.
-
-Lemma step_inv: forall (r1 r2 : State), step r1 r2 -> stepInv r1 -> stepInv r2.
-Proof.
-intros; unfold stepInv; (repeat split).
-apply (step_inv_path r1 r2); auto.
-apply (step_inv_simpleDest r1 r2); auto.
-apply (step_inv_noOverlap r1 r2); auto.
-apply (step_inv_noTmp r1 r2); auto.
-apply (step_inv_noTmpLast r1 r2); auto.
-Qed.
-
-Definition step_NF (r : State) : Prop := ~ (exists s : State , step r s ).
-
-Inductive stepp : State -> State -> Prop :=
- stepp_refl: forall (r : State), stepp r r
- | stepp_trans:
- forall (r1 r2 r3 : State), step r1 r2 -> stepp r2 r3 -> stepp r1 r3 .
-Hint Resolve stepp_refl stepp_trans .
-
-Lemma stepp_transitive:
- forall (r1 r2 r3 : State), stepp r1 r2 -> stepp r2 r3 -> stepp r1 r3.
-Proof.
-intros; induction H as [r|r1 r2 r0 H H1 HrecH]; eauto.
-Qed.
-
-Lemma step_stepp: forall (s1 s2 : State), step s1 s2 -> stepp s1 s2.
-Proof.
-eauto.
-Qed.
-
-Lemma stepp_inv:
- forall (r1 r2 : State), stepp r1 r2 -> stepInv r1 -> stepInv r2.
-Proof.
-intros; induction H as [r|r1 r2 r3 H H1 HrecH]; auto.
-apply HrecH; auto.
-apply (step_inv r1 r2); auto.
-Qed.
-
-Lemma noTmpLast_lastnoTmp:
- forall l s d, noTmpLast (l ++ ((s, d) :: nil)) -> notemporary d.
-Proof.
-induction l.
-simpl.
-intros; unfold notemporary; auto.
-destruct a as [a1 a2]; intros.
-change (noTmpLast ((a1, a2) :: (l ++ ((s, d) :: nil)))) in H |-.
-apply IHl with s.
-apply noTmpLast_pop with (a1, a2); auto.
+
+Lemma is_not_temp_charact:
+ forall l,
+ Parmov.is_not_temp loc temp_for l <-> l <> R IT2 /\ l <> R FT2.
+Proof.
+ intros. unfold Parmov.is_not_temp.
+ destruct (Loc.eq l (R IT2)).
+ subst l. intuition. apply (H (R IT2)). reflexivity. discriminate.
+ destruct (Loc.eq l (R FT2)).
+ subst l. intuition. apply (H (R FT2)). reflexivity.
+ assert (forall d, l <> temp_for d).
+ intro. elim (temp_for_charact d); congruence.
+ intuition.
Qed.
-
-Lemma step_inv_NoOverlap:
- forall (s1 s2 : State) r,
- step s1 s2 -> notemporary r -> stepInv s1 -> NoOverlap r s1 -> NoOverlap r s2.
+
+Lemma disjoint_temp_not_temp:
+ forall l, Loc.notin l temporaries -> Parmov.is_not_temp loc temp_for l.
Proof.
-intros s1 s2 r STEP notempr; inversion_clear STEP; unfold stepInv;
- unfold stepInv, sameExec, sameEnv, exec, StateToMove, StateBeing, StateDone;
- intros [P [SD [NO [TT TB]]]]; unfold NoOverlap; simpl.
-simpl; (repeat rewrite app_nil); simpl; (repeat rewrite <- app_cons); intro;
- apply noOverlap_Pop with ( m := (r0, r0) ); auto.
-(repeat rewrite app_nil); simpl; rewrite app_ass; (repeat rewrite <- app_cons);
- intro; rewrite ass_app; apply noOverlap_movBack; auto.
-simpl; (repeat (rewrite app_ass; simpl)); (repeat rewrite <- app_cons); intro.
-rewrite ass_app; apply noOverlap_insert; rewrite app_ass;
- apply noOverlap_movFront; auto.
-simpl; (repeat rewrite <- app_cons); intro; rewrite ass_app;
- apply noOverlap_movBack0; auto.
-generalize H; (repeat (rewrite app_ass; simpl)); intro.
-assert (noOverlap ((r0, d) :: (((r, r) :: t) ++ ((s, r0ounon) :: b))));
- [apply noOverlap_Front0 | idtac]; auto.
-generalize H0; (repeat (rewrite app_ass; simpl)); auto.
-generalize H1; unfold noOverlap; simpl; intros.
-elim H3; intros H4; clear H3.
-split.
-right; assert (notemporary d).
-change (noTmpLast (((s, r0ounon) :: b) ++ ((r0, d) :: nil))) in TB |-;
- apply (noTmpLast_lastnoTmp ((s, r0ounon) :: b) r0); auto.
-rewrite <- H4; unfold notemporary in H3 |-; apply H3.
-split.
-right; rewrite <- H4; unfold notemporary in notempr |-; apply notempr.
-rewrite <- H4; apply noTmP_noOverlap_aux; auto.
-apply noTmp_append; auto.
-change (noTmpLast (((s, r0ounon) :: b) ++ ((r0, d) :: nil))) in TB |-;
- apply noTmpLast_popBack with ( m := (r0, d) ); auto.
-apply (H2 l0).
-elim H4; intros H3; right; [left | right]; assumption.
-intro;
- change (noOverlap (((r, r) :: t) ++ ((sn, dn) :: (b ++ ((s0, d0) :: nil))))) in
- H1 |-.
-change (noOverlap (((r, r) :: t) ++ (b ++ ((s0, d0) :: nil))));
- apply (noOverlap_Pop (sn, dn)); auto.
-(repeat rewrite <- app_cons); apply noOverlap_Pop.
+ intros. rewrite is_not_temp_charact.
+ unfold temporaries in H; simpl in H.
+ split; apply Loc.diff_not_eq; tauto.
Qed.
-
-Lemma step_inv_getdst:
- forall (s1 s2 : State) r,
- step s1 s2 ->
- In r (getdst (StateToMove s2 ++ StateBeing s2)) ->
- In r (getdst (StateToMove s1 ++ StateBeing s1)).
+
+Lemma loc_norepet_norepet:
+ forall l, Loc.norepet l -> list_norepet l.
Proof.
-intros s1 s2 r STEP; inversion_clear STEP;
- unfold StateToMove, StateBeing, StateDone.
-(repeat rewrite getdst_app); simpl; (repeat rewrite app_nil); intro;
- apply in_or_app.
-elim (in_app_or (getdst t1) (getdst t2) r); auto.
-intro; right; simpl; right; assumption.
-(repeat rewrite getdst_app); destruct m as [m1 m2]; simpl;
- (repeat rewrite app_nil); intro; apply in_or_app.
-elim (in_app_or (getdst t1 ++ getdst t2) (m2 :: nil) r); auto; intro.
-elim (in_app_or (getdst t1) (getdst t2) r); auto; intro.
-right; simpl; right; assumption.
-elim H0; intros H1; [right; simpl; left; (try assumption) | inversion H1].
-(repeat rewrite getdst_app); simpl; (repeat rewrite app_nil); intro;
- apply in_or_app.
-elim (in_app_or (getdst t1 ++ getdst t2) (r0 :: (d :: getdst b)) r); auto;
- intro.
-elim (in_app_or (getdst t1) (getdst t2) r); auto; intro.
-left; apply in_or_app; left; assumption.
-left; apply in_or_app; right; simpl; right; assumption.
-elim H0; intro.
-left; apply in_or_app; right; simpl; left; trivial.
-elim H1; intro.
-right; (simpl; left; trivial).
-right; simpl; right; assumption.
-(repeat (rewrite getdst_app; simpl)); trivial.
-(repeat (rewrite getdst_app; simpl)); intro.
-elim (in_app_or (getdst t) (getdst b ++ (d0 :: nil)) r); auto; intro;
- apply in_or_app; auto.
-elim (in_app_or (getdst b) (d0 :: nil) r); auto; intro.
-right; simpl; right; apply in_or_app; auto.
-elim H3; intro.
-right; simpl; right; apply in_or_app; right; simpl; auto.
-inversion H4.
-rewrite app_nil; (repeat (rewrite getdst_app; simpl)); intro.
-apply in_or_app; left; assumption.
+ induction 1; constructor.
+ apply Loc.notin_not_in; auto. auto.
Qed.
-
-Lemma stepp_sameExec:
- forall (r1 r2 : State), stepp r1 r2 -> stepInv r1 -> sameExec r1 r2.
-Proof.
-intros; induction H as [r|r1 r2 r3 H H1 HrecH].
-unfold sameExec; intros; auto.
-cut (sameExec r1 r2); [idtac | apply (step_sameExec r1); auto].
-unfold sameExec; unfold sameExec in HrecH |-; intros.
-rewrite H2; auto.
-rewrite HrecH; auto.
-apply (step_inv r1); auto.
-intros x H5; apply H4.
-generalize H5; (repeat rewrite getdst_app); intros; apply in_or_app.
-elim
- (in_app_or
- (getdst (StateToMove r2) ++ getdst (StateBeing r2))
- (getdst (StateToMove r3) ++ getdst (StateBeing r3)) x); auto; intro.
-generalize (step_inv_getdst r1 r2 x); (repeat rewrite getdst_app); intro.
-left; apply H8; auto.
-intros x H5; apply H4.
-generalize H5; (repeat rewrite getdst_app); intros; apply in_or_app.
-elim
- (in_app_or
- (getdst (StateToMove r1) ++ getdst (StateBeing r1))
- (getdst (StateToMove r2) ++ getdst (StateBeing r2)) x); auto; intro.
-generalize (step_inv_getdst r1 r2 x); (repeat rewrite getdst_app); intro.
-left; apply H8; auto.
+
+Lemma parmove_prop_1:
+ forall srcs dsts,
+ List.length srcs = List.length dsts ->
+ Loc.norepet dsts ->
+ Loc.disjoint srcs temporaries ->
+ Loc.disjoint dsts temporaries ->
+ forall e,
+ let e' := exec_seq (parmove srcs dsts) e in
+ List.map e' dsts = List.map e srcs /\
+ forall l, ~In l dsts -> l <> R IT2 -> l <> R FT2 -> e' l = e l.
+Proof.
+ intros.
+ assert (NR: list_norepet dsts) by (apply loc_norepet_norepet; auto).
+ assert (NTS: forall r, In r srcs -> Parmov.is_not_temp loc temp_for r).
+ intros. apply disjoint_temp_not_temp. apply Loc.disjoint_notin with srcs; auto.
+ assert (NTD: forall r, In r dsts -> Parmov.is_not_temp loc temp_for r).
+ intros. apply disjoint_temp_not_temp. apply Loc.disjoint_notin with dsts; auto.
+ generalize (Parmov.parmove2_correctness loc temp_for val Loc.eq srcs dsts H NR NTS NTD e).
+ change (Parmov.exec_seq loc val Loc.eq (Parmov.parmove2 loc temp_for Loc.eq srcs dsts) e) with e'.
+ intros [A B].
+ split. auto. intros. apply B. auto. rewrite is_not_temp_charact; auto.
Qed.
-
-Inductive dstep : State -> State -> Prop :=
- dstep_nop:
- forall (r : Reg) (t l : Moves), dstep ((r, r) :: t, nil, l) (t, nil, l)
- | dstep_start:
- forall (t l : Moves) (s d : Reg),
- s <> d -> dstep ((s, d) :: t, nil, l) (t, (s, d) :: nil, l)
- | dstep_push:
- forall (t1 t2 b l : Moves) (s d r : Reg),
- noRead t1 d ->
- dstep
- (t1 ++ ((d, r) :: t2), (s, d) :: b, l)
- (t1 ++ t2, (d, r) :: ((s, d) :: b), l)
- | dstep_pop_loop:
- forall (t b l : Moves) (s d r0 : Reg),
- noRead t r0 ->
- dstep
- (t, (s, r0) :: (b ++ ((r0, d) :: nil)), l)
- (t, b ++ ((T r0, d) :: nil), (s, r0) :: ((r0, T r0) :: l))
- | dstep_pop:
- forall (t b l : Moves) (s0 d0 sn dn : Reg),
- noRead t dn ->
- Loc.diff dn s0 ->
- dstep
- (t, (sn, dn) :: (b ++ ((s0, d0) :: nil)), l)
- (t, b ++ ((s0, d0) :: nil), (sn, dn) :: l)
- | dstep_last:
- forall (t l : Moves) (s d : Reg),
- noRead t d -> dstep (t, (s, d) :: nil, l) (t, nil, (s, d) :: l) .
-Hint Resolve dstep_nop dstep_start dstep_push .
-Hint Resolve dstep_pop_loop dstep_pop dstep_last .
-
-Lemma dstep_step:
- forall (r1 r2 : State), dstep r1 r2 -> stepInv r1 -> stepp r1 r2.
-Proof.
-intros r1 r2 DS; inversion_clear DS; intros SI; eauto.
-change (stepp (nil ++ ((r, r) :: t), nil, l) (t, nil, l)); apply step_stepp;
- apply (step_nop r nil t).
-change (stepp (nil ++ ((s, d) :: t), nil, l) (t, (s, d) :: nil, l));
- apply step_stepp; apply (step_start nil t l).
-apply
- (stepp_trans
- (t, (s, r0) :: (b ++ ((r0, d) :: nil)), l)
- (t, (s, r0) :: (b ++ ((T r0, d) :: nil)), (r0, T r0) :: l)
- (t, b ++ ((T r0, d) :: nil), (s, r0) :: ((r0, T r0) :: l))); auto.
-apply step_stepp; apply step_pop; auto.
-unfold stepInv in SI |-; generalize SI; intros [X [Y [Z [U V]]]].
-generalize V; unfold StateBeing, noTmpLast.
-case (b ++ ((r0, d) :: nil)); auto.
-intros m l0 [R1 [OK PP]]; auto.
+
+Lemma parmove_prop_2:
+ forall srcs dsts s d,
+ In (s, d) (parmove srcs dsts) ->
+ (In s srcs \/ s = R IT2 \/ s = R FT2)
+ /\ (In d dsts \/ d = R IT2 \/ d = R FT2).
+Proof.
+ intros srcs dsts.
+ set (mu := List.combine srcs dsts).
+ assert (forall s d, Parmov.wf_move loc temp_for mu s d ->
+ (In s srcs \/ s = R IT2 \/ s = R FT2)
+ /\ (In d dsts \/ d = R IT2 \/ d = R FT2)).
+ unfold mu; induction 1.
+ split.
+ left. eapply List.in_combine_l; eauto.
+ left. eapply List.in_combine_r; eauto.
+ split.
+ right. apply temp_for_charact.
+ tauto.
+ split.
+ tauto.
+ right. apply temp_for_charact.
+ intros. apply H.
+ apply (Parmov.parmove2_wf_moves loc temp_for Loc.eq srcs dsts s d H0).
Qed.
-
-Lemma dstep_inv:
- forall (r1 r2 : State), dstep r1 r2 -> stepInv r1 -> stepInv r2.
+
+Lemma loc_type_temp_for:
+ forall l, Loc.type (temp_for l) = Loc.type l.
Proof.
-intros.
-apply (stepp_inv r1 r2); auto.
-apply dstep_step; auto.
+ intros; unfold temp_for. destruct (Loc.type l); reflexivity.
Qed.
-
-Inductive dstepp : State -> State -> Prop :=
- dstepp_refl: forall (r : State), dstepp r r
- | dstepp_trans:
- forall (r1 r2 r3 : State), dstep r1 r2 -> dstepp r2 r3 -> dstepp r1 r3 .
-Hint Resolve dstepp_refl dstepp_trans .
-
-Lemma dstepp_stepp:
- forall (s1 s2 : State), stepInv s1 -> dstepp s1 s2 -> stepp s1 s2.
-Proof.
-intros; induction H0 as [r|r1 r2 r3 H0 H1 HrecH0]; auto.
-apply (stepp_transitive r1 r2 r3); auto.
-apply dstep_step; auto.
-apply HrecH0; auto.
-apply (dstep_inv r1 r2); auto.
+
+Lemma loc_type_combine:
+ forall srcs dsts,
+ List.map Loc.type srcs = List.map Loc.type dsts ->
+ forall s d,
+ In (s, d) (List.combine srcs dsts) ->
+ Loc.type s = Loc.type d.
+Proof.
+ induction srcs; destruct dsts; simpl; intros; try discriminate.
+ elim H0.
+ elim H0; intros. inversion H1; subst. congruence.
+ apply IHsrcs with dsts. congruence. auto.
Qed.
-
-Lemma dstepp_sameExec:
- forall (r1 r2 : State), dstepp r1 r2 -> stepInv r1 -> sameExec r1 r2.
-Proof.
-intros; apply stepp_sameExec; auto.
-apply dstepp_stepp; auto.
+
+Lemma parmove_prop_3:
+ forall srcs dsts,
+ List.map Loc.type srcs = List.map Loc.type dsts ->
+ forall s d,
+ In (s, d) (parmove srcs dsts) -> Loc.type s = Loc.type d.
+Proof.
+ intros srcs dsts TYP.
+ set (mu := List.combine srcs dsts).
+ assert (forall s d, Parmov.wf_move loc temp_for mu s d ->
+ Loc.type s = Loc.type d).
+ unfold mu; induction 1.
+ eapply loc_type_combine; eauto.
+ rewrite loc_type_temp_for; auto.
+ rewrite loc_type_temp_for; auto.
+ intros. apply H.
+ apply (Parmov.parmove2_wf_moves loc temp_for Loc.eq srcs dsts s d H0).
Qed.
-
-End pmov.
-Fixpoint split_move' (m : Moves) (r : Reg) {struct m} :
- option ((Moves * Reg) * Moves) :=
- match m with
- (s, d) :: tail =>
- match diff_dec s r with
- right _ => Some (nil, d, tail)
- | left _ =>
- match split_move' tail r with
- Some ((t1, r2, t2)) => Some ((s, d) :: t1, r2, t2)
- | None => None
- end
- end
- | nil => None
- end.
-
-Fixpoint split_move (m : Moves) (r : Reg) {struct m} :
- option ((Moves * Reg) * Moves) :=
- match m with
- (s, d) :: tail =>
- match Loc.eq s r with
- left _ => Some (nil, d, tail)
- | right _ =>
- match split_move tail r with
- Some ((t1, r2, t2)) => Some ((s, d) :: t1, r2, t2)
- | None => None
- end
- end
- | nil => None
- end.
+Section EQUIVALENCE.
-Definition def : Move := (R IT1, R IT1).
-
-Fixpoint last (M : Moves) : Move :=
- match M with nil => def
- | m :: nil => m
- | m :: tail => last tail end.
-
-Fixpoint head_but_last (M : Moves) : Moves :=
- match M with
- nil => nil
- | m' :: nil => nil
- | m' :: tail => m' :: head_but_last tail
- end.
-
-Fixpoint replace_last_s (M : Moves) : Moves :=
- match M with
- nil => nil
- | m :: nil =>
- match m with (s, d) => (T s, d) :: nil end
- | m :: tail => m :: replace_last_s tail
- end.
-
-Ltac CaseEq name := generalize (refl_equal name); pattern name at -1; case name.
-
-Definition stepf' (S1 : State) : State :=
- match S1 with
- (nil, nil, _) => S1
- | ((s, d) :: tl, nil, l) =>
- match diff_dec s d with
- right _ => (tl, nil, l)
- | left _ => (tl, (s, d) :: nil, l)
- end
- | (t, (s, d) :: b, l) =>
- match split_move t d with
- Some ((t1, r, t2)) =>
- (t1 ++ t2, (d, r) :: ((s, d) :: b), l)
- | None =>
- match b with
- nil => (t, nil, (s, d) :: l)
- | _ =>
- match diff_dec d (fst (last b)) with
- right _ =>
- (t, replace_last_s b, (s, d) :: ((d, T d) :: l))
- | left _ => (t, b, (s, d) :: l)
- end
- end
- end
- end.
-
-Definition stepf (S1 : State) : State :=
- match S1 with
- (nil, nil, _) => S1
- | ((s, d) :: tl, nil, l) =>
- match Loc.eq s d with
- left _ => (tl, nil, l)
- | right _ => (tl, (s, d) :: nil, l)
- end
- | (t, (s, d) :: b, l) =>
- match split_move t d with
- Some ((t1, r, t2)) =>
- (t1 ++ t2, (d, r) :: ((s, d) :: b), l)
- | None =>
- match b with
- nil => (t, nil, (s, d) :: l)
- | _ =>
- match Loc.eq d (fst (last b)) with
- left _ =>
- (t, replace_last_s b, (s, d) :: ((d, T d) :: l))
- | right _ => (t, b, (s, d) :: l)
- end
- end
- end
- end.
-
-Lemma rebuild_l:
- forall (l : Moves) (m : Move),
- m :: l = head_but_last (m :: l) ++ (last (m :: l) :: nil).
-Proof.
-induction l; simpl; auto.
-intros m; rewrite (IHl a); auto.
-Qed.
-
-Lemma splitSome:
- forall (l t1 t2 : Moves) (s d r : Reg),
- noOverlap (l ++ ((r, s) :: nil)) ->
- split_move l s = Some (t1, d, t2) -> noRead t1 s.
-Proof.
-induction l; simpl.
-intros; discriminate.
-destruct a as [a1 a2].
-intros t1 t2 s d r Hno; case (Loc.eq a1 s).
-intros e H1; inversion H1.
-simpl; auto.
-CaseEq (split_move l s).
-intros; (repeat destruct p).
-inversion H0; auto.
-simpl; split; auto.
-change (noOverlap (((a1, a2) :: l) ++ ((r, s) :: nil))) in Hno |-.
-assert (noOverlap ((r, s) :: ((a1, a2) :: l))).
-apply noOverlap_Front0; auto.
-unfold noOverlap in H1 |-; simpl in H1 |-.
-elim H1 with ( l0 := a1 );
- [intros H5 H6; (try clear H1); (try exact H5) | idtac].
-elim H5; [intros H1; (try clear H5); (try exact H1) | intros H1; (try clear H5)].
-absurd (a1 = s); auto.
-apply Loc.diff_sym; auto.
-right; left; trivial.
-apply (IHl m0 m s r0 r); auto.
-apply (noOverlap_pop (a1, a2)); auto.
-intros; discriminate.
-Qed.
-
-Lemma unsplit_move:
- forall (l t1 t2 : Moves) (s d r : Reg),
- noOverlap (l ++ ((r, s) :: nil)) ->
- split_move l s = Some (t1, d, t2) -> l = t1 ++ ((s, d) :: t2).
-Proof.
-induction l.
-simpl; intros; discriminate.
-intros t1 t2 s d r HnoO; destruct a as [a1 a2]; simpl; case (diff_dec a1 s);
- intro.
-case (Loc.eq a1 s); intro.
-absurd (Loc.diff a1 s); auto.
-rewrite e; apply Loc.same_not_diff.
-CaseEq (split_move l s); intros; (try discriminate).
-(repeat destruct p); inversion H0.
-rewrite app_cons; subst t2; subst d; rewrite (IHl m0 m s r0 r); auto.
-apply (noOverlap_pop (a1, a2)); auto.
-case (Loc.eq a1 s); intros e H; inversion H; simpl.
-rewrite e; auto.
-cut (noOverlap_aux a1 (getdst ((r, s) :: nil))).
-intros [[H5|H4] H0]; [try exact H5 | idtac].
-absurd (s = a1); auto.
-absurd (Loc.diff a1 s); auto; apply Loc.diff_sym; auto.
-generalize HnoO; rewrite app_cons; intro.
-assert (noOverlap (l ++ ((a1, a2) :: ((r, s) :: nil))));
- (try (apply noOverlap_insert; assumption)).
-assert (noOverlap ((a1, a2) :: ((r, s) :: nil))).
-apply (noOverlap_right l); auto.
-generalize H2; unfold noOverlap; simpl.
-intros H5; elim (H5 a1); [idtac | left; trivial].
-intros H6 [[H7|H8] H9].
-absurd (s = a1); auto.
-split; [right; (try assumption) | auto].
-Qed.
-
-Lemma cons_replace:
- forall (a : Move) (l : Moves),
- l <> nil -> replace_last_s (a :: l) = a :: replace_last_s l.
-Proof.
-intros; simpl.
-CaseEq l.
-intro; contradiction.
-intros m l0 H0; auto.
-Qed.
-
-Lemma last_replace:
- forall (l : Moves) (s d : Reg),
- replace_last_s (l ++ ((s, d) :: nil)) = l ++ ((T s, d) :: nil).
-Proof.
-induction l; (try (simpl; auto; fail)).
-intros; (repeat rewrite <- app_comm_cons).
-rewrite cons_replace.
-rewrite IHl; auto.
-red; intro.
-elim (app_eq_nil l ((s, d) :: nil)); auto; intros; discriminate.
-Qed.
-
-Lemma last_app: forall (l : Moves) (m : Move), last (l ++ (m :: nil)) = m.
-Proof.
-induction l; simpl; auto.
-intros m; CaseEq (l ++ (m :: nil)).
-intro; elim (app_eq_nil l (m :: nil)); auto; intros; discriminate.
-intros m0 l0 H; (rewrite <- H; apply IHl).
-Qed.
-
-Lemma last_cons:
- forall (l : Moves) (m m0 : Move), last (m0 :: (m :: l)) = last (m :: l).
-Proof.
-intros; simpl; auto.
-Qed.
-
-Lemma stepf_popLoop:
- forall (t b l : Moves) (s d r0 : Reg),
- split_move t d = None ->
- stepf (t, (s, d) :: (b ++ ((d, r0) :: nil)), l) =
- (t, b ++ ((T d, r0) :: nil), (s, d) :: ((d, T d) :: l)).
-Proof.
-intros; simpl; rewrite H; CaseEq (b ++ ((d, r0) :: nil)); intros.
-destruct b; discriminate.
-rewrite <- H0; rewrite last_app; simpl; rewrite last_replace.
-case (Loc.eq d d); intro; intuition.
-destruct t; (try destruct m0); simpl; auto.
-Qed.
-
-Lemma stepf_pop:
- forall (t b l : Moves) (s d r r0 : Reg),
- split_move t d = None ->
- d <> r ->
- stepf (t, (s, d) :: (b ++ ((r, r0) :: nil)), l) =
- (t, b ++ ((r, r0) :: nil), (s, d) :: l).
-Proof.
-intros; simpl; rewrite H; CaseEq (b ++ ((r, r0) :: nil)); intros.
-destruct b; discriminate.
-rewrite <- H1; rewrite last_app; simpl.
-case (Loc.eq d r); intro.
-absurd (d = r); auto.
-destruct t; (try destruct m0); simpl; auto.
-Qed.
-
-Lemma noOverlap_head:
- forall l1 l2 m, noOverlap (l1 ++ (m :: l2)) -> noOverlap (l1 ++ (m :: nil)).
-Proof.
-induction l2; simpl; auto.
-intros; apply IHl2.
-cut (l1 ++ (m :: (a :: l2)) = (l1 ++ (m :: nil)) ++ (a :: l2));
- [idtac | rewrite app_ass; auto].
-intros e; rewrite e in H.
-cut (l1 ++ (m :: l2) = (l1 ++ (m :: nil)) ++ l2);
- [idtac | rewrite app_ass; auto].
-intros e'; rewrite e'; auto.
-apply noOverlap_Pop with a; auto.
-Qed.
-
-Lemma splitNone:
- forall (l : Moves) (s d : Reg),
- split_move l d = None -> noOverlap (l ++ ((s, d) :: nil)) -> noRead l d.
-Proof.
-induction l; intros s d; simpl; auto.
-destruct a as [a1 a2]; case (Loc.eq a1 d); intro; (try (intro; discriminate)).
-CaseEq (split_move l d); intros.
-(repeat destruct p); discriminate.
-split; (try assumption).
-change (noOverlap (((a1, a2) :: l) ++ ((s, d) :: nil))) in H1 |-.
-assert (noOverlap ((s, d) :: ((a1, a2) :: l))).
-apply noOverlap_Front0; auto.
-assert (noOverlap ((a1, a2) :: ((s, d) :: l))).
-apply noOverlap_swap; auto.
-unfold noOverlap in H3 |-; simpl in H3 |-.
-elim H3 with ( l0 := a1 );
- [intros H5 H6; (try clear H1); (try exact H5) | idtac].
-elim H6;
- [intros H1 H4; elim H1;
- [intros H7; (try clear H1 H6); (try exact H7) | intros H7; (try clear H1 H6)]].
-absurd (a1 = d); auto.
-apply Loc.diff_sym; auto.
-left; trivial.
-apply IHl with s; auto.
-apply noOverlap_pop with (a1, a2); auto.
-Qed.
-
-Lemma noO_diff:
- forall l1 l2 s d r r0,
- noOverlap (l1 ++ ((s, d) :: (l2 ++ ((r, r0) :: nil)))) ->
- r = d \/ Loc.diff d r.
-Proof.
-intros.
-assert (noOverlap ((s, d) :: (l2 ++ ((r, r0) :: nil)))); auto.
-apply (noOverlap_right l1); auto.
-assert (noOverlap ((l2 ++ ((r, r0) :: nil)) ++ ((s, d) :: nil))); auto.
-apply (noOverlap_movBack0 (l2 ++ ((r, r0) :: nil))); auto.
-assert
- ((l2 ++ ((r, r0) :: nil)) ++ ((s, d) :: nil) =
- l2 ++ (((r, r0) :: nil) ++ ((s, d) :: nil))); auto.
-rewrite app_ass; auto.
-rewrite H2 in H1.
-simpl in H1 |-.
-assert (noOverlap ((r, r0) :: ((s, d) :: nil))); auto.
-apply (noOverlap_right l2); auto.
-unfold noOverlap in H3 |-.
-generalize (H3 r); simpl.
-intros H4; elim H4; intros; [idtac | left; trivial].
-elim H6; intros [H9|H9] H10; [left | right]; auto.
-Qed.
-
-Lemma f2ind:
- forall (S1 S2 : State),
- (forall (l : Moves), (S1 <> (nil, nil, l))) ->
- noOverlap (StateToMove S1 ++ StateBeing S1) -> stepf S1 = S2 -> dstep S1 S2.
-Proof.
-intros S1 S2 Hneq HnoO; destruct S1 as [[t b] l]; destruct b.
-destruct t.
-elim (Hneq l); auto.
-destruct m; simpl; case (Loc.eq r r0).
-intros.
-rewrite e; rewrite <- H; apply dstep_nop.
-intros n H; rewrite <- H; generalize (dstep_start t l r r0); auto.
-intros H; rewrite <- H; destruct m as [s d].
-CaseEq (split_move t d).
-intros p H0; destruct p as [[t1 s0] t2]; simpl; rewrite H0; destruct t; simpl.
-simpl in H0 |-; discriminate.
-rewrite (unsplit_move (m :: t) t1 t2 d s0 s); auto.
-destruct m; generalize dstep_push; intros H1; apply H1.
-unfold StateToMove, StateBeing in HnoO |-.
-apply (splitSome ((r, r0) :: t) t1 t2 d s0 s); auto.
-apply noOverlap_head with b; auto.
-unfold StateToMove, StateBeing in HnoO |-.
-apply noOverlap_head with b; auto.
-intros H0; destruct b.
-simpl.
-rewrite H0.
-destruct t; (try destruct m); generalize dstep_last; intros H1; apply H1.
-simpl; auto.
-unfold StateToMove, StateBeing in HnoO |-.
-apply splitNone with s; auto.
-unfold StateToMove, StateBeing in HnoO |-.
-generalize HnoO; clear HnoO; rewrite (rebuild_l b m); intros HnoO.
-destruct (last (m :: b)).
-case (Loc.eq d r).
-intros e; rewrite <- e.
-CaseEq (head_but_last (m :: b)); intros; [simpl | idtac];
- (try
- (destruct t; (try destruct m0); rewrite H0;
- (case (Loc.eq d d); intros h; (try (elim h; auto))))).
-generalize (dstep_pop_loop nil nil); simpl; intros H3; apply H3; auto.
-generalize (dstep_pop_loop ((r1, r2) :: t) nil); unfold T; simpl app;
- intros H3; apply H3; clear H3; apply splitNone with s; (try assumption).
-apply noOverlap_head with (head_but_last (m :: b) ++ ((r, r0) :: nil)); auto.
-rewrite stepf_popLoop; auto.
-generalize (dstep_pop_loop t (m0 :: l0)); simpl; intros H3; apply H3; clear H3;
- apply splitNone with s; (try assumption).
-apply noOverlap_head with (head_but_last (m :: b) ++ ((r, r0) :: nil)); auto.
-intro; assert (Loc.diff d r).
-assert (r = d \/ Loc.diff d r).
-apply (noO_diff t (head_but_last (m :: b)) s d r r0); auto.
-elim H1; [intros H2; absurd (d = r); auto | intros H2; auto].
-rewrite stepf_pop; auto.
-generalize (dstep_pop t (head_but_last (m :: b))); intros H3; apply H3; auto.
-clear H3; apply splitNone with s; (try assumption).
-apply noOverlap_head with (head_but_last (m :: b) ++ ((r, r0) :: nil)); auto.
-Qed.
-
-Lemma f2ind':
- forall (S1 : State),
- (forall (l : Moves), (S1 <> (nil, nil, l))) ->
- noOverlap (StateToMove S1 ++ StateBeing S1) -> dstep S1 (stepf S1).
-Proof.
-intros S1 H noO; apply f2ind; auto.
-Qed.
-
-Lemma appcons_length:
- forall (l1 l2 : Moves) (m : Move),
- length (l1 ++ (m :: l2)) = (length (l1 ++ l2) + 1%nat)%nat.
-Proof.
-induction l1; simpl; intros; [omega | idtac].
-rewrite IHl1; omega.
-Qed.
-
-Definition mesure (S0 : State) : nat :=
- let (p, _) := S0 in let (t, b) := p in (2 * length t + length b)%nat.
-
-Lemma step_dec0:
- forall (t1 t2 b1 b2 : Moves) (l1 l2 : Moves),
- dstep (t1, b1, l1) (t2, b2, l2) ->
- (2 * length t2 + length b2 < 2 * length t1 + length b1)%nat.
-Proof.
-intros t1 t2 b1 b2 l1 l2 H; inversion H; simpl; (try omega).
-rewrite appcons_length; omega.
-cut (length (b ++ ((T r0, d) :: nil)) = length (b ++ ((r0, d) :: nil)));
- (try omega).
-induction b; simpl; auto.
-(repeat rewrite appcons_length); auto.
-Qed.
-
-Lemma step_dec:
- forall (S1 S2 : State), dstep S1 S2 -> (mesure S2 < mesure S1)%nat.
-Proof.
-unfold mesure; destruct S1 as [[t1 b1] l1]; destruct S2 as [[t2 b2] l2].
-intro; apply (step_dec0 t1 t2 b1 b2 l1 l2); trivial.
-Qed.
-
-Lemma stepf_dec0:
- forall (S1 S2 : State),
- (forall (l : Moves), (S1 <> (nil, nil, l))) /\
- (S2 = stepf S1 /\ noOverlap (StateToMove S1 ++ StateBeing S1)) ->
- (mesure S2 < mesure S1)%nat.
-Proof.
-intros S1 S2 [H1 [H2 H3]]; apply step_dec.
-apply f2ind; trivial.
-rewrite H2; reflexivity.
-Qed.
-
-Lemma stepf_dec:
- forall (S1 S2 : State),
- S2 = stepf S1 /\
- ((forall (l : Moves), (S1 <> (nil, nil, l))) /\
- noOverlap (StateToMove S1 ++ StateBeing S1)) -> ltof _ mesure S2 S1.
-Proof.
-unfold ltof.
-intros S1 S2 [H1 [H2 H3]]; apply step_dec.
-apply f2ind; trivial.
-rewrite H1; reflexivity.
-Qed.
-
-Lemma replace_last_id:
- forall l m m0, replace_last_s (m :: (m0 :: l)) = m :: replace_last_s (m0 :: l).
-Proof.
-intros; case l; simpl.
-destruct m0; simpl; auto.
-intros; case l0; auto.
-Qed.
-
-Lemma length_replace: forall l, length (replace_last_s l) = length l.
-Proof.
-induction l; simpl; auto.
-destruct l; destruct a; simpl; auto.
-Qed.
-
-Lemma length_app:
- forall (A : Set) (l1 l2 : list A),
- (length (l1 ++ l2) = length l1 + length l2)%nat.
-Proof.
-intros A l1 l2; (try assumption).
-induction l1; simpl; auto.
-Qed.
-
-Lemma split_length:
- forall (l t1 t2 : Moves) (s d : Reg),
- split_move l s = Some (t1, d, t2) ->
- (length l = (length t1 + length t2) + 1)%nat.
-Proof.
-induction l.
-intros; discriminate.
-intros t1 t2 s d; destruct a as [r r0]; simpl; case (Loc.eq r s); intro.
-intros H; inversion H.
-simpl; omega.
-CaseEq (split_move l s); (try (intros; discriminate)).
-(repeat destruct p); intros H H0; inversion H0.
-rewrite H2; rewrite (IHl m0 m s r1); auto.
-rewrite H4; rewrite <- H2; simpl; omega.
-Qed.
-
-Lemma stepf_dec0':
- forall (S1 : State),
- (forall (l : Moves), (S1 <> (nil, nil, l))) ->
- (mesure (stepf S1) < mesure S1)%nat.
-Proof.
-intros S1 H.
-unfold mesure; destruct S1 as [[t1 b1] l1].
-destruct t1.
-destruct b1.
-generalize (H l1); intros H1; elim H1; auto.
-destruct m; simpl.
-destruct b1.
-simpl; auto.
-case (Loc.eq r0 (fst (last (m :: b1)))).
-intros; rewrite length_replace; simpl; omega.
-simpl; case b1; intros; simpl; omega.
-destruct m.
-destruct b1.
-simpl.
-case (Loc.eq r r0); intros; simpl; omega.
-destruct m; simpl; case (Loc.eq r r2).
-intros; simpl; omega.
-CaseEq (split_move t1 r2); intros.
-destruct p; destruct p; simpl.
-rewrite (split_length t1 m0 m r2 r3); auto.
-rewrite length_app; auto.
-omega.
-destruct b1.
-simpl; omega.
-case (Loc.eq r2 (fst (last (m :: b1)))); intros.
-rewrite length_replace; simpl; omega.
-simpl; omega.
-Qed.
-
-Lemma stepf1_dec:
- forall (S1 S2 : State),
- (forall (l : Moves), (S1 <> (nil, nil, l))) ->
- S2 = stepf S1 -> ltof _ mesure S2 S1.
-Proof.
-unfold ltof; intros S1 S2 H H0; rewrite H0.
-apply stepf_dec0'; (try assumption).
-Qed.
-
-Lemma disc1:
- forall (a : Move) (l1 l2 l3 l4 : list Move),
- ((a :: l1, l2, l3) <> (nil, nil, l4)).
-Proof.
-intros; discriminate.
-Qed.
-
-Lemma disc2:
- forall (a : Move) (l1 l2 l3 l4 : list Move),
- ((l1, a :: l2, l3) <> (nil, nil, l4)).
-Proof.
-intros; discriminate.
-Qed.
-Hint Resolve disc1 disc2 .
-
-Lemma sameExec_reflexive: forall (r : State), sameExec r r.
-Proof.
-intros r; unfold sameExec, sameEnv, exec.
-destruct r as [[t b] d]; trivial.
-Qed.
-
-Definition base_case_Pmov_dec:
- forall (s : State),
- ({ exists l : list Move , s = (nil, nil, l) }) +
- ({ forall l, (s <> (nil, nil, l)) }).
-Proof.
-destruct s as [[[|x tl] [|y tl']] l]; (try (right; intro; discriminate)).
-left; exists l; auto.
-Defined.
-
-Definition Pmov :=
- Fix
- (well_founded_ltof _ mesure) (fun _ => State)
- (fun (S1 : State) =>
- fun (Pmov : forall x, ltof _ mesure x S1 -> State) =>
- match base_case_Pmov_dec S1 with
- left h => S1
- | right h => Pmov (stepf S1) (stepf_dec0' S1 h) end).
-
-Theorem Pmov_equation: forall S1, Pmov S1 = match S1 with
- ((nil, nil), _) => S1
- | _ => Pmov (stepf S1)
- end.
-Proof.
-intros S1; unfold Pmov at 1;
- rewrite (Fix_eq
- (well_founded_ltof _ mesure) (fun _ => State)
- (fun (S1 : State) =>
- fun (Pmov : forall x, ltof _ mesure x S1 -> State) =>
- match base_case_Pmov_dec S1 with
- left h => S1
- | right h => Pmov (stepf S1) (stepf_dec0' S1 h) end)).
-fold Pmov.
-destruct S1 as [[[|x tl] [|y tl']] l];
- match goal with
- | |- match ?a with left _ => _ | right _ => _ end = _ => case a end;
- (try (intros [l0 Heq]; discriminate Heq)); auto.
-intros H; elim (H l); auto.
-intros x f g Hfg_ext.
-match goal with
-| |- match ?a with left _ => _ | right _ => _ end = _ => case a end; auto.
-Qed.
-
-Lemma sameExec_transitive:
- forall (r1 r2 r3 : State),
- (forall r,
- In r (getdst (StateToMove r2 ++ StateBeing r2)) ->
- In r (getdst (StateToMove r1 ++ StateBeing r1))) ->
- (forall r,
- In r (getdst (StateToMove r3 ++ StateBeing r3)) ->
- In r (getdst (StateToMove r2 ++ StateBeing r2))) ->
- sameExec r1 r2 -> sameExec r2 r3 -> sameExec r1 r3.
-Proof.
-intros r1 r2 r3; unfold sameExec, exec; (repeat rewrite getdst_app).
-destruct r1 as [[t1 b1] d1]; destruct r2 as [[t2 b2] d2];
- destruct r3 as [[t3 b3] d3]; simpl.
-intros Hin; intros.
-rewrite H0; auto.
-rewrite H1; auto.
-intros.
-apply (H3 x).
-apply in_or_app; auto.
-elim (in_app_or (getdst t2 ++ getdst b2) (getdst t3 ++ getdst b3) x); auto.
-intros.
-apply (H3 x).
-apply in_or_app; auto.
-elim (in_app_or (getdst t1 ++ getdst b1) (getdst t2 ++ getdst b2) x); auto.
-Qed.
-
-Lemma dstep_inv_getdst:
- forall (s1 s2 : State) r,
- dstep s1 s2 ->
- In r (getdst (StateToMove s2 ++ StateBeing s2)) ->
- In r (getdst (StateToMove s1 ++ StateBeing s1)).
-intros s1 s2 r STEP; inversion_clear STEP;
- unfold StateToMove, StateBeing, StateDone; (repeat rewrite app_nil);
- (repeat (rewrite getdst_app; simpl)); intro; auto.
-Proof.
-right; (try assumption).
-elim (in_app_or (getdst t) (d :: nil) r); auto; (simpl; intros [H1|H1]);
- [left; assumption | inversion H1].
-elim (in_app_or (getdst t1 ++ getdst t2) (r0 :: (d :: getdst b)) r); auto;
- (simpl; intros).
-elim (in_app_or (getdst t1) (getdst t2) r); auto; (simpl; intros).
-apply in_or_app; left; apply in_or_app; left; assumption.
-apply in_or_app; left; apply in_or_app; right; simpl; right; assumption.
-elim H1; [intros H2 | intros [H2|H2]].
-apply in_or_app; left; apply in_or_app; right; simpl; left; auto.
-apply in_or_app; right; simpl; left; auto.
-apply in_or_app; right; simpl; right; assumption.
-elim (in_app_or (getdst t) (getdst b ++ (d :: nil)) r); auto; (simpl; intros).
-apply in_or_app; left; assumption.
-elim (in_app_or (getdst b) (d :: nil) r); auto; (simpl; intros).
-apply in_or_app; right; simpl; right; apply in_or_app; left; assumption.
-elim H2; [intros H3 | intros H3; inversion H3].
-apply in_or_app; right; simpl; right; apply in_or_app; right; simpl; auto.
-elim (in_app_or (getdst t) (getdst b ++ (d0 :: nil)) r); auto; (simpl; intros).
-apply in_or_app; left; assumption.
-elim (in_app_or (getdst b) (d0 :: nil) r); auto; simpl;
- [intros H3 | intros [H3|H3]; [idtac | inversion H3]].
-apply in_or_app; right; simpl; right; apply in_or_app; left; assumption.
-apply in_or_app; right; simpl; right; apply in_or_app; right; simpl; auto.
-apply in_or_app; left; assumption.
-Qed.
-
-Theorem STM_Pmov: forall (S1 : State), StateToMove (Pmov S1) = nil.
-Proof.
-intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)).
-clear S1; intros S1; intros Hrec; destruct S1 as [[t b] d];
- rewrite Pmov_equation; destruct t.
-destruct b; auto.
-apply Hrec; apply stepf1_dec; auto.
-apply Hrec; apply stepf1_dec; auto.
-Qed.
-
-Theorem SB_Pmov: forall (S1 : State), StateBeing (Pmov S1) = nil.
-Proof.
-intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)).
-clear S1; intros S1; intros Hrec; destruct S1 as [[t b] d];
- rewrite Pmov_equation; destruct t.
-destruct b; auto.
-apply Hrec; apply stepf1_dec; auto.
-apply Hrec; apply stepf1_dec; auto.
-Qed.
-
-Theorem Fpmov_correct:
- forall (S1 : State), stepInv S1 -> sameExec S1 (Pmov S1).
-Proof.
-intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)).
-clear S1; intros S1; intros Hrec Hinv; rewrite Pmov_equation;
- destruct S1 as [[t b] d].
-assert
- (forall (r : Reg) S1,
- In r (getdst (StateToMove (Pmov (stepf S1)) ++ StateBeing (Pmov (stepf S1)))) ->
- In r (getdst (StateToMove (stepf S1) ++ StateBeing (stepf S1)))).
-intros r S1; rewrite (STM_Pmov (stepf S1)); rewrite SB_Pmov; simpl; intros.
-inversion H.
-destruct t.
-destruct b.
-apply sameExec_reflexive.
-set (S1:=(nil (A:=Move), m :: b, d)).
-assert (dstep S1 (stepf S1)); (try apply f2ind); unfold S1; auto.
-elim Hinv; intros Hpath [SD [NO NT]]; assumption.
-apply sameExec_transitive with (stepf S1); auto.
-intros r; apply dstep_inv_getdst; auto.
-apply dstepp_sameExec; auto; apply dstepp_trans with (stepf S1); auto.
-apply dstepp_refl; auto.
-apply Hrec; auto.
-unfold ltof; apply step_dec; assumption.
-apply (dstep_inv S1); assumption.
-set (S1:=(m :: t, b, d)).
-assert (dstep S1 (stepf S1)); (try apply f2ind); unfold S1; auto.
-elim Hinv; intros Hpath [SD [NO NT]]; assumption.
-apply sameExec_transitive with (stepf S1); auto.
-intros r; apply dstep_inv_getdst; auto.
-apply dstepp_sameExec; auto; apply dstepp_trans with (stepf S1); auto.
-apply dstepp_refl; auto.
-apply Hrec; auto.
-unfold ltof; apply step_dec; assumption.
-apply (dstep_inv S1); assumption.
-Qed.
-
-Definition P_move := fun (p : Moves) => StateDone (Pmov (p, nil, nil)).
-
-Definition Sexec := sexec.
-
-Definition Get := get.
-
-Fixpoint listsLoc2Moves (src dst : list loc) {struct src} : Moves :=
- match src with
- nil => nil
- | s :: srcs =>
- match dst with
- nil => nil
- | d :: dsts => (s, d) :: listsLoc2Moves srcs dsts
- end
- end.
-
-Definition no_overlap (l1 l2 : list loc) :=
- forall r, In r l1 -> forall s, In s l2 -> r = s \/ Loc.diff r s.
-
-Definition no_overlap_state (S : State) :=
- no_overlap
- (getsrc (StateToMove S ++ StateBeing S))
- (getdst (StateToMove S ++ StateBeing S)).
-
-Definition no_overlap_list := fun l => no_overlap (getsrc l) (getdst l).
-
-Lemma Indst_noOverlap_aux:
- forall l1 l,
- (forall (s : Reg), In s (getdst l1) -> l = s \/ Loc.diff l s) ->
- noOverlap_aux l (getdst l1).
-Proof.
-intros; induction l1; simpl; auto.
-destruct a as [a1 a2]; simpl; split.
-elim (H a2); (try intros H0).
-left; auto.
-right; apply Loc.diff_sym; auto.
-simpl; left; trivial.
-apply IHl1; intros.
-apply H; simpl; right; (try assumption).
-Qed.
-
-Lemma no_overlap_noOverlap:
- forall r, no_overlap_state r -> noOverlap (StateToMove r ++ StateBeing r).
-Proof.
-intros r; unfold noOverlap, no_overlap_state.
-set (l1:=StateToMove r ++ StateBeing r).
-unfold no_overlap; intros H l H0.
-apply Indst_noOverlap_aux; intros; apply H; auto.
-Qed.
-
-Theorem Fpmov_correctMoves:
- forall p e r,
- simpleDest p ->
- no_overlap_list p ->
- noTmp p ->
- notemporary r ->
- (forall (x : Reg), In x (getdst p) -> r = x \/ Loc.diff r x) ->
- get (pexec p e) r = get (sexec (StateDone (Pmov (p, nil, nil))) e) r.
-Proof.
-intros p e r SD no_O notmp notempo.
-generalize (Fpmov_correct (p, nil, nil)); unfold sameExec, exec; simpl;
- rewrite SB_Pmov; rewrite STM_Pmov; simpl.
-(repeat rewrite app_nil); intro.
-apply H; auto.
-unfold stepInv; simpl; (repeat split); (try (rewrite app_nil; assumption)); auto.
-generalize (no_overlap_noOverlap (p, nil, nil)); simpl; intros; auto.
-apply H0; auto; unfold no_overlap_list in H0 |-.
-unfold no_overlap_state; simpl; (repeat rewrite app_nil); auto.
-Qed.
-
-Theorem Fpmov_correct1:
- forall (p : Moves) (e : Env) (r : Reg),
- simpleDest p ->
- no_overlap_list p ->
- noTmp p ->
- notemporary r ->
- (forall (x : Reg), In x (getdst p) -> r = x \/ Loc.diff r x) ->
- noWrite p r -> get e r = get (sexec (StateDone (Pmov (p, nil, nil))) e) r.
-Proof.
-intros p e r Hsd Hno_O HnoTmp Hrnotempo Hrno_Overlap Hnw.
-rewrite <- (Fpmov_correctMoves p e); (try assumption).
-destruct p; auto.
-destruct m as [m1 m2]; simpl; case (Loc.eq m2 r); intros.
-elim Hnw; intros; absurd (Loc.diff m2 r); auto.
-rewrite e0; apply Loc.same_not_diff.
-elim Hnw; intros H1 H2.
-rewrite get_update_diff; (try assumption).
-apply get_noWrite; (try assumption).
-Qed.
-
-Lemma In_SD_diff:
- forall (s d a1 a2 : Reg) (p : Moves),
- In (s, d) p -> simpleDest ((a1, a2) :: p) -> Loc.diff a2 d.
-Proof.
-intros; induction p.
-inversion H.
-elim H; auto.
-intro; subst a; elim H0; intros H1 H2; elim H1; intros; apply Loc.diff_sym;
- assumption.
-intro; apply IHp; auto.
-apply simpleDest_pop2 with a; (try assumption).
-Qed.
-
-Theorem pexec_correct:
- forall (e : Env) (m : Move) (p : Moves),
- In m p -> simpleDest p -> (let (s, d) := m in get (pexec p e) d = get e s).
-Proof.
-induction p; intros.
-elim H.
-destruct m.
-elim (in_inv H); intro.
-rewrite H1; simpl; rewrite get_update_id; auto.
-destruct a as [a1 a2]; simpl.
-rewrite get_update_diff.
-apply IHp; auto.
-apply (simpleDest_pop (a1, a2)); (try assumption).
-apply (In_SD_diff r) with ( p := p ) ( a1 := a1 ); auto.
-Qed.
-
-Lemma In_noTmp_notempo:
- forall (s d : Reg) (p : Moves), In (s, d) p -> noTmp p -> notemporary d.
-Proof.
-intros; unfold notemporary; induction p.
-inversion H.
-elim H; intro.
-subst a; elim H0; intros H1 [H3 H2]; (try assumption).
-intro; apply IHp; auto.
-destruct a; elim H0; intros _ [H2 H3]; (try assumption).
-Qed.
-
-Lemma In_Indst: forall s d p, In (s, d) p -> In d (getdst p).
-Proof.
-intros; induction p; auto.
-destruct a; simpl.
-elim H; intro.
-left; inversion H0; trivial.
-right; apply IHp; auto.
-Qed.
-
-Lemma In_SD_diff':
- forall (d a1 a2 : Reg) (p : Moves),
- In d (getdst p) -> simpleDest ((a1, a2) :: p) -> Loc.diff a2 d.
-Proof.
-intros d a1 a2 p H H0; induction p.
-inversion H.
-destruct a; elim H.
-elim H0; simpl; intros.
-subst r0.
-elim H1; intros H3 H4; apply Loc.diff_sym; assumption.
-intro; apply IHp; (try assumption).
-apply simpleDest_pop2 with (r, r0); (try assumption).
-Qed.
-
-Lemma In_SD_no_o:
- forall (s d : Reg) (p : Moves),
- In (s, d) p ->
- simpleDest p -> forall (x : Reg), In x (getdst p) -> d = x \/ Loc.diff d x.
-Proof.
-intros s d p Hin Hsd; induction p.
-inversion Hin.
-destruct a as [a1 a2]; elim Hin; intros.
-inversion H; subst d; subst s.
-elim H0; intros H1; [left | right]; (try assumption).
-apply (In_SD_diff' x a1 a2 p); auto.
-elim H0.
-intro; subst x.
-right; apply Loc.diff_sym; apply (In_SD_diff s d a1 a2 p); auto.
-intro; apply IHp; auto.
-apply (simpleDest_pop (a1, a2)); assumption.
-Qed.
-
-Lemma getdst_map: forall p, getdst p = map (fun x => snd x) p.
-Proof.
-induction p.
-simpl; auto.
-destruct a; simpl.
-rewrite IHp; auto.
+Variables srcs dsts: list loc.
+Hypothesis LENGTH: List.length srcs = List.length dsts.
+Hypothesis NOREPET: Loc.norepet dsts.
+Hypothesis NO_OVERLAP: Loc.no_overlap srcs dsts.
+Hypothesis NO_SRCS_TEMP: Loc.disjoint srcs temporaries.
+Hypothesis NO_DSTS_TEMP: Loc.disjoint dsts temporaries.
+
+Definition no_overlap_dests (l: loc) : Prop :=
+ forall d, In d dsts -> l = d \/ Loc.diff l d.
+
+Lemma dests_no_overlap_dests:
+ forall l, In l dsts -> no_overlap_dests l.
+Proof.
+ assert (forall d, Loc.norepet d ->
+ forall l1 l2, In l1 d -> In l2 d -> l1 = l2 \/ Loc.diff l1 l2).
+ induction 1; simpl; intros.
+ contradiction.
+ elim H1; intro; elim H2; intro.
+ left; congruence.
+ right. subst l1. eapply Loc.in_notin_diff; eauto.
+ right. subst l2. apply Loc.diff_sym. eapply Loc.in_notin_diff; eauto.
+ eauto.
+ intros; red; intros. eauto.
Qed.
-
-Lemma getsrc_map: forall p, getsrc p = map (fun x => fst x) p.
+
+Lemma notin_dests_no_overlap_dests:
+ forall l, Loc.notin l dsts -> no_overlap_dests l.
Proof.
-induction p.
-simpl; auto.
-destruct a; simpl.
-rewrite IHp; auto.
+ intros; red; intros.
+ right. eapply Loc.in_notin_diff; eauto.
Qed.
-
-Theorem Fpmov_correct2:
- forall (p : Moves) (e : Env) (m : Move),
- In m p ->
- simpleDest p ->
- no_overlap_list p ->
- noTmp p ->
- (let (s, d) := m in get (sexec (StateDone (Pmov (p, nil, nil))) e) d = get e s).
+
+Lemma source_no_overlap_dests:
+ forall s, In s srcs \/ s = R IT2 \/ s = R FT2 -> no_overlap_dests s.
Proof.
-intros p e m Hin Hsd Hno_O HnoTmp; destruct m as [s d];
- generalize (Fpmov_correctMoves p e); intros.
-rewrite <- H; auto.
-apply pexec_correct with ( m := (s, d) ); auto.
-apply (In_noTmp_notempo s d p); auto.
-apply (In_SD_no_o s d p Hin Hsd).
+ intros. elim H; intro. exact (NO_OVERLAP s H0).
+ elim H0; intro; subst s; red; intros;
+ right; apply Loc.diff_sym; apply NO_DSTS_TEMP; auto; simpl; tauto.
Qed.
-
-Lemma notindst_nW: forall a p, Loc.notin a (getdst p) -> noWrite p a.
+
+Lemma source_not_temp1:
+ forall s, In s srcs \/ s = R IT2 \/ s = R FT2 -> Loc.diff s (R IT1) /\ Loc.diff s (R FT1).
Proof.
-induction p; simpl; auto.
-destruct a0 as [a1 a2].
-simpl.
-intros H; elim H; intro; split.
-apply Loc.diff_sym; (try assumption).
-apply IHp; auto.
+ intros. elim H; intro.
+ split; apply NO_SRCS_TEMP; auto; simpl; tauto.
+ elim H0; intro; subst s; simpl; split; congruence.
Qed.
-
-Lemma disjoint_tmp__noTmp:
- forall p,
- Loc.disjoint (getsrc p) temporaries ->
- Loc.disjoint (getdst p) temporaries -> noTmp p.
-Proof.
-induction p; simpl; auto.
-destruct a as [a1 a2]; simpl getsrc; simpl getdst; unfold Loc.disjoint; intros;
- (repeat split).
-intro; unfold T; case (Loc.type r); apply H; (try (left; trivial; fail)).
-right; left; trivial.
-right; right; right; right; left; trivial.
-intro; unfold T; case (Loc.type r); apply H0; (try (left; trivial; fail)).
-right; left; trivial.
-right; right; right; right; left; trivial.
-apply IHp.
-apply Loc.disjoint_cons_left with a1; auto.
-apply Loc.disjoint_cons_left with a2; auto.
+
+Lemma dest_noteq_diff:
+ forall d l,
+ In d dsts \/ d = R IT2 \/ d = R FT2 ->
+ l <> d ->
+ no_overlap_dests l ->
+ Loc.diff l d.
+Proof.
+ intros. elim H; intro.
+ elim (H1 d H2); intro. congruence. auto.
+ assert (forall r, l <> R r -> Loc.diff l (R r)).
+ intros. destruct l; simpl. congruence. destruct s; auto.
+ elim H2; intro; subst d; auto.
Qed.
-
-Theorem Fpmov_correct_IT3:
- forall p rs,
- simpleDest p ->
- no_overlap_list p ->
- Loc.disjoint (getsrc p) temporaries ->
- Loc.disjoint (getdst p) temporaries ->
- (sexec (StateDone (Pmov (p, nil, nil))) rs) (R IT3) = rs (R IT3).
-Proof.
-intros p rs Hsd Hno_O Hdistmpsrc Hdistmpdst.
-generalize (Fpmov_correctMoves p rs); unfold get, Locmap.get; intros H2.
-rewrite <- H2; auto.
-generalize (get_noWrite p (R IT3)); unfold get, Locmap.get; intros.
-rewrite <- H; auto.
-apply notindst_nW.
-apply (Loc.disjoint_notin temporaries).
-apply Loc.disjoint_sym; auto.
-right; right; left; trivial.
-apply disjoint_tmp__noTmp; auto.
-unfold notemporary, T.
-intros x; case (Loc.type x); simpl; intro; discriminate.
-intros x H; right; apply Loc.in_notin_diff with (getdst p); auto.
-apply Loc.disjoint_notin with temporaries; auto.
-apply Loc.disjoint_sym; auto.
-right; right; left; trivial.
+
+Definition locmap_equiv (e1 e2: Locmap.t): Prop :=
+ forall l,
+ no_overlap_dests l -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> e2 l = e1 l.
+
+Definition effect_move (src dst: loc) (e e': Locmap.t): Prop :=
+ e' dst = e src /\
+ forall l, Loc.diff l dst -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> e' l = e l.
+
+Inductive effect_seqmove: list (loc * loc) -> Locmap.t -> Locmap.t -> Prop :=
+ | effect_seqmove_nil: forall e,
+ effect_seqmove nil e e
+ | effect_seqmove_cons: forall s d m e1 e2 e3,
+ effect_move s d e1 e2 ->
+ effect_seqmove m e2 e3 ->
+ effect_seqmove ((s, d) :: m) e1 e3.
+
+Lemma effect_move_equiv:
+ forall s d e1 e2 e1',
+ (In s srcs \/ s = R IT2 \/ s = R FT2) ->
+ (In d dsts \/ d = R IT2 \/ d = R FT2) ->
+ locmap_equiv e1 e2 -> effect_move s d e1 e1' ->
+ locmap_equiv e1' (Parmov.update loc val Loc.eq d (e2 s) e2).
+Proof.
+ intros. destruct H2. red; intros.
+ unfold Parmov.update. destruct (Loc.eq l d).
+ subst l. elim (source_not_temp1 _ H); intros.
+ rewrite H2. apply H1; auto. apply source_no_overlap_dests; auto.
+ rewrite H3; auto. apply dest_noteq_diff; auto.
Qed.
-
-Theorem Fpmov_correct_map:
- forall p rs,
- simpleDest p ->
- no_overlap_list p ->
- Loc.disjoint (getsrc p) temporaries ->
- Loc.disjoint (getdst p) temporaries ->
- List.map (sexec (StateDone (Pmov (p, nil, nil))) rs) (getdst p) =
- List.map rs (getsrc p).
-Proof.
-intros; rewrite getsrc_map; rewrite getdst_map; rewrite list_map_compose;
- rewrite list_map_compose; apply list_map_exten; intros.
-generalize (Fpmov_correct2 p rs x).
-destruct x; simpl.
-unfold get, Locmap.get; intros; auto.
-rewrite H4; auto.
-apply disjoint_tmp__noTmp; auto.
+
+Lemma effect_seqmove_equiv:
+ forall mu e1 e1',
+ effect_seqmove mu e1 e1' ->
+ forall e2,
+ (forall s d, In (s, d) mu ->
+ (In s srcs \/ s = R IT2 \/ s = R FT2) /\
+ (In d dsts \/ d = R IT2 \/ d = R FT2)) ->
+ locmap_equiv e1 e2 ->
+ locmap_equiv e1' (exec_seq mu e2).
+Proof.
+ induction 1; intros.
+ simpl. auto.
+ simpl. apply IHeffect_seqmove.
+ intros. apply H1. apply in_cons; auto.
+ destruct (H1 s d (in_eq _ _)).
+ eapply effect_move_equiv; eauto.
Qed.
-
-Theorem Fpmov_correct_ext:
- forall p rs,
- simpleDest p ->
- no_overlap_list p ->
- Loc.disjoint (getsrc p) temporaries ->
- Loc.disjoint (getdst p) temporaries ->
- forall l,
- Loc.notin l (getdst p) ->
- Loc.notin l temporaries ->
- (sexec (StateDone (Pmov (p, nil, nil))) rs) l = rs l.
-Proof.
-intros; generalize (Fpmov_correct1 p rs l); unfold get, Locmap.get; intros.
-rewrite <- H5; auto.
-apply disjoint_tmp__noTmp; auto.
-unfold notemporary; simpl in H4 |-; unfold T; intros x; case (Loc.type x).
-elim H4;
- [intros H6 H7; elim H7; [intros H8 H9; (try clear H7 H4); (try exact H8)]].
-elim H4;
- [intros H6 H7; elim H7;
- [intros H8 H9; elim H9;
- [intros H10 H11; elim H11;
- [intros H12 H13; elim H13;
- [intros H14 H15; (try clear H13 H11 H9 H7 H4); (try exact H14)]]]]].
-unfold no_overlap_list, no_overlap in H0 |-; intros.
-case (Loc.eq l x).
-intros e; left; (try assumption).
-intros n; right; (try assumption).
-apply Loc.in_notin_diff with (getdst p); auto.
-apply notindst_nW; auto.
+
+Lemma effect_parmove:
+ forall e e',
+ effect_seqmove (parmove srcs dsts) e e' ->
+ List.map e' dsts = List.map e srcs /\
+ e' (R IT3) = e (R IT3) /\
+ forall l, Loc.notin l dsts -> Loc.notin l temporaries -> e' l = e l.
+Proof.
+ set (mu := parmove srcs dsts). intros.
+ assert (locmap_equiv e e) by (red; auto).
+ generalize (effect_seqmove_equiv mu e e' H e (parmove_prop_2 srcs dsts) H0).
+ intro.
+ generalize (parmove_prop_1 srcs dsts LENGTH NOREPET NO_SRCS_TEMP NO_DSTS_TEMP e).
+ fold mu. intros [A B].
+ (* e' dsts = e srcs *)
+ split. rewrite <- A. apply list_map_exten; intros.
+ apply H1. apply dests_no_overlap_dests; auto.
+ apply NO_DSTS_TEMP; auto; simpl; tauto.
+ apply NO_DSTS_TEMP; auto; simpl; tauto.
+ (* e' IT3 = e IT3 *)
+ split.
+ assert (Loc.notin (R IT3) dsts).
+ apply Loc.disjoint_notin with temporaries.
+ apply Loc.disjoint_sym; auto. simpl; tauto.
+ transitivity (exec_seq mu e (R IT3)).
+ symmetry. apply H1. apply notin_dests_no_overlap_dests. auto.
+ simpl; congruence. simpl; congruence.
+ apply B. apply Loc.notin_not_in; auto. congruence. congruence.
+ (* other locations *)
+ intros. transitivity (exec_seq mu e l).
+ symmetry. apply H1. apply notin_dests_no_overlap_dests; auto.
+ eapply Loc.in_notin_diff; eauto. simpl; tauto.
+ eapply Loc.in_notin_diff; eauto. simpl; tauto.
+ apply B. apply Loc.notin_not_in; auto.
+ apply Loc.diff_not_eq. eapply Loc.in_notin_diff; eauto. simpl; tauto.
+ apply Loc.diff_not_eq. eapply Loc.in_notin_diff; eauto. simpl; tauto.
Qed.
+
+End EQUIVALENCE.
+
diff --git a/backend/RTL.v b/backend/RTL.v
index ac9a415..4a3f8e8 100644
--- a/backend/RTL.v
+++ b/backend/RTL.v
@@ -4,12 +4,13 @@
after Cminor.
*)
-Require Import Relations.
+(*Require Import Relations.*)
Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Values.
+Require Import Events.
Require Import Mem.
Require Import Globalenvs.
Require Import Op.
@@ -54,6 +55,10 @@ Inductive instruction: Set :=
function name), giving it the values of registers [args]
as arguments. It stores the return value in [dest] and branches
to [succ]. *)
+ | Ialloc: reg -> reg -> node -> instruction
+ (** [Ialloc arg dest succ] allocates a fresh block of size
+ the contents of register [arg], stores a pointer to this
+ block in [dest], and branches to [succ]. *)
| Icond: condition -> list reg -> node -> node -> instruction
(** [Icond cond args ifso ifnot] evaluates the boolean condition
[cond] over the values of registers [args]. If the condition
@@ -85,11 +90,19 @@ Record function: Set := mkfunction {
in the CFG. [fn_code_wf] asserts that all instructions of the function
have nodes no greater than [fn_nextpc]. *)
-Definition program := AST.program function.
+Definition fundef := AST.fundef function.
+
+Definition program := AST.program fundef.
+
+Definition funsig (fd: fundef) :=
+ match fd with
+ | Internal f => f.(fn_sig)
+ | External ef => ef.(ef_sig)
+ end.
(** * Operational semantics *)
-Definition genv := Genv.t function.
+Definition genv := Genv.t fundef.
Definition regset := Regmap.t val.
Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset :=
@@ -102,7 +115,8 @@ Section RELSEM.
Variable ge: genv.
-Definition find_function (ros: reg + ident) (rs: regset) : option function :=
+Definition find_function
+ (ros: reg + ident) (rs: regset) : option fundef :=
match ros with
| inl r => Genv.find_funct ge rs#r
| inr symb =>
@@ -132,66 +146,73 @@ Definition find_function (ros: reg + ident) (rs: regset) : option function :=
and memory state [m]. The final state is [pc'], [rs'] and [m']. *)
Inductive exec_instr: code -> val ->
- node -> regset -> mem ->
+ node -> regset -> mem -> trace ->
node -> regset -> mem -> Prop :=
| exec_Inop:
forall c sp pc rs m pc',
c!pc = Some(Inop pc') ->
- exec_instr c sp pc rs m pc' rs m
+ exec_instr c sp pc rs m E0 pc' rs m
| exec_Iop:
forall c sp pc rs m op args res pc' v,
c!pc = Some(Iop op args res pc') ->
eval_operation ge sp op rs##args = Some v ->
- exec_instr c sp pc rs m pc' (rs#res <- v) m
+ exec_instr c sp pc rs m E0 pc' (rs#res <- v) m
| exec_Iload:
forall c sp pc rs m chunk addr args dst pc' a v,
c!pc = Some(Iload chunk addr args dst pc') ->
eval_addressing ge sp addr rs##args = Some a ->
Mem.loadv chunk m a = Some v ->
- exec_instr c sp pc rs m pc' (rs#dst <- v) m
+ exec_instr c sp pc rs m E0 pc' (rs#dst <- v) m
| exec_Istore:
forall c sp pc rs m chunk addr args src pc' a m',
c!pc = Some(Istore chunk addr args src pc') ->
eval_addressing ge sp addr rs##args = Some a ->
Mem.storev chunk m a rs#src = Some m' ->
- exec_instr c sp pc rs m pc' rs m'
+ exec_instr c sp pc rs m E0 pc' rs m'
| exec_Icall:
- forall c sp pc rs m sig ros args res pc' f vres m',
+ forall c sp pc rs m sig ros args res pc' f vres m' t,
c!pc = Some(Icall sig ros args res pc') ->
find_function ros rs = Some f ->
- sig = f.(fn_sig) ->
- exec_function f rs##args m vres m' ->
- exec_instr c sp pc rs m pc' (rs#res <- vres) m'
+ funsig f = sig ->
+ exec_function f rs##args m t vres m' ->
+ exec_instr c sp pc rs m t pc' (rs#res <- vres) m'
+ | exec_Ialloc:
+ forall c sp pc rs m pc' arg res sz m' b,
+ c!pc = Some(Ialloc arg res pc') ->
+ rs#arg = Vint sz ->
+ Mem.alloc m 0 (Int.signed sz) = (m', b) ->
+ exec_instr c sp pc rs m E0 pc' (rs#res <- (Vptr b Int.zero)) m'
| exec_Icond_true:
forall c sp pc rs m cond args ifso ifnot,
c!pc = Some(Icond cond args ifso ifnot) ->
eval_condition cond rs##args = Some true ->
- exec_instr c sp pc rs m ifso rs m
+ exec_instr c sp pc rs m E0 ifso rs m
| exec_Icond_false:
forall c sp pc rs m cond args ifso ifnot,
c!pc = Some(Icond cond args ifso ifnot) ->
eval_condition cond rs##args = Some false ->
- exec_instr c sp pc rs m ifnot rs m
+ exec_instr c sp pc rs m E0 ifnot rs m
(** [exec_instrs ge c sp pc rs m pc' rs' m'] is the reflexive
transitive closure of [exec_instr]. It corresponds to the execution
of zero, one or finitely many transitions. *)
with exec_instrs: code -> val ->
- node -> regset -> mem ->
+ node -> regset -> mem -> trace ->
node -> regset -> mem -> Prop :=
| exec_refl:
forall c sp pc rs m,
- exec_instrs c sp pc rs m pc rs m
+ exec_instrs c sp pc rs m E0 pc rs m
| exec_one:
- forall c sp pc rs m pc' rs' m',
- exec_instr c sp pc rs m pc' rs' m' ->
- exec_instrs c sp pc rs m pc' rs' m'
+ forall c sp pc rs m t pc' rs' m',
+ exec_instr c sp pc rs m t pc' rs' m' ->
+ exec_instrs c sp pc rs m t pc' rs' m'
| exec_trans:
- forall c sp pc1 rs1 m1 pc2 rs2 m2 pc3 rs3 m3,
- exec_instrs c sp pc1 rs1 m1 pc2 rs2 m2 ->
- exec_instrs c sp pc2 rs2 m2 pc3 rs3 m3 ->
- exec_instrs c sp pc1 rs1 m1 pc3 rs3 m3
+ forall c sp pc1 rs1 m1 t1 pc2 rs2 m2 t2 pc3 rs3 m3 t3,
+ exec_instrs c sp pc1 rs1 m1 t1 pc2 rs2 m2 ->
+ exec_instrs c sp pc2 rs2 m2 t2 pc3 rs3 m3 ->
+ t3 = t1 ** t2 ->
+ exec_instrs c sp pc1 rs1 m1 t3 pc3 rs3 m3
(** [exec_function ge f args m res m'] executes a function application.
[f] is the called function, [args] the values of its arguments,
@@ -205,17 +226,21 @@ with exec_instrs: code -> val ->
(Non-parameter registers are initialized to [Vundef].) Before returning,
the stack activation block is freed. *)
-with exec_function: function -> list val -> mem ->
- val -> mem -> Prop :=
- | exec_funct:
- forall f m m1 stk args pc rs m2 or vres,
+with exec_function: fundef -> list val -> mem -> trace ->
+ val -> mem -> Prop :=
+ | exec_funct_internal:
+ forall f m m1 stk args t pc rs m2 or vres,
Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) ->
- exec_instrs f.(fn_code) (Vptr stk Int.zero)
+ exec_instrs f.(fn_code) (Vptr stk Int.zero)
f.(fn_entrypoint) (init_regs args f.(fn_params)) m1
- pc rs m2 ->
+ t pc rs m2 ->
f.(fn_code)!pc = Some(Ireturn or) ->
vres = regmap_optget or Vundef rs ->
- exec_function f args m vres (Mem.free m2 stk).
+ exec_function (Internal f) args m t vres (Mem.free m2 stk)
+ | exec_funct_external:
+ forall ef args m t res,
+ event_match ef args t res ->
+ exec_function (External ef) args m t res m.
Scheme exec_instr_ind_3 := Minimality for exec_instr Sort Prop
with exec_instrs_ind_3 := Minimality for exec_instrs Sort Prop
@@ -224,12 +249,13 @@ Scheme exec_instr_ind_3 := Minimality for exec_instr Sort Prop
(** Some derived execution rules. *)
Lemma exec_step:
- forall c sp pc1 rs1 m1 pc2 rs2 m2 pc3 rs3 m3,
- exec_instr c sp pc1 rs1 m1 pc2 rs2 m2 ->
- exec_instrs c sp pc2 rs2 m2 pc3 rs3 m3 ->
- exec_instrs c sp pc1 rs1 m1 pc3 rs3 m3.
+ forall c sp pc1 rs1 m1 t1 pc2 rs2 m2 t2 pc3 rs3 m3 t3,
+ exec_instr c sp pc1 rs1 m1 t1 pc2 rs2 m2 ->
+ exec_instrs c sp pc2 rs2 m2 t2 pc3 rs3 m3 ->
+ t3 = t1 ** t2 ->
+ exec_instrs c sp pc1 rs1 m1 t3 pc3 rs3 m3.
Proof.
- intros. eapply exec_trans. apply exec_one. eauto. eauto.
+ intros. eapply exec_trans. apply exec_one. eauto. eauto. auto.
Qed.
Lemma exec_Iop':
@@ -237,7 +263,7 @@ Lemma exec_Iop':
c!pc = Some(Iop op args res pc') ->
eval_operation ge sp op rs##args = Some v ->
rs' = (rs#res <- v) ->
- exec_instr c sp pc rs m pc' rs' m.
+ exec_instr c sp pc rs m E0 pc' rs' m.
Proof.
intros. subst rs'. eapply exec_Iop; eauto.
Qed.
@@ -248,7 +274,7 @@ Lemma exec_Iload':
eval_addressing ge sp addr rs##args = Some a ->
Mem.loadv chunk m a = Some v ->
rs' = (rs#dst <- v) ->
- exec_instr c sp pc rs m pc' rs' m.
+ exec_instr c sp pc rs m E0 pc' rs' m.
Proof.
intros. subst rs'. eapply exec_Iload; eauto.
Qed.
@@ -257,16 +283,16 @@ Qed.
is defined in the CFG. *)
Lemma exec_instr_present:
- forall c sp pc rs m pc' rs' m',
- exec_instr c sp pc rs m pc' rs' m' ->
+ forall c sp pc rs m t pc' rs' m',
+ exec_instr c sp pc rs m t pc' rs' m' ->
c!pc <> None.
Proof.
induction 1; congruence.
Qed.
Lemma exec_instrs_present:
- forall c sp pc rs m pc' rs' m',
- exec_instrs c sp pc rs m pc' rs' m' ->
+ forall c sp pc rs m t pc' rs' m',
+ exec_instrs c sp pc rs m t pc' rs' m' ->
c!pc' <> None -> c!pc <> None.
Proof.
induction 1; intros.
@@ -280,14 +306,14 @@ End RELSEM.
(** Execution of whole programs. As in Cminor, we call the ``main'' function
with no arguments and observe its return value. *)
-Definition exec_program (p: program) (r: val) : Prop :=
+Definition exec_program (p: program) (t: trace) (r: val) : Prop :=
let ge := Genv.globalenv p in
let m0 := Genv.init_mem p in
exists b, exists f, exists m,
Genv.find_symbol ge p.(prog_main) = Some b /\
Genv.find_funct_ptr ge b = Some f /\
- f.(fn_sig) = mksignature nil (Some Tint) /\
- exec_function ge f nil m0 r m.
+ funsig f = mksignature nil (Some Tint) /\
+ exec_function ge f nil m0 t r m.
(** * Operations on RTL abstract syntax *)
@@ -304,14 +330,15 @@ Definition successors (f: function) (pc: node) : list node :=
| Iload chunk addr args dst s => s :: nil
| Istore chunk addr args src s => s :: nil
| Icall sig ros args res s => s :: nil
+ | Ialloc arg res s => s :: nil
| Icond cond args ifso ifnot => ifso :: ifnot :: nil
| Ireturn optarg => nil
end
end.
Lemma successors_correct:
- forall ge f sp pc rs m pc' rs' m',
- exec_instr ge f.(fn_code) sp pc rs m pc' rs' m' ->
+ forall ge f sp pc rs m t pc' rs' m',
+ exec_instr ge f.(fn_code) sp pc rs m t pc' rs' m' ->
In pc' (successors f pc).
Proof.
intros ge f. unfold successors. generalize (fn_code f).
@@ -345,5 +372,5 @@ Definition transf_function (f: function) : function :=
f.(fn_entrypoint)
f.(fn_nextpc)
(transf_code_wf f.(fn_code) f.(fn_nextpc) f.(fn_code_wf)).
-
+
End TRANSF.
diff --git a/backend/RTLgen.v b/backend/RTLgen.v
index 38b19a0..a5c3ae7 100644
--- a/backend/RTLgen.v
+++ b/backend/RTLgen.v
@@ -28,6 +28,7 @@ Fixpoint mutated_expr (a: expr) : list ident :=
| Econdition b c d => mutated_condexpr b ++ mutated_expr c ++ mutated_expr d
| Elet b c => mutated_expr b ++ mutated_expr c
| Eletvar n => nil
+ | Ealloc b => mutated_expr b
end
with mutated_condexpr (a: condexpr) : list ident :=
@@ -328,6 +329,10 @@ Fixpoint transl_expr (map: mapping) (mut: list ident)
transl_expr map mut b r nc
| Eletvar n =>
do r <- find_letvar map n; add_move r rd nd
+ | Ealloc a =>
+ do r <- alloc_reg map mut a;
+ do no <- add_instr (Ialloc r rd nd);
+ transl_expr map mut a r no
end
(** Translation of a conditional expression. Similar to [transl_expr],
@@ -473,16 +478,18 @@ Definition transl_function (f: Cminor.function) : option RTL.function :=
| Error => None
| OK (nentry, rparams) s =>
Some (RTL.mkfunction
- f.(Cminor.fn_sig)
- rparams
- f.(Cminor.fn_stackspace)
- s.(st_code)
- nentry
- s.(st_nextnode)
- s.(st_wf))
+ f.(Cminor.fn_sig)
+ rparams
+ f.(Cminor.fn_stackspace)
+ s.(st_code)
+ nentry
+ s.(st_nextnode)
+ s.(st_wf))
end.
+Definition transl_fundef := transf_partial_fundef transl_function.
+
(** Translation of a whole program. *)
Definition transl_program (p: Cminor.program) : option RTL.program :=
- transform_partial_program transl_function p.
+ transform_partial_program transl_fundef p.
diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v
index d34bae9..24cc41b 100644
--- a/backend/RTLgenproof.v
+++ b/backend/RTLgenproof.v
@@ -6,6 +6,7 @@ Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Registers.
@@ -30,45 +31,59 @@ 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 transl_function.
+ apply Genv.find_symbol_transf_partial with transl_fundef.
exact TRANSL.
Qed.
Lemma function_ptr_translated:
- forall (b: block) (f: Cminor.function),
+ forall (b: block) (f: Cminor.fundef),
Genv.find_funct_ptr ge b = Some f ->
exists tf,
- Genv.find_funct_ptr tge b = Some tf /\ transl_function f = Some tf.
+ Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = Some tf.
Proof.
intros.
generalize
- (Genv.find_funct_ptr_transf_partial transl_function TRANSL H).
- case (transl_function f).
+ (Genv.find_funct_ptr_transf_partial transl_fundef TRANSL H).
+ case (transl_fundef f).
intros tf [A B]. exists tf. tauto.
intros [A B]. elim B. reflexivity.
Qed.
Lemma functions_translated:
- forall (v: val) (f: Cminor.function),
+ forall (v: val) (f: Cminor.fundef),
Genv.find_funct ge v = Some f ->
exists tf,
- Genv.find_funct tge v = Some tf /\ transl_function f = Some tf.
+ Genv.find_funct tge v = Some tf /\ transl_fundef f = Some tf.
Proof.
intros.
generalize
- (Genv.find_funct_transf_partial transl_function TRANSL H).
- case (transl_function f).
+ (Genv.find_funct_transf_partial transl_fundef TRANSL H).
+ case (transl_fundef f).
intros tf [A B]. exists tf. tauto.
intros [A B]. elim B. reflexivity.
Qed.
+Lemma sig_transl_function:
+ forall (f: Cminor.fundef) (tf: RTL.fundef),
+ transl_fundef f = Some tf ->
+ RTL.funsig tf = Cminor.funsig f.
+Proof.
+ intros until tf. unfold transl_fundef, transf_partial_fundef.
+ case f; intro.
+ unfold transl_function.
+ case (transl_fun f0 init_state); intros.
+ discriminate.
+ destruct p. inversion H. reflexivity.
+ intro. inversion H. reflexivity.
+Qed.
+
(** Correctness of the code generated by [add_move]. *)
Lemma add_move_correct:
forall r1 r2 sp nd s ns s' rs m,
add_move r1 r2 nd s = OK ns s' ->
exists rs',
- exec_instrs tge s'.(st_code) sp ns rs m nd rs' m /\
+ exec_instrs tge s'.(st_code) sp ns rs m E0 nd rs' m /\
rs'#r2 = rs#r1 /\
(forall r, r <> r2 -> rs'#r = rs#r).
Proof.
@@ -118,7 +133,7 @@ Qed.
Definition transl_expr_correct
(sp: val) (le: letenv) (e: env) (m: mem) (a: expr)
- (e': env) (m': mem) (v: val) : Prop :=
+ (t: trace) (e': env) (m': mem) (v: val) : Prop :=
forall map mut rd nd s ns s' rs
(MWF: map_wf map s)
(TE: transl_expr map mut a rd nd s = OK ns s')
@@ -126,7 +141,7 @@ Definition transl_expr_correct
(MUT: incl (mutated_expr a) mut)
(TRG: target_reg_ok s map mut a rd),
exists rs',
- exec_instrs tge s'.(st_code) sp ns rs m nd rs' m'
+ exec_instrs tge s'.(st_code) sp ns rs m t nd rs' m'
/\ match_env map e' le rs'
/\ rs'#rd = v
/\ (forall r,
@@ -139,7 +154,7 @@ Definition transl_expr_correct
Definition transl_exprlist_correct
(sp: val) (le: letenv) (e: env) (m: mem) (al: exprlist)
- (e': env) (m': mem) (vl: list val) : Prop :=
+ (t: trace) (e': env) (m': mem) (vl: list val) : Prop :=
forall map mut rl nd s ns s' rs
(MWF: map_wf map s)
(TE: transl_exprlist map mut al rl nd s = OK ns s')
@@ -147,7 +162,7 @@ Definition transl_exprlist_correct
(MUT: incl (mutated_exprlist al) mut)
(TRG: target_regs_ok s map mut al rl),
exists rs',
- exec_instrs tge s'.(st_code) sp ns rs m nd rs' m'
+ exec_instrs tge s'.(st_code) sp ns rs m t nd rs' m'
/\ match_env map e' le rs'
/\ rs'##rl = vl
/\ (forall r,
@@ -157,14 +172,14 @@ Definition transl_exprlist_correct
Definition transl_condition_correct
(sp: val) (le: letenv) (e: env) (m: mem) (a: condexpr)
- (e': env) (m': mem) (vb: bool) : Prop :=
+ (t: trace) (e': env) (m': mem) (vb: bool) : Prop :=
forall map mut ntrue nfalse s ns s' rs
(MWF: map_wf map s)
(TE: transl_condition map mut a ntrue nfalse s = OK ns s')
(ME: match_env map e le rs)
(MUT: incl (mutated_condexpr a) mut),
exists rs',
- exec_instrs tge s'.(st_code) sp ns rs m (if vb then ntrue else nfalse) rs' m'
+ exec_instrs tge s'.(st_code) sp ns rs m t (if vb then ntrue else nfalse) rs' m'
/\ match_env map e' le rs'
/\ (forall r,
reg_valid r s -> ~(mutated_reg map mut r) ->
@@ -233,7 +248,7 @@ Definition match_return_outcome
Definition transl_stmt_correct
(sp: val) (e: env) (m: mem) (a: stmt)
- (e': env) (m': mem) (out: outcome) : Prop :=
+ (t: trace) (e': env) (m': mem) (out: outcome) : Prop :=
forall map ncont nexits nret rret s ns s' nd rs
(MWF: map_wf map s)
(TE: transl_stmt map a ncont nexits nret rret s = OK ns s')
@@ -241,7 +256,7 @@ Definition transl_stmt_correct
(OUT: outcome_node out ncont nexits nret nd)
(RRG: return_reg_ok s map rret),
exists rs',
- exec_instrs tge s'.(st_code) sp ns rs m nd rs' m'
+ exec_instrs tge s'.(st_code) sp ns rs m t nd rs' m'
/\ match_env map e' nil rs'
/\ match_return_outcome out rret rs'.
@@ -251,11 +266,11 @@ Definition transl_stmt_correct
the same modifications on the memory state. *)
Definition transl_function_correct
- (m: mem) (f: Cminor.function) (vargs: list val)
- (m':mem) (vres: val) : Prop :=
+ (m: mem) (f: Cminor.fundef) (vargs: list val)
+ (t: trace) (m':mem) (vres: val) : Prop :=
forall tf
- (TE: transl_function f = Some tf),
- exec_function tge tf vargs m vres m'.
+ (TE: transl_fundef f = Some tf),
+ exec_function tge tf vargs m t vres m'.
(** The correctness of the translation is a huge induction over
the Cminor evaluation derivation for the source program. To keep
@@ -268,7 +283,7 @@ Definition transl_function_correct
Lemma transl_expr_Evar_correct:
forall (sp: val) (le: letenv) (e: env) (m: mem) (id: ident) (v: val),
e!id = Some v ->
- transl_expr_correct sp le e m (Evar id) e m v.
+ transl_expr_correct sp le e m (Evar id) E0 e m v.
Proof.
intros; red; intros. monadInv TE. intro.
generalize EQ; unfold find_var. caseEq (map_vars map)!id.
@@ -303,12 +318,12 @@ Qed.
Lemma transl_expr_Eop_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem) (op : operation)
- (al : exprlist) (e1 : env) (m1 : mem) (vl : list val)
+ (al : exprlist) (t: trace) (e1 : env) (m1 : mem) (vl : list val)
(v: val),
- eval_exprlist ge sp le e m al e1 m1 vl ->
- transl_exprlist_correct sp le e m al e1 m1 vl ->
+ eval_exprlist ge sp le e m al t e1 m1 vl ->
+ transl_exprlist_correct sp le e m al t e1 m1 vl ->
eval_operation ge sp op vl = Some v ->
- transl_expr_correct sp le e m (Eop op al) e1 m1 v.
+ transl_expr_correct sp le e m (Eop op al) t e1 m1 v.
Proof.
intros until v. intros EEL TEL EOP. red; intros.
simpl in TE. monadInv TE. intro EQ1.
@@ -323,9 +338,9 @@ Proof.
apply exec_instrs_incr with s1. eauto with rtlg.
apply exec_one; eapply exec_Iop. eauto with rtlg.
subst vl.
- rewrite (@eval_operation_preserved Cminor.function RTL.function ge tge).
+ rewrite (@eval_operation_preserved Cminor.fundef RTL.fundef ge tge).
eexact EOP.
- exact symbols_preserved.
+ exact symbols_preserved. traceEq.
(* Match-env *)
split. inversion TRG. eauto with rtlg.
(* Result reg *)
@@ -344,11 +359,11 @@ Qed.
Lemma transl_expr_Eassign_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem)
- (id : ident) (a : expr) (e1 : env) (m1 : mem)
+ (id : ident) (a : expr) (t: trace) (e1 : env) (m1 : mem)
(v : val),
- eval_expr ge sp le e m a e1 m1 v ->
- transl_expr_correct sp le e m a e1 m1 v ->
- transl_expr_correct sp le e m (Eassign id a) (PTree.set id v e1) m1 v.
+ eval_expr ge sp le e m a t e1 m1 v ->
+ transl_expr_correct sp le e m a t e1 m1 v ->
+ transl_expr_correct sp le e m (Eassign id a) t (PTree.set id v e1) m1 v.
Proof.
intros; red; intros.
simpl in TE. monadInv TE. intro EQ1.
@@ -366,7 +381,7 @@ Proof.
(* Exec *)
split. eapply exec_trans. eexact EX1.
apply exec_instrs_incr with s1. eauto with rtlg.
- exact EX2.
+ eexact EX2. traceEq.
(* Match-env *)
split.
apply match_env_update_var with rs1 r s s0; auto.
@@ -387,13 +402,13 @@ Qed.
Lemma transl_expr_Eload_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem)
(chunk : memory_chunk) (addr : addressing)
- (al : exprlist) (e1 : env) (m1 : mem) (v : val)
+ (al : exprlist) (t: trace) (e1 : env) (m1 : mem) (v : val)
(vl : list val) (a: val),
- eval_exprlist ge sp le e m al e1 m1 vl ->
- transl_exprlist_correct sp le e m al e1 m1 vl ->
+ eval_exprlist ge sp le e m al t e1 m1 vl ->
+ transl_exprlist_correct sp le e m al t e1 m1 vl ->
eval_addressing ge sp addr vl = Some a ->
Mem.loadv chunk m1 a = Some v ->
- transl_expr_correct sp le e m (Eload chunk addr al) e1 m1 v.
+ transl_expr_correct sp le e m (Eload chunk addr al) t e1 m1 v.
Proof.
intros; red; intros. simpl in TE. monadInv TE. intro EQ1. clear TE.
simpl in MUT.
@@ -407,7 +422,7 @@ Proof.
apply exec_instrs_incr with s1. eauto with rtlg.
apply exec_one. eapply exec_Iload. eauto with rtlg.
rewrite RES1. rewrite (@eval_addressing_preserved _ _ ge tge).
- eexact H1. exact symbols_preserved. assumption.
+ eexact H1. exact symbols_preserved. assumption. traceEq.
(* Match-env *)
split. eapply match_env_update_temp. assumption. inversion TRG. assumption.
(* Result *)
@@ -425,16 +440,17 @@ Qed.
Lemma transl_expr_Estore_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem)
(chunk : memory_chunk) (addr : addressing)
- (al : exprlist) (b : expr) (e1 : env) (m1 : mem)
- (vl : list val) (e2 : env) (m2 m3 : mem)
+ (al : exprlist) (b : expr) (t t1: trace) (e1 : env) (m1 : mem)
+ (vl : list val) (t2: trace) (e2 : env) (m2 m3 : mem)
(v : val) (a: val),
- eval_exprlist ge sp le e m al e1 m1 vl ->
- transl_exprlist_correct sp le e m al e1 m1 vl ->
- eval_expr ge sp le e1 m1 b e2 m2 v ->
- transl_expr_correct sp le e1 m1 b e2 m2 v ->
+ eval_exprlist ge sp le e m al t1 e1 m1 vl ->
+ transl_exprlist_correct sp le e m al t1 e1 m1 vl ->
+ eval_expr ge sp le e1 m1 b t2 e2 m2 v ->
+ transl_expr_correct sp le e1 m1 b t2 e2 m2 v ->
eval_addressing ge sp addr vl = Some a ->
Mem.storev chunk m2 a v = Some m3 ->
- transl_expr_correct sp le e m (Estore chunk addr al b) e2 m3 v.
+ t = t1 ** t2 ->
+ transl_expr_correct sp le e m (Estore chunk addr al b) t e2 m3 v.
Proof.
intros; red; intros. simpl in TE; monadInv TE. intro EQ2; clear TE.
simpl in MUT.
@@ -467,10 +483,11 @@ Proof.
tauto. right. apply sym_not_equal.
apply valid_fresh_different with s. inversion TRG; assumption.
assumption.
- rewrite H5; rewrite RES1.
+ rewrite H6; rewrite RES1.
rewrite (@eval_addressing_preserved _ _ ge tge).
eexact H3. exact symbols_preserved.
rewrite RES2. assumption.
+ reflexivity. traceEq.
(* Match-env *)
split. assumption.
(* Result *)
@@ -488,18 +505,20 @@ Qed.
Lemma transl_expr_Ecall_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem)
- (sig : signature) (a : expr) (bl : exprlist)
- (e1 e2 : env) (m1 m2 m3 : mem) (vf : val)
- (vargs : list val) (vres : val) (f : Cminor.function),
- eval_expr ge sp le e m a e1 m1 vf ->
- transl_expr_correct sp le e m a e1 m1 vf ->
- eval_exprlist ge sp le e1 m1 bl e2 m2 vargs ->
- transl_exprlist_correct sp le e1 m1 bl e2 m2 vargs ->
+ (sig : signature) (a : expr) (bl : exprlist) (t t1: trace)
+ (e1: env) (m1: mem) (t2: trace) (e2 : env) (m2 : mem)
+ (t3: trace) (m3: mem) (vf : val)
+ (vargs : list val) (vres : val) (f : Cminor.fundef),
+ eval_expr ge sp le e m a t1 e1 m1 vf ->
+ transl_expr_correct sp le e m a t1 e1 m1 vf ->
+ eval_exprlist ge sp le e1 m1 bl t2 e2 m2 vargs ->
+ transl_exprlist_correct sp le e1 m1 bl t2 e2 m2 vargs ->
Genv.find_funct ge vf = Some f ->
- Cminor.fn_sig f = sig ->
- eval_funcall ge m2 f vargs m3 vres ->
- transl_function_correct m2 f vargs m3 vres ->
- transl_expr_correct sp le e m (Ecall sig a bl) e2 m3 vres.
+ Cminor.funsig f = sig ->
+ eval_funcall ge m2 f vargs t3 m3 vres ->
+ transl_function_correct m2 f vargs t3 m3 vres ->
+ t = t1 ** t2 ** t3 ->
+ transl_expr_correct sp le e m (Ecall sig a bl) t e2 m3 vres.
Proof.
intros. red; simpl; intros.
monadInv TE. intro EQ3. clear TE.
@@ -530,7 +549,7 @@ Proof.
generalize (H6 tf TF). intro EXF.
assert (EX3: exec_instrs tge (st_code s2) sp n rs2 m2
- nd (rs2#rd <- vres) m3).
+ t3 nd (rs2#rd <- vres) m3).
apply exec_one. eapply exec_Icall.
eauto with rtlg. simpl. replace (rs2#r) with vf. eexact TFIND.
rewrite <- RES1. symmetry. apply OTHER2.
@@ -543,10 +562,7 @@ Proof.
tauto. byContradiction. apply valid_fresh_absurd with r s0.
eauto with rtlg. assumption.
tauto.
- generalize TF. unfold transl_function.
- destruct (transl_fun f init_state).
- intro; discriminate. destruct p. intros. injection TF0. intro.
- rewrite <- H7; simpl. auto.
+ generalize (sig_transl_function _ _ TF). congruence.
rewrite RES2. assumption.
exists (rs2#rd <- vres).
@@ -555,7 +571,7 @@ Proof.
apply exec_instrs_incr with s3. eauto with rtlg.
eapply exec_trans. eexact EX2.
apply exec_instrs_incr with s2. eauto with rtlg.
- exact EX3.
+ eexact EX3. reflexivity. traceEq.
(* Match env *)
split. apply match_env_update_temp. assumption.
inversion TRG. assumption.
@@ -591,13 +607,14 @@ Qed.
Lemma transl_expr_Econdition_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem)
- (a : condexpr) (b c : expr) (e1 : env) (m1 : mem)
- (v1 : bool) (e2 : env) (m2 : mem) (v2 : val),
- eval_condexpr ge sp le e m a e1 m1 v1 ->
- transl_condition_correct sp le e m a e1 m1 v1 ->
- eval_expr ge sp le e1 m1 (if v1 then b else c) e2 m2 v2 ->
- transl_expr_correct sp le e1 m1 (if v1 then b else c) e2 m2 v2 ->
- transl_expr_correct sp le e m (Econdition a b c) e2 m2 v2.
+ (a : condexpr) (b c : expr) (t t1: trace) (e1 : env) (m1 : mem)
+ (v1 : bool) (t2: trace) (e2 : env) (m2 : mem) (v2 : val),
+ eval_condexpr ge sp le e m a t1 e1 m1 v1 ->
+ transl_condition_correct sp le e m a t1 e1 m1 v1 ->
+ eval_expr ge sp le e1 m1 (if v1 then b else c) t2 e2 m2 v2 ->
+ transl_expr_correct sp le e1 m1 (if v1 then b else c) t2 e2 m2 v2 ->
+ t = t1 ** t2 ->
+ transl_expr_correct sp le e m (Econdition a b c) t e2 m2 v2.
Proof.
intros; red; intros. simpl in TE; monadInv TE. intro EQ1; clear TE.
simpl in MUT.
@@ -619,7 +636,7 @@ Proof.
(* Exec *)
split. eapply exec_trans. eexact EX1.
apply exec_instrs_incr with s1. eauto with rtlg.
- exact EX2.
+ eexact EX2. auto.
(* Match-env *)
split. assumption.
(* Result value *)
@@ -639,7 +656,7 @@ Proof.
(* Exec *)
split. eapply exec_trans. eexact EX1.
apply exec_instrs_incr with s0. eauto with rtlg.
- exact EX2.
+ eexact EX2. auto.
(* Match-env *)
split. assumption.
(* Result value *)
@@ -653,13 +670,14 @@ Qed.
Lemma transl_expr_Elet_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem)
- (a b : expr) (e1 : env) (m1 : mem) (v1 : val)
- (e2 : env) (m2 : mem) (v2 : val),
- eval_expr ge sp le e m a e1 m1 v1 ->
- transl_expr_correct sp le e m a e1 m1 v1 ->
- eval_expr ge sp (v1 :: le) e1 m1 b e2 m2 v2 ->
- transl_expr_correct sp (v1 :: le) e1 m1 b e2 m2 v2 ->
- transl_expr_correct sp le e m (Elet a b) e2 m2 v2.
+ (a b : expr) (t t1: trace) (e1 : env) (m1 : mem) (v1 : val)
+ (t2: trace) (e2 : env) (m2 : mem) (v2 : val),
+ eval_expr ge sp le e m a t1 e1 m1 v1 ->
+ transl_expr_correct sp le e m a t1 e1 m1 v1 ->
+ eval_expr ge sp (v1 :: le) e1 m1 b t2 e2 m2 v2 ->
+ transl_expr_correct sp (v1 :: le) e1 m1 b t2 e2 m2 v2 ->
+ t = t1 ** t2 ->
+ transl_expr_correct sp le e m (Elet a b) t e2 m2 v2.
Proof.
intros; red; intros.
simpl in TE; monadInv TE. intro EQ1.
@@ -678,17 +696,17 @@ Proof.
assert (TRG2: target_reg_ok s0 (add_letvar map r) mut b rd).
inversion TRG. apply target_reg_other.
unfold reg_in_map, add_letvar; simpl. red; intro.
- elim H10; intro. apply H3. left. assumption.
- elim H11; intro. apply valid_fresh_absurd with rd s.
- assumption. rewrite <- H12. eauto with rtlg.
- apply H3. right. assumption.
+ elim H11; intro. apply H4. left. assumption.
+ elim H12; intro. apply valid_fresh_absurd with rd s.
+ assumption. rewrite <- H13. eauto with rtlg.
+ apply H4. right. assumption.
eauto with rtlg.
generalize (H2 _ _ _ _ _ _ _ _ MWF2 EQ0 ME2 MUT2 TRG2).
intros [rs2 [EX2 [ME3 [RES2 OTHER2]]]].
exists rs2.
(* Exec *)
split. eapply exec_trans. eexact EX1.
- apply exec_instrs_incr with s1. eauto with rtlg. exact EX2.
+ apply exec_instrs_incr with s1. eauto with rtlg. eexact EX2. auto.
(* Match-env *)
split. apply mk_match_env. exact (me_vars _ _ _ _ ME3).
generalize (me_letvars _ _ _ _ ME3).
@@ -699,21 +717,21 @@ Proof.
intros. transitivity (rs1#r0).
apply OTHER2. eauto with rtlg.
unfold mutated_reg. unfold add_letvar; simpl. assumption.
- elim H5; intro. left.
+ elim H6; intro. left.
unfold reg_in_map, add_letvar; simpl.
- unfold reg_in_map in H6; tauto.
+ unfold reg_in_map in H7; tauto.
tauto.
apply OTHER1. eauto with rtlg.
assumption.
right. red; intro. apply valid_fresh_absurd with r0 s.
- assumption. rewrite H6. eauto with rtlg.
+ assumption. rewrite H7. eauto with rtlg.
Qed.
Lemma transl_expr_Eletvar_correct:
forall (sp: val) (le : list val) (e : env)
(m : mem) (n : nat) (v : val),
nth_error le n = Some v ->
- transl_expr_correct sp le e m (Eletvar n) e m v.
+ transl_expr_correct sp le e m (Eletvar n) E0 e m v.
Proof.
intros; red; intros.
simpl in TE; monadInv TE. intro EQ1.
@@ -746,9 +764,46 @@ Proof.
intro; monadSimpl.
Qed.
+Lemma transl_expr_Ealloc_correct:
+ forall (sp: val) (le : letenv) (e : env) (m : mem)
+ (a : expr) (t: trace) (e1 : env) (m1 : mem) (n: int)
+ (m2: mem) (b: block),
+ eval_expr ge sp le e m a t e1 m1 (Vint n) ->
+ transl_expr_correct sp le e m a t e1 m1 (Vint n) ->
+ Mem.alloc m1 0 (Int.signed n) = (m2, b) ->
+ transl_expr_correct sp le e m (Ealloc a) t e1 m2 (Vptr b Int.zero).
+Proof.
+ intros until b; intros EE TEC ALLOC; red; intros.
+ simpl in TE. monadInv TE. intro EQ1.
+ simpl in MUT.
+ assert (TRG': target_reg_ok s1 map mut a r); eauto with rtlg.
+ assert (MWF': map_wf map s1). eauto with rtlg.
+ generalize (TEC _ _ _ _ _ _ _ _ MWF' EQ1 ME MUT TRG').
+ intros [rs1 [EX1 [ME1 [RR1 RO1]]]].
+ exists (rs1#rd <- (Vptr b Int.zero)).
+(* Exec *)
+ split. eapply exec_trans. eexact EX1.
+ apply exec_instrs_incr with s1. eauto with rtlg.
+ apply exec_one; eapply exec_Ialloc. eauto with rtlg.
+ eexact RR1. assumption. traceEq.
+(* Match-env *)
+ split. inversion TRG. eauto with rtlg.
+(* Result *)
+ split. apply Regmap.gss.
+(* Other regs *)
+ intros. rewrite Regmap.gso.
+ apply RO1. eauto with rtlg. assumption.
+ case (Reg.eq r0 r); intro.
+ subst r0. left. elim (alloc_reg_fresh_or_in_map _ _ _ _ _ _ MWF EQ); intro.
+ auto. byContradiction; eauto with rtlg.
+ right; assumption.
+ elim H1; intro. red; intro. subst r0. inversion TRG. contradiction.
+ auto.
+Qed.
+
Lemma transl_condition_CEtrue_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem),
- transl_condition_correct sp le e m CEtrue e m true.
+ transl_condition_correct sp le e m CEtrue E0 e m true.
Proof.
intros; red; intros. simpl in TE; monadInv TE. subst ns.
exists rs. split. apply exec_refl. split. auto. auto.
@@ -756,7 +811,7 @@ Qed.
Lemma transl_condition_CEfalse_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem),
- transl_condition_correct sp le e m CEfalse e m false.
+ transl_condition_correct sp le e m CEfalse E0 e m false.
Proof.
intros; red; intros. simpl in TE; monadInv TE. subst ns.
exists rs. split. apply exec_refl. split. auto. auto.
@@ -764,12 +819,12 @@ Qed.
Lemma transl_condition_CEcond_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem)
- (cond : condition) (al : exprlist) (e1 : env)
+ (cond : condition) (al : exprlist) (t1: trace) (e1 : env)
(m1 : mem) (vl : list val) (b : bool),
- eval_exprlist ge sp le e m al e1 m1 vl ->
- transl_exprlist_correct sp le e m al e1 m1 vl ->
+ eval_exprlist ge sp le e m al t1 e1 m1 vl ->
+ transl_exprlist_correct sp le e m al t1 e1 m1 vl ->
eval_condition cond vl = Some b ->
- transl_condition_correct sp le e m (CEcond cond al) e1 m1 b.
+ transl_condition_correct sp le e m (CEcond cond al) t1 e1 m1 b.
Proof.
intros; red; intros. simpl in TE; monadInv TE. intro EQ1; clear TE.
assert (MWF1: map_wf map s1). eauto with rtlg.
@@ -788,6 +843,7 @@ Proof.
rewrite RES1. assumption.
eapply exec_Icond_false. eauto with rtlg.
rewrite RES1. assumption.
+ traceEq.
(* Match-env *)
split. assumption.
(* Regs *)
@@ -800,13 +856,14 @@ Qed.
Lemma transl_condition_CEcondition_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem)
- (a b c : condexpr) (e1 : env) (m1 : mem)
- (vb1 : bool) (e2 : env) (m2 : mem) (vb2 : bool),
- eval_condexpr ge sp le e m a e1 m1 vb1 ->
- transl_condition_correct sp le e m a e1 m1 vb1 ->
- eval_condexpr ge sp le e1 m1 (if vb1 then b else c) e2 m2 vb2 ->
- transl_condition_correct sp le e1 m1 (if vb1 then b else c) e2 m2 vb2 ->
- transl_condition_correct sp le e m (CEcondition a b c) e2 m2 vb2.
+ (a b c : condexpr) (t t1: trace) (e1 : env) (m1 : mem)
+ (vb1 : bool) (t2: trace) (e2 : env) (m2 : mem) (vb2 : bool),
+ eval_condexpr ge sp le e m a t1 e1 m1 vb1 ->
+ transl_condition_correct sp le e m a t1 e1 m1 vb1 ->
+ eval_condexpr ge sp le e1 m1 (if vb1 then b else c) t2 e2 m2 vb2 ->
+ transl_condition_correct sp le e1 m1 (if vb1 then b else c) t2 e2 m2 vb2 ->
+ t = t1 ** t2 ->
+ transl_condition_correct sp le e m (CEcondition a b c) t e2 m2 vb2.
Proof.
intros; red; intros. simpl in TE; monadInv TE. intro EQ1; clear TE.
simpl in MUT.
@@ -823,7 +880,7 @@ Proof.
exists rs2.
split. eapply exec_trans. eexact EX1.
apply exec_instrs_incr with s1. eauto with rtlg.
- exact EX2.
+ eexact EX2. auto.
split. assumption.
intros. transitivity (rs1#r).
apply OTHER2; eauto with rtlg.
@@ -835,7 +892,7 @@ Proof.
exists rs2.
split. eapply exec_trans. eexact EX1.
apply exec_instrs_incr with s0. eauto with rtlg.
- exact EX2.
+ eexact EX2. auto.
split. assumption.
intros. transitivity (rs1#r).
apply OTHER2; eauto with rtlg.
@@ -844,7 +901,7 @@ Qed.
Lemma transl_exprlist_Enil_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem),
- transl_exprlist_correct sp le e m Enil e m nil.
+ transl_exprlist_correct sp le e m Enil E0 e m nil.
Proof.
intros; red; intros.
generalize TE. simpl. destruct rl; monadSimpl.
@@ -857,17 +914,18 @@ Qed.
Lemma transl_exprlist_Econs_correct:
forall (sp: val) (le : letenv) (e : env) (m : mem)
- (a : expr) (bl : exprlist) (e1 : env) (m1 : mem)
- (v : val) (e2 : env) (m2 : mem) (vl : list val),
- eval_expr ge sp le e m a e1 m1 v ->
- transl_expr_correct sp le e m a e1 m1 v ->
- eval_exprlist ge sp le e1 m1 bl e2 m2 vl ->
- transl_exprlist_correct sp le e1 m1 bl e2 m2 vl ->
- transl_exprlist_correct sp le e m (Econs a bl) e2 m2 (v :: vl).
+ (a : expr) (bl : exprlist) (t t1: trace) (e1 : env) (m1 : mem)
+ (v : val) (t2: trace) (e2 : env) (m2 : mem) (vl : list val),
+ eval_expr ge sp le e m a t1 e1 m1 v ->
+ transl_expr_correct sp le e m a t1 e1 m1 v ->
+ eval_exprlist ge sp le e1 m1 bl t2 e2 m2 vl ->
+ transl_exprlist_correct sp le e1 m1 bl t2 e2 m2 vl ->
+ t = t1 ** t2 ->
+ transl_exprlist_correct sp le e m (Econs a bl) t e2 m2 (v :: vl).
Proof.
intros. red. intros.
inversion TRG.
- rewrite <- H10 in TE. simpl in TE. monadInv TE. intro EQ1.
+ rewrite <- H11 in TE. simpl in TE. monadInv TE. intro EQ1.
simpl in MUT.
assert (MUT1: incl (mutated_expr a) mut); eauto with coqlib.
assert (MUT2: incl (mutated_exprlist bl) mut); eauto with coqlib.
@@ -875,12 +933,13 @@ Proof.
assert (TRG1: target_reg_ok s1 map mut a r); eauto with rtlg.
generalize (H0 _ _ _ _ _ _ _ _ MWF1 EQ1 ME MUT1 TRG1).
intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]].
- generalize (H2 _ _ _ _ _ _ _ _ MWF EQ ME1 MUT2 H11).
+ generalize (H2 _ _ _ _ _ _ _ _ MWF EQ ME1 MUT2 H12).
intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]].
exists rs2.
(* Exec *)
split. eapply exec_trans. eexact EX1.
- apply exec_instrs_incr with s1. eauto with rtlg. assumption.
+ apply exec_instrs_incr with s1. eauto with rtlg.
+ eexact EX2. auto.
(* Match-env *)
split. assumption.
(* Results *)
@@ -894,22 +953,23 @@ Proof.
transitivity (rs1#r0).
apply OTHER2; auto. tauto.
apply OTHER1; auto. eauto with rtlg.
- elim H14; intro. left; assumption. right; apply sym_not_equal; tauto.
+ elim H15; intro. left; assumption. right; apply sym_not_equal; tauto.
Qed.
-Lemma transl_funcall_correct:
- forall (m : mem) (f : Cminor.function) (vargs : list val)
- (m1 : mem) (sp : block) (e e2 : env) (m2 : mem)
- (out : outcome) (vres : val),
+Lemma transl_funcall_internal_correct:
+ forall (m : mem) (f : Cminor.function)
+ (vargs : list val) (m1 : mem) (sp : block) (e : env) (t : trace)
+ (e2 : env) (m2 : mem) (out : outcome) (vres : val),
Mem.alloc m 0 (fn_stackspace f) = (m1, sp) ->
- set_locals (Cminor.fn_vars f) (set_params vargs (Cminor.fn_params f)) = e ->
- exec_stmt ge (Vptr sp Int.zero) e m1 (fn_body f) e2 m2 out ->
- transl_stmt_correct (Vptr sp Int.zero) e m1 (fn_body f) e2 m2 out ->
+ set_locals (fn_vars f) (set_params vargs (Cminor.fn_params f)) = e ->
+ exec_stmt ge (Vptr sp Int.zero) e m1 (fn_body f) t e2 m2 out ->
+ transl_stmt_correct (Vptr sp Int.zero) e m1 (fn_body f) t e2 m2 out ->
outcome_result_value out f.(Cminor.fn_sig).(sig_res) vres ->
- transl_function_correct m f vargs (Mem.free m2 sp) vres.
+ transl_function_correct m (Internal f)
+ vargs t (Mem.free m2 sp) vres.
Proof.
intros; red; intros.
- generalize TE. unfold transl_function.
+ generalize TE. unfold transl_fundef, transl_function; simpl.
caseEq (transl_fun f init_state).
intros; discriminate.
intros ns s. unfold transl_fun. monadSimpl.
@@ -934,30 +994,41 @@ Proof.
apply map_wf_incr with s1. apply state_incr_trans with s2; eauto with rtlg.
assumption.
- assert (RRG: return_reg_ok s3 y0 (ret_reg (Cminor.fn_sig f) r)).
+ set (rr := ret_reg (Cminor.fn_sig f) r) in *.
+ assert (RRG: return_reg_ok s3 y0 rr).
apply return_reg_ok_incr with s2. eauto with rtlg.
- apply new_reg_return_ok with s1; assumption.
+ unfold rr; apply new_reg_return_ok with s1; assumption.
generalize (H2 _ _ _ _ _ _ _ _ _ rs MWF EQ3 ME OUT RRG).
intros [rs1 [EX1 [ME1 MR1]]].
- apply exec_funct with m1 n rs1 (ret_reg (Cminor.fn_sig f) r).
- rewrite <- TF; simpl; assumption.
- rewrite <- TF; simpl. exact EX1.
- rewrite <- TF; simpl. apply instr_at_incr with s3.
+ rewrite <- TF. apply exec_funct_internal with m1 n rs1 rr; simpl.
+ assumption.
+ exact EX1.
+ apply instr_at_incr with s3.
eauto with rtlg. discriminate. eauto with rtlg.
generalize MR1. unfold match_return_outcome.
generalize H3. unfold outcome_result_value.
- unfold ret_reg; destruct (sig_res (Cminor.fn_sig f)).
+ unfold rr, ret_reg; destruct (sig_res (Cminor.fn_sig f)).
unfold regmap_optget. destruct out; try contradiction.
destruct o; try contradiction. intros; congruence.
unfold regmap_optget. destruct out; contradiction||auto.
destruct o; contradiction||auto.
Qed.
+Lemma transl_funcall_external_correct:
+ forall (ef : external_function) (m : mem) (args : list val) (t: trace) (res : val),
+ event_match ef args t res ->
+ transl_function_correct m (External ef) args t m res.
+Proof.
+ intros; red; intros. unfold transl_function in TE; simpl in TE.
+ inversion TE; subst tf.
+ apply exec_funct_external. auto.
+Qed.
+
Lemma transl_stmt_Sskip_correct:
forall (sp: val) (e : env) (m : mem),
- transl_stmt_correct sp e m Sskip e m Out_normal.
+ transl_stmt_correct sp e m Sskip E0 e m Out_normal.
Proof.
intros; red; intros. simpl in TE. monadInv TE.
subst s'; subst ns.
@@ -966,13 +1037,15 @@ Proof.
Qed.
Lemma transl_stmt_Sseq_continue_correct:
- forall (sp : val) (e : env) (m : mem) (s1 : stmt) (e1 : env)
- (m1 : mem) (s2 : stmt) (e2 : env) (m2 : mem) (out : outcome),
- exec_stmt ge sp e m s1 e1 m1 Out_normal ->
- transl_stmt_correct sp e m s1 e1 m1 Out_normal ->
- exec_stmt ge sp e1 m1 s2 e2 m2 out ->
- transl_stmt_correct sp e1 m1 s2 e2 m2 out ->
- transl_stmt_correct sp e m (Sseq s1 s2) e2 m2 out.
+ forall (sp : val) (e : env) (m : mem) (t: trace) (s1 : stmt)
+ (t1: trace) (e1 : env) (m1 : mem) (s2 : stmt) (t2: trace)
+ (e2 : env) (m2 : mem) (out : outcome),
+ exec_stmt ge sp e m s1 t1 e1 m1 Out_normal ->
+ transl_stmt_correct sp e m s1 t1 e1 m1 Out_normal ->
+ exec_stmt ge sp e1 m1 s2 t2 e2 m2 out ->
+ transl_stmt_correct sp e1 m1 s2 t2 e2 m2 out ->
+ t = t1 ** t2 ->
+ transl_stmt_correct sp e m (Sseq s1 s2) t e2 m2 out.
Proof.
intros; red; intros. simpl in TE; monadInv TE. intro EQ0.
assert (MWF1: map_wf map s0). eauto with rtlg.
@@ -987,18 +1060,18 @@ Proof.
(* Exec *)
split. eapply exec_trans. eexact EX1.
apply exec_instrs_incr with s0. eauto with rtlg.
- exact EX2.
+ eexact EX2. auto.
(* Match-env + return *)
tauto.
Qed.
Lemma transl_stmt_Sseq_stop_correct:
- forall (sp : val) (e : env) (m : mem) (s1 s2 : stmt) (e1 : env)
+ forall (sp : val) (e : env) (m : mem) (t: trace) (s1 s2 : stmt) (e1 : env)
(m1 : mem) (out : outcome),
- exec_stmt ge sp e m s1 e1 m1 out ->
- transl_stmt_correct sp e m s1 e1 m1 out ->
+ exec_stmt ge sp e m s1 t e1 m1 out ->
+ transl_stmt_correct sp e m s1 t e1 m1 out ->
out <> Out_normal ->
- transl_stmt_correct sp e m (Sseq s1 s2) e1 m1 out.
+ transl_stmt_correct sp e m (Sseq s1 s2) t e1 m1 out.
Proof.
intros; red; intros.
simpl in TE; monadInv TE. intro EQ0; clear TE.
@@ -1010,11 +1083,11 @@ Proof.
Qed.
Lemma transl_stmt_Sexpr_correct:
- forall (sp: val) (e : env) (m : mem) (a : expr)
+ forall (sp: val) (e : env) (m : mem) (a : expr) (t: trace)
(e1 : env) (m1 : mem) (v : val),
- eval_expr ge sp nil e m a e1 m1 v ->
- transl_expr_correct sp nil e m a e1 m1 v ->
- transl_stmt_correct sp e m (Sexpr a) e1 m1 Out_normal.
+ eval_expr ge sp nil e m a t e1 m1 v ->
+ transl_expr_correct sp nil e m a t e1 m1 v ->
+ transl_stmt_correct sp e m (Sexpr a) t e1 m1 Out_normal.
Proof.
intros; red; intros.
simpl in OUT. subst nd.
@@ -1028,17 +1101,18 @@ Qed.
Lemma transl_stmt_Sifthenelse_correct:
forall (sp: val) (e : env) (m : mem) (a : condexpr)
- (sl1 sl2 : stmt) (e1 : env) (m1 : mem)
- (v1 : bool) (e2 : env) (m2 : mem) (out : outcome),
- eval_condexpr ge sp nil e m a e1 m1 v1 ->
- transl_condition_correct sp nil e m a e1 m1 v1 ->
- exec_stmt ge sp e1 m1 (if v1 then sl1 else sl2) e2 m2 out ->
- transl_stmt_correct sp e1 m1 (if v1 then sl1 else sl2) e2 m2 out ->
- transl_stmt_correct sp e m (Sifthenelse a sl1 sl2) e2 m2 out.
+ (s1 s2 : stmt) (t t1: trace) (e1 : env) (m1 : mem)
+ (v1 : bool) (t2: trace) (e2 : env) (m2 : mem) (out : outcome),
+ eval_condexpr ge sp nil e m a t1 e1 m1 v1 ->
+ transl_condition_correct sp nil e m a t1 e1 m1 v1 ->
+ exec_stmt ge sp e1 m1 (if v1 then s1 else s2) t2 e2 m2 out ->
+ transl_stmt_correct sp e1 m1 (if v1 then s1 else s2) t2 e2 m2 out ->
+ t = t1 ** t2 ->
+ transl_stmt_correct sp e m (Sifthenelse a s1 s2) t e2 m2 out.
Proof.
intros; red; intros until rs; intro MWF.
- simpl. case (more_likely a sl1 sl2); monadSimpl; intro EQ2; intros.
- assert (MWF1: map_wf map s1). eauto with rtlg.
+ simpl. case (more_likely a s1 s2); monadSimpl; intro EQ2; intros.
+ assert (MWF1: map_wf map s3). eauto with rtlg.
generalize (H0 _ _ _ _ _ _ _ rs MWF1 EQ2 ME (incl_refl _)).
intros [rs1 [EX1 [ME1 OTHER1]]].
destruct v1.
@@ -1047,17 +1121,17 @@ Proof.
generalize (H2 _ _ _ _ _ _ _ _ _ _ MWF0 EQ0 ME1 OUT RRG0).
intros [rs2 [EX2 [ME2 MRE2]]].
exists rs2. split.
- eapply exec_trans. eexact EX1. apply exec_instrs_incr with s1.
- eauto with rtlg. exact EX2.
+ eapply exec_trans. eexact EX1. apply exec_instrs_incr with s3.
+ eauto with rtlg. eexact EX2. auto.
tauto.
generalize (H2 _ _ _ _ _ _ _ _ _ _ MWF EQ ME1 OUT RRG).
intros [rs2 [EX2 [ME2 MRE2]]].
exists rs2. split.
eapply exec_trans. eexact EX1. apply exec_instrs_incr with s0.
- eauto with rtlg. exact EX2.
+ eauto with rtlg. eexact EX2. auto.
tauto.
- assert (MWF1: map_wf map s1). eauto with rtlg.
+ assert (MWF1: map_wf map s3). eauto with rtlg.
generalize (H0 _ _ _ _ _ _ _ rs MWF1 EQ2 ME (incl_refl _)).
intros [rs1 [EX1 [ME1 OTHER1]]].
destruct v1.
@@ -1065,27 +1139,28 @@ Proof.
intros [rs2 [EX2 [ME2 MRE2]]].
exists rs2. split.
eapply exec_trans. eexact EX1. apply exec_instrs_incr with s0.
- eauto with rtlg. exact EX2.
+ eauto with rtlg. eexact EX2. auto.
tauto.
assert (MWF0: map_wf map s0). eauto with rtlg.
assert (RRG0: return_reg_ok s0 map rret). eauto with rtlg.
generalize (H2 _ _ _ _ _ _ _ _ _ _ MWF0 EQ0 ME1 OUT RRG0).
intros [rs2 [EX2 [ME2 MRE2]]].
exists rs2. split.
- eapply exec_trans. eexact EX1. apply exec_instrs_incr with s1.
- eauto with rtlg. exact EX2.
+ eapply exec_trans. eexact EX1. apply exec_instrs_incr with s3.
+ eauto with rtlg. eexact EX2. auto.
tauto.
Qed.
Lemma transl_stmt_Sloop_loop_correct:
- forall (sp: val) (e : env) (m : mem) (sl : stmt)
- (e1 : env) (m1 : mem) (e2 : env) (m2 : mem)
+ forall (sp: val) (e : env) (m : mem) (sl : stmt) (t t1: trace)
+ (e1 : env) (m1 : mem) (t2: trace) (e2 : env) (m2 : mem)
(out : outcome),
- exec_stmt ge sp e m sl e1 m1 Out_normal ->
- transl_stmt_correct sp e m sl e1 m1 Out_normal ->
- exec_stmt ge sp e1 m1 (Sloop sl) e2 m2 out ->
- transl_stmt_correct sp e1 m1 (Sloop sl) e2 m2 out ->
- transl_stmt_correct sp e m (Sloop sl) e2 m2 out.
+ exec_stmt ge sp e m sl t1 e1 m1 Out_normal ->
+ transl_stmt_correct sp e m sl t1 e1 m1 Out_normal ->
+ exec_stmt ge sp e1 m1 (Sloop sl) t2 e2 m2 out ->
+ transl_stmt_correct sp e1 m1 (Sloop sl) t2 e2 m2 out ->
+ t = t1 ** t2 ->
+ transl_stmt_correct sp e m (Sloop sl) t e2 m2 out.
Proof.
intros; red; intros.
generalize TE. simpl. monadSimpl. subst s2; subst n0. intros.
@@ -1107,22 +1182,23 @@ Proof.
apply exec_instrs_extends with s1.
eapply update_instr_extends.
eexact EQ. eauto with rtlg. eexact EQ1. eexact EX1.
- apply exec_trans with ns rs1 m1.
+ apply exec_trans with E0 ns rs1 m1 t2.
apply exec_one. apply exec_Inop.
generalize EQ1. unfold update_instr.
case (plt n (st_nextnode s1)); intro; monadSimpl.
- rewrite <- H4. simpl. apply PTree.gss.
+ rewrite <- H5. simpl. apply PTree.gss.
exact EX2.
+ reflexivity. traceEq.
tauto.
Qed.
Lemma transl_stmt_Sloop_stop_correct:
- forall (sp: val) (e : env) (m : mem) (sl : stmt)
+ forall (sp: val) (e : env) (m : mem) (t: trace) (sl : stmt)
(e1 : env) (m1 : mem) (out : outcome),
- exec_stmt ge sp e m sl e1 m1 out ->
- transl_stmt_correct sp e m sl e1 m1 out ->
+ exec_stmt ge sp e m sl t e1 m1 out ->
+ transl_stmt_correct sp e m sl t e1 m1 out ->
out <> Out_normal ->
- transl_stmt_correct sp e m (Sloop sl) e1 m1 out.
+ transl_stmt_correct sp e m (Sloop sl) t e1 m1 out.
Proof.
intros; red; intros.
simpl in TE. monadInv TE. subst s2; subst n0.
@@ -1145,11 +1221,11 @@ Proof.
Qed.
Lemma transl_stmt_Sblock_correct:
- forall (sp: val) (e : env) (m : mem) (sl : stmt)
+ forall (sp: val) (e : env) (m : mem) (sl : stmt) (t: trace)
(e1 : env) (m1 : mem) (out : outcome),
- exec_stmt ge sp e m sl e1 m1 out ->
- transl_stmt_correct sp e m sl e1 m1 out ->
- transl_stmt_correct sp e m (Sblock sl) e1 m1 (outcome_block out).
+ exec_stmt ge sp e m sl t e1 m1 out ->
+ transl_stmt_correct sp e m sl t e1 m1 out ->
+ transl_stmt_correct sp e m (Sblock sl) t e1 m1 (outcome_block out).
Proof.
intros; red; intros. simpl in TE.
assert (OUT': outcome_node out ncont (ncont :: nexits) nret nd).
@@ -1180,7 +1256,7 @@ Qed.
Lemma transl_stmt_Sexit_correct:
forall (sp: val) (e : env) (m : mem) (n : nat),
- transl_stmt_correct sp e m (Sexit n) e m (Out_exit n).
+ transl_stmt_correct sp e m (Sexit n) E0 e m (Out_exit n).
Proof.
intros; red; intros.
simpl in TE. simpl in OUT.
@@ -1194,7 +1270,7 @@ Lemma transl_switch_correct:
transl_switch r nexits cases default s = OK ns s' ->
nth_error nexits (switch_target i default cases) = Some nd ->
rs#r = Vint i ->
- exec_instrs tge s'.(st_code) sp ns rs m nd rs m.
+ exec_instrs tge s'.(st_code) sp ns rs m E0 nd rs m.
Proof.
induction cases; simpl; intros.
generalize (transl_exit_correct _ _ _ _ _ H). intros.
@@ -1202,23 +1278,23 @@ Proof.
destruct a as [key1 exit1]. monadInv H. clear H. intro EQ1.
caseEq (Int.eq i key1); intro IEQ; rewrite IEQ in H0.
(* i = key1 *)
- apply exec_trans with n0 rs m. apply exec_one.
+ apply exec_trans with E0 n0 rs m E0. apply exec_one.
eapply exec_Icond_true. eauto with rtlg. simpl. rewrite H1. congruence.
generalize (transl_exit_correct _ _ _ _ _ EQ0); intro.
- assert (n0 = nd). congruence. subst n0. apply exec_refl.
+ assert (n0 = nd). congruence. subst n0. apply exec_refl. traceEq.
(* i <> key1 *)
- apply exec_trans with n rs m. apply exec_one.
+ apply exec_trans with E0 n rs m E0. apply exec_one.
eapply exec_Icond_false. eauto with rtlg. simpl. rewrite H1. congruence.
- apply exec_instrs_incr with s0; eauto with rtlg.
+ apply exec_instrs_incr with s0; eauto with rtlg. traceEq.
Qed.
Lemma transl_stmt_Sswitch_correct:
forall (sp : val) (e : env) (m : mem) (a : expr)
- (cases : list (int * nat)) (default : nat) (e1 : env) (m1 : mem)
- (n : int),
- eval_expr ge sp nil e m a e1 m1 (Vint n) ->
- transl_expr_correct sp nil e m a e1 m1 (Vint n) ->
- transl_stmt_correct sp e m (Sswitch a cases default) e1 m1
+ (cases : list (int * nat)) (default : nat)
+ (t1 : trace) (e1 : env) (m1 : mem) (n : int),
+ eval_expr ge sp nil e m a t1 e1 m1 (Vint n) ->
+ transl_expr_correct sp nil e m a t1 e1 m1 (Vint n) ->
+ transl_stmt_correct sp e m (Sswitch a cases default) t1 e1 m1
(Out_exit (switch_target n default cases)).
Proof.
intros; red; intros. monadInv TE. clear TE; intros EQ1.
@@ -1234,14 +1310,14 @@ Proof.
(* execution *)
split. eapply exec_trans. eexact EXEC1.
apply exec_instrs_incr with s1. eauto with rtlg.
- eapply transl_switch_correct; eauto.
+ eapply transl_switch_correct; eauto. traceEq.
(* match_env & match_reg *)
tauto.
Qed.
Lemma transl_stmt_Sreturn_none_correct:
forall (sp: val) (e : env) (m : mem),
- transl_stmt_correct sp e m (Sreturn None) e m (Out_return None).
+ transl_stmt_correct sp e m (Sreturn None) E0 e m (Out_return None).
Proof.
intros; red; intros. generalize TE. simpl.
destruct rret; monadSimpl.
@@ -1250,11 +1326,11 @@ Proof.
Qed.
Lemma transl_stmt_Sreturn_some_correct:
- forall (sp: val) (e : env) (m : mem) (a : expr)
+ forall (sp: val) (e : env) (m : mem) (a : expr) (t: trace)
(e1 : env) (m1 : mem) (v : val),
- eval_expr ge sp nil e m a e1 m1 v ->
- transl_expr_correct sp nil e m a e1 m1 v ->
- transl_stmt_correct sp e m (Sreturn (Some a)) e1 m1 (Out_return (Some v)).
+ eval_expr ge sp nil e m a t e1 m1 v ->
+ transl_expr_correct sp nil e m a t e1 m1 v ->
+ transl_stmt_correct sp e m (Sreturn (Some a)) t e1 m1 (Out_return (Some v)).
Proof.
intros; red; intros. generalize TE; simpl.
destruct rret. intro EQ.
@@ -1278,9 +1354,9 @@ Scheme eval_expr_ind_5 := Minimality for eval_expr Sort Prop
with exec_stmt_ind_5 := Minimality for exec_stmt Sort Prop.
Theorem transl_function_correctness:
- forall m f vargs m' vres,
- eval_funcall ge m f vargs m' vres ->
- transl_function_correct m f vargs m' vres.
+ forall m f vargs t m' vres,
+ eval_funcall ge m f vargs t m' vres ->
+ transl_function_correct m f vargs t m' vres.
Proof
(eval_funcall_ind_5 ge
transl_expr_correct
@@ -1298,13 +1374,15 @@ Proof
transl_expr_Econdition_correct
transl_expr_Elet_correct
transl_expr_Eletvar_correct
+ transl_expr_Ealloc_correct
transl_condition_CEtrue_correct
transl_condition_CEfalse_correct
transl_condition_CEcond_correct
transl_condition_CEcondition_correct
transl_exprlist_Enil_correct
transl_exprlist_Econs_correct
- transl_funcall_correct
+ transl_funcall_internal_correct
+ transl_funcall_external_correct
transl_stmt_Sskip_correct
transl_stmt_Sexpr_correct
transl_stmt_Sifthenelse_correct
@@ -1319,26 +1397,23 @@ Proof
transl_stmt_Sreturn_some_correct).
Theorem transl_program_correct:
- forall (r: val),
- Cminor.exec_program prog r ->
- RTL.exec_program tprog r.
+ forall (t: trace) (r: val),
+ Cminor.exec_program prog t r ->
+ RTL.exec_program tprog t r.
Proof.
- intros r [b [f [m [SYMB [FUNC [SIG EVAL]]]]]].
+ intros t r [b [f [m [SYMB [FUNC [SIG EVAL]]]]]].
generalize (function_ptr_translated _ _ FUNC).
intros [tf [TFIND TRANSLF]].
red; exists b; exists tf; exists m.
split. rewrite symbols_preserved.
replace (prog_main tprog) with (prog_main prog).
assumption.
- symmetry; apply transform_partial_program_main with transl_function.
+ symmetry; apply transform_partial_program_main with transl_fundef.
exact TRANSL.
split. exact TFIND.
- split. generalize TRANSLF. unfold transl_function.
- destruct (transl_fun f init_state).
- intro; discriminate. destruct p; intro EQ; injection EQ; intro EQ1.
- rewrite <- EQ1. simpl. congruence.
- rewrite (Genv.init_mem_transf_partial transl_function prog TRANSL).
- exact (transl_function_correctness _ _ _ _ _ EVAL _ TRANSLF).
+ split. generalize (sig_transl_function _ _ TRANSLF). congruence.
+ unfold fundef; rewrite (Genv.init_mem_transf_partial transl_fundef prog TRANSL).
+ exact (transl_function_correctness _ _ _ _ _ _ EVAL _ TRANSLF).
Qed.
End CORRECTNESS.
diff --git a/backend/RTLgenproof1.v b/backend/RTLgenproof1.v
index 85d420e..8b14901 100644
--- a/backend/RTLgenproof1.v
+++ b/backend/RTLgenproof1.v
@@ -5,6 +5,7 @@ Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Values.
+Require Import Events.
Require Import Mem.
Require Import Globalenvs.
Require Import Op.
@@ -200,28 +201,28 @@ Variable s1 s2: state.
Hypothesis EXT: state_extends s1 s2.
Lemma exec_instr_not_halt:
- forall ge c sp pc rs m pc' rs' m',
- exec_instr ge c sp pc rs m pc' rs' m' -> c!pc <> None.
+ forall ge c sp pc rs m t pc' rs' m',
+ exec_instr ge c sp pc rs m t pc' rs' m' -> c!pc <> None.
Proof.
induction 1; rewrite H; discriminate.
Qed.
Lemma exec_instr_in_s2:
- forall ge sp pc rs m pc' rs' m',
- exec_instr ge s1.(st_code) sp pc rs m pc' rs' m' ->
+ forall ge sp pc rs m t pc' rs' m',
+ exec_instr ge s1.(st_code) sp pc rs m t pc' rs' m' ->
s2.(st_code)!pc = s1.(st_code)!pc.
Proof.
intros.
elim (EXT pc); intro.
- elim (exec_instr_not_halt _ _ _ _ _ _ _ _ _ H H0).
+ elim (exec_instr_not_halt _ _ _ _ _ _ _ _ _ _ H H0).
assumption.
Qed.
Lemma exec_instr_extends_rec:
- forall ge c sp pc rs m pc' rs' m',
- exec_instr ge c sp pc rs m pc' rs' m' ->
+ forall ge c sp pc rs m t pc' rs' m',
+ exec_instr ge c sp pc rs m t pc' rs' m' ->
forall c', c!pc = c'!pc ->
- exec_instr ge c' sp pc rs m pc' rs' m'.
+ exec_instr ge c' sp pc rs m t pc' rs' m'.
Proof.
induction 1; intros.
apply exec_Inop. congruence.
@@ -230,14 +231,15 @@ Proof.
apply exec_Istore with chunk addr args src a.
congruence. auto. auto.
apply exec_Icall with sig ros args f; auto. congruence.
+ apply exec_Ialloc with arg sz; auto. congruence.
apply exec_Icond_true with cond args ifnot; auto. congruence.
apply exec_Icond_false with cond args ifso; auto. congruence.
Qed.
Lemma exec_instr_extends:
- forall ge sp pc rs m pc' rs' m',
- exec_instr ge s1.(st_code) sp pc rs m pc' rs' m' ->
- exec_instr ge s2.(st_code) sp pc rs m pc' rs' m'.
+ forall ge sp pc rs m t pc' rs' m',
+ exec_instr ge s1.(st_code) sp pc rs m t pc' rs' m' ->
+ exec_instr ge s2.(st_code) sp pc rs m t pc' rs' m'.
Proof.
intros.
apply exec_instr_extends_rec with (st_code s1).
@@ -246,21 +248,21 @@ Proof.
Qed.
Lemma exec_instrs_extends_rec:
- forall ge c sp pc rs m pc' rs' m',
- exec_instrs ge c sp pc rs m pc' rs' m' ->
+ forall ge c sp pc rs m t pc' rs' m',
+ exec_instrs ge c sp pc rs m t pc' rs' m' ->
c = s1.(st_code) ->
- exec_instrs ge s2.(st_code) sp pc rs m pc' rs' m'.
+ exec_instrs ge s2.(st_code) sp pc rs m t pc' rs' m'.
Proof.
induction 1; intros.
apply exec_refl.
apply exec_one. apply exec_instr_extends; auto. rewrite <- H0; auto.
- apply exec_trans with pc2 rs2 m2; auto.
+ apply exec_trans with t1 pc2 rs2 m2 t2; auto.
Qed.
Lemma exec_instrs_extends:
- forall ge sp pc rs m pc' rs' m',
- exec_instrs ge s1.(st_code) sp pc rs m pc' rs' m' ->
- exec_instrs ge s2.(st_code) sp pc rs m pc' rs' m'.
+ forall ge sp pc rs m t pc' rs' m',
+ exec_instrs ge s1.(st_code) sp pc rs m t pc' rs' m' ->
+ exec_instrs ge s2.(st_code) sp pc rs m t pc' rs' m'.
Proof.
intros.
apply exec_instrs_extends_rec with (st_code s1); auto.
@@ -281,9 +283,9 @@ Variable s1 s2: state.
Hypothesis INCR: state_incr s1 s2.
Lemma exec_instr_incr:
- forall ge sp pc rs m pc' rs' m',
- exec_instr ge s1.(st_code) sp pc rs m pc' rs' m' ->
- exec_instr ge s2.(st_code) sp pc rs m pc' rs' m'.
+ forall ge sp pc rs m t pc' rs' m',
+ exec_instr ge s1.(st_code) sp pc rs m t pc' rs' m' ->
+ exec_instr ge s2.(st_code) sp pc rs m t pc' rs' m'.
Proof.
intros.
apply exec_instr_extends with s1.
@@ -292,9 +294,9 @@ Proof.
Qed.
Lemma exec_instrs_incr:
- forall ge sp pc rs m pc' rs' m',
- exec_instrs ge s1.(st_code) sp pc rs m pc' rs' m' ->
- exec_instrs ge s2.(st_code) sp pc rs m pc' rs' m'.
+ forall ge sp pc rs m t pc' rs' m',
+ exec_instrs ge s1.(st_code) sp pc rs m t pc' rs' m' ->
+ exec_instrs ge s2.(st_code) sp pc rs m t pc' rs' m'.
Proof.
intros.
apply exec_instrs_extends with s1.
@@ -1318,6 +1320,7 @@ forall (P : expr -> Prop) (P0 : condexpr -> Prop)
P e -> forall e0 : expr, P e0 -> P (Econdition c e e0)) ->
(forall e : expr, P e -> forall e0 : expr, P e0 -> P (Elet e e0)) ->
(forall n : nat, P (Eletvar n)) ->
+ (forall e : expr, P e -> P (Ealloc e)) ->
P0 CEtrue ->
P0 CEfalse ->
(forall (c : condition) (e : exprlist), P1 e -> P0 (CEcond c e)) ->
diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v
index d15dbb8..33338d3 100644
--- a/backend/RTLtyping.v
+++ b/backend/RTLtyping.v
@@ -6,7 +6,7 @@ Require Import AST.
Require Import Op.
Require Import Registers.
Require Import RTL.
-Require Import union_find.
+Require Conventions.
(** * The type system *)
@@ -38,7 +38,7 @@ Definition regenv := reg -> typ.
Section WT_INSTR.
Variable env: regenv.
-Variable funct: function.
+Variable funsig: signature.
Inductive wt_instr : instruction -> Prop :=
| wt_Inop:
@@ -72,13 +72,17 @@ Inductive wt_instr : instruction -> Prop :=
List.map env args = sig.(sig_args) ->
env res = match sig.(sig_res) with None => Tint | Some ty => ty end ->
wt_instr (Icall sig ros args res s)
+ | wt_Ialloc:
+ forall arg res s,
+ env arg = Tint -> env res = Tint ->
+ wt_instr (Ialloc arg res s)
| wt_Icond:
forall cond args s1 s2,
List.map env args = type_of_condition cond ->
wt_instr (Icond cond args s1 s2)
| wt_Ireturn:
forall optres,
- option_map env optres = funct.(fn_sig).(sig_res) ->
+ option_map env optres = funsig.(sig_res) ->
wt_instr (Ireturn optres).
End WT_INSTR.
@@ -88,15 +92,27 @@ End WT_INSTR.
parameters agree in types with the function signature, and
names of parameters are pairwise distinct. *)
-Record wt_function (env: regenv) (f: function) : Prop :=
+Record wt_function (f: function) (env: regenv): Prop :=
mk_wt_function {
wt_params:
List.map env f.(fn_params) = f.(fn_sig).(sig_args);
wt_norepet:
list_norepet f.(fn_params);
wt_instrs:
- forall pc instr, f.(fn_code)!pc = Some instr -> wt_instr env f instr
- }.
+ forall pc instr,
+ f.(fn_code)!pc = Some instr -> wt_instr env f.(fn_sig) instr
+}.
+
+Inductive wt_fundef: fundef -> Prop :=
+ | wt_fundef_external: forall ef,
+ Conventions.sig_external_ok ef.(ef_sig) ->
+ wt_fundef (External ef)
+ | wt_function_internal: forall f env,
+ wt_function f env ->
+ wt_fundef (Internal f).
+
+Definition wt_program (p: program): Prop :=
+ forall i f, In (i, f) (prog_funct p) -> wt_fundef f.
(** * Type inference *)
@@ -109,1022 +125,221 @@ Record wt_function (env: regenv) (f: function) : Prop :=
each pseudo-register from its uses in the code. We follow the second
approach.
- The algorithm and its correctness proof in this section were
- contributed by Damien Doligez. *)
+ We delegate the task of determining the type of each pseudo-register
+ to an external ``oracle'': a function written in Caml and not
+ proved correct. We verify the returned type environment using
+ the following Coq code, which we will prove correct. *)
-(** ** Type inference algorithm *)
+Parameter infer_type_environment:
+ function -> list (node * instruction) -> option regenv.
-Set Implicit Arguments.
+(** ** Algorithm to check the correctness of a type environment *)
-(** Type inference for RTL is similar to that for simply-typed
- lambda-calculus: we use type variables to represent the types
- of registers that have not yet been determined to be [Tint] or [Tfloat]
- based on their uses. We need exactly one type variable per pseudo-register,
- therefore type variables can be conveniently equated with registers.
- The type of a register during inference is therefore either
- [tTy t] (with [t = Tint] or [t = Tfloat]) for a known type,
- or [tReg r] to mean ``the same type as that of register [r]''. *)
+Section TYPECHECKING.
-Inductive myT : Set :=
- | tTy : typ -> myT
- | tReg : reg -> myT.
+Variable funct: function.
+Variable env: regenv.
-(** The algorithm proceeds by unification of the currently inferred
- type for a pseudo-register with the type dictated by its uses.
- Unification builds on a ``union-find'' data structure representing
- equivalence classes of types (see module [Union_find]).
-*)
+Lemma typ_eq: forall (t1 t2: typ), {t1=t2} + {t1<>t2}.
+Proof. decide equality. Qed.
-Module myreg.
- Definition T := myT.
- Definition eq : forall (x y : T), {x=y}+{x<>y}.
- Proof.
- destruct x; destruct y; auto;
- try (apply right; discriminate); try (apply left; discriminate).
- destruct t; destruct t0;
- try (apply right; congruence); try (apply left; congruence).
- elim (peq r r0); intros.
- rewrite a; apply left; apply refl_equal.
- apply right; congruence.
- Defined.
-End myreg.
-
-Module mymap.
- Definition elt := myreg.T.
- Definition encode (t : myreg.T) : positive :=
- match t with
- | tTy Tint => xH
- | tTy Tfloat => xI xH
- | tReg r => xO r
- end.
- Definition decode (p : positive) : elt :=
- match p with
- | xH => tTy Tint
- | xI _ => tTy Tfloat
- | xO r => tReg r
- end.
-
- Lemma encode_decode : forall x : myreg.T, decode (encode x) = x.
- Proof.
- destruct x; try destruct t; simpl; auto.
- Qed.
-
- Lemma encode_injective :
- forall (x y : myreg.T), encode x = encode y -> x = y.
- Proof.
- intros.
- unfold encode in H. destruct x; destruct y; try congruence;
- try destruct t; try destruct t0; congruence.
- Qed.
-
- Definition T := PTree.t positive.
- Definition empty := PTree.empty positive.
- Definition get (adr : elt) (t : T) :=
- option_map decode (PTree.get (encode adr) t).
- Definition add (adr dat : elt) (t : T) :=
- PTree.set (encode adr) (encode dat) t.
-
- Theorem get_empty : forall (x : elt), get x empty = None.
- Proof.
- intro.
- unfold get. unfold empty.
- rewrite PTree.gempty.
- simpl; auto.
- Qed.
- Theorem get_add_1 :
- forall (x y : elt) (m : T), get x (add x y m) = Some y.
- Proof.
- intros.
- unfold add. unfold get.
- rewrite PTree.gss.
- simpl; rewrite encode_decode; auto.
- Qed.
- Theorem get_add_2 :
- forall (x y z : elt) (m : T), z <> x -> get z (add x y m) = get z m.
- Proof.
- intros.
- unfold get. unfold add.
- rewrite PTree.gso; auto.
- intro. apply H. apply encode_injective. auto.
- Qed.
-End mymap.
-
-Module Uf := Unionfind (myreg) (mymap).
-
-Definition error := Uf.identify Uf.empty (tTy Tint) (tTy Tfloat).
-
-Fixpoint fold2 (A B : Set) (f : Uf.T -> A -> B -> Uf.T)
- (init : Uf.T) (la : list A) (lb : list B) {struct la}
- : Uf.T :=
- match la, lb with
- | ha::ta, hb::tb => fold2 f (f init ha hb) ta tb
- | nil, nil => init
- | _, _ => error
- end.
+Definition check_reg (r: reg) (ty: typ): bool :=
+ if typ_eq (env r) ty then true else false.
-Definition option_fold2 (A B : Set) (f : Uf.T -> A -> B -> Uf.T)
- (init : Uf.T) (oa : option A) (ob : option B)
- : Uf.T :=
- match oa, ob with
- | Some a, Some b => f init a b
- | None, None => init
- | _, _ => error
- end.
-
-Definition teq (ty1 ty2 : typ) : bool :=
- match ty1, ty2 with
- | Tint, Tint => true
- | Tfloat, Tfloat => true
+Fixpoint check_regs (rl: list reg) (tyl: list typ) {struct rl}: bool :=
+ match rl, tyl with
+ | nil, nil => true
+ | r1::rs, ty::tys => check_reg r1 ty && check_regs rs tys
| _, _ => false
end.
-Definition type_rtl_arg (u : Uf.T) (r : reg) (t : typ) :=
- Uf.identify u (tReg r) (tTy t).
-
-Definition type_rtl_ros (u : Uf.T) (ros : reg+ident) :=
- match ros with
- | inl r => Uf.identify u (tReg r) (tTy Tint)
- | inr s => u
- end.
+Definition check_op (op: operation) (args: list reg) (res: reg): bool :=
+ let (targs, tres) := type_of_operation op in
+ check_regs args targs && check_reg res tres.
-Definition type_of_sig_res (sig : signature) :=
- match sig.(sig_res) with None => Tint | Some ty => ty end.
-
-(** This is the core type inference function. The [u] argument is
- the current substitution / equivalence classes between types.
- An updated set of equivalence classes, reflecting unifications
- possibly performed during the type-checking of [i], is returned.
- Note that [type_rtl_instr] never fails explicitly. However,
- in case of type error (e.g. applying the [Oadd] integer operation
- to float registers), the equivalence relation returned will
- put [tTy Tint] and [tTy Tfloat] in the same equivalence class.
- This fact will propagate through type inference for other instructions,
- and be detected at the end of type inference, indicating a typing failure.
-*)
-
-Definition type_rtl_instr (rtyp : option typ)
- (u : Uf.T) (_ : positive) (i : instruction) :=
+Definition check_instr (i: instruction) : bool :=
match i with
- | Inop _ => u
- | Iop Omove (r1 :: nil) r0 _ => Uf.identify u (tReg r0) (tReg r1)
- | Iop Omove _ _ _ => error
- | Iop Oundef nil _ _ => u
- | Iop Oundef _ _ _ => error
- | Iop op args r0 _ =>
- let (argtyp, restyp) := type_of_operation op in
- let u1 := type_rtl_arg u r0 restyp in
- fold2 type_rtl_arg u1 args argtyp
- | Iload chunk addr args r0 _ =>
- let u1 := type_rtl_arg u r0 (type_of_chunk chunk) in
- fold2 type_rtl_arg u1 args (type_of_addressing addr)
- | Istore chunk addr args r0 _ =>
- let u1 := type_rtl_arg u r0 (type_of_chunk chunk) in
- fold2 type_rtl_arg u1 args (type_of_addressing addr)
- | Icall sign ros args r0 _ =>
- let u1 := type_rtl_ros u ros in
- let u2 := type_rtl_arg u1 r0 (type_of_sig_res sign) in
- fold2 type_rtl_arg u2 args sign.(sig_args)
+ | Inop _ =>
+ true
+ | Iop Omove (arg::nil) res _ =>
+ if typ_eq (env arg) (env res) then true else false
+ | Iop Omove args res _ =>
+ false
+ | Iop Oundef nil res _ =>
+ true
+ | Iop Oundef args res _ =>
+ false
+ | Iop op args res _ =>
+ check_op op args res
+ | Iload chunk addr args dst _ =>
+ check_regs args (type_of_addressing addr)
+ && check_reg dst (type_of_chunk chunk)
+ | Istore chunk addr args src _ =>
+ check_regs args (type_of_addressing addr)
+ && check_reg src (type_of_chunk chunk)
+ | Icall sig ros args res _ =>
+ match ros with inl r => check_reg r Tint | inr s => true end
+ && check_regs args sig.(sig_args)
+ && check_reg res (match sig.(sig_res) with None => Tint | Some ty => ty end)
+ | Ialloc arg res _ =>
+ check_reg arg Tint && check_reg res Tint
| Icond cond args _ _ =>
- fold2 type_rtl_arg u args (type_of_condition cond)
- | Ireturn o => option_fold2 type_rtl_arg u o rtyp
+ check_regs args (type_of_condition cond)
+ | Ireturn optres =>
+ match optres, funct.(fn_sig).(sig_res) with
+ | None, None => true
+ | Some r, Some t => check_reg r t
+ | _, _ => false
+ end
end.
-Definition mk_env (u : Uf.T) (r : reg) :=
- if myreg.eq (Uf.repr u (tReg r)) (Uf.repr u (tTy Tfloat))
- then Tfloat
- else Tint.
+Definition check_params_norepet (params: list reg): bool :=
+ if list_norepet_dec Reg.eq params then true else false.
-Fixpoint member (x : reg) (l : list reg) {struct l} : bool :=
- match l with
- | nil => false
- | y :: rest => if peq x y then true else member x rest
+Fixpoint check_instrs (instrs: list (node * instruction)) : bool :=
+ match instrs with
+ | nil => true
+ | (pc, i) :: rem => check_instr i && check_instrs rem
end.
-Fixpoint repet (l : list reg) : bool :=
- match l with
- | nil => false
- | x :: rest => member x rest || repet rest
- end.
+(** ** Correctness of the type-checking algorithm *)
-Definition type_rtl_function (f : function) :=
- let u1 := PTree.fold (type_rtl_instr f.(fn_sig).(sig_res))
- f.(fn_code) Uf.empty in
- let u2 := fold2 type_rtl_arg u1 f.(fn_params) f.(fn_sig).(sig_args) in
- if repet f.(fn_params) then
- None
- else
- if myreg.eq (Uf.repr u2 (tTy Tint)) (Uf.repr u2 (tTy Tfloat))
- then None
- else Some (mk_env u2).
-
-Unset Implicit Arguments.
-
-(** ** Correctness proof for type inference *)
-
-(** General properties of the type equivalence relation. *)
-
-Definition consistent (u : Uf.T) :=
- Uf.repr u (tTy Tint) <> Uf.repr u (tTy Tfloat).
-
-Lemma consistent_not_eq : forall (u : Uf.T) (A : Type) (x y : A),
- consistent u ->
- (if myreg.eq (Uf.repr u (tTy Tint)) (Uf.repr u (tTy Tfloat)) then x else y)
- = y.
- Proof.
- intros.
- unfold consistent in H.
- destruct (myreg.eq (Uf.repr u (tTy Tint)) (Uf.repr u (tTy Tfloat)));
- congruence.
- Qed.
-
-Lemma equal_eq : forall (t : myT) (A : Type) (x y : A),
- (if myreg.eq t t then x else y) = x.
- Proof.
- intros.
- destruct (myreg.eq t t); congruence.
- Qed.
-
-Lemma error_inconsistent : forall (A : Prop), consistent error -> A.
- Proof.
- intros.
- absurd (consistent error); auto.
- intro.
- unfold error in H. unfold consistent in H.
- rewrite Uf.sameclass_identify_1 in H.
- congruence.
- Qed.
-
-Lemma teq_correct : forall (t1 t2 : typ), teq t1 t2 = true -> t1 = t2.
- Proof.
- intros; destruct t1; destruct t2; try simpl in H; congruence.
- Qed.
-
-Definition included (u1 u2 : Uf.T) : Prop :=
- forall (e1 e2: myT),
- Uf.repr u1 e1 = Uf.repr u1 e2 -> Uf.repr u2 e1 = Uf.repr u2 e2.
-
-Lemma included_refl :
- forall (e : Uf.T), included e e.
- Proof.
- unfold included. auto.
- Qed.
-
-Lemma included_trans :
- forall (e1 e2 e3 : Uf.T),
- included e3 e2 -> included e2 e1 -> included e3 e1.
- Proof.
- unfold included. auto.
- Qed.
-
-Lemma included_consistent :
- forall (u1 u2 : Uf.T),
- included u1 u2 -> consistent u2 -> consistent u1.
- Proof.
- unfold consistent. unfold included.
- intros.
- intro. apply H0. apply H.
- auto.
- Qed.
-
-Lemma included_identify :
- forall (u : Uf.T) (t1 t2 : myT), included u (Uf.identify u t1 t2).
- Proof.
- unfold included.
- intros.
- apply Uf.sameclass_identify_2; auto.
- Qed.
-
-Lemma type_arg_correct_1 :
- forall (u : Uf.T) (r : reg) (t : typ),
- consistent (type_rtl_arg u r t)
- -> Uf.repr (type_rtl_arg u r t) (tReg r)
- = Uf.repr (type_rtl_arg u r t) (tTy t).
- Proof.
- intros.
- unfold type_rtl_arg.
- rewrite Uf.sameclass_identify_1.
- auto.
- Qed.
-
-Lemma type_arg_correct :
- forall (u : Uf.T) (r : reg) (t : typ),
- consistent (type_rtl_arg u r t) -> mk_env (type_rtl_arg u r t) r = t.
- Proof.
- intros.
- unfold mk_env.
- rewrite type_arg_correct_1.
- destruct t.
- apply consistent_not_eq; auto.
- destruct (myreg.eq (Uf.repr (type_rtl_arg u r Tfloat) (tTy Tfloat)));
- congruence.
- auto.
- Qed.
-
-Lemma type_arg_included :
- forall (u : Uf.T) (r : reg) (t : typ), included u (type_rtl_arg u r t).
- Proof.
- intros.
- unfold type_rtl_arg.
- apply included_identify.
- Qed.
-
-Lemma type_arg_extends :
- forall (u : Uf.T) (r : reg) (t : typ),
- consistent (type_rtl_arg u r t) -> consistent u.
- Proof.
- intros.
- apply included_consistent with (u2 := type_rtl_arg u r t).
- apply type_arg_included.
- auto.
- Qed.
-
-Lemma type_args_included :
- forall (l1 : list reg) (l2 : list typ) (u : Uf.T),
- consistent (fold2 type_rtl_arg u l1 l2)
- -> included u (fold2 type_rtl_arg u l1 l2).
- Proof.
- induction l1; intros; destruct l2.
- simpl in H; simpl; apply included_refl.
- simpl in H. apply error_inconsistent. auto.
- simpl in H. apply error_inconsistent. auto.
- simpl.
- simpl in H.
- apply included_trans with (e2 := type_rtl_arg u a t).
- apply type_arg_included.
- apply IHl1.
- auto.
- Qed.
-
-Lemma type_args_extends :
- forall (l1 : list reg) (l2 : list typ) (u : Uf.T),
- consistent (fold2 type_rtl_arg u l1 l2) -> consistent u.
- Proof.
- intros.
- apply (included_consistent _ _ (type_args_included l1 l2 u H)).
- auto.
- Qed.
-
-Lemma type_args_correct :
- forall (l1 : list reg) (l2 : list typ) (u : Uf.T),
- consistent (fold2 type_rtl_arg u l1 l2)
- -> map (mk_env (fold2 type_rtl_arg u l1 l2)) l1 = l2.
- Proof.
- induction l1.
- intros.
- destruct l2.
- unfold map; simpl; auto.
- simpl in H; apply error_inconsistent; auto.
- intros.
- destruct l2.
- simpl in H; apply error_inconsistent; auto.
- simpl.
- simpl in H.
- rewrite (IHl1 l2 (type_rtl_arg u a t) H).
- unfold mk_env.
- destruct t.
- rewrite (type_args_included _ _ _ H (tReg a) (tTy Tint)).
- rewrite consistent_not_eq; auto.
- apply type_arg_correct_1.
- apply type_args_extends with (l1 := l1) (l2 := l2); auto.
- rewrite (type_args_included _ _ _ H (tReg a) (tTy Tfloat)).
- rewrite equal_eq; auto.
- apply type_arg_correct_1.
- apply type_args_extends with (l1 := l1) (l2 := l2); auto.
- Qed.
-
-(** Correctness of [wt_params]. *)
-
-Lemma type_rtl_function_params :
- forall (f: function) (env: regenv),
- type_rtl_function f = Some env
- -> List.map env f.(fn_params) = f.(fn_sig).(sig_args).
- Proof.
- destruct f; unfold type_rtl_function; simpl.
- destruct (repet fn_params); simpl; intros; try congruence.
- pose (u := PTree.fold (type_rtl_instr (sig_res fn_sig)) fn_code Uf.empty).
- fold u in H.
- cut (consistent (fold2 type_rtl_arg u fn_params (sig_args fn_sig))).
- intro.
- pose (R := Uf.repr (fold2 type_rtl_arg u fn_params (sig_args fn_sig))).
- fold R in H.
- destruct (myreg.eq (R (tTy Tint)) (R (tTy Tfloat))).
- congruence.
- injection H.
- intro.
- rewrite <- H1.
- apply type_args_correct.
- auto.
- intro.
- rewrite H0 in H.
- rewrite equal_eq in H.
- congruence.
- Qed.
-
-(** Correctness of [wt_norepet]. *)
-
-Lemma member_correct :
- forall (l : list reg) (a : reg), member a l = false -> ~In a l.
- Proof.
- induction l; simpl; intros; try tauto.
- destruct (peq a0 a); simpl; try congruence.
- intro. destruct H0; try congruence.
- generalize H0; apply IHl; auto.
- Qed.
-
-Lemma repet_correct :
- forall (l : list reg), repet l = false -> list_norepet l.
- Proof.
- induction l; simpl; intros.
- exact (list_norepet_nil reg).
- elim (orb_false_elim (member a l) (repet l) H); intros.
- apply list_norepet_cons.
- apply member_correct; auto.
- apply IHl; auto.
- Qed.
-
-Lemma type_rtl_function_norepet :
- forall (f: function) (env: regenv),
- type_rtl_function f = Some env
- -> list_norepet f.(fn_params).
- Proof.
- destruct f; unfold type_rtl_function; simpl.
- intros. cut (repet fn_params = false).
- intro. apply repet_correct. auto.
- destruct (repet fn_params); congruence.
- Qed.
-
-(** Correctness of [wt_instrs]. *)
-
-Lemma step1 :
- forall (f : function) (env : regenv),
- type_rtl_function f = Some env
- -> exists u2 : Uf.T,
- included (PTree.fold (type_rtl_instr f.(fn_sig).(sig_res))
- f.(fn_code) Uf.empty)
- u2
- /\ env = mk_env u2
- /\ consistent u2.
- Proof.
- intros f env.
- pose (u1 := (PTree.fold (type_rtl_instr f.(fn_sig).(sig_res))
- f.(fn_code) Uf.empty)).
- fold u1.
- unfold type_rtl_function.
- intros.
- destruct (repet f.(fn_params)).
- congruence.
- fold u1 in H.
- pose (u2 := (fold2 type_rtl_arg u1 f.(fn_params) f.(fn_sig).(sig_args))).
- fold u2 in H.
- exists u2.
- caseEq (myreg.eq (Uf.repr u2 (tTy Tint)) (Uf.repr u2 (tTy Tfloat))).
- intros.
- rewrite e in H.
- rewrite equal_eq in H.
- congruence.
- intros.
- rewrite consistent_not_eq in H.
- apply conj.
- unfold u2.
- apply type_args_included.
- auto.
- apply conj; auto.
- congruence.
- auto.
- Qed.
-
-Lemma let_fold_args_res :
- forall (u : Uf.T) (l : list reg) (r : reg) (e : list typ * typ),
- (let (argtyp, restyp) := e in
- fold2 type_rtl_arg (type_rtl_arg u r restyp) l argtyp)
- = fold2 type_rtl_arg (type_rtl_arg u r (snd e)) l (fst e).
- Proof.
- intros. rewrite (surjective_pairing e). simpl. auto.
- Qed.
-
-Lemma type_args_res_included :
- forall (l1 : list reg) (l2 : list typ) (u : Uf.T) (r : reg) (t : typ),
- consistent (fold2 type_rtl_arg (type_rtl_arg u r t) l1 l2)
- -> included u (fold2 type_rtl_arg (type_rtl_arg u r t) l1 l2).
- Proof.
- intros.
- apply included_trans with (e2 := type_rtl_arg u r t).
- apply type_arg_included.
- apply type_args_included; auto.
- Qed.
-
-Lemma type_args_res_ros_included :
- forall (l1 : list reg) (l2 : list typ) (u : Uf.T) (r : reg) (t : typ)
- (ros : reg+ident),
- consistent (fold2 type_rtl_arg (type_rtl_arg (type_rtl_ros u ros) r t) l1 l2)
- -> included u (fold2 type_rtl_arg (type_rtl_arg (type_rtl_ros u ros) r t) l1 l2).
+Lemma check_reg_correct:
+ forall r ty, check_reg r ty = true -> env r = ty.
Proof.
- intros.
- apply included_trans with (e2 := type_rtl_ros u ros).
- unfold type_rtl_ros; destruct ros.
- apply included_identify.
- apply included_refl.
- apply type_args_res_included; auto.
+ unfold check_reg; intros.
+ destruct (typ_eq (env r) ty). auto. discriminate.
Qed.
-Lemma type_instr_included :
- forall (p : positive) (i : instruction) (u : Uf.T) (res_ty : option typ),
- consistent (type_rtl_instr res_ty u p i)
- -> included u (type_rtl_instr res_ty u p i).
- Proof.
- intros.
- destruct i; simpl; simpl in H; try apply type_args_res_included; auto.
- apply included_refl; auto.
- destruct o; simpl; simpl in H; try apply type_args_res_included; auto.
- destruct l; simpl; simpl in H; auto.
- apply error_inconsistent; auto.
- destruct l; simpl; simpl in H; auto.
- apply included_identify.
- apply error_inconsistent; auto.
- destruct l; simpl; simpl in H; auto.
- apply included_refl.
- apply error_inconsistent; auto.
- apply type_args_res_ros_included; auto.
- apply type_args_included; auto.
- destruct res_ty; destruct o; simpl; simpl in H;
- try (apply error_inconsistent; auto; fail).
- apply type_arg_included.
- apply included_refl.
- Qed.
-
-Lemma type_instrs_extends :
- forall (l : list (positive * instruction)) (u : Uf.T) (res_ty : option typ),
- consistent
- (fold_left (fun v p => type_rtl_instr res_ty v (fst p) (snd p)) l u)
- -> consistent u.
+Lemma check_regs_correct:
+ forall rl tyl, check_regs rl tyl = true -> List.map env rl = tyl.
Proof.
- induction l; simpl; intros.
- auto.
- apply included_consistent
- with (u2 := (type_rtl_instr res_ty u (fst a) (snd a))).
- apply type_instr_included.
- apply IHl with (res_ty := res_ty); auto.
- apply IHl with (res_ty := res_ty); auto.
+ induction rl; destruct tyl; simpl; intros.
+ auto. discriminate. discriminate.
+ elim (andb_prop _ _ H); intros.
+ rewrite (check_reg_correct _ _ H0). rewrite (IHrl tyl H1). auto.
Qed.
-Lemma type_instrs_included :
- forall (l : list (positive * instruction)) (u : Uf.T) (res_ty : option typ),
- consistent
- (fold_left (fun v p => type_rtl_instr res_ty v (fst p) (snd p)) l u)
- -> included u
- (fold_left (fun v p => type_rtl_instr res_ty v (fst p) (snd p)) l u).
- Proof.
- induction l; simpl; intros.
- apply included_refl; auto.
- apply included_trans with (e2 := (type_rtl_instr res_ty u (fst a) (snd a))).
- apply type_instr_included.
- apply type_instrs_extends with (res_ty := res_ty) (l := l); auto.
- apply IHl; auto.
- Qed.
-
-Lemma step2 :
- forall (res_ty : option typ) (c : code) (u0 : Uf.T),
- consistent (PTree.fold (type_rtl_instr res_ty) c u0) ->
- forall (pc : positive) (i : instruction),
- c!pc = Some i
- -> exists u : Uf.T,
- consistent (type_rtl_instr res_ty u pc i)
- /\ included (type_rtl_instr res_ty u pc i)
- (PTree.fold (type_rtl_instr res_ty) c u0).
- Proof.
- intros.
- rewrite PTree.fold_spec.
- rewrite PTree.fold_spec in H.
- pose (H1 := PTree.elements_correct _ _ H0).
- generalize H. clear H.
- generalize u0. clear u0.
- generalize H1. clear H1.
- induction (PTree.elements c).
- intros.
- absurd (In (pc, i) nil).
- apply in_nil.
- auto.
- intros.
- simpl in H.
- elim H1.
- intro.
- rewrite H2 in H.
- simpl in H.
- rewrite H2. simpl.
- exists u0.
- apply conj.
- apply type_instrs_extends with (res_ty := res_ty) (l := l).
- auto.
- apply type_instrs_included.
- auto.
- intro.
- simpl.
- apply IHl.
- auto.
- auto.
- Qed.
-
-Definition mapped (u : Uf.T) (r : reg) :=
- Uf.repr u (tReg r) = Uf.repr u (tTy Tfloat)
- \/ Uf.repr u (tReg r) = Uf.repr u (tTy Tint).
-
-Definition definite (u : Uf.T) (i : instruction) :=
- match i with
- | Inop _ => True
- | Iop Omove (r1 :: nil) r0 _ => Uf.repr u (tReg r1) = Uf.repr u (tReg r0)
- | Iop Oundef _ _ _ => True
- | Iop _ args r0 _ =>
- mapped u r0 /\ forall r : reg, In r args -> mapped u r
- | Iload _ _ args r0 _ =>
- mapped u r0 /\ forall r : reg, In r args -> mapped u r
- | Istore _ _ args r0 _ =>
- mapped u r0 /\ forall r : reg, In r args -> mapped u r
- | Icall _ ros args r0 _ =>
- match ros with inl r => mapped u r | _ => True end
- /\ mapped u r0 /\ forall r : reg, In r args -> mapped u r
- | Icond _ args _ _ =>
- forall r : reg, In r args -> mapped u r
- | Ireturn None => True
- | Ireturn (Some r) => mapped u r
- end.
-
-Lemma type_arg_complete :
- forall (u : Uf.T) (r : reg) (t : typ),
- mapped (type_rtl_arg u r t) r.
-Proof.
- intros.
- unfold type_rtl_arg.
- unfold mapped.
- destruct t.
- right; apply Uf.sameclass_identify_1.
- left; apply Uf.sameclass_identify_1.
-Qed.
-
-Lemma type_arg_mapped :
- forall (u : Uf.T) (r r0 : reg) (t : typ),
- mapped u r0 -> mapped (type_rtl_arg u r t) r0.
-Proof.
- unfold mapped.
- unfold type_rtl_arg.
- intros.
- elim H; intros.
- left; apply Uf.sameclass_identify_2; auto.
- right; apply Uf.sameclass_identify_2; auto.
-Qed.
-
-Lemma type_args_mapped :
- forall (lr : list reg) (lt : list typ) (u : Uf.T) (r : reg),
- consistent (fold2 type_rtl_arg u lr lt) ->
- mapped u r ->
- mapped (fold2 type_rtl_arg u lr lt) r.
+Lemma check_op_correct:
+ forall op args res,
+ check_op op args res = true ->
+ (List.map env args, env res) = type_of_operation op.
Proof.
- induction lr; simpl; intros.
- destruct lt; simpl; auto; try (apply error_inconsistent; auto; fail).
- destruct lt; simpl; auto; try (apply error_inconsistent; auto; fail).
- apply IHlr.
+ unfold check_op; intros.
+ destruct (type_of_operation op) as [targs tres].
+ elim (andb_prop _ _ H); intros.
+ rewrite (check_regs_correct _ _ H0).
+ rewrite (check_reg_correct _ _ H1).
auto.
- apply type_arg_mapped; auto.
-Qed.
-
-Lemma type_args_complete :
- forall (lr : list reg) (lt : list typ) (u : Uf.T),
- consistent (fold2 type_rtl_arg u lr lt)
- -> forall r, (In r lr -> mapped (fold2 type_rtl_arg u lr lt) r).
-Proof.
- induction lr; simpl; intros.
- destruct lt; simpl; try tauto.
- destruct lt; simpl.
- apply error_inconsistent; auto.
- elim H0; intros.
- rewrite H1.
- rewrite H1 in H.
- apply type_args_mapped; auto.
- apply type_arg_complete.
- apply IHlr; auto.
-Qed.
-
-Lemma type_res_complete :
- forall (u : Uf.T) (lr : list reg) (lt : list typ) (r : reg) (t : typ),
- consistent (fold2 type_rtl_arg (type_rtl_arg u r t) lr lt)
- -> mapped (fold2 type_rtl_arg (type_rtl_arg u r t) lr lt) r.
-Proof.
- intros.
- apply type_args_mapped; auto.
- apply type_arg_complete.
Qed.
-Lemma type_args_res_complete :
- forall (u : Uf.T) (lr : list reg) (lt : list typ) (r : reg) (t : typ),
- consistent (fold2 type_rtl_arg (type_rtl_arg u r t) lr lt)
- -> mapped (fold2 type_rtl_arg (type_rtl_arg u r t) lr lt) r
- /\ forall rr, (In rr lr -> mapped (fold2 type_rtl_arg (type_rtl_arg u r t)
- lr lt)
- rr).
+Lemma check_instr_correct:
+ forall i, check_instr i = true -> wt_instr env funct.(fn_sig) i.
Proof.
- intros.
- apply conj.
- apply type_res_complete; auto.
- apply type_args_complete; auto.
+ unfold check_instr; intros; destruct i.
+ (* nop *)
+ constructor.
+ (* op *)
+ destruct o;
+ try (apply wt_Iop; [congruence|congruence|apply check_op_correct;auto]).
+ destruct l; try discriminate. destruct l; try discriminate.
+ destruct (typ_eq (env r0) (env r)); try discriminate.
+ apply wt_Iopmove; auto.
+ destruct l; try discriminate.
+ apply wt_Iopundef.
+ (* load *)
+ elim (andb_prop _ _ H); intros.
+ constructor. apply check_regs_correct; auto. apply check_reg_correct; auto.
+ (* store *)
+ elim (andb_prop _ _ H); intros.
+ constructor. apply check_regs_correct; auto. apply check_reg_correct; auto.
+ (* call *)
+ elim (andb_prop _ _ H); clear H; intros.
+ elim (andb_prop _ _ H); clear H; intros.
+ constructor.
+ destruct s0; auto. apply check_reg_correct; auto.
+ apply check_regs_correct; auto.
+ apply check_reg_correct; auto.
+ (* alloc *)
+ elim (andb_prop _ _ H); intros.
+ constructor; apply check_reg_correct; auto.
+ (* cond *)
+ constructor. apply check_regs_correct; auto.
+ (* return *)
+ constructor.
+ destruct o; simpl; destruct funct.(fn_sig).(sig_res); try discriminate.
+ rewrite (check_reg_correct _ _ H); auto.
+ auto.
Qed.
-Lemma type_ros_complete :
- forall (u : Uf.T) (lr : list reg) (lt : list typ) (r r1 : reg) (t : typ),
- consistent (fold2 type_rtl_arg (type_rtl_arg
- (type_rtl_ros u (inl ident r1)) r t) lr lt)
- ->
- mapped (fold2 type_rtl_arg (type_rtl_arg
- (type_rtl_ros u (inl ident r1)) r t) lr lt) r1.
+Lemma check_instrs_correct:
+ forall instrs,
+ check_instrs instrs = true ->
+ forall pc i, In (pc, i) instrs -> wt_instr env funct.(fn_sig) i.
Proof.
- intros.
- apply type_args_mapped; auto.
- apply type_arg_mapped.
- unfold type_rtl_ros.
- unfold mapped.
- right.
- apply Uf.sameclass_identify_1; auto.
+ induction instrs; simpl; intros.
+ elim H0.
+ destruct a as [pc' i']. elim (andb_prop _ _ H); clear H; intros.
+ elim H0; intro.
+ inversion H2; subst pc' i'. apply check_instr_correct; auto.
+ eauto.
Qed.
-Lemma type_res_correct :
- forall (u : Uf.T) (lr : list reg) (lt : list typ) (r : reg) (t : typ),
- consistent (fold2 type_rtl_arg (type_rtl_arg u r t) lr lt)
- -> mk_env (fold2 type_rtl_arg (type_rtl_arg u r t) lr lt) r = t.
-Proof.
- intros.
- unfold mk_env.
- rewrite (type_args_included _ _ _ H (tReg r) (tTy t)).
- destruct t.
- apply consistent_not_eq; auto.
- apply equal_eq; auto.
- unfold type_rtl_arg; apply Uf.sameclass_identify_1; auto.
-Qed.
+End TYPECHECKING.
-Lemma type_ros_correct :
- forall (u : Uf.T) (lr : list reg) (lt : list typ) (r r1 : reg) (t : typ),
- consistent (fold2 type_rtl_arg (type_rtl_arg
- (type_rtl_ros u (inl ident r1)) r t) lr lt)
- ->
- mk_env (fold2 type_rtl_arg (type_rtl_arg
- (type_rtl_ros u (inl ident r1)) r t) lr lt) r1
- = Tint.
-Proof.
- intros.
- unfold mk_env.
- rewrite (type_args_included _ _ _ H (tReg r1) (tTy Tint)).
- apply consistent_not_eq; auto.
- rewrite (type_arg_included (type_rtl_ros u (inl ident r1)) r t (tReg r1) (tTy Tint)).
- auto.
- simpl.
- apply Uf.sameclass_identify_1; auto.
-Qed.
-
-Lemma step3 :
- forall (u : Uf.T) (f : function) (c : code) (i : instruction) (pc : positive),
- c!pc = Some i ->
- consistent (type_rtl_instr f.(fn_sig).(sig_res) u pc i)
- -> wt_instr (mk_env (type_rtl_instr f.(fn_sig).(sig_res) u pc i)) f i
- /\ definite (type_rtl_instr f.(fn_sig).(sig_res) u pc i) i.
- Proof.
- Opaque type_rtl_arg.
- intros.
- destruct i; simpl in H0; simpl.
- (* Inop *)
- apply conj; auto. apply wt_Inop.
- (* Iop *)
- destruct o;
- try (apply conj; [
- apply wt_Iop; try congruence; simpl;
- rewrite (type_args_correct _ _ _ H0);
- rewrite (type_res_correct _ _ _ _ _ H0);
- auto
- |apply (type_args_res_complete _ _ _ _ _ H0)]).
- (* Omove *)
- destruct l; [apply error_inconsistent; auto | idtac].
- destruct l; [idtac | apply error_inconsistent; auto].
- apply conj.
- apply wt_Iopmove.
- simpl.
- unfold mk_env.
- rewrite Uf.sameclass_identify_1.
- congruence.
- simpl.
- rewrite Uf.sameclass_identify_1; congruence.
- (* Oundef *)
- destruct l; [idtac | apply error_inconsistent; auto].
- apply conj. apply wt_Iopundef.
- unfold definite. auto.
- (* Iload *)
- apply conj.
- apply wt_Iload.
- rewrite (type_args_correct _ _ _ H0); auto.
- rewrite (type_res_correct _ _ _ _ _ H0); auto.
- simpl; apply (type_args_res_complete _ _ _ _ _ H0).
- (* IStore *)
- apply conj.
- apply wt_Istore.
- rewrite (type_args_correct _ _ _ H0); auto.
- rewrite (type_res_correct _ _ _ _ _ H0); auto.
- simpl; apply (type_args_res_complete _ _ _ _ _ H0).
- (* Icall *)
- apply conj.
- apply wt_Icall.
- destruct s0; auto. apply type_ros_correct. auto.
- apply type_args_correct. auto.
- fold (type_of_sig_res s). apply type_res_correct. auto.
- destruct s0.
- apply conj.
- apply type_ros_complete. auto.
- apply type_args_res_complete. auto.
- apply conj; auto.
- apply type_args_res_complete. auto.
- (* Icond *)
- apply conj.
- apply wt_Icond.
- apply (type_args_correct _ _ _ H0).
- simpl; apply (type_args_complete _ _ _ H0).
- (* Ireturn *)
- destruct o; simpl.
- apply conj.
- apply wt_Ireturn.
- destruct f.(fn_sig).(sig_res); simpl; simpl in H0.
- rewrite type_arg_correct; auto.
- apply error_inconsistent; auto.
- destruct f.(fn_sig).(sig_res); simpl; simpl in H0.
- apply type_arg_complete.
- apply error_inconsistent; auto.
- apply conj; auto. apply wt_Ireturn.
- destruct f.(fn_sig).(sig_res); simpl; simpl in H0.
- apply error_inconsistent; auto.
- congruence.
- Transparent type_rtl_arg.
- Qed.
-
-Lemma mapped_included_consistent :
- forall (u1 u2 : Uf.T) (r : reg),
- mapped u1 r ->
- included u1 u2 ->
- consistent u2 ->
- mk_env u2 r = mk_env u1 r.
-Proof.
- intros.
- unfold mk_env.
- unfold mapped in H.
- elim H; intros; rewrite H2; rewrite (H0 _ _ H2).
- rewrite equal_eq; rewrite equal_eq; auto.
- rewrite (consistent_not_eq u2).
- rewrite (consistent_not_eq u1).
- auto.
- apply included_consistent with (u2 := u2).
- auto.
- auto.
- auto.
-Qed.
+(** ** The type inference function **)
-Lemma mapped_list_included :
- forall (u1 u2 : Uf.T) (lr : list reg),
- (forall r, In r lr -> mapped u1 r) ->
- included u1 u2 ->
- consistent u2 ->
- map (mk_env u2) lr = map (mk_env u1) lr.
-Proof.
- induction lr; simpl; intros.
- auto.
- rewrite (mapped_included_consistent u1 u2 a).
- rewrite IHlr; auto.
- apply (H a); intros.
- left; auto.
- auto.
- auto.
-Qed.
+Definition type_function (f: function): option regenv :=
+ let instrs := PTree.elements f.(fn_code) in
+ match infer_type_environment f instrs with
+ | None => None
+ | Some env =>
+ if check_regs env f.(fn_params) f.(fn_sig).(sig_args)
+ && check_params_norepet f.(fn_params)
+ && check_instrs f env instrs
+ then Some env else None
+ end.
-Lemma included_mapped :
- forall (u1 u2 : Uf.T) (r : reg),
- included u1 u2 ->
- mapped u1 r ->
- mapped u2 r.
-Proof.
- unfold mapped.
- intros.
- elim H0; intros.
- left; rewrite (H _ _ H1); auto.
- right; rewrite (H _ _ H1); auto.
-Qed.
+Definition type_external_function (ef: external_function): bool :=
+ List.fold_right
+ (fun l b => match l with Locations.S _ => false | Locations.R _ => b end)
+ true (Conventions.loc_arguments ef.(ef_sig)).
-Lemma included_mapped_forall :
- forall (u1 u2 : Uf.T) (r : reg) (l : list reg),
- included u1 u2 ->
- mapped u1 r /\ (forall r, In r l -> mapped u1 r) ->
- mapped u2 r /\ (forall r, In r l -> mapped u2 r).
+Lemma type_function_correct:
+ forall f env,
+ type_function f = Some env ->
+ wt_function f env.
Proof.
- intros.
- elim H0; intros.
- apply conj.
- apply (included_mapped _ _ r H); auto.
- intros.
- apply (included_mapped _ _ r0 H).
- apply H2; auto.
+ unfold type_function; intros until env.
+ set (instrs := PTree.elements f.(fn_code)).
+ case (infer_type_environment f instrs).
+ intro env'.
+ caseEq (check_regs env' f.(fn_params) f.(fn_sig).(sig_args)); intro; simpl; try congruence.
+ caseEq (check_params_norepet f.(fn_params)); intro; simpl; try congruence.
+ caseEq (check_instrs f env' instrs); intro; simpl; try congruence.
+ intro EQ; inversion EQ; subst env'.
+ constructor.
+ apply check_regs_correct; auto.
+ unfold check_params_norepet in H0.
+ destruct (list_norepet_dec Reg.eq (fn_params f)). auto. discriminate.
+ intros. eapply check_instrs_correct. eauto.
+ unfold instrs. apply PTree.elements_correct. eauto.
+ congruence.
Qed.
-Lemma definite_included :
- forall (u1 u2 : Uf.T) (i : instruction),
- included u1 u2 -> definite u1 i -> definite u2 i.
+Lemma type_external_function_correct:
+ forall ef,
+ type_external_function ef = true ->
+ Conventions.sig_external_ok ef.(ef_sig).
Proof.
- unfold definite.
- intros.
- destruct i; try apply (included_mapped_forall _ _ _ _ H H0); auto.
- destruct o; try apply (included_mapped_forall _ _ _ _ H H0); auto.
- destruct l; auto.
- apply (included_mapped_forall _ _ _ _ H H0).
- destruct l; auto.
- apply (included_mapped_forall _ _ _ _ H H0).
- destruct s0; auto.
- elim H0; intros.
- apply conj.
- apply (included_mapped _ _ _ H H1).
- apply (included_mapped_forall _ _ _ _ H H2).
- elim H0; intros.
- apply conj; auto.
- apply (included_mapped_forall _ _ _ _ H H2).
- intros.
- apply (included_mapped _ _ _ H (H0 r H1)).
- destruct o; auto.
- apply (included_mapped _ _ _ H H0).
+ intro ef. unfold type_external_function, Conventions.sig_external_ok.
+ generalize (Conventions.loc_arguments (ef_sig ef)).
+ induction l; simpl.
+ tauto.
+ destruct a. intros. firstorder congruence.
+ congruence.
Qed.
-Lemma step4 :
- forall (f : function) (u1 u3 : Uf.T) (i : instruction),
- included u3 u1 ->
- wt_instr (mk_env u3) f i ->
- definite u3 i ->
- consistent u1 ->
- wt_instr (mk_env u1) f i.
- Proof.
- intros f u1 u3 i H1 H H0 X.
- destruct H; try simpl in H0; try (elim H0; intros).
- apply wt_Inop.
- apply wt_Iopmove. unfold mk_env. rewrite (H1 _ _ H0). auto.
- apply wt_Iopundef.
- apply wt_Iop; auto.
- destruct op; try congruence; simpl; simpl in H3;
- simpl in H0; elim H0; intros; rewrite (mapped_included_consistent _ _ _ H4 H1 X);
- rewrite (mapped_list_included _ _ _ H5 H1); auto.
- apply wt_Iload.
- rewrite (mapped_list_included _ _ _ H4 H1); auto.
- rewrite (mapped_included_consistent _ _ _ H3 H1 X). auto.
- apply wt_Istore.
- rewrite (mapped_list_included _ _ _ H4 H1); auto.
- rewrite (mapped_included_consistent _ _ _ H3 H1 X). auto.
- elim H5; intros; destruct ros; apply wt_Icall.
- rewrite (mapped_included_consistent _ _ _ H4 H1 X); auto.
- rewrite (mapped_list_included _ _ _ H7 H1); auto.
- rewrite (mapped_included_consistent _ _ _ H6 H1 X); auto.
- auto.
- rewrite (mapped_list_included _ _ _ H7 H1); auto.
- rewrite (mapped_included_consistent _ _ _ H6 H1 X); auto.
- apply wt_Icond. rewrite (mapped_list_included _ _ _ H0 H1); auto.
- apply wt_Ireturn.
- destruct optres; destruct f.(fn_sig).(sig_res);
- simpl in H; simpl; try congruence.
- rewrite (mapped_included_consistent _ _ _ H0 H1 X); auto.
- Qed.
-
-Lemma type_rtl_function_instrs :
- forall (f: function) (env: regenv),
- type_rtl_function f = Some env
- -> forall pc i, f.(fn_code)!pc = Some i -> wt_instr env f i.
- Proof.
- intros.
- elim (step1 _ _ H).
- intros.
- elim H1.
- intros.
- elim H3.
- intros.
- rewrite H4.
- elim (step2 _ _ _ (included_consistent _ _ H2 H5) _ _ H0).
- intros.
- elim H6. intros.
- elim (step3 x0 f _ _ _ H0); auto. intros.
- apply (step4 f _ _ i H2); auto.
- apply (step4 _ _ _ _ H8 H9 H10).
- apply (included_consistent _ _ H2); auto.
- apply (definite_included _ _ _ H8 H10); auto.
- Qed.
-
-(** Combining the sub-proofs. *)
-
-Theorem type_rtl_function_correct:
- forall (f: function) (env: regenv),
- type_rtl_function f = Some env -> wt_function env f.
- Proof.
- intros.
- exact (mk_wt_function env f (type_rtl_function_params f _ H)
- (type_rtl_function_norepet f _ H)
- (type_rtl_function_instrs f _ H)).
- Qed.
-
-Definition wt_program (p: program) : Prop :=
- forall i f, In (i, f) (prog_funct p) -> type_rtl_function f <> None.
-
(** * Type preservation during evaluation *)
(** The type system for RTL is not sound in that it does not guarantee
@@ -1143,6 +358,7 @@ Require Import Globalenvs.
Require Import Values.
Require Import Mem.
Require Import Integers.
+Require Import Events.
Definition wt_regset (env: regenv) (rs: regset) : Prop :=
forall r, Val.has_type (rs#r) (env r).
@@ -1180,6 +396,14 @@ Proof.
apply wt_regset_assign; auto.
Qed.
+Lemma wt_event_match:
+ forall ef args t res,
+ event_match ef args t res ->
+ Val.has_type res (proj_sig_res ef.(ef_sig)).
+Proof.
+ induction 1. inversion H0; exact I.
+Qed.
+
Section SUBJECT_REDUCTION.
Variable p: program.
@@ -1190,26 +414,24 @@ Let ge := Genv.globalenv p.
Definition exec_instr_subject_reduction
(c: code) (sp: val)
- (pc: node) (rs: regset) (m: mem)
+ (pc: node) (rs: regset) (m: mem) (t: trace)
(pc': node) (rs': regset) (m': mem) : Prop :=
forall env f
(CODE: c = fn_code f)
- (WT_FN: wt_function env f)
+ (WT_FN: wt_function f env)
(WT_RS: wt_regset env rs),
wt_regset env rs'.
Definition exec_function_subject_reduction
- (f: function) (args: list val) (m: mem) (res: val) (m': mem) : Prop :=
- forall env,
- wt_function env f ->
- Val.has_type_list args f.(fn_sig).(sig_args) ->
- Val.has_type res
- (match f.(fn_sig).(sig_res) with None => Tint | Some ty => ty end).
+ (f: fundef) (args: list val) (m: mem) (t: trace) (res: val) (m': mem) : Prop :=
+ wt_fundef f ->
+ Val.has_type_list args (sig_args (funsig f)) ->
+ Val.has_type res (proj_sig_res (funsig f)).
Lemma subject_reduction:
- forall f args m res m',
- exec_function ge f args m res m' ->
- exec_function_subject_reduction f args m res m'.
+ forall f args m t res m',
+ exec_function ge f args m t res m' ->
+ exec_function_subject_reduction f args m t res m'.
Proof.
apply (exec_function_ind_3 ge
exec_instr_subject_reduction
@@ -1217,7 +439,7 @@ Proof.
exec_function_subject_reduction);
intros; red; intros;
try (rewrite CODE in H;
- generalize (wt_instrs env _ WT_FN pc _ H);
+ generalize (wt_instrs _ _ WT_FN pc _ H);
intro WT_INSTR;
inversion WT_INSTR).
@@ -1233,7 +455,7 @@ Proof.
apply wt_regset_assign. auto.
replace (env res) with (snd (type_of_operation op)).
- apply type_of_operation_sound with function ge rs##args sp; auto.
+ apply type_of_operation_sound with fundef ge rs##args sp; auto.
rewrite <- H7. reflexivity.
apply wt_regset_assign. auto. rewrite H8.
@@ -1241,37 +463,39 @@ Proof.
assumption.
- apply wt_regset_assign. auto. rewrite H11. rewrite H1.
- assert (type_rtl_function f <> None).
+ apply wt_regset_assign. auto. rewrite H11. rewrite <- H1.
+ assert (wt_fundef f).
destruct ros; simpl in H0.
- pattern f. apply Genv.find_funct_prop with function p (rs#r).
+ pattern f. apply Genv.find_funct_prop with fundef p (rs#r).
exact wt_p. exact H0.
caseEq (Genv.find_symbol ge i); intros; rewrite H12 in H0.
- pattern f. apply Genv.find_funct_ptr_prop with function p b.
+ pattern f. apply Genv.find_funct_ptr_prop with fundef p b.
exact wt_p. exact H0.
discriminate.
- assert (exists env1, wt_function env1 f).
- caseEq (type_rtl_function f); intros; try congruence.
- exists t. apply type_rtl_function_correct; auto.
- elim H13; intros env1 WT_FN1.
- eapply H3. eexact WT_FN1. rewrite <- H1. rewrite <- H10.
+ eapply H3. auto. rewrite H1. rewrite <- H10.
apply wt_regset_list; auto.
+ apply wt_regset_assign. auto. rewrite H6; exact I.
+
assumption.
assumption.
assumption.
eauto.
eauto.
+ inversion H4; subst f0.
assert (WT_INIT: wt_regset env (init_regs args (fn_params f))).
- apply wt_init_regs. rewrite (wt_params env f H4). assumption.
- generalize (H1 env f (refl_equal (fn_code f)) H4 WT_INIT).
+ apply wt_init_regs. rewrite (wt_params _ _ H7). assumption.
+ generalize (H1 env f (refl_equal (fn_code f)) H7 WT_INIT).
intro WT_RS.
- generalize (wt_instrs env _ H4 pc _ H2).
+ generalize (wt_instrs _ _ H7 pc _ H2).
intro WT_INSTR; inversion WT_INSTR.
- destruct or; simpl in H3; simpl in H7; rewrite <- H7.
+ unfold proj_sig_res; simpl.
+ destruct or; simpl in H3; simpl in H8; rewrite <- H8.
rewrite H3. apply WT_RS.
rewrite H3. simpl; auto.
+
+ simpl. eapply wt_event_match; eauto.
Qed.
End SUBJECT_REDUCTION.
diff --git a/backend/Stacking.v b/backend/Stacking.v
index 1f0c454..85ac933 100644
--- a/backend/Stacking.v
+++ b/backend/Stacking.v
@@ -186,6 +186,8 @@ Definition transl_instr
Mstore chunk (transl_addr fe addr) args src :: k
| Lcall sig ros =>
Mcall sig ros :: k
+ | Lalloc =>
+ Malloc :: k
| Llabel lbl =>
Mlabel lbl :: k
| Lgoto lbl =>
@@ -222,5 +224,8 @@ Definition transf_function (f: Linear.function) : option Mach.function :=
f.(Linear.fn_stacksize)
fe.(fe_size)).
+Definition transf_fundef (f: Linear.fundef) : option Mach.fundef :=
+ AST.transf_partial_fundef transf_function f.
+
Definition transf_program (p: Linear.program) : option Mach.program :=
- transform_partial_program transf_function p.
+ transform_partial_program transf_fundef p.
diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v
index 002ca8d..9692670 100644
--- a/backend/Stackingproof.v
+++ b/backend/Stackingproof.v
@@ -15,6 +15,7 @@ Require Import Integers.
Require Import Values.
Require Import Op.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Locations.
Require Import Mach.
@@ -299,7 +300,7 @@ Lemma exec_Mgetstack':
get_slot fr ty (offset_of_index fe idx) v ->
Machabstr.exec_instrs tge tf sp parent
(Mgetstack (Int.repr (offset_of_index fe idx)) ty dst :: c) rs fr m
- c (rs#dst <- v) fr m.
+ E0 c (rs#dst <- v) fr m.
Proof.
intros. apply Machabstr.exec_one. apply Machabstr.exec_Mgetstack.
rewrite offset_of_index_no_overflow. auto. auto.
@@ -311,7 +312,7 @@ Lemma exec_Msetstack':
set_slot fr ty (offset_of_index fe idx) (rs src) fr' ->
Machabstr.exec_instrs tge tf sp parent
(Msetstack src (Int.repr (offset_of_index fe idx)) ty :: c) rs fr m
- c rs fr' m.
+ E0 c rs fr' m.
Proof.
intros. apply Machabstr.exec_one. apply Machabstr.exec_Msetstack.
rewrite offset_of_index_no_overflow. auto. auto.
@@ -632,7 +633,7 @@ Lemma save_int_callee_save_correct_rec:
exists fr',
Machabstr.exec_instrs tge tf sp parent
(List.fold_right (save_int_callee_save fe) k l) rs fr m
- k rs fr' m
+ E0 k rs fr' m
/\ fr'.(high) = 0
/\ fr'.(low) = -fe.(fe_size)
/\ (forall r,
@@ -670,7 +671,7 @@ Proof.
intros [fr' [A [B [C [D E]]]]].
exists fr'.
split. eapply Machabstr.exec_trans. apply exec_Msetstack'; eauto with stacking.
- exact A.
+ eexact A. traceEq.
split. auto.
split. auto.
split. intros. elim H3; intros. subst r.
@@ -701,7 +702,7 @@ Lemma save_int_callee_save_correct:
exists fr',
Machabstr.exec_instrs tge tf sp parent
(List.fold_right (save_int_callee_save fe) k int_callee_save_regs) rs fr m
- k rs fr' m
+ E0 k rs fr' m
/\ fr'.(high) = 0
/\ fr'.(low) = -fe.(fe_size)
/\ (forall r,
@@ -733,7 +734,7 @@ Lemma save_float_callee_save_correct_rec:
exists fr',
Machabstr.exec_instrs tge tf sp parent
(List.fold_right (save_float_callee_save fe) k l) rs fr m
- k rs fr' m
+ E0 k rs fr' m
/\ fr'.(high) = 0
/\ fr'.(low) = -fe.(fe_size)
/\ (forall r,
@@ -771,7 +772,7 @@ Proof.
intros [fr' [A [B [C [D E]]]]].
exists fr'.
split. eapply Machabstr.exec_trans. apply exec_Msetstack'; eauto with stacking.
- exact A.
+ eexact A. traceEq.
split. auto.
split. auto.
split. intros. elim H3; intros. subst r.
@@ -802,7 +803,7 @@ Lemma save_float_callee_save_correct:
exists fr',
Machabstr.exec_instrs tge tf sp parent
(List.fold_right (save_float_callee_save fe) k float_callee_save_regs) rs fr m
- k rs fr' m
+ E0 k rs fr' m
/\ fr'.(high) = 0
/\ fr'.(low) = -fe.(fe_size)
/\ (forall r,
@@ -846,7 +847,7 @@ Lemma save_callee_save_correct:
exists fr',
Machabstr.exec_instrs tge tf sp parent
(save_callee_save fe k) rs fr m
- k rs fr' m
+ E0 k rs fr' m
/\ agree (LTL.call_regs ls) rs fr' parent rs.
Proof.
intros. unfold save_callee_save.
@@ -857,7 +858,7 @@ Proof.
generalize (save_float_callee_save_correct k sp parent rs fr1 m B1 C1).
intros [fr2 [A2 [B2 [C2 [D2 E2]]]]].
exists fr2.
- split. eapply Machabstr.exec_trans. eexact A1. eexact A2.
+ split. eapply Machabstr.exec_trans. eexact A1. eexact A2. traceEq.
constructor; unfold LTL.call_regs; auto.
(* agree_local *)
intros. rewrite E2; auto with stacking.
@@ -886,7 +887,7 @@ Lemma restore_int_callee_save_correct_rec:
exists ls', exists rs',
Machabstr.exec_instrs tge tf sp parent
(List.fold_right (restore_int_callee_save fe) k l) rs fr m
- k rs' fr m
+ E0 k rs' fr m
/\ (forall r, In r l -> rs' r = rs0 r)
/\ (forall r, ~(In r l) -> rs' r = rs r)
/\ agree ls' rs' fr parent rs0.
@@ -916,11 +917,11 @@ Proof.
generalize (IHl ls1 rs1 R1 R2 R3).
intros [ls' [rs' [A [B [C D]]]]].
exists ls'. exists rs'.
- split. apply Machabstr.exec_trans with k1 rs1 fr m.
+ split. apply Machabstr.exec_trans with E0 k1 rs1 fr m E0.
unfold rs1; apply exec_Mgetstack'; eauto with stacking.
apply get_slot_index; eauto with stacking.
symmetry. eauto with stacking.
- eauto with stacking.
+ eauto with stacking. traceEq.
split. intros. elim H2; intros.
subst r. rewrite C. unfold rs1. apply Regmap.gss. inversion H0; auto.
auto.
@@ -945,7 +946,7 @@ Lemma restore_int_callee_save_correct:
exists ls', exists rs',
Machabstr.exec_instrs tge tf sp parent
(List.fold_right (restore_int_callee_save fe) k int_callee_save_regs) rs fr m
- k rs' fr m
+ E0 k rs' fr m
/\ (forall r, In r int_callee_save_regs -> rs' r = rs0 r)
/\ (forall r, ~(In r int_callee_save_regs) -> rs' r = rs r)
/\ agree ls' rs' fr parent rs0.
@@ -962,7 +963,7 @@ Lemma restore_float_callee_save_correct_rec:
exists ls', exists rs',
Machabstr.exec_instrs tge tf sp parent
(List.fold_right (restore_float_callee_save fe) k l) rs fr m
- k rs' fr m
+ E0 k rs' fr m
/\ (forall r, In r l -> rs' r = rs0 r)
/\ (forall r, ~(In r l) -> rs' r = rs r)
/\ agree ls' rs' fr parent rs0.
@@ -992,11 +993,11 @@ Proof.
generalize (IHl ls1 rs1 R1 R2 R3).
intros [ls' [rs' [A [B [C D]]]]].
exists ls'. exists rs'.
- split. apply Machabstr.exec_trans with k1 rs1 fr m.
+ split. apply Machabstr.exec_trans with E0 k1 rs1 fr m E0.
unfold rs1; apply exec_Mgetstack'; eauto with stacking.
apply get_slot_index; eauto with stacking.
symmetry. eauto with stacking.
- exact A.
+ exact A. traceEq.
split. intros. elim H2; intros.
subst r. rewrite C. unfold rs1. apply Regmap.gss. inversion H0; auto.
auto.
@@ -1021,7 +1022,7 @@ Lemma restore_float_callee_save_correct:
exists ls', exists rs',
Machabstr.exec_instrs tge tf sp parent
(List.fold_right (restore_float_callee_save fe) k float_callee_save_regs) rs fr m
- k rs' fr m
+ E0 k rs' fr m
/\ (forall r, In r float_callee_save_regs -> rs' r = rs0 r)
/\ (forall r, ~(In r float_callee_save_regs) -> rs' r = rs r)
/\ agree ls' rs' fr parent rs0.
@@ -1036,7 +1037,7 @@ Lemma restore_callee_save_correct:
exists rs',
Machabstr.exec_instrs tge tf sp parent
(restore_callee_save fe k) rs fr m
- k rs' fr m
+ E0 k rs' fr m
/\ (forall r,
In r int_callee_save_regs \/ In r float_callee_save_regs ->
rs' r = rs0 r)
@@ -1053,7 +1054,7 @@ Proof.
generalize (restore_float_callee_save_correct sp parent
k fr m rs0 ls1 rs1 D).
intros [ls2 [rs2 [P [Q [R S]]]]].
- exists rs2. split. eapply Machabstr.exec_trans. eexact A. exact P.
+ exists rs2. split. eapply Machabstr.exec_trans. eexact A. eexact P. traceEq.
split. intros. elim H0; intros.
rewrite R. apply B. auto. apply list_disjoint_notin with int_callee_save_regs.
apply int_float_callee_save_disjoint. auto.
@@ -1148,8 +1149,8 @@ Proof.
Qed.
Lemma exec_instr_incl:
- forall f sp c1 ls1 m1 c2 ls2 m2,
- Linear.exec_instr ge f sp c1 ls1 m1 c2 ls2 m2 ->
+ forall f sp c1 ls1 m1 t c2 ls2 m2,
+ Linear.exec_instr ge f sp c1 ls1 m1 t c2 ls2 m2 ->
incl c1 f.(fn_code) ->
incl c2 f.(fn_code).
Proof.
@@ -1159,8 +1160,8 @@ Proof.
Qed.
Lemma exec_instrs_incl:
- forall f sp c1 ls1 m1 c2 ls2 m2,
- Linear.exec_instrs ge f sp c1 ls1 m1 c2 ls2 m2 ->
+ forall f sp c1 ls1 m1 t c2 ls2 m2,
+ Linear.exec_instrs ge f sp c1 ls1 m1 t c2 ls2 m2 ->
incl c1 f.(fn_code) ->
incl c2 f.(fn_code).
Proof.
@@ -1174,7 +1175,7 @@ Lemma symbols_preserved:
forall id, Genv.find_symbol tge id = Genv.find_symbol ge id.
Proof.
intros. unfold ge, tge.
- apply Genv.find_symbol_transf_partial with transf_function.
+ apply Genv.find_symbol_transf_partial with transf_fundef.
exact TRANSF.
Qed.
@@ -1182,11 +1183,11 @@ Lemma functions_translated:
forall f v,
Genv.find_funct ge v = Some f ->
exists tf,
- Genv.find_funct tge v = Some tf /\ transf_function f = Some tf.
+ Genv.find_funct tge v = Some tf /\ transf_fundef f = Some tf.
Proof.
intros.
- generalize (Genv.find_funct_transf_partial transf_function TRANSF H).
- case (transf_function f).
+ generalize (Genv.find_funct_transf_partial transf_fundef TRANSF H).
+ case (transf_fundef f).
intros tf [A B]. exists tf. tauto.
intros. tauto.
Qed.
@@ -1195,15 +1196,26 @@ Lemma function_ptr_translated:
forall f v,
Genv.find_funct_ptr ge v = Some f ->
exists tf,
- Genv.find_funct_ptr tge v = Some tf /\ transf_function f = Some tf.
+ Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = Some tf.
Proof.
intros.
- generalize (Genv.find_funct_ptr_transf_partial transf_function TRANSF H).
- case (transf_function f).
+ generalize (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF H).
+ case (transf_fundef f).
intros tf [A B]. exists tf. tauto.
intros. tauto.
Qed.
+Lemma sig_preserved:
+ forall f tf, transf_fundef f = Some tf -> Mach.funsig tf = Linear.funsig f.
+Proof.
+ intros until tf; unfold transf_fundef, transf_partial_fundef.
+ destruct f. unfold transf_function.
+ destruct (zlt (fn_stacksize f) 0). congruence.
+ destruct (zlt (- Int.min_signed) (fe_size (make_env (function_bounds f)))). congruence.
+ intros. inversion H; reflexivity.
+ intro. inversion H. reflexivity.
+Qed.
+
(** Correctness of stack pointer relocation in operations and
addressing modes. *)
@@ -1287,7 +1299,7 @@ Qed.
Definition exec_instr_prop
(f: function) (sp: val)
- (c: code) (ls: locset) (m: mem)
+ (c: code) (ls: locset) (m: mem) (t: trace)
(c': code) (ls': locset) (m': mem) :=
forall tf rs fr parent rs0
(TRANSL: transf_function f = Some tf)
@@ -1297,7 +1309,7 @@ Definition exec_instr_prop
exists rs', exists fr',
Machabstr.exec_instrs tge tf (shift_sp tf sp) parent
(transl_code (make_env (function_bounds f)) c) rs fr m
- (transl_code (make_env (function_bounds f)) c') rs' fr' m'
+ t (transl_code (make_env (function_bounds f)) c') rs' fr' m'
/\ agree f ls' rs' fr' parent rs0.
(** The simulation property for function calls has different preconditions
@@ -1306,19 +1318,19 @@ Definition exec_instr_prop
postconditions (preservation of callee-save registers). *)
Definition exec_function_prop
- (f: function)
- (ls: locset) (m: mem)
+ (f: fundef)
+ (ls: locset) (m: mem) (t: trace)
(ls': locset) (m': mem) :=
forall tf rs parent
- (TRANSL: transf_function f = Some tf)
- (WTF: wt_function f)
+ (TRANSL: transf_fundef f = Some tf)
+ (WTF: wt_fundef f)
(AG1: forall r, rs r = ls (R r))
(AG2: forall ofs ty,
6 <= ofs ->
- ofs + typesize ty <= size_arguments f.(fn_sig) ->
+ ofs + typesize ty <= size_arguments (funsig f) ->
get_slot parent ty (Int.signed (Int.repr (4 * ofs))) (ls (S (Outgoing ofs ty)))),
exists rs',
- Machabstr.exec_function tge tf parent rs m rs' m'
+ Machabstr.exec_function tge tf parent rs m t rs' m'
/\ (forall r,
In (R r) temporaries \/ In (R r) destroyed_at_call ->
rs' r = ls' (R r))
@@ -1329,9 +1341,9 @@ Definition exec_function_prop
Hypothesis wt_prog: wt_program prog.
Lemma transf_function_correct:
- forall f ls m ls' m',
- Linear.exec_function ge f ls m ls' m' ->
- exec_function_prop f ls m ls' m'.
+ forall f ls m t ls' m',
+ Linear.exec_function ge f ls m t ls' m' ->
+ exec_function_prop f ls m t ls' m'.
Proof.
assert (RED: forall f i c,
transl_code (make_env (function_bounds f)) (i :: c) =
@@ -1412,13 +1424,13 @@ Proof.
(* Lcall *)
inversion WTI.
- assert (WTF': wt_function f').
+ assert (WTF': wt_fundef f').
destruct ros; simpl in H.
- apply (Genv.find_funct_prop wt_function wt_prog H).
+ apply (Genv.find_funct_prop wt_fundef wt_prog H).
destruct (Genv.find_symbol ge i); try discriminate.
- apply (Genv.find_funct_ptr_prop wt_function wt_prog H).
+ apply (Genv.find_funct_ptr_prop wt_fundef wt_prog H).
assert (TR: exists tf', Mach.find_function tge ros rs0 = Some tf'
- /\ transf_function f' = Some tf').
+ /\ transf_fundef f' = Some tf').
destruct ros; simpl in H; simpl.
eapply functions_translated.
rewrite (agree_eval_reg _ _ _ _ _ _ m0 AG). auto.
@@ -1430,7 +1442,7 @@ Proof.
intro. symmetry. eapply agree_reg; eauto.
assert (AG2: forall ofs ty,
6 <= ofs ->
- ofs + typesize ty <= size_arguments f'.(fn_sig) ->
+ ofs + typesize ty <= size_arguments (funsig f') ->
get_slot fr ty (Int.signed (Int.repr (4 * ofs))) (rs (S (Outgoing ofs ty)))).
intros.
assert (slot_bounded f (Outgoing ofs ty)).
@@ -1446,6 +1458,13 @@ Proof.
apply Machabstr.exec_one; apply Machabstr.exec_Mcall with tf'; auto.
apply agree_return_regs with rs0; auto.
+ (* Lalloc *)
+ exists (rs0#loc_alloc_result <- (Vptr blk Int.zero)); exists fr. split.
+ apply Machabstr.exec_one; eapply Machabstr.exec_Malloc; eauto.
+ rewrite (agree_eval_reg _ _ _ _ _ _ loc_alloc_argument AG). auto.
+ apply agree_set_reg; auto.
+ red. simpl. generalize (max_over_regs_of_funct_pos f int_callee_save). omega.
+
(* Llabel *)
exists rs0; exists fr. split.
apply Machabstr.exec_one; apply Machabstr.exec_Mlabel.
@@ -1483,25 +1502,30 @@ Proof.
generalize (H2 tf rs' fr' parent rs0 TRANSL WTF B INCL').
intros [rs'' [fr'' [C D]]].
exists rs''; exists fr''. split.
- eapply Machabstr.exec_trans. eexact A. eexact C.
+ eapply Machabstr.exec_trans. eexact A. eexact C. auto.
auto.
(* function *)
+ generalize TRANSL; clear TRANSL.
+ unfold transf_fundef, transf_partial_fundef.
+ caseEq (transf_function f); try congruence.
+ intros tfn TRANSL EQ. inversion EQ; clear EQ; subst tf.
+ inversion WTF as [|f' WTFN]. subst f'.
assert (X: forall link ra,
exists rs' : regset,
- Machabstr.exec_function_body tge tf parent link ra rs0 m rs' (free m2 stk) /\
+ Machabstr.exec_function_body tge tfn parent link ra rs0 m t rs' (free m2 stk) /\
(forall r : mreg,
In (R r) temporaries \/ In (R r) destroyed_at_call -> rs' r = rs2 (R r)) /\
(forall r : mreg,
In r int_callee_save_regs \/ In r float_callee_save_regs -> rs' r = rs0 r)).
intros.
set (sp := Vptr stk Int.zero) in *.
- set (tsp := shift_sp tf sp).
+ set (tsp := shift_sp tfn sp).
set (fe := make_env (function_bounds f)).
- assert (low (init_frame tf) = -fe.(fe_size)).
+ assert (low (init_frame tfn) = -fe.(fe_size)).
simpl low. rewrite (unfold_transf_function _ _ TRANSL).
reflexivity.
- assert (exists fr1, set_slot (init_frame tf) Tint 0 link fr1).
+ assert (exists fr1, set_slot (init_frame tfn) Tint 0 link fr1).
apply set_slot_ok. reflexivity. omega. rewrite H2. generalize (size_pos f).
unfold fe. simpl typesize. omega.
elim H3; intros fr1 SET1; clear H3.
@@ -1526,28 +1550,29 @@ Proof.
apply slot_gi. omega. omega.
simpl typesize. omega. simpl typesize. omega.
inversion H8. symmetry. exact H11.
- generalize (save_callee_save_correct f tf TRANSL
+ generalize (save_callee_save_correct f tfn TRANSL
tsp parent
(transl_code (make_env (function_bounds f)) f.(fn_code))
rs0 fr2 m1 rs AG1 AG2 H5 H6 UNDEF).
intros [fr [EXP AG]].
- generalize (H1 tf rs0 fr parent rs0 TRANSL WTF AG (incl_refl _)).
+ generalize (H1 tfn rs0 fr parent rs0 TRANSL WTFN AG (incl_refl _)).
intros [rs' [fr' [EXB AG']]].
- generalize (restore_callee_save_correct f tf TRANSL tsp parent
+ generalize (restore_callee_save_correct f tfn TRANSL tsp parent
(Mreturn :: transl_code (make_env (function_bounds f)) b)
fr' m2 rs0 rs2 rs' AG').
intros [rs'' [EXX [REGS1 REGS2]]].
exists rs''. split. eapply Machabstr.exec_funct_body.
- rewrite (unfold_transf_function f tf TRANSL); eexact H.
+ rewrite (unfold_transf_function f tfn TRANSL); eexact H.
eexact SET1. eexact SET2.
- replace (Mach.fn_code tf) with
+ replace (Mach.fn_code tfn) with
(transl_body f (make_env (function_bounds f))).
- replace (Vptr stk (Int.repr (- fn_framesize tf))) with tsp.
+ replace (Vptr stk (Int.repr (- fn_framesize tfn))) with tsp.
eapply Machabstr.exec_trans. eexact EXP.
- eapply Machabstr.exec_trans. eexact EXB. eexact EXX.
+ eapply Machabstr.exec_trans. eexact EXB. eexact EXX.
+ reflexivity. traceEq.
unfold tsp, shift_sp, sp. unfold Val.add.
rewrite Int.add_commut. rewrite Int.add_zero. auto.
- rewrite (unfold_transf_function f tf TRANSL). simpl. auto.
+ rewrite (unfold_transf_function f tfn TRANSL). simpl. auto.
split. intros. rewrite REGS2. symmetry; eapply agree_reg; eauto.
apply int_callee_save_not_destroyed; auto.
apply float_callee_save_not_destroyed; auto.
@@ -1563,21 +1588,36 @@ Proof.
rewrite REGS2'. apply REGS2. auto. auto.
rewrite H4. auto.
split; auto.
+
+ (* external function *)
+ simpl in TRANSL. inversion TRANSL; subst tf.
+ inversion WTF. subst ef0. set (sg := ef_sig ef) in *.
+ exists (rs#(loc_result sg) <- res).
+ split. econstructor. eauto.
+ fold sg. rewrite H0. rewrite Conventions.loc_external_arguments_loc_arguments; auto.
+ rewrite list_map_compose. apply list_map_exten; intros. auto.
+ reflexivity.
+ split; intros. rewrite H1.
+ unfold Regmap.set. case (RegEq.eq r (loc_result sg)); intro.
+ rewrite e. rewrite Locmap.gss; auto. rewrite Locmap.gso; auto.
+ red; auto.
+ apply Regmap.gso. red; intro; subst r.
+ elim (Conventions.loc_result_not_callee_save _ H2).
Qed.
End PRESERVATION.
Theorem transl_program_correct:
- forall (p: Linear.program) (tp: Mach.program) (r: val),
+ forall (p: Linear.program) (tp: Mach.program) (t: trace) (r: val),
wt_program p ->
transf_program p = Some tp ->
- Linear.exec_program p r ->
- Machabstr.exec_program tp r.
+ Linear.exec_program p t r ->
+ Machabstr.exec_program tp t r.
Proof.
- intros p tp r WTP TRANSF
+ intros p tp t r WTP TRANSF
[fptr [f [ls' [m [FINDSYMB [FINDFUNC [SIG [EXEC RES]]]]]]]].
- assert (WTF: wt_function f).
- apply (Genv.find_funct_ptr_prop wt_function WTP FINDFUNC).
+ assert (WTF: wt_fundef f).
+ apply (Genv.find_funct_ptr_prop wt_fundef WTP FINDFUNC).
set (ls := Locmap.init Vundef) in *.
set (rs := Regmap.init Vundef).
set (fr := empty_frame).
@@ -1585,26 +1625,25 @@ Proof.
intros; reflexivity.
assert (AG2: forall ofs ty,
6 <= ofs ->
- ofs + typesize ty <= size_arguments f.(fn_sig) ->
+ ofs + typesize ty <= size_arguments (funsig f) ->
get_slot fr ty (Int.signed (Int.repr (4 * ofs))) (ls (S (Outgoing ofs ty)))).
rewrite SIG. unfold size_arguments, sig_args, size_arguments_rec.
intros. generalize (typesize_pos ty).
intro. omegaContradiction.
generalize (function_ptr_translated p tp TRANSF f _ FINDFUNC).
intros [tf [TFIND TRANSL]].
- generalize (transf_function_correct p tp TRANSF WTP _ _ _ _ _ EXEC
+ generalize (transf_function_correct p tp TRANSF WTP _ _ _ _ _ _ EXEC
tf rs fr TRANSL WTF AG1 AG2).
intros [rs' [A [B C]]].
red. exists fptr; exists tf; exists rs'; exists m.
split. rewrite (symbols_preserved p tp TRANSF).
- rewrite (transform_partial_program_main transf_function p TRANSF).
+ rewrite (transform_partial_program_main transf_fundef p TRANSF).
assumption.
split. assumption.
- split. rewrite (unfold_transf_function f tf TRANSL); simpl.
- assumption.
split. replace (Genv.init_mem tp) with (Genv.init_mem p).
- exact A. symmetry. apply Genv.init_mem_transf_partial with transf_function.
+ exact A. symmetry. apply Genv.init_mem_transf_partial with transf_fundef.
exact TRANSF.
- rewrite <- RES. rewrite (unfold_transf_function f tf TRANSL); simpl.
+ rewrite <- RES. replace R3 with (loc_result (funsig f)).
apply B. right. apply loc_result_acceptable.
+ rewrite SIG; reflexivity.
Qed.
diff --git a/backend/Stackingtyping.v b/backend/Stackingtyping.v
index 85d1922..996ada4 100644
--- a/backend/Stackingtyping.v
+++ b/backend/Stackingtyping.v
@@ -166,6 +166,8 @@ Proof.
(* call *)
apply wt_instrs_cons; auto.
constructor; auto.
+ (* alloc *)
+ apply wt_instrs_cons; auto. constructor.
(* label *)
apply wt_instrs_cons; auto.
constructor.
@@ -208,6 +210,20 @@ Proof.
rewrite H2. eapply size_no_overflow; eauto.
Qed.
+Lemma wt_transf_fundef:
+ forall f tf,
+ Lineartyping.wt_fundef f ->
+ transf_fundef f = Some tf ->
+ wt_fundef tf.
+Proof.
+ intros f tf WT. inversion WT; subst.
+ simpl; intros; inversion H0. constructor; auto.
+ unfold transf_fundef, transf_partial_fundef.
+ caseEq (transf_function f0); try congruence.
+ intros tfn TRANSF EQ. inversion EQ; subst tf.
+ constructor; eapply wt_transf_function; eauto.
+Qed.
+
Lemma program_typing_preserved:
forall (p: Linear.program) (tp: Mach.program),
transf_program p = Some tp ->
@@ -215,8 +231,8 @@ Lemma program_typing_preserved:
Machtyping.wt_program tp.
Proof.
intros; red; intros.
- generalize (transform_partial_program_function transf_function p i f H H1).
+ generalize (transform_partial_program_function transf_fundef p i f H H1).
intros [f0 [IN TRANSF]].
- apply wt_transf_function with f0; auto.
+ apply wt_transf_fundef with f0; auto.
eapply H0; eauto.
Qed.
diff --git a/backend/Tunneling.v b/backend/Tunneling.v
index 9c3e82c..4fbdc9f 100644
--- a/backend/Tunneling.v
+++ b/backend/Tunneling.v
@@ -100,6 +100,8 @@ Fixpoint tunnel_block (f: LTL.function) (b: block) {struct b} : block :=
Bstore chunk addr args src (tunnel_block f b)
| Bcall sig ros b =>
Bcall sig ros (tunnel_block f b)
+ | Balloc b =>
+ Balloc (tunnel_block f b)
| Bgoto s =>
Bgoto (branch_target f s)
| Bcond cond args s1 s2 =>
@@ -126,6 +128,9 @@ Definition tunnel_function (f: LTL.function) : LTL.function :=
(fn_entrypoint f)
(wf_tunneled_code f).
+Definition tunnel_fundef (f: LTL.fundef) : LTL.fundef :=
+ transf_fundef tunnel_function f.
+
Definition tunnel_program (p: LTL.program) : LTL.program :=
- transform_program tunnel_function p.
+ transform_program tunnel_fundef p.
diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v
index 111d1d8..88547e7 100644
--- a/backend/Tunnelingproof.v
+++ b/backend/Tunnelingproof.v
@@ -5,6 +5,7 @@ Require Import Maps.
Require Import AST.
Require Import Values.
Require Import Mem.
+Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
@@ -82,68 +83,75 @@ Let tge := Genv.globalenv tp.
Lemma functions_translated:
forall v f,
Genv.find_funct ge v = Some f ->
- Genv.find_funct tge v = Some (tunnel_function f).
-Proof (@Genv.find_funct_transf _ _ tunnel_function p).
+ Genv.find_funct tge v = Some (tunnel_fundef f).
+Proof (@Genv.find_funct_transf _ _ tunnel_fundef p).
Lemma function_ptr_translated:
forall v f,
Genv.find_funct_ptr ge v = Some f ->
- Genv.find_funct_ptr tge v = Some (tunnel_function f).
-Proof (@Genv.find_funct_ptr_transf _ _ tunnel_function p).
+ Genv.find_funct_ptr tge v = Some (tunnel_fundef f).
+Proof (@Genv.find_funct_ptr_transf _ _ tunnel_fundef p).
Lemma symbols_preserved:
forall id,
Genv.find_symbol tge id = Genv.find_symbol ge id.
-Proof (@Genv.find_symbol_transf _ _ tunnel_function p).
+Proof (@Genv.find_symbol_transf _ _ tunnel_fundef p).
+
+Lemma sig_preserved:
+ forall f, funsig (tunnel_fundef f) = funsig f.
+Proof.
+ destruct f; reflexivity.
+Qed.
(** These are inversion lemmas, characterizing what happens in the LTL
semantics when executing [Bgoto] instructions or basic blocks. *)
Lemma exec_instrs_Bgoto_inv:
- forall sp b1 ls1 m1 b2 ls2 m2,
- exec_instrs ge sp b1 ls1 m1 b2 ls2 m2 ->
+ forall sp b1 ls1 m1 t b2 ls2 m2,
+ exec_instrs ge sp b1 ls1 m1 t b2 ls2 m2 ->
forall s1,
- b1 = Bgoto s1 -> b2 = b1 /\ ls2 = ls1 /\ m2 = m1.
+ b1 = Bgoto s1 -> t = E0 /\ b2 = b1 /\ ls2 = ls1 /\ m2 = m1.
Proof.
induction 1.
intros. tauto.
- intros. subst b1. inversion H.
- intros. generalize (IHexec_instrs1 s1 H1). intros [A [B C]].
- subst b2; subst rs2; subst m2. eauto.
+ intros. subst b1. inversion H.
+ intros. generalize (IHexec_instrs1 s1 H2). intros [A [B [C D]]].
+ subst t1 b2 rs2 m2.
+ generalize (IHexec_instrs2 s1 H2). intros [A [B [C D]]].
+ subst t2 b3 rs3 m3. intuition. traceEq.
Qed.
Lemma exec_block_Bgoto_inv:
- forall sp s ls1 m1 out ls2 m2,
- exec_block ge sp (Bgoto s) ls1 m1 out ls2 m2 ->
- out = Cont s /\ ls2 = ls1 /\ m2 = m1.
+ forall sp s ls1 m1 t out ls2 m2,
+ exec_block ge sp (Bgoto s) ls1 m1 t out ls2 m2 ->
+ t = E0 /\ out = Cont s /\ ls2 = ls1 /\ m2 = m1.
Proof.
intros. inversion H;
- generalize (exec_instrs_Bgoto_inv _ _ _ _ _ _ _ H0 s (refl_equal _));
- intros [A [B C]].
- split. congruence. tauto.
- discriminate.
- discriminate.
- discriminate.
+ generalize (exec_instrs_Bgoto_inv _ _ _ _ _ _ _ _ H0 s (refl_equal _));
+ intros [A [B [C D]]];
+ try discriminate.
+ intuition congruence.
Qed.
Lemma exec_blocks_Bgoto_inv:
- forall c sp pc1 ls1 m1 out ls2 m2 s,
- exec_blocks ge c sp pc1 ls1 m1 out ls2 m2 ->
+ forall c sp pc1 ls1 m1 t out ls2 m2 s,
+ exec_blocks ge c sp pc1 ls1 m1 t out ls2 m2 ->
c!pc1 = Some (Bgoto s) ->
- (out = Cont pc1 /\ ls2 = ls1 /\ m2 = m1)
- \/ exec_blocks ge c sp s ls1 m1 out ls2 m2.
+ (t = E0 /\ out = Cont pc1 /\ ls2 = ls1 /\ m2 = m1)
+ \/ exec_blocks ge c sp s ls1 m1 t out ls2 m2.
Proof.
induction 1; intros.
left; tauto.
assert (b = Bgoto s). congruence. subst b.
- generalize (exec_block_Bgoto_inv _ _ _ _ _ _ _ H0).
- intros [A [B C]]. subst out; subst rs'; subst m'.
+ generalize (exec_block_Bgoto_inv _ _ _ _ _ _ _ _ H0).
+ intros [A [B [C D]]]. subst t out rs' m'.
right. apply exec_blocks_refl.
- elim (IHexec_blocks1 H1).
- intros [A [B C]].
- assert (pc2 = pc1). congruence. subst rs2; subst m2; subst pc2.
- apply IHexec_blocks2; auto.
- intro. right. apply exec_blocks_trans with pc2 rs2 m2; auto.
+ elim (IHexec_blocks1 H2).
+ intros [A [B [C D]]].
+ assert (pc2 = pc1). congruence. subst t1 rs2 m2 pc2.
+ replace t with t2. apply IHexec_blocks2; auto. traceEq.
+ intro. right.
+ eapply exec_blocks_trans; eauto.
Qed.
(** The following [exec_*_prop] predicates state the correctness
@@ -163,43 +171,43 @@ Definition tunnel_outcome (f: function) (out: outcome) :=
end.
Definition exec_instr_prop
- (sp: val) (b1: block) (ls1: locset) (m1: mem)
+ (sp: val) (b1: block) (ls1: locset) (m1: mem) (t: trace)
(b2: block) (ls2: locset) (m2: mem) : Prop :=
forall f,
exec_instr tge sp (tunnel_block f b1) ls1 m1
- (tunnel_block f b2) ls2 m2.
+ t (tunnel_block f b2) ls2 m2.
Definition exec_instrs_prop
- (sp: val) (b1: block) (ls1: locset) (m1: mem)
+ (sp: val) (b1: block) (ls1: locset) (m1: mem) (t: trace)
(b2: block) (ls2: locset) (m2: mem) : Prop :=
forall f,
exec_instrs tge sp (tunnel_block f b1) ls1 m1
- (tunnel_block f b2) ls2 m2.
+ t (tunnel_block f b2) ls2 m2.
Definition exec_block_prop
- (sp: val) (b1: block) (ls1: locset) (m1: mem)
+ (sp: val) (b1: block) (ls1: locset) (m1: mem) (t: trace)
(out: outcome) (ls2: locset) (m2: mem) : Prop :=
forall f,
exec_block tge sp (tunnel_block f b1) ls1 m1
- (tunnel_outcome f out) ls2 m2.
+ t (tunnel_outcome f out) ls2 m2.
Definition tunneled_code (f: function) :=
PTree.map (fun pc b => tunnel_block f b) (fn_code f).
Definition exec_blocks_prop
(c: code) (sp: val)
- (pc: node) (ls1: locset) (m1: mem)
+ (pc: node) (ls1: locset) (m1: mem) (t: trace)
(out: outcome) (ls2: locset) (m2: mem) : Prop :=
forall f,
f.(fn_code) = c ->
exec_blocks tge (tunneled_code f) sp
(branch_target f pc) ls1 m1
- (tunnel_outcome f out) ls2 m2.
+ t (tunnel_outcome f out) ls2 m2.
Definition exec_function_prop
- (f: function) (ls1: locset) (m1: mem)
- (ls2: locset) (m2: mem) : Prop :=
- exec_function tge (tunnel_function f) ls1 m1 ls2 m2.
+ (f: fundef) (ls1: locset) (m1: mem) (t: trace)
+ (ls2: locset) (m2: mem) : Prop :=
+ exec_function tge (tunnel_fundef f) ls1 m1 t ls2 m2.
Scheme exec_instr_ind5 := Minimality for LTL.exec_instr Sort Prop
with exec_instrs_ind5 := Minimality for LTL.exec_instrs Sort Prop
@@ -212,9 +220,9 @@ Scheme exec_instr_ind5 := Minimality for LTL.exec_instr Sort Prop
using the [exec_*_prop] predicates above as induction hypotheses. *)
Lemma tunnel_function_correct:
- forall f ls1 m1 ls2 m2,
- exec_function ge f ls1 m1 ls2 m2 ->
- exec_function_prop f ls1 m1 ls2 m2.
+ forall f ls1 m1 t ls2 m2,
+ exec_function ge f ls1 m1 t ls2 m2 ->
+ exec_function_prop f ls1 m1 t ls2 m2.
Proof.
apply (exec_function_ind5 ge
exec_instr_prop
@@ -239,19 +247,21 @@ Proof.
apply eval_addressing_preserved. exact symbols_preserved.
auto.
(* call *)
- apply exec_Bcall with (tunnel_function f).
+ apply exec_Bcall with (tunnel_fundef f).
generalize H; unfold find_function; destruct ros.
intro. apply functions_translated; auto.
rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
intro. apply function_ptr_translated; auto. congruence.
- rewrite H0; reflexivity.
+ generalize (sig_preserved f). congruence.
apply H2.
+ (* alloc *)
+ eapply exec_Balloc; eauto.
(* instr_refl *)
apply exec_refl.
(* instr_one *)
apply exec_one. apply H0.
(* instr_trans *)
- apply exec_trans with (tunnel_block f b2) rs2 m2; auto.
+ apply exec_trans with t1 (tunnel_block f b2) rs2 m2 t2; auto.
(* goto *)
apply exec_Bgoto. red in H0. simpl in H0. apply H0.
(* cond, true *)
@@ -270,13 +280,13 @@ Proof.
reflexivity. apply H1.
intros [pc' [ATpc BTS]].
assert (b = Bgoto pc'). congruence. subst b.
- generalize (exec_block_Bgoto_inv _ _ _ _ _ _ _ H0).
- intros [A [B C]]. subst out; subst rs'; subst m'.
+ generalize (exec_block_Bgoto_inv _ _ _ _ _ _ _ _ H0).
+ intros [A [B [C D]]]. subst t out rs' m'.
simpl. rewrite BTS. apply exec_blocks_refl.
(* blocks_trans *)
- apply exec_blocks_trans with (branch_target f pc2) rs2 m2.
- exact (H0 f H3). exact (H2 f H3).
- (* function *)
+ apply exec_blocks_trans with t1 (branch_target f pc2) rs2 m2 t2.
+ exact (H0 f H4). exact (H2 f H4). auto.
+ (* internal function *)
econstructor. eexact H.
change (fn_code (tunnel_function f)) with (tunneled_code f).
simpl.
@@ -284,28 +294,30 @@ Proof.
intro BT. rewrite <- BT. exact (H1 f (refl_equal _)).
intros [pc [ATpc BT]].
apply exec_blocks_trans with
- (branch_target f (fn_entrypoint f)) (call_regs rs) m1.
+ E0 (branch_target f (fn_entrypoint f)) (call_regs rs) m1 t.
eapply exec_blocks_one.
unfold tunneled_code. rewrite PTree.gmap. rewrite ATpc.
simpl. reflexivity.
apply exec_Bgoto. rewrite BT. apply exec_refl.
- exact (H1 f (refl_equal _)).
+ exact (H1 f (refl_equal _)). traceEq.
+ (* external function *)
+ econstructor; eauto.
Qed.
End PRESERVATION.
Theorem transf_program_correct:
- forall (p: program) (r: val),
- exec_program p r ->
- exec_program (tunnel_program p) r.
+ forall (p: program) (t: trace) (r: val),
+ exec_program p t r ->
+ exec_program (tunnel_program p) t r.
Proof.
- intros p r [b [f [ls [m [FIND1 [FIND2 [SIG [EX RES]]]]]]]].
- red. exists b; exists (tunnel_function f); exists ls; exists m.
+ intros p t r [b [f [ls [m [FIND1 [FIND2 [SIG [EX RES]]]]]]]].
+ red. exists b; exists (tunnel_fundef f); exists ls; exists m.
split. change (prog_main (tunnel_program p)) with (prog_main p).
rewrite <- FIND1. apply symbols_preserved.
split. apply function_ptr_translated. assumption.
- split. rewrite <- SIG. reflexivity.
+ split. generalize (sig_preserved f). congruence.
split. apply tunnel_function_correct.
unfold tunnel_program. rewrite Genv.init_mem_transf. auto.
- exact RES.
+ rewrite sig_preserved. exact RES.
Qed.
diff --git a/backend/Tunnelingtyping.v b/backend/Tunnelingtyping.v
index 29b74f1..6281afa 100644
--- a/backend/Tunnelingtyping.v
+++ b/backend/Tunnelingtyping.v
@@ -33,12 +33,19 @@ Proof.
intros; discriminate.
Qed.
+Lemma wt_tunnel_fundef:
+ forall f, wt_fundef f -> wt_fundef (tunnel_fundef f).
+Proof.
+ intros. inversion H; simpl. constructor; auto.
+ constructor. apply wt_tunnel_function; auto.
+Qed.
+
Lemma program_typing_preserved:
forall (p: LTL.program),
wt_program p -> wt_program (tunnel_program p).
Proof.
intros; red; intros.
- generalize (transform_program_function tunnel_function p i f H0).
+ generalize (transform_program_function tunnel_fundef p i f H0).
intros [f0 [IN TRANSF]].
- subst f. apply wt_tunnel_function. eauto.
+ subst f. apply wt_tunnel_fundef. eauto.
Qed.
diff --git a/caml/Allocationaux.ml b/caml/Allocationaux.ml
deleted file mode 100644
index c682c3c..0000000
--- a/caml/Allocationaux.ml
+++ /dev/null
@@ -1,39 +0,0 @@
-open Camlcoq
-open Datatypes
-open CList
-open AST
-open Locations
-
-type status = To_move | Being_moved | Moved
-
-let parallel_move_order lsrc ldst =
- let src = array_of_coqlist lsrc
- and dst = array_of_coqlist ldst in
- let n = Array.length src in
- let status = Array.make n To_move in
- let moves = ref Coq_nil in
- let rec move_one i =
- if src.(i) <> dst.(i) then begin
- status.(i) <- Being_moved;
- for j = 0 to n - 1 do
- if src.(j) = dst.(i) then
- match status.(j) with
- To_move ->
- move_one j
- | Being_moved ->
- let tmp =
- match Loc.coq_type src.(j) with
- | Tint -> R IT2
- | Tfloat -> R FT2 in
- moves := Coq_cons (Coq_pair(src.(j), tmp), !moves);
- src.(j) <- tmp
- | Moved ->
- ()
- done;
- moves := Coq_cons(Coq_pair(src.(i), dst.(i)), !moves);
- status.(i) <- Moved
- end in
- for i = 0 to n - 1 do
- if status.(i) = To_move then move_one i
- done;
- CList.rev !moves
diff --git a/caml/Allocationaux.mli b/caml/Allocationaux.mli
deleted file mode 100644
index 0cf3b94..0000000
--- a/caml/Allocationaux.mli
+++ /dev/null
@@ -1,5 +0,0 @@
-open Datatypes
-open List
-open Locations
-
-val parallel_move_order: loc list -> loc list -> (loc, loc) prod list
diff --git a/caml/CMlexer.mll b/caml/CMlexer.mll
index b8d3ae7..49d0dbd 100644
--- a/caml/CMlexer.mll
+++ b/caml/CMlexer.mll
@@ -20,6 +20,7 @@ rule token = parse
| blank + { token lexbuf }
| "/*" { comment lexbuf; token lexbuf }
| "absf" { ABSF }
+ | "alloc" { ALLOC }
| "&" { AMPERSAND }
| "&&" { AMPERSANDAMPERSAND }
| "!" { BANG }
@@ -38,6 +39,7 @@ rule token = parse
| "==f" { EQUALEQUALF }
| "==u" { EQUALEQUALU }
| "exit" { EXIT }
+ | "extern" { EXTERN }
| "float" { FLOAT }
| "float32" { FLOAT32 }
| "float64" { FLOAT64 }
diff --git a/caml/CMparser.mly b/caml/CMparser.mly
index d461a15..5595afe 100644
--- a/caml/CMparser.mly
+++ b/caml/CMparser.mly
@@ -24,6 +24,7 @@ let orbool e1 e2 =
%token ABSF
%token AMPERSAND
%token AMPERSANDAMPERSAND
+%token ALLOC
%token BANG
%token BANGEQUAL
%token BANGEQUALF
@@ -41,6 +42,7 @@ let orbool e1 e2 =
%token EQUALEQUALU
%token EOF
%token EXIT
+%token EXTERN
%token FLOAT
%token FLOAT32
%token FLOAT64
@@ -120,7 +122,7 @@ let orbool e1 e2 =
%left LESSLESS GREATERGREATER GREATERGREATERU
%left PLUS PLUSF MINUS MINUSF
%left STAR SLASH PERCENT STARF SLASHF SLASHU PERCENTU
-%nonassoc BANG TILDE p_uminus ABSF INTOFFLOAT FLOATOFINT FLOATOFINTU INT8S INT8U INT16S INT16U FLOAT32
+%nonassoc BANG TILDE p_uminus ABSF INTOFFLOAT FLOATOFINT FLOATOFINTU INT8S INT8U INT16S INT16U FLOAT32 ALLOC
%left LPAREN
/* Entry point */
@@ -145,7 +147,8 @@ global_declarations:
;
global_declaration:
- VAR STRINGLIT LBRACKET INTLIT RBRACKET { Coq_pair($2, z_of_camlint $4) }
+ VAR STRINGLIT LBRACKET INTLIT RBRACKET
+ { Coq_pair($2, Coq_cons(Init_space (z_of_camlint $4), Coq_nil)) }
;
proc_list:
@@ -163,11 +166,15 @@ proc:
stmt_list
RBRACE
{ Coq_pair($1,
- { fn_sig = $6;
- fn_params = CList.rev $3;
- fn_vars = CList.rev $9;
- fn_stackspace = $8;
- fn_body = $10 }) }
+ Internal { fn_sig = $6;
+ fn_params = CList.rev $3;
+ fn_vars = CList.rev $9;
+ fn_stackspace = $8;
+ fn_body = $10 }) }
+ | EXTERN STRINGLIT COLON signature
+ { Coq_pair($2,
+ External { ef_id = $2;
+ ef_sig = $4 }) }
;
signature:
@@ -250,6 +257,7 @@ expr:
| INT16S expr { Cmconstr.cast16signed $2 }
| INT16U expr { Cmconstr.cast16unsigned $2 }
| FLOAT32 expr { Cmconstr.singleoffloat $2 }
+ | ALLOC expr { Ealloc $2 }
| expr PLUS expr { Cmconstr.add $1 $3 }
| expr MINUS expr { Cmconstr.sub $1 $3 }
| expr STAR expr { Cmconstr.mul $1 $3 }
diff --git a/caml/CMtypecheck.ml b/caml/CMtypecheck.ml
index b6f94cb..4e700d7 100644
--- a/caml/CMtypecheck.ml
+++ b/caml/CMtypecheck.ml
@@ -5,6 +5,7 @@ open Datatypes
open CList
open Camlcoq
open AST
+open Integers
open Op
open Cminor
@@ -95,6 +96,8 @@ let type_operation = function
| Oundef -> [], newvar()
| Ocast8signed -> [tint], tint
| Ocast16signed -> [tint], tint
+ | Ocast8unsigned -> [tint], tint
+ | Ocast16unsigned -> [tint], tint
| Oadd -> [tint;tint], tint
| Oaddimm _ -> [tint], tint
| Osub -> [tint;tint], tint
@@ -141,6 +144,8 @@ let name_of_operation = function
| Oundef -> "undef"
| Ocast8signed -> "cast8signed"
| Ocast16signed -> "cast16signed"
+ | Ocast8unsigned -> "cast8unsigned"
+ | Ocast16unsigned -> "cast16unsigned"
| Oadd -> "add"
| Oaddimm n -> sprintf "addimm %ld" (camlint_of_coqint n)
| Osub -> "sub"
@@ -282,6 +287,14 @@ let rec type_expr env lenv e =
te2
| Eletvar n ->
type_letvar lenv n
+ | Ealloc e ->
+ let te = type_expr env lenv e in
+ begin try
+ unify tint te
+ with Error s ->
+ raise (Error (sprintf "In alloc:\n%s" s))
+ end;
+ tint
and type_exprlist env lenv el =
match el with
@@ -349,7 +362,7 @@ let rec env_of_vars idl =
| Coq_nil -> []
| Coq_cons(id1, idt) -> (id1, newvar()) :: env_of_vars idt
-let type_function (Coq_pair (id, f)) =
+let type_function id f =
try
type_stmt
(env_of_vars f.fn_vars @ env_of_vars f.fn_params)
@@ -357,5 +370,10 @@ let type_function (Coq_pair (id, f)) =
with Error s ->
raise (Error (sprintf "In function %s:\n%s" (extern_atom id) s))
+let type_fundef (Coq_pair (id, fd)) =
+ match fd with
+ | Internal f -> type_function id f
+ | External ef -> ()
+
let type_program p =
- coqlist_iter type_function p.prog_funct; p
+ coqlist_iter type_fundef p.prog_funct; p
diff --git a/caml/Camlcoq.ml b/caml/Camlcoq.ml
index b0bb4ff..fc5d2d8 100644
--- a/caml/Camlcoq.ml
+++ b/caml/Camlcoq.ml
@@ -7,6 +7,11 @@ open BinInt
(* Integers *)
+let rec camlint_of_nat n =
+ match n with
+ | O -> 0l
+ | S n -> Int32.add (camlint_of_nat n) 1l
+
let rec camlint_of_positive = function
| Coq_xI p -> Int32.add (Int32.shift_left (camlint_of_positive p) 1) 1l
| Coq_xO p -> Int32.shift_left (camlint_of_positive p) 1
diff --git a/caml/Coloringaux.ml b/caml/Coloringaux.ml
index f4f4bcd..a7c8db5 100644
--- a/caml/Coloringaux.ml
+++ b/caml/Coloringaux.ml
@@ -266,15 +266,13 @@ let class_of_type = function Tint -> 0 | Tfloat -> 1
let num_register_classes = 2
let caller_save_registers = [|
- [| R3; R4; R5; R6; R7; R8; R9; R10 |];
- [| F1; F2; F3; F4; F5; F6; F7; F8; F9; F10 |]
+ array_of_coqlist Conventions.int_caller_save_regs;
+ array_of_coqlist Conventions.float_caller_save_regs
|]
let callee_save_registers = [|
- [| R13; R14; R15; R16; R17; R18; R19; R20; R21; R22;
- R23; R24; R25; R26; R27; R28; R29; R30; R31 |];
- [| F14; F15; F16; F17; F18; F19; F20; F21; F22;
- F23; F24; F25; F26; F27; F28; F29; F30; F31 |]
+ array_of_coqlist Conventions.int_callee_save_regs;
+ array_of_coqlist Conventions.float_callee_save_regs
|]
let num_available_registers =
diff --git a/caml/Floataux.ml b/caml/Floataux.ml
index f43efa2..f61bd5b 100644
--- a/caml/Floataux.ml
+++ b/caml/Floataux.ml
@@ -1,4 +1,5 @@
open Camlcoq
+open Integers
let singleoffloat f =
Int32.float_of_bits (Int32.bits_of_float f)
@@ -15,9 +16,9 @@ let floatofintu i =
let cmp c (x: float) (y: float) =
match c with
- | AST.Ceq -> x = y
- | AST.Cne -> x <> y
- | AST.Clt -> x < y
- | AST.Cle -> x <= y
- | AST.Cgt -> x > y
- | AST.Cge -> x >= y
+ | Ceq -> x = y
+ | Cne -> x <> y
+ | Clt -> x < y
+ | Cle -> x <= y
+ | Cgt -> x > y
+ | Cge -> x >= y
diff --git a/caml/PrintPPC.ml b/caml/PrintPPC.ml
index 830de0d..eaa383b 100644
--- a/caml/PrintPPC.ml
+++ b/caml/PrintPPC.ml
@@ -26,10 +26,23 @@ let label_for_label lbl =
Hashtbl.add current_function_labels lbl lbl';
lbl'
+(* Record identifiers of external functions *)
+
+module IdentSet = Set.Make(struct type t = ident let compare = compare end)
+
+let extfuns = ref IdentSet.empty
+
+let record_extfun (Coq_pair(name, defn)) =
+ match defn with
+ | Internal _ -> ()
+ | External _ -> extfuns := IdentSet.add name !extfuns
+
(* Basic printing functions *)
let print_symb oc symb =
- fprintf oc "_%s" (extern_atom symb)
+ if IdentSet.mem symb !extfuns
+ then fprintf oc "L%s$stub" (extern_atom symb)
+ else fprintf oc "_%s" (extern_atom symb)
let print_label oc lbl =
fprintf oc "L%d" (label_for_label lbl)
@@ -99,6 +112,8 @@ let print_instruction oc labels = function
fprintf oc " addis %a, %a, %a\n" ireg r1 ireg_or_zero r2 print_constant c
| Paddze(r1, r2) ->
fprintf oc " addze %a, %a\n" ireg r1 ireg r2
+ | Pallocblock ->
+ fprintf oc " bl _compcert_alloc\n"
| Pallocframe(lo, hi) ->
let lo = camlint_of_coqint lo
and hi = camlint_of_coqint hi in
@@ -317,7 +332,7 @@ let rec labels_of_code = function
Labelset.add lbl (labels_of_code c)
| Coq_cons(_, c) -> labels_of_code c
-let print_function oc (Coq_pair(name, code)) =
+let print_function oc name code =
Hashtbl.clear current_function_labels;
fprintf oc " .text\n";
fprintf oc " .align 2\n";
@@ -325,10 +340,52 @@ let print_function oc (Coq_pair(name, code)) =
fprintf oc "%a:\n" print_symb name;
coqlist_iter (print_instruction oc (labels_of_code code)) code
-let print_var oc (Coq_pair(name, size)) =
- fprintf oc " .comm %a, %ld\n" print_symb name (camlint_of_z size)
+let print_external_function oc name =
+ let name = extern_atom name in
+ fprintf oc " .text\n";
+ fprintf oc " .align 2\n";
+ fprintf oc "L%s$stub:\n" name;
+ fprintf oc " addis r11, 0, ha16(L%s$ptr)\n" name;
+ fprintf oc " lwz r11, lo16(L%s$ptr)(r11)\n" name;
+ fprintf oc " mtctr r11\n";
+ fprintf oc " bctr\n";
+ fprintf oc " .non_lazy_symbol_pointer\n";
+ fprintf oc "L%s$ptr:\n" name;
+ fprintf oc " .indirect_symbol _%s\n" name;
+ fprintf oc " .long 0\n"
+
+let print_fundef oc (Coq_pair(name, defn)) =
+ match defn with
+ | Internal code -> print_function oc name code
+ | External ef -> print_external_function oc name
+
+let print_init_data oc = function
+ | Init_int8 n ->
+ fprintf oc " .byte %ld\n" (camlint_of_coqint n)
+ | Init_int16 n ->
+ fprintf oc " .short %ld\n" (camlint_of_coqint n)
+ | Init_int32 n ->
+ fprintf oc " .long %ld\n" (camlint_of_coqint n)
+ | Init_float32 n ->
+ fprintf oc " .long %ld # %g \n" (Int32.bits_of_float n) n
+ | Init_float64 n ->
+ fprintf oc " .quad %Ld # %g \n" (Int64.bits_of_float n) n
+ | Init_space n ->
+ let n = camlint_of_z n in
+ if n > 0l then fprintf oc " .space %ld\n" n
+
+let print_var oc (Coq_pair(name, init_data)) =
+ match init_data with
+ | Coq_nil -> ()
+ | _ ->
+ fprintf oc " .data\n";
+ fprintf oc " .globl %a\n" print_symb name;
+ fprintf oc "%a:" print_symb name;
+ coqlist_iter (print_init_data oc) init_data
let print_program oc p =
+ extfuns := IdentSet.empty;
+ coqlist_iter record_extfun p.prog_funct;
coqlist_iter (print_var oc) p.prog_vars;
- coqlist_iter (print_function oc) p.prog_funct
+ coqlist_iter (print_fundef oc) p.prog_funct
diff --git a/caml/RTLtypingaux.ml b/caml/RTLtypingaux.ml
new file mode 100644
index 0000000..b76a0bb
--- /dev/null
+++ b/caml/RTLtypingaux.ml
@@ -0,0 +1,122 @@
+(* Type inference for RTL *)
+
+open Datatypes
+open CList
+open Camlcoq
+open Maps
+open AST
+open Op
+open Registers
+open RTL
+
+exception Type_error of string
+
+let env = ref (PTree.empty : typ PTree.t)
+
+let set_type r ty =
+ match PTree.get r !env with
+ | None -> env := PTree.set r ty !env
+ | Some ty' -> if ty <> ty' then raise (Type_error "type mismatch")
+
+let rec set_types rl tyl =
+ match rl, tyl with
+ | Coq_nil, Coq_nil -> ()
+ | Coq_cons(r1, rs), Coq_cons(ty1, tys) -> set_type r1 ty1; set_types rs tys
+ | _, _ -> raise (Type_error "arity mismatch")
+
+(* First pass: process constraints of the form typeof(r) = ty *)
+
+let type_instr retty (Coq_pair(pc, i)) =
+ match i with
+ | Inop(_) ->
+ ()
+ | Iop(Omove, _, _, _) ->
+ ()
+ | Iop(Oundef, Coq_nil, res, _) ->
+ ()
+ | Iop(Oundef, _, _, _) ->
+ raise (Type_error "wrong Oundef")
+ | Iop(op, args, res, _) ->
+ let (Coq_pair(targs, tres)) = type_of_operation op in
+ set_types args targs; set_type res tres
+ | Iload(chunk, addr, args, dst, _) ->
+ set_types args (type_of_addressing addr);
+ set_type dst (type_of_chunk chunk)
+ | Istore(chunk, addr, args, src, _) ->
+ set_types args (type_of_addressing addr);
+ set_type src (type_of_chunk chunk)
+ | Icall(sg, ros, args, res, _) ->
+ begin match ros with
+ | Coq_inl r -> set_type r Tint
+ | Coq_inr _ -> ()
+ end;
+ set_types args sg.sig_args;
+ set_type res (match sg.sig_res with None -> Tint | Some ty -> ty)
+ | Ialloc(arg, res, _) ->
+ set_type arg Tint; set_type res Tint
+ | Icond(cond, args, _, _) ->
+ set_types args (type_of_condition cond)
+ | Ireturn(optres) ->
+ begin match optres, retty with
+ | None, None -> ()
+ | Some r, Some ty -> set_type r ty
+ | _, _ -> raise (Type_error "type mismatch in Ireturn")
+ end
+
+let type_pass1 retty instrs =
+ coqlist_iter (type_instr retty) instrs
+
+(* Second pass: extract move constraints typeof(r1) = typeof(r2)
+ and solve them iteratively *)
+
+let rec extract_moves = function
+ | Coq_nil -> []
+ | Coq_cons(Coq_pair(pc, i), rem) ->
+ match i with
+ | Iop(Omove, Coq_cons(r1, Coq_nil), r2, _) ->
+ (r1, r2) :: extract_moves rem
+ | Iop(Omove, _, _, _) ->
+ raise (Type_error "wrong Omove")
+ | _ ->
+ extract_moves rem
+
+let changed = ref false
+
+let rec solve_moves = function
+ | [] -> []
+ | (r1, r2) :: rem ->
+ match (PTree.get r1 !env, PTree.get r2 !env) with
+ | Some ty1, Some ty2 ->
+ if ty1 = ty2
+ then (changed := true; solve_moves rem)
+ else raise (Type_error "type mismatch in Omove")
+ | Some ty1, None ->
+ env := PTree.set r2 ty1 !env; changed := true; solve_moves rem
+ | None, Some ty2 ->
+ env := PTree.set r1 ty2 !env; changed := true; solve_moves rem
+ | None, None ->
+ (r1, r2) :: solve_moves rem
+
+let rec iter_solve_moves mvs =
+ changed := false;
+ let mvs' = solve_moves mvs in
+ if !changed then iter_solve_moves mvs'
+
+let type_pass2 instrs =
+ iter_solve_moves (extract_moves instrs)
+
+let typeof e r =
+ match PTree.get r e with Some ty -> ty | None -> Tint
+
+let infer_type_environment f instrs =
+ try
+ env := PTree.empty;
+ set_types f.fn_params f.fn_sig.sig_args;
+ type_pass1 f.fn_sig.sig_res instrs;
+ type_pass2 instrs;
+ let e = !env in
+ env := PTree.empty;
+ Some(typeof e)
+ with Type_error msg ->
+ Printf.eprintf "Error during RTL type inference: %s\n" msg;
+ None
diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v
new file mode 100644
index 0000000..b73e83c
--- /dev/null
+++ b/cfrontend/Csem.v
@@ -0,0 +1,752 @@
+(** * Dynamic semantics for the Clight language *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import AST.
+Require Import Mem.
+Require Import Events.
+Require Import Globalenvs.
+Require Import Csyntax.
+
+(** ** Semantics of type-dependent operations *)
+
+Inductive is_false: val -> type -> Prop :=
+ | is_false_int: forall sz sg,
+ is_false (Vint Int.zero) (Tint sz sg)
+ | is_false_pointer: forall t,
+ is_false (Vint Int.zero) (Tpointer t)
+ | is_false_float: forall sz,
+ is_false (Vfloat Float.zero) (Tfloat sz).
+
+Inductive is_true: val -> type -> Prop :=
+ | is_true_int_int: forall n sz sg,
+ n <> Int.zero ->
+ is_true (Vint n) (Tint sz sg)
+ | is_true_pointer_int: forall b ofs sz sg,
+ is_true (Vptr b ofs) (Tint sz sg)
+ | is_true_int_pointer: forall n t,
+ n <> Int.zero ->
+ is_true (Vint n) (Tpointer t)
+ | is_true_pointer_pointer: forall b ofs t,
+ is_true (Vptr b ofs) (Tpointer t)
+ | is_true_float: forall f sz,
+ f <> Float.zero ->
+ is_true (Vfloat f) (Tfloat sz).
+
+Inductive bool_of_val : val -> type -> val -> Prop :=
+ | bool_of_val_true: forall v ty,
+ is_true v ty ->
+ bool_of_val v ty Vtrue
+ | bool_of_val_false: forall v ty,
+ is_false v ty ->
+ bool_of_val v ty Vfalse.
+
+Function sem_neg (v: val) (ty: type) : option val :=
+ match ty with
+ | Tint _ _ =>
+ match v with
+ | Vint n => Some (Vint (Int.neg n))
+ | _ => None
+ end
+ | Tfloat _ =>
+ match v with
+ | Vfloat f => Some (Vfloat (Float.neg f))
+ | _ => None
+ end
+ | _ => None
+ end.
+
+Function sem_notint (v: val) : option val :=
+ match v with
+ | Vint n => Some (Vint (Int.xor n Int.mone))
+ | _ => None
+ end.
+
+Function sem_notbool (v: val) (ty: type) : option val :=
+ match ty with
+ | Tint _ _ =>
+ match v with
+ | Vint n => Some (Val.of_bool (Int.eq n Int.zero))
+ | Vptr _ _ => Some Vfalse
+ | _ => None
+ end
+ | Tpointer _ =>
+ match v with
+ | Vint n => Some (Val.of_bool (Int.eq n Int.zero))
+ | Vptr _ _ => Some Vfalse
+ | _ => None
+ end
+ | Tfloat _ =>
+ match v with
+ | Vfloat f => Some (Val.of_bool (Float.cmp Ceq f Float.zero))
+ | _ => None
+ end
+ | _ => None
+ end.
+
+Function sem_add (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
+ match classify_add t1 t2 with
+ | add_case_ii =>
+ match v1, v2 with
+ | Vint n1, Vint n2 => Some (Vint (Int.add n1 n2))
+ | _, _ => None
+ end
+ | add_case_ff =>
+ match v1, v2 with
+ | Vfloat n1, Vfloat n2 => Some (Vfloat (Float.add n1 n2))
+ | _, _ => None
+ end
+ | add_case_pi ty=>
+ match v1,v2 with
+ | Vptr b1 ofs1, Vint n2 =>
+ Some (Vptr b1 (Int.add ofs1 (Int.mul (Int.repr (sizeof ty)) n2)))
+ | _, _ => None
+ end
+ | add_default => None
+end.
+
+Function sem_sub (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
+ match classify_sub t1 t2 with
+ | sub_case_ii => (* integer subtraction *)
+ match v1,v2 with
+ | Vint n1, Vint n2 => Some (Vint (Int.sub n1 n2))
+ | _, _ => None
+ end
+ | sub_case_ff => (* float subtraction *)
+ match v1,v2 with
+ | Vfloat f1, Vfloat f2 => Some (Vfloat(Float.sub f1 f2))
+ | _, _ => None
+ end
+ | sub_case_pi ty => (*array| pointer - offset *)
+ match v1,v2 with
+ | Vptr b1 ofs1, Vint n2 =>
+ Some (Vptr b1 (Int.sub ofs1 (Int.mul (Int.repr (sizeof ty)) n2)))
+ | _, _ => None
+ end
+ | sub_case_pp ty => (* array|pointer - array|pointer *)
+ match v1,v2 with
+ | Vptr b1 ofs1, Vptr b2 ofs2 =>
+ if zeq b1 b2 then
+ if Int.eq (Int.repr (sizeof ty)) Int.zero then None
+ else Some (Vint (Int.divu (Int.sub ofs1 ofs2) (Int.repr (sizeof ty))))
+ else None
+ | _, _ => None
+ end
+ | sub_default => None
+ end.
+
+Function sem_mul (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
+ match classify_mul t1 t2 with
+ | mul_case_ii =>
+ match v1,v2 with
+ | Vint n1, Vint n2 => Some (Vint (Int.mul n1 n2))
+ | _, _ => None
+ end
+ | mul_case_ff =>
+ match v1,v2 with
+ | Vfloat f1, Vfloat f2 => Some (Vfloat (Float.mul f1 f2))
+ | _, _ => None
+ end
+ | mul_default =>
+ None
+end.
+
+Function sem_div (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
+ match classify_div t1 t2 with
+ | div_case_I32unsi =>
+ match v1,v2 with
+ | Vint n1, Vint n2 =>
+ if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2))
+ | _,_ => None
+ end
+ | div_case_ii =>
+ match v1,v2 with
+ | Vint n1, Vint n2 =>
+ if Int.eq n2 Int.zero then None else Some (Vint(Int.divs n1 n2))
+ | _,_ => None
+ end
+ | div_case_ff =>
+ match v1,v2 with
+ | Vfloat f1, Vfloat f2 => Some (Vfloat(Float.div f1 f2))
+ | _, _ => None
+ end
+ | div_default =>
+ None
+end.
+
+Function sem_mod (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
+ match classify_mod t1 t2 with
+ | mod_case_I32unsi =>
+ match v1, v2 with
+ | Vint n1, Vint n2 =>
+ if Int.eq n2 Int.zero then None else Some (Vint (Int.modu n1 n2))
+ | _, _ => None
+ end
+ | mod_case_ii =>
+ match v1,v2 with
+ | Vint n1, Vint n2 =>
+ if Int.eq n2 Int.zero then None else Some (Vint (Int.mods n1 n2))
+ | _, _ => None
+ end
+ | mod_default =>
+ None
+ end.
+
+Function sem_and (v1 v2: val) : option val :=
+ match v1, v2 with
+ | Vint n1, Vint n2 => Some (Vint(Int.and n1 n2))
+ | _, _ => None
+ end .
+
+Function sem_or (v1 v2: val) : option val :=
+ match v1, v2 with
+ | Vint n1, Vint n2 => Some (Vint(Int.or n1 n2))
+ | _, _ => None
+ end.
+
+Function sem_xor (v1 v2: val): option val :=
+ match v1, v2 with
+ | Vint n1, Vint n2 => Some (Vint(Int.xor n1 n2))
+ | _, _ => None
+ end.
+
+Function sem_shl (v1 v2: val): option val :=
+ match v1, v2 with
+ | Vint n1, Vint n2 =>
+ if Int.ltu n2 (Int.repr 32) then Some (Vint(Int.shl n1 n2)) else None
+ | _, _ => None
+ end.
+
+Function sem_shr (v1: val) (t1: type) (v2: val) (t2: type): option val :=
+ match classify_shr t1 t2 with
+ | shr_case_I32unsi =>
+ match v1,v2 with
+ | Vint n1, Vint n2 =>
+ if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shru n1 n2)) else None
+ | _,_ => None
+ end
+ | shr_case_ii =>
+ match v1,v2 with
+ | Vint n1, Vint n2 =>
+ if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shr n1 n2)) else None
+ | _, _ => None
+ end
+ | shr_default=>
+ None
+ end.
+
+Function sem_cmp_mismatch (c: comparison): option val :=
+ match c with
+ | Ceq => Some Vfalse
+ | Cne => Some Vtrue
+ | _ => None
+ end.
+
+Function sem_cmp (c:comparison)
+ (v1: val) (t1: type) (v2: val) (t2: type)
+ (m: mem): option val :=
+ match classify_cmp t1 t2 with
+ | cmp_case_I32unsi =>
+ match v1,v2 with
+ | Vint n1, Vint n2 =>Some (Val.of_bool (Int.cmpu c n1 n2))
+ | _, _ => None
+ end
+ | cmp_case_ii =>
+ match v1,v2 with
+ | Vint n1, Vint n2 =>Some (Val.of_bool (Int.cmp c n1 n2))
+ | _, _ => None
+ end
+ | cmp_case_ff =>
+ match v1,v2 with
+ | Vfloat f1, Vfloat f2 =>Some (Val.of_bool (Float.cmp c f1 f2))
+ | _, _ => None
+ end
+ | cmp_case_pi =>
+ match v1,v2 with
+ | Vptr b ofs, Vint n2 =>
+ if Int.eq n2 Int.zero then sem_cmp_mismatch c else None
+ | _, _ => None
+ end
+ | cmp_case_pp =>
+ match v1,v2 with
+ | Vptr b1 ofs1, Vptr b2 ofs2 =>
+ if valid_pointer m b1 (Int.signed ofs1) && valid_pointer m b2 (Int.signed ofs2) then
+ if zeq b1 b2
+ then Some (Val.of_bool (Int.cmp c ofs1 ofs2))
+ else None
+ else None
+ | _, _ => None
+ end
+ | cmp_default => None
+ end.
+
+Definition sem_unary_operation
+ (op: unary_operation) (v: val) (ty: type): option val :=
+ match op with
+ | Onotbool => sem_notbool v ty
+ | Onotint => sem_notint v
+ | Oneg => sem_neg v ty
+ end.
+
+Definition sem_binary_operation
+ (op: binary_operation)
+ (v1: val) (t1: type) (v2: val) (t2:type)
+ (m: mem): option val :=
+ match op with
+ | Oadd => sem_add v1 t1 v2 t2
+ | Osub => sem_sub v1 t1 v2 t2
+ | Omul => sem_mul v1 t1 v2 t2
+ | Omod => sem_mod v1 t1 v2 t2
+ | Odiv => sem_div v1 t1 v2 t2
+ | Oand => sem_and v1 v2
+ | Oor => sem_or v1 v2
+ | Oxor => sem_xor v1 v2
+ | Oshl => sem_shl v1 v2
+ | Oshr => sem_shr v1 t1 v2 t2
+ | Oeq => sem_cmp Ceq v1 t1 v2 t2 m
+ | One => sem_cmp Cne v1 t1 v2 t2 m
+ | Olt => sem_cmp Clt v1 t1 v2 t2 m
+ | Ogt => sem_cmp Cgt v1 t1 v2 t2 m
+ | Ole => sem_cmp Cle v1 t1 v2 t2 m
+ | Oge => sem_cmp Cge v1 t1 v2 t2 m
+ end.
+
+Definition cast_int_int (sz: intsize) (sg: signedness) (i: int) : int :=
+ match sz, sg with
+ | I8, Signed => Int.cast8signed i
+ | I8, Unsigned => Int.cast8unsigned i
+ | I16, Signed => Int.cast16signed i
+ | I16, Unsigned => Int.cast16unsigned i
+ | I32 , _ => i
+ end.
+
+Definition cast_int_float (si : signedness) (i: int) : float :=
+ match si with
+ | Signed => Float.floatofint i
+ | Unsigned => Float.floatofintu i
+ end.
+
+Definition cast_float_float (sz: floatsize) (f: float) : float :=
+ match sz with
+ | F32 => Float.singleoffloat f
+ | F64 => f
+ end.
+
+Inductive cast : val -> type -> type -> val -> Prop :=
+ | cast_ii: forall i sz2 sz1 si1 si2,
+ cast (Vint i) (Tint sz1 si1) (Tint sz2 si2)
+ (Vint (cast_int_int sz2 si2 i))
+ | cast_fi: forall f sz1 sz2 si2,
+ cast (Vfloat f) (Tfloat sz1) (Tint sz2 si2)
+ (Vint (cast_int_int sz2 si2 (Float.intoffloat f)))
+ | cast_if: forall i sz1 sz2 si1,
+ cast (Vint i) (Tint sz1 si1) (Tfloat sz2)
+ (Vfloat (cast_float_float sz2 (cast_int_float si1 i)))
+ | cast_ff: forall f sz1 sz2,
+ cast (Vfloat f) (Tfloat sz1) (Tfloat sz2)
+ (Vfloat (cast_float_float sz2 f))
+ | cast_ip_p: forall b ofs t1 si2,
+ cast (Vptr b ofs) (Tint I32 si2) (Tpointer t1) (Vptr b ofs)
+ | cast_pi_p: forall b ofs t1 si2,
+ cast (Vptr b ofs) (Tpointer t1) (Tint I32 si2) (Vptr b ofs)
+ | cast_pp_p: forall b ofs t1 t2,
+ cast (Vptr b ofs) (Tpointer t1) (Tpointer t2) (Vptr b ofs)
+ | cast_ip_i: forall n t1 si2,
+ cast (Vint n) (Tint I32 si2) (Tpointer t1) (Vint n)
+ | cast_pi_i: forall n t1 si2,
+ cast (Vint n) (Tpointer t1) (Tint I32 si2) (Vint n)
+ | cast_pp_i: forall n t1 t2,
+ cast (Vint n) (Tpointer t1) (Tpointer t2) (Vint n).
+
+(** ** Operational semantics *)
+
+(** Global environment *)
+
+Definition genv := Genv.t fundef.
+
+Definition globalenv (p: program) : genv :=
+ Genv.globalenv (program_of_program p).
+
+Definition init_mem (p: program) : mem :=
+ Genv.init_mem (program_of_program p).
+
+(** Local environment *)
+
+Definition env := PTree.t block. (* map variable -> location *)
+
+Definition empty_env: env := (PTree.empty block).
+
+(** Outcomes for statements *)
+
+Inductive outcome: Set :=
+ | Out_break: outcome
+ | Out_continue: outcome
+ | Out_normal: outcome
+ | Out_return: option val -> outcome.
+
+Inductive out_normal_or_continue : outcome -> Prop :=
+ | Out_normal_or_continue_N: out_normal_or_continue Out_normal
+ | Out_normal_or_continue_C: out_normal_or_continue Out_continue.
+
+Inductive out_break_or_return : outcome -> outcome -> Prop :=
+ | Out_break_or_return_B: out_break_or_return Out_break Out_normal
+ | Out_break_or_return_R: forall ov,
+ out_break_or_return (Out_return ov) (Out_return ov).
+
+Definition outcome_switch (out: outcome) : outcome :=
+ match out with
+ | Out_break => Out_normal
+ | o => o
+ end.
+
+Definition outcome_result_value (out: outcome) (t: type) (v: val) : Prop :=
+ match out, t with
+ | Out_normal, Tvoid => v = Vundef
+ | Out_return None, Tvoid => v = Vundef
+ | Out_return (Some v'), ty => ty <> Tvoid /\ v'=v
+ | _, _ => False
+ end.
+
+(** Selection of the appropriate case of a [switch] *)
+
+Fixpoint select_switch (n: int) (sl: labeled_statements)
+ {struct sl}: labeled_statements :=
+ match sl with
+ | LSdefault _ => sl
+ | LScase c s sl' => if Int.eq c n then sl else select_switch n sl'
+ end.
+
+(** Loads and stores by type *)
+
+Definition load_value_of_type (ty: type) (m: mem) (b: block) (ofs: int) : option val :=
+ match access_mode ty with
+ | By_value chunk => Mem.loadv chunk m (Vptr b ofs)
+ | By_reference => Some (Vptr b ofs)
+ | By_nothing => None
+ end.
+
+Definition store_value_of_type (ty_dest: type) (m: mem) (loc: block) (ofs: int) (v: val) : option mem :=
+ match access_mode ty_dest with
+ | By_value chunk => Mem.storev chunk m (Vptr loc ofs) v
+ | By_reference => None
+ | By_nothing => None
+ end.
+
+(** Allocation and initialization of function-local variables *)
+
+Inductive alloc_variables: env -> mem ->
+ list (ident * type) ->
+ env -> mem -> list block -> Prop :=
+ | alloc_variables_nil:
+ forall e m,
+ alloc_variables e m nil e m nil
+ | alloc_variables_cons:
+ forall e m id ty vars m1 b1 m2 e2 lb,
+ Mem.alloc m 0 (sizeof ty) = (m1, b1) ->
+ alloc_variables (PTree.set id b1 e) m1 vars e2 m2 lb ->
+ alloc_variables e m ((id, ty) :: vars) e2 m2 (b1 :: lb).
+
+Inductive bind_parameters: env ->
+ mem -> list (ident * type) -> list val ->
+ mem -> Prop :=
+ | bind_parameters_nil:
+ forall e m,
+ bind_parameters e m nil nil m
+ | bind_parameters_cons:
+ forall e m id ty params v1 vl b m1 m2,
+ PTree.get id e = Some b ->
+ store_value_of_type ty m b Int.zero v1 = Some m1 ->
+ bind_parameters e m1 params vl m2 ->
+ bind_parameters e m ((id, ty) :: params) (v1 :: vl) m2.
+
+Section RELSEM.
+
+Variable ge: genv.
+
+(** Evaluation of an expression in r-value position *)
+
+Inductive eval_expr: env -> mem -> expr -> trace -> mem -> val -> Prop :=
+ | eval_Econst_int: forall e m i ty,
+ eval_expr e m (Expr (Econst_int i) ty)
+ E0 m (Vint i)
+ | eval_Econst_float: forall e m f ty,
+ eval_expr e m (Expr (Econst_float f) ty)
+ E0 m (Vfloat f)
+ | eval_Elvalue: forall e m a ty t m1 loc ofs v,
+ eval_lvalue e m (Expr a ty) t m1 loc ofs ->
+ load_value_of_type ty m1 loc ofs = Some v ->
+ eval_expr e m (Expr a ty)
+ t m1 v
+ | eval_Eaddrof: forall e m a t m1 loc ofs ty,
+ eval_lvalue e m a t m1 loc ofs ->
+ eval_expr e m (Expr (Eaddrof a) ty)
+ t m1 (Vptr loc ofs)
+ | eval_Esizeof: forall e m ty' ty,
+ eval_expr e m (Expr (Esizeof ty') ty)
+ E0 m (Vint (Int.repr (sizeof ty')))
+ | eval_Eunop: forall e m op a ty t m1 v1 v,
+ eval_expr e m a t m1 v1 ->
+ sem_unary_operation op v1 (typeof a) = Some v ->
+ eval_expr e m (Expr (Eunop op a) ty)
+ t m1 v
+ | eval_Ebinop: forall e m op a1 a2 ty t1 m1 v1 t2 m2 v2 v,
+ eval_expr e m a1 t1 m1 v1 ->
+ eval_expr e m1 a2 t2 m2 v2 ->
+ sem_binary_operation op v1 (typeof a1) v2 (typeof a2) m2 = Some v ->
+ eval_expr e m (Expr (Ebinop op a1 a2) ty)
+ (t1 ** t2) m2 v
+ | eval_Eorbool_1: forall e m a1 a2 t m1 v1 ty,
+ eval_expr e m a1 t m1 v1 ->
+ is_true v1 (typeof a1) ->
+ eval_expr e m (Expr (Eorbool a1 a2) ty)
+ t m1 Vtrue
+ | eval_Eorbool_2: forall e m a1 a2 ty t1 m1 v1 t2 m2 v2 v,
+ eval_expr e m a1 t1 m1 v1 ->
+ is_false v1 (typeof a1) ->
+ eval_expr e m1 a2 t2 m2 v2 ->
+ bool_of_val v2 (typeof a2) v ->
+ eval_expr e m (Expr (Eorbool a1 a2) ty)
+ (t1 ** t2) m2 v
+ | eval_Eandbool_1: forall e m a1 a2 t m1 v1 ty,
+ eval_expr e m a1 t m1 v1 ->
+ is_false v1 (typeof a1) ->
+ eval_expr e m (Expr (Eandbool a1 a2) ty)
+ t m1 Vfalse
+ | eval_Eandbool_2: forall e m a1 a2 ty t1 m1 v1 t2 m2 v2 v,
+ eval_expr e m a1 t1 m1 v1 ->
+ is_true v1 (typeof a1) ->
+ eval_expr e m1 a2 t2 m2 v2 ->
+ bool_of_val v2 (typeof a2) v ->
+ eval_expr e m (Expr (Eandbool a1 a2) ty)
+ (t1 ** t2) m2 v
+ | eval_Ecast: forall e m a ty t m1 v1 v,
+ eval_expr e m a t m1 v1 ->
+ cast v1 (typeof a) ty v ->
+ eval_expr e m (Expr (Ecast ty a) ty)
+ t m1 v
+ | eval_Ecall: forall e m a bl ty m3 vres t1 m1 vf t2 m2 vargs f t3,
+ eval_expr e m a t1 m1 vf ->
+ eval_exprlist e m1 bl t2 m2 vargs ->
+ Genv.find_funct ge vf = Some f ->
+ type_of_fundef f = typeof a ->
+ eval_funcall m2 f vargs t3 m3 vres ->
+ eval_expr e m (Expr (Ecall a bl) ty)
+ (t1 ** t2 ** t3) m3 vres
+
+(** Evaluation of an expression in l-value position *)
+
+with eval_lvalue: env -> mem -> expr -> trace -> mem -> block -> int -> Prop :=
+ | eval_Evar_local: forall e m id l ty,
+ e!id = Some l ->
+ eval_lvalue e m (Expr (Evar id) ty)
+ E0 m l Int.zero
+ | eval_Evar_global: forall e m id l ty,
+ e!id = None ->
+ Genv.find_symbol ge id = Some l ->
+ eval_lvalue e m (Expr (Evar id) ty)
+ E0 m l Int.zero
+ | eval_Ederef: forall e m m1 a t ofs ty l,
+ eval_expr e m a t m1 (Vptr l ofs) ->
+ eval_lvalue e m (Expr (Ederef a) ty)
+ t m1 l ofs
+ | eval_Eindex: forall e m a1 t1 m1 v1 a2 t2 m2 v2 l ofs ty,
+ eval_expr e m a1 t1 m1 v1 ->
+ eval_expr e m1 a2 t2 m2 v2 ->
+ sem_add v1 (typeof a1) v2 (typeof a2) = Some (Vptr l ofs) ->
+ eval_lvalue e m (Expr (Eindex a1 a2) ty)
+ (t1 ** t2) m2 l ofs
+ | eval_Efield_struct: forall e m a t m1 l ofs fList i ty delta,
+ eval_lvalue e m a t m1 l ofs ->
+ typeof a = Tstruct fList ->
+ field_offset i fList = Some delta ->
+ eval_lvalue e m (Expr (Efield a i) ty)
+ t m1 l (Int.add ofs (Int.repr delta))
+ | eval_Efield_union: forall e m a t m1 l ofs fList i ty,
+ eval_lvalue e m a t m1 l ofs ->
+ typeof a = Tunion fList ->
+ eval_lvalue e m (Expr (Efield a i) ty)
+ t m1 l ofs
+
+(** Evaluation of a list of expressions *)
+
+with eval_exprlist: env -> mem -> exprlist -> trace -> mem -> list val -> Prop :=
+ | eval_Enil: forall e m,
+ eval_exprlist e m Enil E0 m nil
+ | eval_Econs: forall e m a bl t1 m1 v t2 m2 vl,
+ eval_expr e m a t1 m1 v ->
+ eval_exprlist e m1 bl t2 m2 vl ->
+ eval_exprlist e m (Econs a bl)
+ (t1 ** t2) m2 (v :: vl)
+
+(** Execution of a statement *)
+
+with exec_stmt: env -> mem -> statement -> trace -> mem -> outcome -> Prop :=
+ | exec_Sskip: forall e m,
+ exec_stmt e m Sskip
+ E0 m Out_normal
+ | exec_Sexpr: forall e m a t m1 v,
+ eval_expr e m a t m1 v ->
+ exec_stmt e m (Sexpr a)
+ t m1 Out_normal
+ | exec_Sassign: forall e m a1 a2 t1 m1 loc ofs t2 m2 v2 m3,
+ eval_lvalue e m a1 t1 m1 loc ofs ->
+ eval_expr e m1 a2 t2 m2 v2 ->
+ store_value_of_type (typeof a1) m2 loc ofs v2 = Some m3 ->
+ exec_stmt e m (Sassign a1 a2)
+ (t1 ** t2) m3 Out_normal
+ | exec_Sseq_1: forall e m s1 s2 t1 m1 t2 m2 out,
+ exec_stmt e m s1 t1 m1 Out_normal ->
+ exec_stmt e m1 s2 t2 m2 out ->
+ exec_stmt e m (Ssequence s1 s2)
+ (t1 ** t2) m2 out
+ | exec_Sseq_2: forall e m s1 s2 t1 m1 out,
+ exec_stmt e m s1 t1 m1 out ->
+ out <> Out_normal ->
+ exec_stmt e m (Ssequence s1 s2)
+ t1 m1 out
+ | exec_Sifthenelse_true: forall e m a s1 s2 t1 m1 v1 t2 m2 out,
+ eval_expr e m a t1 m1 v1 ->
+ is_true v1 (typeof a) ->
+ exec_stmt e m1 s1 t2 m2 out ->
+ exec_stmt e m (Sifthenelse a s1 s2)
+ (t1 ** t2) m2 out
+ | exec_Sifthenelse_false: forall e m a s1 s2 t1 m1 v1 t2 m2 out,
+ eval_expr e m a t1 m1 v1 ->
+ is_false v1 (typeof a) ->
+ exec_stmt e m1 s2 t2 m2 out ->
+ exec_stmt e m (Sifthenelse a s1 s2)
+ (t1 ** t2) m2 out
+ | exec_Sreturn_none: forall e m,
+ exec_stmt e m (Sreturn None)
+ E0 m (Out_return None)
+ | exec_Sreturn_some: forall e m a t m1 v,
+ eval_expr e m a t m1 v ->
+ exec_stmt e m (Sreturn (Some a))
+ t m1 (Out_return (Some v))
+ | exec_Sbreak: forall e m,
+ exec_stmt e m Sbreak
+ E0 m Out_break
+ | exec_Scontinue: forall e m,
+ exec_stmt e m Scontinue
+ E0 m Out_continue
+ | exec_Swhile_false: forall e m s a t v m1,
+ eval_expr e m a t m1 v ->
+ is_false v (typeof a) ->
+ exec_stmt e m (Swhile a s)
+ t m1 Out_normal
+ | exec_Swhile_stop: forall e m a t1 m1 v s m2 t2 out2 out,
+ eval_expr e m a t1 m1 v ->
+ is_true v (typeof a) ->
+ exec_stmt e m1 s t2 m2 out2 ->
+ out_break_or_return out2 out ->
+ exec_stmt e m (Swhile a s)
+ (t1 ** t2) m2 out
+ | exec_Swhile_loop: forall e m a t1 m1 v s out2 out t2 m2 t3 m3,
+ eval_expr e m a t1 m1 v ->
+ is_true v (typeof a) ->
+ exec_stmt e m1 s t2 m2 out2 ->
+ out_normal_or_continue out2 ->
+ exec_stmt e m2 (Swhile a s) t3 m3 out ->
+ exec_stmt e m (Swhile a s)
+ (t1 ** t2 ** t3) m3 out
+ | exec_Sdowhile_false: forall e m s a t1 m1 out1 v t2 m2,
+ exec_stmt e m s t1 m1 out1 ->
+ out_normal_or_continue out1 ->
+ eval_expr e m1 a t2 m2 v ->
+ is_false v (typeof a) ->
+ exec_stmt e m (Sdowhile a s)
+ (t1 ** t2) m2 Out_normal
+ | exec_Sdowhile_stop: forall e m s a t m1 out1 out,
+ exec_stmt e m s t m1 out1 ->
+ out_break_or_return out1 out ->
+ exec_stmt e m (Sdowhile a s)
+ t m1 out
+ | exec_Sdowhile_loop: forall e m s a m1 m2 m3 t1 t2 t3 out out1 v,
+ exec_stmt e m s t1 m1 out1 ->
+ out_normal_or_continue out1 ->
+ eval_expr e m1 a t2 m2 v ->
+ is_true v (typeof a) ->
+ exec_stmt e m2 (Sdowhile a s) t3 m3 out ->
+ exec_stmt e m (Sdowhile a s)
+ (t1 ** t2 ** t3) m3 out
+ | exec_Sfor_start: forall e m s a1 a2 a3 out m1 m2 t1 t2,
+ exec_stmt e m a1 t1 m1 Out_normal ->
+ exec_stmt e m1 (Sfor Sskip a2 a3 s) t2 m2 out ->
+ exec_stmt e m (Sfor a1 a2 a3 s)
+ (t1 ** t2) m2 out
+ | exec_Sfor_false: forall e m s a2 a3 t v m1,
+ eval_expr e m a2 t m1 v ->
+ is_false v (typeof a2) ->
+ exec_stmt e m (Sfor Sskip a2 a3 s)
+ t m1 Out_normal
+ | exec_Sfor_stop: forall e m s a2 a3 v m1 m2 t1 t2 out2 out,
+ eval_expr e m a2 t1 m1 v ->
+ is_true v (typeof a2) ->
+ exec_stmt e m1 s t2 m2 out2 ->
+ out_break_or_return out2 out ->
+ exec_stmt e m (Sfor Sskip a2 a3 s)
+ (t1 ** t2) m2 out
+ | exec_Sfor_loop: forall e m s a2 a3 v m1 m2 m3 m4 t1 t2 t3 t4 out2 out,
+ eval_expr e m a2 t1 m1 v ->
+ is_true v (typeof a2) ->
+ exec_stmt e m1 s t2 m2 out2 ->
+ out_normal_or_continue out2 ->
+ exec_stmt e m2 a3 t3 m3 Out_normal ->
+ exec_stmt e m3 (Sfor Sskip a2 a3 s) t4 m4 out ->
+ exec_stmt e m (Sfor Sskip a2 a3 s)
+ (t1 ** t2 ** t3 ** t4) m4 out
+ | exec_Sswitch: forall e m a t1 m1 n sl t2 m2 out,
+ eval_expr e m a t1 m1 (Vint n) ->
+ exec_lblstmts e m1 (select_switch n sl) t2 m2 out ->
+ exec_stmt e m (Sswitch a sl)
+ (t1 ** t2) m2 (outcome_switch out)
+
+(** Execution of a list of labeled statements *)
+
+with exec_lblstmts: env -> mem -> labeled_statements -> trace -> mem -> outcome -> Prop :=
+ | exec_LSdefault: forall e m s t m1 out,
+ exec_stmt e m s t m1 out ->
+ exec_lblstmts e m (LSdefault s) t m1 out
+ | exec_LScase_fallthrough: forall e m n s ls t1 m1 t2 m2 out,
+ exec_stmt e m s t1 m1 Out_normal ->
+ exec_lblstmts e m1 ls t2 m2 out ->
+ exec_lblstmts e m (LScase n s ls) (t1 ** t2) m2 out
+ | exec_LScase_stop: forall e m n s ls t m1 out,
+ exec_stmt e m s t m1 out -> out <> Out_normal ->
+ exec_lblstmts e m (LScase n s ls) t m1 out
+
+(** Evaluation of a function invocation *)
+
+with eval_funcall: mem -> fundef -> list val -> trace -> mem -> val -> Prop :=
+ | eval_funcall_internal: forall m f vargs t e m1 lb m2 m3 out vres,
+ alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 lb ->
+ bind_parameters e m1 f.(fn_params) vargs m2 ->
+ exec_stmt e m2 f.(fn_body) t m3 out ->
+ outcome_result_value out f.(fn_return) vres ->
+ eval_funcall m (Internal f) vargs t (Mem.free_list m3 lb) vres
+ | eval_funcall_external: forall m id targs tres vargs t vres,
+ event_match (external_function id targs tres) vargs t vres ->
+ eval_funcall m (External id targs tres) vargs t m vres.
+
+Scheme eval_expr_ind6 := Minimality for eval_expr Sort Prop
+ with eval_lvalue_ind6 := Minimality for eval_lvalue Sort Prop
+ with eval_exprlist_ind6 := Minimality for eval_exprlist Sort Prop
+ with exec_stmt_ind6 := Minimality for exec_stmt Sort Prop
+ with exec_lblstmts_ind6 := Minimality for exec_lblstmts Sort Prop
+ with eval_funcall_ind6 := Minimality for eval_funcall Sort Prop.
+
+End RELSEM.
+
+(** Execution of a whole program *)
+
+Definition exec_program (p: program) (t: trace) (r: val) : Prop :=
+ let ge := globalenv p in
+ let m0 := init_mem p in
+ exists b, exists f, exists m1,
+ Genv.find_symbol ge p.(prog_main) = Some b /\
+ Genv.find_funct_ptr ge b = Some f /\
+ type_of_fundef f = Tfunction Tnil (Tint I32 Signed) /\
+ eval_funcall ge m0 f nil t m1 r.
diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v
new file mode 100644
index 0000000..58c0bb8
--- /dev/null
+++ b/cfrontend/Cshmgen.v
@@ -0,0 +1,598 @@
+Require Import Coqlib.
+Require Import Integers.
+Require Import Floats.
+Require Import AST.
+Require Import Csyntax.
+Require Import Csharpminor.
+
+(** The error monad *)
+
+Definition bind (A B: Set) (f: option A) (g: A -> option B) :=
+ match f with None => None | Some x => g x end.
+
+Implicit Arguments bind [A B].
+
+Notation "'do' X <- A ; B" := (bind A (fun X => B))
+ (at level 200, X ident, A at level 100, B at level 200).
+
+(** ** Operations on C types *)
+
+Definition signature_of_function (f: Csyntax.function) : signature :=
+ mksignature
+ (typlist_of_typelist (type_of_params (Csyntax.fn_params f)))
+ (opttyp_of_type (Csyntax.fn_return f)).
+
+Definition chunk_of_type (ty: type): option memory_chunk :=
+ match access_mode ty with
+ | By_value chunk => Some chunk
+ | _ => None
+ end.
+
+Definition var_kind_of_type (ty: type): option var_kind :=
+ match ty with
+ | Tint I8 Signed => Some(Vscalar Mint8signed)
+ | Tint I8 Unsigned => Some(Vscalar Mint8unsigned)
+ | Tint I16 Signed => Some(Vscalar Mint16signed)
+ | Tint I16 Unsigned => Some(Vscalar Mint16unsigned)
+ | Tint I32 _ => Some(Vscalar Mint32)
+ | Tfloat F32 => Some(Vscalar Mfloat32)
+ | Tfloat F64 => Some(Vscalar Mfloat64)
+ | Tvoid => None
+ | Tpointer _ => Some(Vscalar Mint32)
+ | Tarray _ _ => Some(Varray (Csyntax.sizeof ty))
+ | Tfunction _ _ => None
+ | Tstruct fList => Some(Varray (Csyntax.sizeof ty))
+ | Tunion fList => Some(Varray (Csyntax.sizeof ty))
+end.
+
+(** ** Csharpminor constructors *)
+
+(* The following functions build Csharpminor expressions that compute
+ the value of a C operation. Most construction functions take
+ as arguments
+ - Csharpminor subexpressions that compute the values of the
+ arguments of the operation;
+ - The C types of the arguments of the operation. These types
+ are used to insert the necessary numeric conversions and to
+ resolve operation overloading.
+ Most of these functions return an [option expr], with [None]
+ denoting a case where the operation is not defined at the given types.
+*)
+
+Definition make_intconst (n: int) := Eop (Ointconst n) Enil.
+
+Definition make_floatconst (f: float) := Eop (Ofloatconst f) Enil.
+
+Definition make_unop (op: operation) (e: expr) := Eop op (Econs e Enil).
+
+Definition make_binop (op: operation) (e1 e2: expr) :=
+ Eop op (Econs e1 (Econs e2 Enil)).
+
+Definition make_floatofint (e: expr) (sg: signedness) :=
+ match sg with
+ | Signed => make_unop Ofloatofint e
+ | Unsigned => make_unop Ofloatofintu e
+ end.
+
+(* [make_boolean e ty] returns a Csharpminor expression that evaluates
+ to the boolean value of [e]. Recall that:
+ - in Csharpminor, [false] is the integer 0,
+ [true] any non-zero integer or any pointer
+ - in C, [false] is the integer 0, the null pointer, the float 0.0
+ [true] is any non-zero integer, non-null pointer, non-null float.
+*)
+Definition make_boolean (e: expr) (ty: type) :=
+ match ty with
+ | Tfloat _ => make_binop (Ocmpf Cne) e (make_floatconst Float.zero)
+ | _ => e
+ end.
+
+Definition make_neg (e: expr) (ty: type) :=
+ match ty with
+ | Tint _ _ => Some (make_binop Osub (make_intconst Int.zero) e)
+ | Tfloat _ => Some (make_unop Onegf e)
+ | _ => None
+ end.
+
+Definition make_notbool (e: expr) (ty: type) :=
+ make_binop (Ocmp Ceq) (make_boolean e ty) (make_intconst Int.zero).
+
+Definition make_notint (e: expr) (ty: type) :=
+ make_unop Onotint e.
+
+Definition make_add (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ match classify_add ty1 ty2 with
+ | add_case_ii => Some (make_binop Oadd e1 e2)
+ | add_case_ff => Some (make_binop Oaddf e1 e2)
+ | add_case_pi ty =>
+ let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in
+ Some (make_binop Oadd e1 (make_binop Omul n e2))
+ | add_default => None
+ end.
+
+Definition make_sub (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ match classify_sub ty1 ty2 with
+ | sub_case_ii => Some (make_binop Osub e1 e2)
+ | sub_case_ff => Some (make_binop Osubf e1 e2)
+ | sub_case_pi ty =>
+ let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in
+ Some (make_binop Osub e1 (make_binop Omul n e2))
+ | sub_case_pp ty =>
+ let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in
+ Some (make_binop Odivu (make_binop Osub e1 e2) n)
+ | sub_default => None
+ end.
+
+Definition make_mul (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ match classify_mul ty1 ty2 with
+ | mul_case_ii => Some (make_binop Omul e1 e2)
+ | mul_case_ff => Some (make_binop Omulf e1 e2)
+ | mul_default => None
+ end.
+
+Definition make_div (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ match classify_div ty1 ty2 with
+ | div_case_I32unsi => Some (make_binop Odivu e1 e2)
+ | div_case_ii => Some (make_binop Odiv e1 e2)
+ | div_case_ff => Some (make_binop Odivf e1 e2)
+ | div_default => None
+ end.
+
+Definition make_mod (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ match classify_mod ty1 ty2 with
+ | mod_case_I32unsi => Some (make_binop Omodu e1 e2)
+ | mod_case_ii=> Some (make_binop Omod e1 e2)
+ | mod_default => None
+ end.
+
+Definition make_and (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ Some(make_binop Oand e1 e2).
+
+Definition make_or (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ Some(make_binop Oor e1 e2).
+
+Definition make_xor (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ Some(make_binop Oxor e1 e2).
+
+Definition make_shl (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ Some(make_binop Oshl e1 e2).
+
+Definition make_shr (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ match classify_shr ty1 ty2 with
+ | shr_case_I32unsi => Some (make_binop Oshru e1 e2)
+ | shr_case_ii=> Some (make_binop Oshr e1 e2)
+ | shr_default => None
+ end.
+
+Definition make_cmp (c: comparison) (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ match classify_cmp ty1 ty2 with
+ | cmp_case_I32unsi => Some (make_binop (Ocmpu c) e1 e2)
+ | cmp_case_ii => Some (make_binop (Ocmp c) e1 e2)
+ | cmp_case_ff => Some (make_binop (Ocmpf c) e1 e2)
+ | cmp_case_pi => Some (make_binop (Ocmp c) e1 e2)
+ | cmp_case_pp => Some (make_binop (Ocmp c) e1 e2)
+ | cmp_default => None
+ end.
+
+Definition make_andbool (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ Econdition
+ (make_boolean e1 ty1)
+ (Econdition
+ (make_boolean e2 ty2)
+ (make_intconst Int.one)
+ (make_intconst Int.zero))
+ (make_intconst Int.zero).
+
+Definition make_orbool (e1: expr) (ty1: type) (e2: expr) (ty2: type) :=
+ Econdition
+ (make_boolean e1 ty1)
+ (make_intconst Int.one)
+ (Econdition
+ (make_boolean e2 ty2)
+ (make_intconst Int.one)
+ (make_intconst Int.zero)).
+
+(* [make_cast from to e] applies to [e] the numeric conversions needed
+ to transform a result of type [from] to a result of type [to].
+ It is decomposed in two functions:
+ - [make_cast1] converts between int/pointer and float if necessary
+ - [make_cast2] converts to a "smaller" int or float type if necessary.
+*)
+
+Definition make_cast1 (from to: type) (e: expr) :=
+ match from, to with
+ | Tint _ uns, Tfloat _ => make_floatofint e uns
+ | Tfloat _, Tint _ _ => make_unop Ointoffloat e
+ | _, _ => e
+ end.
+
+Definition make_cast2 (from to: type) (e: expr) :=
+ match to with
+ | Tint I8 Signed => make_unop Ocast8signed e
+ | Tint I8 Unsigned => make_unop Ocast8unsigned e
+ | Tint I16 Signed => make_unop Ocast16signed e
+ | Tint I16 Unsigned => make_unop Ocast16unsigned e
+ | Tfloat F32 => make_unop Osingleoffloat e
+ | _ => e
+ end.
+
+Definition make_cast (from to: type) (e: expr) :=
+ make_cast2 from to (make_cast1 from to e).
+
+(* [make_load addr ty_res] loads a value of type [ty_res] from
+ the memory location denoted by the Csharpminor expression [addr].
+ If [ty_res] is an array or function type, returns [addr] instead,
+ as consistent with C semantics.
+*)
+
+Definition make_load (addr: expr) (ty_res: type) :=
+ match (access_mode ty_res) with
+ | By_value chunk => Some (Eload chunk addr)
+ | By_reference => Some addr
+ | By_nothing => None
+ end.
+
+(* [make_store addr ty_res rhs ty_rhs] stores the value of the
+ Csharpminor expression [rhs] into the memory location denoted by the
+ Csharpminor expression [addr].
+ [ty] is the type of the memory location. *)
+
+Definition make_store (addr: expr) (ty: type) (rhs: expr) :=
+ match access_mode ty with
+ | By_value chunk => Some (Sstore chunk addr rhs)
+ | _ => None
+ end.
+
+(** ** Reading and writing variables *)
+
+(* [var_get id ty] builds Csharpminor code that evaluates to the
+ value of C variable [id] with type [ty]. Note that
+ C variables of array or function type evaluate to the address
+ of the corresponding CabsCoq memory block, while variables of other types
+ evaluate to the contents of the corresponding C memory block.
+*)
+
+Definition var_get (id: ident) (ty: type) :=
+ match access_mode ty with
+ | By_value chunk => Some (Evar id)
+ | By_reference => Some (Eaddrof id)
+ | _ => None
+ end.
+
+(* [var_set id ty rhs] stores the value of the Csharpminor
+ expression [rhs] into the CabsCoq variable [id] of type [ty].
+*)
+
+Definition var_set (id: ident) (ty: type) (rhs: expr) :=
+ match access_mode ty with
+ | By_value chunk => Some (Sassign id rhs)
+ | _ => None
+ end.
+
+(** ** Translation of operators *)
+
+Definition transl_unop (op: unary_operation) (a: expr) (ta: type) : option expr :=
+ match op with
+ | Csyntax.Onotbool => Some(make_notbool a ta)
+ | Csyntax.Onotint => Some(make_notint a ta)
+ | Csyntax.Oneg => make_neg a ta
+ end.
+
+Definition transl_binop (op: binary_operation) (a: expr) (ta: type)
+ (b: expr) (tb: type) : option expr :=
+ match op with
+ | Csyntax.Oadd => make_add a ta b tb
+ | Csyntax.Osub => make_sub a ta b tb
+ | Csyntax.Omul => make_mul a ta b tb
+ | Csyntax.Odiv => make_div a ta b tb
+ | Csyntax.Omod => make_mod a ta b tb
+ | Csyntax.Oand => make_and a ta b tb
+ | Csyntax.Oor => make_or a ta b tb
+ | Csyntax.Oxor => make_xor a ta b tb
+ | Csyntax.Oshl => make_shl a ta b tb
+ | Csyntax.Oshr => make_shr a ta b tb
+ | Csyntax.Oeq => make_cmp Ceq a ta b tb
+ | Csyntax.One => make_cmp Cne a ta b tb
+ | Csyntax.Olt => make_cmp Clt a ta b tb
+ | Csyntax.Ogt => make_cmp Cgt a ta b tb
+ | Csyntax.Ole => make_cmp Cle a ta b tb
+ | Csyntax.Oge => make_cmp Cge a ta b tb
+ end.
+
+(** ** Translation of expressions *)
+
+(* [transl_expr a] returns the Csharpminor code that computes the value
+ of expression [a]. The result is an option type to enable error reporting.
+
+ Most cases are self-explanatory. We outline the non-obvious cases:
+
+ a && b ---> a ? (b ? 1 : 0) : 0
+
+ a || b ---> a ? 1 : (b ? 1 : 0)
+*)
+
+Fixpoint transl_expr (a: Csyntax.expr) {struct a} : option expr :=
+ match a with
+ | Expr (Csyntax.Econst_int n) _ =>
+ Some(make_intconst n)
+ | Expr (Csyntax.Econst_float n) _ =>
+ Some(make_floatconst n)
+ | Expr (Csyntax.Evar id) ty =>
+ var_get id ty
+ | Expr (Csyntax.Ederef b) _ =>
+ do tb <- transl_expr b;
+ make_load tb (typeof a)
+ | Expr (Csyntax.Eaddrof b) _ =>
+ transl_lvalue b
+ | Expr (Csyntax.Eunop op b) _ =>
+ do tb <- transl_expr b;
+ transl_unop op tb (typeof b)
+ | Expr (Csyntax.Ebinop op b c) _ =>
+ do tb <- transl_expr b;
+ do tc <- transl_expr c;
+ transl_binop op tb (typeof b) tc (typeof c)
+ | Expr (Csyntax.Ecast ty b) _ =>
+ do tb <- transl_expr b;
+ Some (make_cast (typeof b) ty tb)
+ | Expr (Csyntax.Eindex b c) ty =>
+ do tb <- transl_expr b;
+ do tc <- transl_expr c;
+ do ts <- make_add tb (typeof b) tc (typeof c);
+ make_load ts ty
+ | Expr (Csyntax.Ecall b cl) _ =>
+ match (classify_fun (typeof b)) with
+ | fun_case_f args res =>
+ do tb <- transl_expr b;
+ do tcl <- transl_exprlist cl;
+ Some(Ecall (signature_of_type args res) tb tcl)
+ | _ => None
+ end
+ | Expr (Csyntax.Eandbool b c) _ =>
+ do tb <- transl_expr b;
+ do tc <- transl_expr c;
+ Some(make_andbool tb (typeof b) tc (typeof c))
+ | Expr (Csyntax.Eorbool b c) _ =>
+ do tb <- transl_expr b;
+ do tc <- transl_expr c;
+ Some(make_orbool tb (typeof b) tc (typeof c))
+ | Expr (Csyntax.Esizeof ty) _ =>
+ Some(make_intconst (Int.repr (Csyntax.sizeof ty)))
+ | Expr (Csyntax.Efield b i) ty =>
+ match typeof b with
+ | Tstruct fld =>
+ do tb <- transl_lvalue b;
+ do ofs <- field_offset i fld;
+ make_load
+ (make_binop Oadd tb (make_intconst (Int.repr ofs)))
+ ty
+ | Tunion fld =>
+ do tb <- transl_lvalue b;
+ make_load tb ty
+ | _ => None
+ end
+ end
+
+(* [transl_lvalue a] returns the Csharpminor code that evaluates
+ [a] as a lvalue, that is, code that returns the memory address
+ where the value of [a] is stored.
+*)
+
+with transl_lvalue (a: Csyntax.expr) {struct a} : option expr :=
+ match a with
+ | Expr (Csyntax.Evar id) _ =>
+ Some (Eaddrof id)
+ | Expr (Csyntax.Ederef b) _ =>
+ transl_expr b
+ | Expr (Csyntax.Eindex b c) _ =>
+ do tb <- transl_expr b;
+ do tc <- transl_expr c;
+ make_add tb (typeof b) tc (typeof c)
+ | Expr (Csyntax.Efield b i) ty =>
+ match typeof b with
+ | Tstruct fld =>
+ do tb <- transl_lvalue b;
+ do ofs <- field_offset i fld;
+ Some (make_binop Oadd tb (make_intconst (Int.repr ofs)))
+ | Tunion fld =>
+ transl_lvalue b
+ | _ => None
+ end
+ | _ => None
+ end
+
+(* [transl_exprlist al] returns a list of Csharpminor expressions
+ that compute the values of the list [al] of Csyntax expressions.
+ Used for function applications. *)
+
+with transl_exprlist (al: Csyntax.exprlist): option exprlist :=
+ match al with
+ | Csyntax.Enil => Some Enil
+ | Csyntax.Econs a1 a2 =>
+ do ta1 <- transl_expr a1;
+ do ta2 <- transl_exprlist a2;
+ Some (Econs ta1 ta2)
+ end.
+
+(** ** Translation of statements *)
+
+(** Determine if a C expression is a variable *)
+
+Definition is_variable (e: Csyntax.expr) : option ident :=
+ match e with
+ | Expr (Csyntax.Evar id) _ => Some id
+ | _ => None
+ end.
+
+(* [exit_if_false e] return the statement that tests the boolean
+ value of the CabsCoq expression [e] and performs an [exit 0] if [e]
+ evaluates to false.
+*)
+Definition exit_if_false (e: Csyntax.expr) : option stmt :=
+ do te <- transl_expr e;
+ Some(Sifthenelse
+ (make_notbool te (typeof e))
+ (Sexit 0%nat)
+ Sskip).
+
+(* [transl_statement nbrk ncnt s] returns a Csharpminor statement
+ that performs the same computations as the CabsCoq statement [s].
+
+ If the statement [s] terminates prematurely on a [break] construct,
+ the generated Csharpminor statement terminates prematurely on an
+ [exit nbrk] construct.
+
+ If the statement [s] terminates prematurely on a [continue]
+ construct, the generated Csharpminor statement terminates
+ prematurely on an [exit ncnt] construct.
+
+ Immediately within a loop, [nbrk = 1] and [ncnt = 0], but this
+ changes when we're inside a [switch] construct.
+
+ The general translation for loops is as follows:
+
+while (e1) s; ---> block {
+ loop {
+ if (!e1) exit 0;
+ block { s }
+ // continue in s branches here
+ }
+ }
+ // break in s branches here
+
+do s; while (e1); ---> block {
+ loop {
+ block { s }
+ // continue in s branches here
+ if (!e1) exit 0;
+ }
+ }
+ // break in s branches here
+
+for (e1;e2;e3) s; ---> e1;
+ block {
+ loop {
+ if (!e2) exit 0;
+ block { s }
+ // continue in s branches here
+ e3;
+ }
+ }
+ // break in s branches here
+
+switch (e) { ---> block { block { block { block {
+ case N1: s1; switch (e) { N1: exit 0; N2: exit 1; default: exit 2; }
+ case N2: s2; } ; s1 // with break -> exit 2 and continue -> exit 3
+ default: s; } ; s2 // with break -> exit 1 and continue -> exit 2
+} } ; s // with break -> exit 0 and continue -> exit 1
+ }
+*)
+
+Fixpoint switch_table (sl: labeled_statements) (k: nat) {struct sl} : list (int * nat) :=
+ match sl with
+ | LSdefault _ => nil
+ | LScase ni _ rem => (ni, k) :: switch_table rem (k+1)
+ end.
+
+Fixpoint transl_statement (nbrk ncnt: nat) (s: Csyntax.statement) {struct s} : option stmt :=
+ match s with
+ | Csyntax.Sskip =>
+ Some Sskip
+ | Csyntax.Sexpr e =>
+ do te <- transl_expr e;
+ Some (Sexpr te)
+ | Csyntax.Sassign b c =>
+ match (is_variable b) with
+ | Some id =>
+ do tc <- transl_expr c;
+ var_set id (typeof b) tc
+ | None =>
+ do tb <- transl_lvalue b;
+ do tc <- transl_expr c;
+ make_store tb (typeof b) tc
+ end
+ | Csyntax.Ssequence s1 s2 =>
+ do ts1 <- transl_statement nbrk ncnt s1;
+ do ts2 <- transl_statement nbrk ncnt s2;
+ Some (Sseq ts1 ts2)
+ | Csyntax.Sifthenelse e s1 s2 =>
+ do te <- transl_expr e;
+ do ts1 <- transl_statement nbrk ncnt s1;
+ do ts2 <- transl_statement nbrk ncnt s2;
+ Some (Sifthenelse (make_boolean te (typeof e)) ts1 ts2)
+ | Csyntax.Swhile e s1 =>
+ do te <- exit_if_false e;
+ do ts1 <- transl_statement 1%nat 0%nat s1;
+ Some (Sblock (Sloop (Sseq te (Sblock ts1))))
+ | Csyntax.Sdowhile e s1 =>
+ do te <- exit_if_false e;
+ do ts1 <- transl_statement 1%nat 0%nat s1;
+ Some (Sblock (Sloop (Sseq (Sblock ts1) te)))
+ | Csyntax.Sfor e1 e2 e3 s1 =>
+ do te1 <- transl_statement nbrk ncnt e1;
+ do te2 <- exit_if_false e2;
+ do te3 <- transl_statement nbrk ncnt e3;
+ do ts1 <- transl_statement 1%nat 0%nat s1;
+ Some (Sseq te1 (Sblock (Sloop (Sseq te2 (Sseq (Sblock ts1) te3)))))
+ | Csyntax.Sbreak =>
+ Some (Sexit nbrk)
+ | Csyntax.Scontinue =>
+ Some (Sexit ncnt)
+ | Csyntax.Sreturn (Some e) =>
+ do te <- transl_expr e;
+ Some (Sreturn (Some te))
+ | Csyntax.Sreturn None =>
+ Some (Sreturn None)
+ | Csyntax.Sswitch e sl =>
+ let cases := switch_table sl 0 in
+ let ncases := List.length cases in
+ do te <- transl_expr e;
+ transl_lblstmts ncases (ncnt + ncases + 1)%nat sl (Sblock (Sswitch te cases ncases))
+ end
+
+with transl_lblstmts (nbrk ncnt: nat) (sl: labeled_statements) (body: stmt)
+ {struct sl}: option stmt :=
+ match sl with
+ | LSdefault s =>
+ do ts <- transl_statement nbrk ncnt s;
+ Some (Sblock (Sseq body ts))
+ | LScase _ s rem =>
+ do ts <- transl_statement nbrk ncnt s;
+ transl_lblstmts (pred nbrk) (pred ncnt) rem (Sblock (Sseq body ts))
+ end.
+
+(*** Translation of functions *)
+
+Definition transl_params := transf_partial_program chunk_of_type.
+Definition transl_vars := transf_partial_program var_kind_of_type.
+
+Definition transl_function (f: Csyntax.function) : option function :=
+ do tparams <- transl_params (Csyntax.fn_params f);
+ do tvars <- transl_vars (Csyntax.fn_vars f);
+ do tbody <- transl_statement 1%nat 0%nat (Csyntax.fn_body f);
+ Some (mkfunction (signature_of_function f) tparams tvars tbody).
+
+Definition transl_fundef (f: Csyntax.fundef) : option fundef :=
+ match f with
+ | Csyntax.Internal g =>
+ do tg <- transl_function g; Some(AST.Internal tg)
+ | Csyntax.External id args res =>
+ Some(AST.External (external_function id args res))
+ end.
+
+(** ** Translation of programs *)
+
+Fixpoint transl_global_vars
+ (vl: list (ident * type * list init_data)) :
+ option (list (ident * var_kind * list init_data)) :=
+ match vl with
+ | nil => Some nil
+ | (id, ty, init) :: rem =>
+ do vk <- var_kind_of_type ty;
+ do trem <- transl_global_vars rem;
+ Some ((id, vk, init) :: trem)
+ end.
+
+Definition transl_program (p: Csyntax.program) : option program :=
+ do tfun <- transf_partial_program transl_fundef (Csyntax.prog_funct p);
+ do tvars <- transl_global_vars (Csyntax.prog_defs p);
+ Some (mkprogram tfun (Csyntax.prog_main p) tvars).
diff --git a/cfrontend/Cshmgenproof1.v b/cfrontend/Cshmgenproof1.v
new file mode 100644
index 0000000..17f7aa9
--- /dev/null
+++ b/cfrontend/Cshmgenproof1.v
@@ -0,0 +1,288 @@
+(** * Correctness of the C front end, part 1: syntactic properties *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import Integers.
+Require Import Floats.
+Require Import AST.
+Require Import Values.
+Require Import Events.
+Require Import Mem.
+Require Import Globalenvs.
+Require Import Csyntax.
+Require Import Csem.
+Require Import Ctyping.
+Require Import Csharpminor.
+Require Import Cshmgen.
+
+(** Monadic simplification *)
+
+Ltac monadSimpl1 :=
+ match goal with
+ | [ |- (bind ?F ?G = Some ?X) -> _ ] =>
+ unfold bind at 1;
+ generalize (refl_equal F);
+ pattern F at -1 in |- *;
+ case F;
+ [ (let EQ := fresh "EQ" in
+ (intro; intro EQ; try monadSimpl1))
+ | intro; intro; discriminate ]
+ | [ |- (None = Some _) -> _ ] =>
+ intro; discriminate
+ | [ |- (Some _ = Some _) -> _ ] =>
+ let h := fresh "H" in
+ (intro h; injection h; intro; clear h)
+ | [ |- (_ = Some _) -> _ ] =>
+ let EQ := fresh "EQ" in intro EQ
+ end.
+
+Ltac monadSimpl :=
+ match goal with
+ | [ |- (bind ?F ?G = Some ?X) -> _ ] => monadSimpl1
+ | [ |- (None = Some _) -> _ ] => monadSimpl1
+ | [ |- (Some _ = Some _) -> _ ] => monadSimpl1
+ | [ |- (?F _ _ _ _ _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1
+ | [ |- (?F _ _ _ _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1
+ | [ |- (?F _ _ _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1
+ | [ |- (?F _ _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1
+ | [ |- (?F _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1
+ | [ |- (?F _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1
+ end.
+
+Ltac monadInv H :=
+ generalize H; monadSimpl.
+
+(** Operations on types *)
+
+Lemma transl_fundef_sig1:
+ forall f tf args res,
+ transl_fundef f = Some tf ->
+ classify_fun (type_of_fundef f) = fun_case_f args res ->
+ funsig tf = signature_of_type args res.
+Proof.
+ intros. destruct f; monadInv H.
+ monadInv EQ. rewrite <- H2. rewrite <- H3. simpl.
+ simpl in H0. inversion H0. reflexivity.
+ rewrite <- H2. simpl.
+ simpl in H0. congruence.
+Qed.
+
+Lemma transl_fundef_sig2:
+ forall f tf args res,
+ transl_fundef f = Some tf ->
+ type_of_fundef f = Tfunction args res ->
+ funsig tf = signature_of_type args res.
+Proof.
+ intros. eapply transl_fundef_sig1; eauto.
+ rewrite H0; reflexivity.
+Qed.
+
+Lemma var_kind_by_value:
+ forall ty chunk,
+ access_mode ty = By_value chunk ->
+ var_kind_of_type ty = Some(Vscalar chunk).
+Proof.
+ intros ty chunk; destruct ty; simpl; try congruence.
+ destruct i; try congruence; destruct s; congruence.
+ destruct f; congruence.
+Qed.
+
+Lemma sizeof_var_kind_of_type:
+ forall ty vk,
+ var_kind_of_type ty = Some vk ->
+ Csharpminor.sizeof vk = Csyntax.sizeof ty.
+Proof.
+ intros ty vk.
+ assert (sizeof (Varray (Csyntax.sizeof ty)) = Csyntax.sizeof ty).
+ simpl. rewrite Zmax_spec. apply zlt_false.
+ generalize (Csyntax.sizeof_pos ty). omega.
+ destruct ty; try (destruct i; try destruct s); try (destruct f);
+ simpl; intro EQ; inversion EQ; subst vk; auto.
+Qed.
+
+(** Transformation of programs and functions *)
+
+Lemma transform_program_of_program:
+ forall prog tprog,
+ transl_program prog = Some tprog ->
+ transform_partial_program transl_fundef (Csyntax.program_of_program prog) =
+ Some (program_of_program tprog).
+Proof.
+ intros prog tprog TRANSL.
+ monadInv TRANSL. rewrite <- H0. unfold program_of_program; simpl.
+ unfold transform_partial_program, Csyntax.program_of_program; simpl.
+ rewrite EQ. decEq. decEq.
+ generalize EQ0. generalize l0. generalize (prog_defs prog).
+ induction l1; simpl; intros.
+ inversion EQ1; subst l1. reflexivity.
+ destruct a as [[id ty] init]. monadInv EQ1. subst l2. simpl. decEq. apply IHl1. auto.
+Qed.
+
+(** ** Some properties of the translation functions *)
+
+Lemma transf_partial_program_names:
+ forall (A B: Set) (f: A -> option B)
+ (l: list (ident * A)) (tl: list (ident * B)),
+ transf_partial_program f l = Some tl ->
+ List.map (@fst ident B) tl = List.map (@fst ident A) l.
+Proof.
+ induction l; simpl.
+ intros. inversion H. reflexivity.
+ intro tl. destruct a as [id x]. destruct (f x); try congruence.
+ caseEq (transf_partial_program f l); intros; try congruence.
+ inversion H0; subst tl. simpl. decEq. auto.
+Qed.
+
+Lemma transf_partial_program_append:
+ forall (A B: Set) (f: A -> option B)
+ (l1 l2: list (ident * A)) (tl1 tl2: list (ident * B)),
+ transf_partial_program f l1 = Some tl1 ->
+ transf_partial_program f l2 = Some tl2 ->
+ transf_partial_program f (l1 ++ l2) = Some (tl1 ++ tl2).
+Proof.
+ induction l1; intros until tl2; simpl.
+ intros. inversion H. simpl; auto.
+ destruct a as [id x]. destruct (f x); try congruence.
+ caseEq (transf_partial_program f l1); intros; try congruence.
+ inversion H0. rewrite (IHl1 _ _ _ H H1). auto.
+Qed.
+
+Lemma transl_params_names:
+ forall vars tvars,
+ transl_params vars = Some tvars ->
+ List.map (@fst ident memory_chunk) tvars = Ctyping.var_names vars.
+Proof.
+ exact (transf_partial_program_names _ _ chunk_of_type).
+Qed.
+
+Lemma transl_vars_names:
+ forall vars tvars,
+ transl_vars vars = Some tvars ->
+ List.map (@fst ident var_kind) tvars = Ctyping.var_names vars.
+Proof.
+ exact (transf_partial_program_names _ _ var_kind_of_type).
+Qed.
+
+Lemma transl_names_norepet:
+ forall params vars sg tparams tvars body,
+ list_norepet (var_names params ++ var_names vars) ->
+ transl_params params = Some tparams ->
+ transl_vars vars = Some tvars ->
+ let f := Csharpminor.mkfunction sg tparams tvars body in
+ list_norepet (fn_params_names f ++ fn_vars_names f).
+Proof.
+ intros. unfold fn_params_names, fn_vars_names, f. simpl.
+ rewrite (transl_params_names _ _ H0).
+ rewrite (transl_vars_names _ _ H1).
+ auto.
+Qed.
+
+Lemma transl_vars_append:
+ forall l1 l2 tl1 tl2,
+ transl_vars l1 = Some tl1 -> transl_vars l2 = Some tl2 ->
+ transl_vars (l1 ++ l2) = Some (tl1 ++ tl2).
+Proof.
+ exact (transf_partial_program_append _ _ var_kind_of_type).
+Qed.
+
+Lemma transl_params_vars:
+ forall params tparams,
+ transl_params params = Some tparams ->
+ transl_vars params =
+ Some (List.map (fun id_chunk => (fst id_chunk, Vscalar (snd id_chunk))) tparams).
+Proof.
+ induction params; intro tparams; simpl.
+ intros. inversion H. reflexivity.
+ destruct a as [id x].
+ unfold chunk_of_type. caseEq (access_mode x); try congruence.
+ intros chunk AM.
+ caseEq (transl_params params); intros; try congruence.
+ inversion H0.
+ rewrite (var_kind_by_value _ _ AM).
+ rewrite (IHparams _ H). reflexivity.
+Qed.
+
+Lemma transl_fn_variables:
+ forall params vars sg tparams tvars body,
+ transl_params params = Some tparams ->
+ transl_vars vars = Some tvars ->
+ let f := Csharpminor.mkfunction sg tparams tvars body in
+ transl_vars (params ++ vars) = Some (fn_variables f).
+Proof.
+ intros.
+ generalize (transl_params_vars _ _ H); intro.
+ rewrite (transl_vars_append _ _ _ _ H1 H0).
+ reflexivity.
+Qed.
+
+(** Transformation of expressions and statements *)
+
+Lemma is_variable_correct:
+ forall a id,
+ is_variable a = Some id ->
+ a = Csyntax.Expr (Csyntax.Evar id) (typeof a).
+Proof.
+ intros until id. destruct a as [ad aty]; simpl.
+ destruct ad; intros; try discriminate.
+ congruence.
+Qed.
+
+Lemma transl_expr_lvalue:
+ forall ge e m1 a ty t m2 loc ofs ta,
+ Csem.eval_lvalue ge e m1 (Expr a ty) t m2 loc ofs ->
+ transl_expr (Expr a ty) = Some ta ->
+ (exists id, a = Csyntax.Evar id /\ var_get id ty = Some ta) \/
+ (exists tb, transl_lvalue (Expr a ty) = Some tb /\
+ make_load tb ty = Some ta).
+Proof.
+ intros. inversion H; subst; clear H; simpl in H0.
+ left; exists id; auto.
+ left; exists id; auto.
+ monadInv H0. right. exists e0; split; auto.
+ simpl. monadInv H0. right. exists e2; split; auto.
+ simpl. rewrite H6 in H0. rewrite H6.
+ monadInv H0. right.
+ exists (make_binop Oadd e0 (make_intconst (Int.repr z))). split; auto.
+ simpl. rewrite H10 in H0. rewrite H10.
+ monadInv H0. right.
+ exists e0; auto.
+Qed.
+
+Lemma transl_stmt_Sfor_start:
+ forall nbrk ncnt s1 e2 s3 s4 ts,
+ transl_statement nbrk ncnt (Sfor s1 e2 s3 s4) = Some ts ->
+ exists ts1, exists ts2,
+ ts = Sseq ts1 ts2
+ /\ transl_statement nbrk ncnt s1 = Some ts1
+ /\ transl_statement nbrk ncnt (Sfor Csyntax.Sskip e2 s3 s4) = Some (Sseq Sskip ts2).
+Proof.
+ intros. monadInv H. simpl.
+ exists s; exists (Sblock (Sloop (Sseq s0 (Sseq (Sblock s5) s2)))).
+ intuition.
+Qed.
+
+(** Properties related to switch constructs *)
+
+Fixpoint lblstmts_length (sl: labeled_statements) : nat :=
+ match sl with
+ | LSdefault _ => 0%nat
+ | LScase _ _ sl' => S (lblstmts_length sl')
+ end.
+
+Lemma switch_target_table_shift:
+ forall n sl base dfl,
+ switch_target n (S dfl) (switch_table sl (S base)) =
+ S(switch_target n dfl (switch_table sl base)).
+Proof.
+ induction sl; intros; simpl.
+ auto.
+ case (Int.eq n i). auto. auto.
+Qed.
+
+Lemma length_switch_table:
+ forall sl base, List.length (switch_table sl base) = lblstmts_length sl.
+Proof.
+ induction sl; intro; simpl. auto. decEq; auto.
+Qed.
+
+
diff --git a/cfrontend/Cshmgenproof2.v b/cfrontend/Cshmgenproof2.v
new file mode 100644
index 0000000..602e33a
--- /dev/null
+++ b/cfrontend/Cshmgenproof2.v
@@ -0,0 +1,419 @@
+(** * Correctness of the C front end, part 2: Csharpminor construction functions *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import Integers.
+Require Import Floats.
+Require Import AST.
+Require Import Values.
+Require Import Events.
+Require Import Mem.
+Require Import Globalenvs.
+Require Import Csyntax.
+Require Import Csem.
+Require Import Ctyping.
+Require Import Csharpminor.
+Require Import Cshmgen.
+Require Import Cshmgenproof1.
+
+Section CONSTRUCTORS.
+
+Variable tprog: Csharpminor.program.
+
+(** Properties of the translation of [switch] constructs. *)
+
+Lemma transl_lblstmts_exit:
+ forall e m1 t m2 sl body n tsl nbrk ncnt,
+ exec_stmt tprog e m1 body t m2 (Out_exit (lblstmts_length sl + n)) ->
+ transl_lblstmts nbrk ncnt sl body = Some tsl ->
+ exec_stmt tprog e m1 tsl t m2 (outcome_block (Out_exit n)).
+Proof.
+ induction sl; intros.
+ simpl in H; simpl in H0; monadInv H0.
+ rewrite <- H2. constructor. apply exec_Sseq_stop. auto. congruence.
+ simpl in H; simpl in H0; monadInv H0.
+ eapply IHsl with (body := Sblock (Sseq body s0)); eauto.
+ change (Out_exit (lblstmts_length sl + n))
+ with (outcome_block (Out_exit (S (lblstmts_length sl + n)))).
+ constructor. apply exec_Sseq_stop. auto. congruence.
+Qed.
+
+Lemma transl_lblstmts_return:
+ forall e m1 t m2 sl body optv tsl nbrk ncnt,
+ exec_stmt tprog e m1 body t m2 (Out_return optv) ->
+ transl_lblstmts nbrk ncnt sl body = Some tsl ->
+ exec_stmt tprog e m1 tsl t m2 (Out_return optv).
+Proof.
+ induction sl; intros.
+ simpl in H; simpl in H0; monadInv H0.
+ rewrite <- H2. change (Out_return optv) with (outcome_block (Out_return optv)).
+ constructor. apply exec_Sseq_stop. auto. congruence.
+ simpl in H; simpl in H0; monadInv H0.
+ eapply IHsl with (body := Sblock (Sseq body s0)); eauto.
+ change (Out_return optv) with (outcome_block (Out_return optv)).
+ constructor. apply exec_Sseq_stop. auto. congruence.
+Qed.
+
+
+(** Correctness of Csharpminor construction functions *)
+
+Lemma make_intconst_correct:
+ forall n le e m1,
+ Csharpminor.eval_expr tprog le e m1 (make_intconst n) E0 m1 (Vint n).
+Proof.
+ intros. unfold make_intconst. econstructor. constructor. reflexivity.
+Qed.
+
+Lemma make_floatconst_correct:
+ forall n le e m1,
+ Csharpminor.eval_expr tprog le e m1 (make_floatconst n) E0 m1 (Vfloat n).
+Proof.
+ intros. unfold make_floatconst. econstructor. constructor. reflexivity.
+Qed.
+
+Lemma make_unop_correct:
+ forall op le e m1 a ta m2 va v,
+ Csharpminor.eval_expr tprog le e m1 a ta m2 va ->
+ eval_operation op (va :: nil) m2 = Some v ->
+ Csharpminor.eval_expr tprog le e m1 (make_unop op a) ta m2 v.
+Proof.
+ intros. unfold make_unop. econstructor. econstructor. eauto. constructor.
+ traceEq. auto.
+Qed.
+
+Lemma make_binop_correct:
+ forall op le e m1 a ta m2 va b tb m3 vb t v,
+ Csharpminor.eval_expr tprog le e m1 a ta m2 va ->
+ Csharpminor.eval_expr tprog le e m2 b tb m3 vb ->
+ eval_operation op (va :: vb :: nil) m3 = Some v ->
+ t = ta ** tb ->
+ Csharpminor.eval_expr tprog le e m1 (make_binop op a b) t m3 v.
+Proof.
+ intros. unfold make_binop.
+ econstructor. econstructor. eauto. econstructor. eauto. constructor.
+ reflexivity. traceEq. auto.
+Qed.
+
+Hint Resolve make_intconst_correct make_floatconst_correct
+ make_unop_correct make_binop_correct: cshm.
+Hint Extern 2 (@eq trace _ _) => traceEq: cshm.
+
+Remark Vtrue_is_true: Val.is_true Vtrue.
+Proof.
+ simpl. apply Int.one_not_zero.
+Qed.
+
+Remark Vfalse_is_false: Val.is_false Vfalse.
+Proof.
+ simpl. auto.
+Qed.
+
+Lemma make_boolean_correct_true:
+ forall le e m1 a t m2 v ty,
+ Csharpminor.eval_expr tprog le e m1 a t m2 v ->
+ is_true v ty ->
+ exists vb,
+ Csharpminor.eval_expr tprog le e m1 (make_boolean a ty) t m2 vb
+ /\ Val.is_true vb.
+Proof.
+ intros until ty; intros EXEC VTRUE.
+ destruct ty; simpl;
+ try (exists v; intuition; inversion VTRUE; simpl; auto; fail).
+ exists Vtrue; split.
+ eapply make_binop_correct; eauto with cshm.
+ inversion VTRUE; simpl.
+ replace (Float.cmp Cne f0 Float.zero) with (negb (Float.cmp Ceq f0 Float.zero)).
+ rewrite Float.eq_zero_false. reflexivity. auto.
+ rewrite Float.cmp_ne_eq. auto.
+ apply Vtrue_is_true.
+Qed.
+
+Lemma make_boolean_correct_false:
+ forall le e m1 a t m2 v ty,
+ Csharpminor.eval_expr tprog le e m1 a t m2 v ->
+ is_false v ty ->
+ exists vb,
+ Csharpminor.eval_expr tprog le e m1 (make_boolean a ty) t m2 vb
+ /\ Val.is_false vb.
+Proof.
+ intros until ty; intros EXEC VFALSE.
+ destruct ty; simpl;
+ try (exists v; intuition; inversion VFALSE; simpl; auto; fail).
+ exists Vfalse; split.
+ eapply make_binop_correct; eauto with cshm.
+ inversion VFALSE; simpl.
+ replace (Float.cmp Cne Float.zero Float.zero) with (negb (Float.cmp Ceq Float.zero Float.zero)).
+ rewrite Float.eq_zero_true. reflexivity.
+ rewrite Float.cmp_ne_eq. auto.
+ apply Vfalse_is_false.
+Qed.
+
+Lemma make_neg_correct:
+ forall a tya c ta va v le e m1 m2,
+ sem_neg va tya = Some v ->
+ make_neg a tya = Some c ->
+ eval_expr tprog le e m1 a ta m2 va ->
+ eval_expr tprog le e m1 c ta m2 v.
+Proof.
+ intros until m2; intro SEM. unfold make_neg.
+ functional inversion SEM; intros.
+ inversion H4. eapply make_binop_correct; eauto with cshm.
+ inversion H4. eauto with cshm.
+Qed.
+
+Lemma make_notbool_correct:
+ forall a tya c ta va v le e m1 m2,
+ sem_notbool va tya = Some v ->
+ make_notbool a tya = c ->
+ eval_expr tprog le e m1 a ta m2 va ->
+ eval_expr tprog le e m1 c ta m2 v.
+Proof.
+ intros until m2; intro SEM. unfold make_notbool.
+ functional inversion SEM; intros; inversion H4; simpl;
+ eauto with cshm.
+ eapply make_binop_correct.
+ eapply make_binop_correct. eauto. eauto with cshm.
+ simpl; reflexivity. reflexivity. eauto with cshm.
+ simpl. rewrite Float.cmp_ne_eq.
+ destruct (Float.cmp Ceq f Float.zero); reflexivity.
+ traceEq.
+Qed.
+
+Lemma make_notint_correct:
+ forall a tya c ta va v le e m1 m2,
+ sem_notint va = Some v ->
+ make_notint a tya = c ->
+ eval_expr tprog le e m1 a ta m2 va ->
+ eval_expr tprog le e m1 c ta m2 v.
+Proof.
+ intros until m2; intro SEM. unfold make_notint.
+ functional inversion SEM; intros.
+ inversion H2; eauto with cshm.
+Qed.
+
+Definition binary_constructor_correct
+ (make: expr -> type -> expr -> type -> option expr)
+ (sem: val -> type -> val -> type -> option val): Prop :=
+ forall a tya b tyb c ta va tb vb v le e m1 m2 m3,
+ sem va tya vb tyb = Some v ->
+ make a tya b tyb = Some c ->
+ eval_expr tprog le e m1 a ta m2 va ->
+ eval_expr tprog le e m2 b tb m3 vb ->
+ eval_expr tprog le e m1 c (ta ** tb) m3 v.
+
+Definition binary_constructor_correct'
+ (make: expr -> type -> expr -> type -> option expr)
+ (sem: val -> val -> option val): Prop :=
+ forall a tya b tyb c ta va tb vb v le e m1 m2 m3,
+ sem va vb = Some v ->
+ make a tya b tyb = Some c ->
+ eval_expr tprog le e m1 a ta m2 va ->
+ eval_expr tprog le e m2 b tb m3 vb ->
+ eval_expr tprog le e m1 c (ta ** tb) m3 v.
+
+Lemma make_add_correct: binary_constructor_correct make_add sem_add.
+Proof.
+ red; intros until m3. intro SEM. unfold make_add.
+ functional inversion SEM; rewrite H0; intros.
+ inversion H7. eauto with cshm.
+ inversion H7. eauto with cshm.
+ inversion H7.
+ eapply make_binop_correct. eauto.
+ eapply make_binop_correct. eauto with cshm. eauto.
+ simpl. reflexivity. reflexivity.
+ simpl. reflexivity. traceEq.
+Qed.
+
+Lemma make_sub_correct: binary_constructor_correct make_sub sem_sub.
+Proof.
+ red; intros until m3. intro SEM. unfold make_sub.
+ functional inversion SEM; rewrite H0; intros;
+ inversion H7; eauto with cshm.
+ eapply make_binop_correct. eauto.
+ eapply make_binop_correct. eauto with cshm. eauto.
+ simpl. reflexivity. reflexivity.
+ simpl. reflexivity. traceEq.
+ inversion H9. eapply make_binop_correct.
+ eapply make_binop_correct; eauto.
+ simpl. unfold eq_block; rewrite H3. reflexivity.
+ eauto with cshm. simpl. rewrite H8. reflexivity. traceEq.
+Qed.
+
+Lemma make_mul_correct: binary_constructor_correct make_mul sem_mul.
+Proof.
+ red; intros until m3. intro SEM. unfold make_mul.
+ functional inversion SEM; rewrite H0; intros;
+ inversion H7; eauto with cshm.
+Qed.
+
+Lemma make_div_correct: binary_constructor_correct make_div sem_div.
+Proof.
+ red; intros until m3. intro SEM. unfold make_div.
+ functional inversion SEM; rewrite H0; intros.
+ inversion H8. eapply make_binop_correct; eauto with cshm.
+ simpl. rewrite H7; auto.
+ inversion H8. eapply make_binop_correct; eauto with cshm.
+ simpl. rewrite H7; auto.
+ inversion H7; eauto with cshm.
+Qed.
+
+Lemma make_mod_correct: binary_constructor_correct make_mod sem_mod.
+ red; intros until m3. intro SEM. unfold make_mod.
+ functional inversion SEM; rewrite H0; intros.
+ inversion H8. eapply make_binop_correct; eauto with cshm.
+ simpl. rewrite H7; auto.
+ inversion H8. eapply make_binop_correct; eauto with cshm.
+ simpl. rewrite H7; auto.
+Qed.
+
+Lemma make_and_correct: binary_constructor_correct' make_and sem_and.
+Proof.
+ red; intros until m3. intro SEM. unfold make_and.
+ functional inversion SEM. intros. inversion H4.
+ eauto with cshm.
+Qed.
+
+Lemma make_or_correct: binary_constructor_correct' make_or sem_or.
+Proof.
+ red; intros until m3. intro SEM. unfold make_or.
+ functional inversion SEM. intros. inversion H4.
+ eauto with cshm.
+Qed.
+
+Lemma make_xor_correct: binary_constructor_correct' make_xor sem_xor.
+Proof.
+ red; intros until m3. intro SEM. unfold make_xor.
+ functional inversion SEM. intros. inversion H4.
+ eauto with cshm.
+Qed.
+
+Lemma make_shl_correct: binary_constructor_correct' make_shl sem_shl.
+Proof.
+ red; intros until m3. intro SEM. unfold make_shl.
+ functional inversion SEM. intros. inversion H5.
+ eapply make_binop_correct; eauto with cshm.
+ simpl. rewrite H4. auto.
+Qed.
+
+Lemma make_shr_correct: binary_constructor_correct make_shr sem_shr.
+Proof.
+ red; intros until m3. intro SEM. unfold make_shr.
+ functional inversion SEM; intros; rewrite H0 in H8; inversion H8.
+ eapply make_binop_correct; eauto with cshm.
+ simpl; rewrite H7; auto.
+ eapply make_binop_correct; eauto with cshm.
+ simpl; rewrite H7; auto.
+Qed.
+
+Lemma make_cmp_correct:
+ forall cmp a tya b tyb c ta va tb vb v le e m1 m2 m3,
+ sem_cmp cmp va tya vb tyb m3 = Some v ->
+ make_cmp cmp a tya b tyb = Some c ->
+ eval_expr tprog le e m1 a ta m2 va ->
+ eval_expr tprog le e m2 b tb m3 vb ->
+ eval_expr tprog le e m1 c (ta ** tb) m3 v.
+Proof.
+ intros until m3. intro SEM. unfold make_cmp.
+ functional inversion SEM; rewrite H0; intros.
+ inversion H8. eauto with cshm.
+ inversion H8. eauto with cshm.
+ inversion H8. eauto with cshm.
+ inversion H9. eapply make_binop_correct; eauto with cshm.
+ simpl. functional inversion H; subst; unfold eval_compare_null;
+ rewrite H8; auto.
+ inversion H10. eapply make_binop_correct; eauto with cshm.
+ simpl. rewrite H3. unfold eq_block; rewrite H9. auto.
+Qed.
+
+Lemma transl_unop_correct:
+ forall op a tya c ta va v le e m1 m2,
+ transl_unop op a tya = Some c ->
+ sem_unary_operation op va tya = Some v ->
+ eval_expr tprog le e m1 a ta m2 va ->
+ eval_expr tprog le e m1 c ta m2 v.
+Proof.
+ intros. destruct op; simpl in *.
+ eapply make_notbool_correct; eauto. congruence.
+ eapply make_notint_correct with (tya := tya); eauto. congruence.
+ eapply make_neg_correct; eauto.
+Qed.
+
+Lemma transl_binop_correct:
+forall op a tya b tyb c ta va tb vb v le e m1 m2 m3,
+ transl_binop op a tya b tyb = Some c ->
+ sem_binary_operation op va tya vb tyb m3 = Some v ->
+ eval_expr tprog le e m1 a ta m2 va ->
+ eval_expr tprog le e m2 b tb m3 vb ->
+ eval_expr tprog le e m1 c (ta ** tb) m3 v.
+Proof.
+ intros. destruct op; simpl in *.
+ eapply make_add_correct; eauto.
+ eapply make_sub_correct; eauto.
+ eapply make_mul_correct; eauto.
+ eapply make_div_correct; eauto.
+ eapply make_mod_correct; eauto.
+ eapply make_and_correct; eauto.
+ eapply make_or_correct; eauto.
+ eapply make_xor_correct; eauto.
+ eapply make_shl_correct; eauto.
+ eapply make_shr_correct; eauto.
+ eapply make_cmp_correct; eauto.
+ eapply make_cmp_correct; eauto.
+ eapply make_cmp_correct; eauto.
+ eapply make_cmp_correct; eauto.
+ eapply make_cmp_correct; eauto.
+ eapply make_cmp_correct; eauto.
+Qed.
+
+Lemma make_cast_correct:
+ forall le e m1 a t m2 v ty1 ty2 v',
+ eval_expr tprog le e m1 a t m2 v ->
+ cast v ty1 ty2 v' ->
+ eval_expr tprog le e m1 (make_cast ty1 ty2 a) t m2 v'.
+Proof.
+ unfold make_cast, make_cast1, make_cast2, make_unop.
+ intros until v'; intros EVAL CAST.
+ inversion CAST; clear CAST; subst; auto.
+ (* cast_int_int *)
+ destruct sz2; destruct si2; repeat econstructor; eauto with cshm.
+ (* cast_float_int *)
+ destruct sz2; destruct si2; repeat econstructor; eauto with cshm; simpl; auto.
+ (* cast_int_float *)
+ destruct sz2; destruct si1; unfold make_floatofint, make_unop; repeat econstructor; eauto with cshm; simpl; auto.
+ (* cast_float_float *)
+ destruct sz2; repeat econstructor; eauto with cshm.
+Qed.
+
+Lemma make_load_correct:
+ forall addr ty code b ofs v le e m1 t m2,
+ make_load addr ty = Some code ->
+ eval_expr tprog le e m1 addr t m2 (Vptr b ofs) ->
+ load_value_of_type ty m2 b ofs = Some v ->
+ eval_expr tprog le e m1 code t m2 v.
+Proof.
+ unfold make_load, load_value_of_type.
+ intros until m2; intros MKLOAD EVEXP LDVAL.
+ destruct (access_mode ty); inversion MKLOAD.
+ (* access_mode ty = By_value m *)
+ apply eval_Eload with (Vptr b ofs); auto.
+ (* access_mode ty = By_reference *)
+ subst code. inversion LDVAL. auto.
+Qed.
+
+Lemma make_store_correct:
+ forall addr ty rhs code e m1 t1 m2 b ofs t2 m3 v m4,
+ make_store addr ty rhs = Some code ->
+ eval_expr tprog nil e m1 addr t1 m2 (Vptr b ofs) ->
+ eval_expr tprog nil e m2 rhs t2 m3 v ->
+ store_value_of_type ty m3 b ofs v = Some m4 ->
+ exec_stmt tprog e m1 code (t1 ** t2) m4 Out_normal.
+Proof.
+ unfold make_store, store_value_of_type.
+ intros until m4; intros MKSTORE EV1 EV2 STVAL.
+ destruct (access_mode ty); inversion MKSTORE.
+ (* access_mode ty = By_value m *)
+ eapply eval_Sstore; eauto.
+Qed.
+
+End CONSTRUCTORS.
+
diff --git a/cfrontend/Cshmgenproof3.v b/cfrontend/Cshmgenproof3.v
new file mode 100644
index 0000000..b33771b
--- /dev/null
+++ b/cfrontend/Cshmgenproof3.v
@@ -0,0 +1,1503 @@
+(** * Correctness of the C front end, part 3: semantic preservation *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import Integers.
+Require Import Floats.
+Require Import AST.
+Require Import Values.
+Require Import Events.
+Require Import Mem.
+Require Import Globalenvs.
+Require Import Csyntax.
+Require Import Csem.
+Require Import Ctyping.
+Require Import Csharpminor.
+Require Import Cshmgen.
+Require Import Cshmgenproof1.
+Require Import Cshmgenproof2.
+
+Section CORRECTNESS.
+
+Variable prog: Csyntax.program.
+Variable tprog: Csharpminor.program.
+Hypothesis WTPROG: wt_program prog.
+Hypothesis TRANSL: transl_program prog = Some tprog.
+
+Let ge := Csem.globalenv prog.
+Let tge := Genv.globalenv (Csharpminor.program_of_program tprog).
+
+Lemma symbols_preserved:
+ forall s, Genv.find_symbol tge s = Genv.find_symbol ge s.
+Proof.
+ intros. unfold ge, Csem.globalenv, tge.
+ apply Genv.find_symbol_transf_partial with transl_fundef.
+ apply transform_program_of_program; auto.
+Qed.
+
+Lemma functions_translated:
+ forall v f,
+ Genv.find_funct ge v = Some f ->
+ exists tf, Genv.find_funct tge v = Some tf /\ transl_fundef f = Some tf.
+Proof.
+ intros.
+ generalize (Genv.find_funct_transf_partial transl_fundef (transform_program_of_program _ _ TRANSL) H).
+ intros [A B].
+ destruct (transl_fundef f). exists f0; split. assumption. auto. congruence.
+Qed.
+
+Lemma function_ptr_translated:
+ forall b f,
+ Genv.find_funct_ptr ge b = Some f ->
+ exists tf, Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = Some tf.
+Proof.
+ intros.
+ generalize (Genv.find_funct_ptr_transf_partial transl_fundef (transform_program_of_program _ _ TRANSL) H).
+ intros [A B].
+ destruct (transl_fundef f). exists f0; split. assumption. auto. congruence.
+Qed.
+
+Lemma functions_well_typed:
+ forall v f,
+ Genv.find_funct ge v = Some f ->
+ wt_fundef (global_typenv prog) f.
+Proof.
+ intros. inversion WTPROG.
+ apply (@Genv.find_funct_prop _ (wt_fundef (global_typenv prog))
+ (Csyntax.program_of_program prog) v f).
+ intros. apply wt_program_funct with id. assumption.
+ assumption.
+Qed.
+
+Lemma function_ptr_well_typed:
+ forall b f,
+ Genv.find_funct_ptr ge b = Some f ->
+ wt_fundef (global_typenv prog) f.
+Proof.
+ intros. inversion WTPROG.
+ apply (@Genv.find_funct_ptr_prop _ (wt_fundef (global_typenv prog))
+ (Csyntax.program_of_program prog) b f).
+ intros. apply wt_program_funct with id. assumption.
+ assumption.
+Qed.
+
+(** ** Matching between environments *)
+
+Definition match_var_kind (ty: type) (vk: var_kind) : Prop :=
+ match access_mode ty with
+ | By_value chunk => vk = Vscalar chunk
+ | _ => True
+ end.
+
+Record match_env (tyenv: typenv) (e: Csem.env) (te: Csharpminor.env) : Prop :=
+ mk_match_env {
+ me_local:
+ forall id b ty,
+ e!id = Some b -> tyenv!id = Some ty ->
+ exists vk, match_var_kind ty vk /\ te!id = Some (b, vk);
+ me_global:
+ forall id ty,
+ e!id = None -> tyenv!id = Some ty ->
+ te!id = None /\
+ (forall chunk, access_mode ty = By_value chunk -> (global_var_env tprog)!id = Some (Vscalar chunk))
+ }.
+
+Definition match_globalenv (tyenv: typenv) (gv: gvarenv): Prop :=
+ forall id ty chunk,
+ tyenv!id = Some ty -> access_mode ty = By_value chunk ->
+ gv!id = Some (Vscalar chunk).
+
+Lemma match_globalenv_match_env_empty:
+ forall tyenv,
+ match_globalenv tyenv (global_var_env tprog) ->
+ match_env tyenv Csem.empty_env Csharpminor.empty_env.
+Proof.
+ intros. unfold Csem.empty_env, Csharpminor.empty_env.
+ constructor.
+ intros until ty. repeat rewrite PTree.gempty. congruence.
+ intros. split.
+ apply PTree.gempty.
+ intros. red in H. eauto.
+Qed.
+
+Lemma match_var_kind_of_type:
+ forall ty vk, var_kind_of_type ty = Some vk -> match_var_kind ty vk.
+Proof.
+ intros; red.
+ caseEq (access_mode ty); auto.
+ intros chunk AM. generalize (var_kind_by_value _ _ AM). congruence.
+Qed.
+
+Lemma match_env_alloc_variables:
+ forall e1 m1 vars e2 m2 lb,
+ Csem.alloc_variables e1 m1 vars e2 m2 lb ->
+ forall tyenv te1 tvars,
+ match_env tyenv e1 te1 ->
+ transl_vars vars = Some tvars ->
+ exists te2,
+ Csharpminor.alloc_variables te1 m1 tvars te2 m2 lb
+ /\ match_env (Ctyping.add_vars tyenv vars) e2 te2.
+Proof.
+ induction 1; intros.
+ simpl in H0. inversion H0; subst; clear H0.
+ exists te1; split. constructor. simpl. auto.
+ generalize H2. simpl.
+ caseEq (var_kind_of_type ty); [intros vk VK | congruence].
+ caseEq (transl_vars vars); [intros tvrs TVARS | congruence].
+ intro EQ; inversion EQ; subst tvars; clear EQ.
+ set (te2 := PTree.set id (b1, vk) te1).
+ assert (match_env (add_var tyenv (id, ty)) (PTree.set id b1 e) te2).
+ inversion H1. unfold te2, add_var. constructor.
+ (* me_local *)
+ intros until ty0. repeat rewrite PTree.gsspec. simpl. destruct (peq id0 id); intros.
+ subst id0. exists vk; split.
+ apply match_var_kind_of_type. congruence. congruence.
+ auto.
+ (* me_global *)
+ intros until ty0. repeat rewrite PTree.gsspec. simpl. destruct (peq id0 id); intros.
+ discriminate.
+ auto.
+ destruct (IHalloc_variables _ _ _ H3 TVARS) as [te3 [ALLOC MENV]].
+ exists te3; split.
+ econstructor; eauto.
+ rewrite (sizeof_var_kind_of_type _ _ VK). auto.
+ auto.
+Qed.
+
+Lemma bind_parameters_match_rec:
+ forall e m1 vars vals m2,
+ Csem.bind_parameters e m1 vars vals m2 ->
+ forall tyenv te tvars,
+ (forall id ty, In (id, ty) vars -> tyenv!id = Some ty) ->
+ match_env tyenv e te ->
+ transl_params vars = Some tvars ->
+ Csharpminor.bind_parameters te m1 tvars vals m2.
+Proof.
+ induction 1; intros.
+ simpl in H1. inversion H1. constructor.
+ generalize H4; clear H4; simpl.
+ caseEq (chunk_of_type ty); [intros chunk CHK | congruence].
+ caseEq (transl_params params); [intros tparams TPARAMS | congruence].
+ intro EQ; inversion EQ; clear EQ; subst tvars.
+ generalize CHK. unfold chunk_of_type.
+ caseEq (access_mode ty); intros; try discriminate.
+ inversion CHK0; clear CHK0; subst m0.
+ unfold store_value_of_type in H0. rewrite H4 in H0.
+ apply bind_parameters_cons with b m1.
+ assert (tyenv!id = Some ty). apply H2. apply in_eq.
+ destruct (me_local _ _ _ H3 _ _ _ H H5) as [vk [A B]].
+ red in A; rewrite H4 in A. congruence.
+ assumption.
+ apply IHbind_parameters with tyenv; auto.
+ intros. apply H2. apply in_cons; auto.
+Qed.
+
+Lemma tyenv_add_vars_norepet:
+ forall vars tyenv,
+ list_norepet (var_names vars) ->
+ (forall id ty,
+ In (id, ty) vars -> (Ctyping.add_vars tyenv vars)!id = Some ty)
+ /\
+ (forall id,
+ ~In id (var_names vars) -> (Ctyping.add_vars tyenv vars)!id = tyenv!id).
+Proof.
+ induction vars; simpl; intros.
+ tauto.
+ destruct a as [id1 ty1]. simpl in *. inversion H; clear H; subst.
+ destruct (IHvars (add_var tyenv (id1, ty1)) H3) as [A B].
+ split; intros.
+ destruct H. inversion H; subst id1 ty1; clear H.
+ rewrite B. unfold add_var. simpl. apply PTree.gss. auto.
+ auto.
+ rewrite B. unfold add_var; simpl. apply PTree.gso. apply sym_not_equal; tauto. tauto.
+Qed.
+
+Lemma bind_parameters_match:
+ forall e m1 params vals vars m2 tyenv tvars te,
+ Csem.bind_parameters e m1 params vals m2 ->
+ list_norepet (var_names params ++ var_names vars) ->
+ match_env (Ctyping.add_vars tyenv (params ++ vars)) e te ->
+ transl_params params = Some tvars ->
+ Csharpminor.bind_parameters te m1 tvars vals m2.
+Proof.
+ intros.
+ eapply bind_parameters_match_rec; eauto.
+ assert (list_norepet (var_names (params ++ vars))).
+ unfold var_names. rewrite List.map_app. assumption.
+ destruct (tyenv_add_vars_norepet _ tyenv H3) as [A B].
+ intros. apply A. apply List.in_or_app. auto.
+Qed.
+
+Definition globvarenv
+ (gv: gvarenv)
+ (vars: list (ident * var_kind * list init_data)) :=
+ List.fold_left
+ (fun gve x => match x with (id, k, init) => PTree.set id k gve end)
+ vars gv.
+
+Definition type_not_by_value (ty: type) : Prop :=
+ match access_mode ty with
+ | By_value _ => False
+ | _ => True
+ end.
+
+Lemma add_global_funs_charact:
+ forall fns tyenv,
+ (forall id ty, tyenv!id = Some ty -> type_not_by_value ty) ->
+ (forall id ty, (add_global_funs tyenv fns)!id = Some ty -> type_not_by_value ty).
+Proof.
+ induction fns; simpl; intros.
+ eauto.
+ apply IHfns with (add_global_fun tyenv a) id.
+ intros until ty0. destruct a as [id1 fn1].
+ unfold add_global_fun; simpl. rewrite PTree.gsspec.
+ destruct (peq id0 id1).
+ intros. inversion H1.
+ unfold type_of_fundef. destruct fn1; exact I.
+ eauto.
+ auto.
+Qed.
+
+Definition global_fun_typenv :=
+ add_global_funs (PTree.empty type) (Csyntax.prog_funct prog).
+
+Lemma add_global_funs_match_global_env:
+ match_globalenv global_fun_typenv (PTree.empty var_kind).
+Proof.
+ intros; red; intros.
+ assert (type_not_by_value ty).
+ apply add_global_funs_charact with (Csyntax.prog_funct prog) (PTree.empty type) id.
+ intros until ty0. rewrite PTree.gempty. congruence.
+ assumption.
+ red in H1. rewrite H0 in H1. contradiction.
+Qed.
+
+Lemma add_global_var_match_globalenv:
+ forall vars tenv gv tvars,
+ match_globalenv tenv gv ->
+ transl_global_vars vars = Some tvars ->
+ match_globalenv (add_global_vars tenv vars) (globvarenv gv tvars).
+Proof.
+ induction vars; intros; simpl.
+ simpl in H0. inversion H0. simpl. auto.
+ destruct a as [[id ty] init]. monadInv H0. subst tvars.
+ simpl. apply IHvars; auto.
+ red. intros until chunk. repeat rewrite PTree.gsspec.
+ destruct (peq id0 id); intros.
+ inversion H1; clear H1; subst id0 ty0.
+ generalize (var_kind_by_value _ _ H2). congruence.
+ red in H. eauto.
+Qed.
+
+Lemma match_global_typenv:
+ match_globalenv (global_typenv prog) (global_var_env tprog).
+Proof.
+ change (global_var_env tprog)
+ with (globvarenv (PTree.empty var_kind) (prog_vars tprog)).
+ unfold global_typenv.
+ apply add_global_var_match_globalenv.
+ apply add_global_funs_match_global_env.
+ monadInv TRANSL. rewrite <- H0. reflexivity.
+Qed.
+
+(** ** Variable accessors *)
+
+Lemma var_get_correct:
+ forall e m id ty loc ofs v tyenv code te le,
+ Csem.eval_lvalue ge e m (Expr (Csyntax.Evar id) ty) E0 m loc ofs ->
+ load_value_of_type ty m loc ofs = Some v ->
+ wt_expr tyenv (Expr (Csyntax.Evar id) ty) ->
+ var_get id ty = Some code ->
+ match_env tyenv e te ->
+ eval_expr tprog le te m code E0 m v.
+Proof.
+ intros. inversion H1; subst; clear H1.
+ unfold load_value_of_type in H0.
+ unfold var_get in H2.
+ caseEq (access_mode ty).
+ (* access mode By_value *)
+ intros chunk ACC. rewrite ACC in H0. rewrite ACC in H2.
+ inversion H2; clear H2; subst.
+ inversion H; subst; clear H.
+ (* local variable *)
+ exploit me_local; eauto. intros [vk [A B]].
+ red in A; rewrite ACC in A.
+ subst vk.
+ eapply eval_Evar.
+ eapply eval_var_ref_local. eauto. assumption.
+ (* global variable *)
+ exploit me_global; eauto. intros [A B].
+ eapply eval_Evar.
+ eapply eval_var_ref_global. auto.
+ fold tge. rewrite symbols_preserved. eauto.
+ eauto. assumption.
+ (* access mode By_reference *)
+ intros ACC. rewrite ACC in H0. rewrite ACC in H2.
+ inversion H0; clear H0; subst.
+ inversion H2; clear H2; subst.
+ inversion H; subst; clear H.
+ (* local variable *)
+ exploit me_local; eauto. intros [vk [A B]].
+ eapply eval_Eaddrof.
+ eapply eval_var_addr_local. eauto.
+ (* global variable *)
+ exploit me_global; eauto. intros [A B].
+ eapply eval_Eaddrof.
+ eapply eval_var_addr_global. auto.
+ fold tge. rewrite symbols_preserved. eauto.
+ (* access mode By_nothing *)
+ intros. rewrite H1 in H0; discriminate.
+Qed.
+
+Lemma var_set_correct:
+ forall e m id ty m1 loc ofs t1 m2 v t2 m3 tyenv code te rhs,
+ Csem.eval_lvalue ge e m (Expr (Csyntax.Evar id) ty) t1 m1 loc ofs ->
+ store_value_of_type ty m2 loc ofs v = Some m3 ->
+ wt_expr tyenv (Expr (Csyntax.Evar id) ty) ->
+ var_set id ty rhs = Some code ->
+ match_env tyenv e te ->
+ eval_expr tprog nil te m1 rhs t2 m2 v ->
+ exec_stmt tprog te m code (t1 ** t2) m3 Out_normal.
+Proof.
+ intros. inversion H1; subst; clear H1.
+ unfold store_value_of_type in H0.
+ unfold var_set in H2.
+ caseEq (access_mode ty).
+ (* access mode By_value *)
+ intros chunk ACC. rewrite ACC in H0. rewrite ACC in H2.
+ inversion H2; clear H2; subst.
+ inversion H; subst; clear H; rewrite E0_left.
+ (* local variable *)
+ exploit me_local; eauto. intros [vk [A B]].
+ red in A; rewrite ACC in A; subst vk.
+ eapply eval_Sassign. eauto.
+ eapply eval_var_ref_local. eauto. assumption.
+ (* global variable *)
+ exploit me_global; eauto. intros [A B].
+ eapply eval_Sassign. eauto.
+ eapply eval_var_ref_global. auto.
+ fold tge. rewrite symbols_preserved. eauto.
+ eauto. assumption.
+ (* access mode By_reference *)
+ intros ACC. rewrite ACC in H0. discriminate.
+ (* access mode By_nothing *)
+ intros. rewrite H1 in H0; discriminate.
+Qed.
+
+(** ** Proof of semantic simulation *)
+
+(** Inductive properties *)
+
+Definition eval_expr_prop
+ (e: Csem.env) (m1: mem) (a: Csyntax.expr) (t: trace) (m2: mem) (v: val) : Prop :=
+ forall tyenv ta te tle
+ (WT: wt_expr tyenv a)
+ (TR: transl_expr a = Some ta)
+ (MENV: match_env tyenv e te),
+ Csharpminor.eval_expr tprog tle te m1 ta t m2 v.
+
+Definition eval_lvalue_prop
+ (e: Csem.env) (m1: mem) (a: Csyntax.expr) (t: trace)
+ (m2: mem) (b: block) (ofs: int) : Prop :=
+ forall tyenv ta te tle
+ (WT: wt_expr tyenv a)
+ (TR: transl_lvalue a = Some ta)
+ (MENV: match_env tyenv e te),
+ Csharpminor.eval_expr tprog tle te m1 ta t m2 (Vptr b ofs).
+
+Definition eval_exprlist_prop
+ (e: Csem.env) (m1: mem) (al: Csyntax.exprlist) (t: trace)
+ (m2: mem) (vl: list val) : Prop :=
+ forall tyenv tal te tle
+ (WT: wt_exprlist tyenv al)
+ (TR: transl_exprlist al = Some tal)
+ (MENV: match_env tyenv e te),
+ Csharpminor.eval_exprlist tprog tle te m1 tal t m2 vl.
+
+Definition transl_outcome (nbrk ncnt: nat) (out: Csem.outcome): Csharpminor.outcome :=
+ match out with
+ | Csem.Out_normal => Csharpminor.Out_normal
+ | Csem.Out_break => Csharpminor.Out_exit nbrk
+ | Csem.Out_continue => Csharpminor.Out_exit ncnt
+ | Csem.Out_return vopt => Csharpminor.Out_return vopt
+ end.
+
+Definition exec_stmt_prop
+ (e: Csem.env) (m1: mem) (s: Csyntax.statement) (t: trace)
+ (m2: mem) (out: Csem.outcome) : Prop :=
+ forall tyenv nbrk ncnt ts te
+ (WT: wt_stmt tyenv s)
+ (TR: transl_statement nbrk ncnt s = Some ts)
+ (MENV: match_env tyenv e te),
+ Csharpminor.exec_stmt tprog te m1 ts t m2 (transl_outcome nbrk ncnt out).
+
+Definition exec_lblstmts_prop
+ (e: Csem.env) (m1: mem) (s: Csyntax.labeled_statements)
+ (t: trace) (m2: mem) (out: Csem.outcome) : Prop :=
+ forall tyenv nbrk ncnt body ts te m0 t0
+ (WT: wt_lblstmts tyenv s)
+ (TR: transl_lblstmts (lblstmts_length s)
+ (1 + lblstmts_length s + ncnt)
+ s body = Some ts)
+ (MENV: match_env tyenv e te)
+ (BODY: Csharpminor.exec_stmt tprog te m0 body t0 m1 Out_normal),
+ Csharpminor.exec_stmt tprog te m0 ts (t0 ** t) m2
+ (transl_outcome nbrk ncnt (outcome_switch out)).
+
+Definition eval_funcall_prop
+ (m1: mem) (f: Csyntax.fundef) (params: list val)
+ (t: trace) (m2: mem) (res: val) : Prop :=
+ forall tf
+ (WT: wt_fundef (global_typenv prog) f)
+ (TR: transl_fundef f = Some tf),
+ Csharpminor.eval_funcall tprog m1 tf params t m2 res.
+
+(*
+Set Printing Depth 100.
+Check (Csem.eval_funcall_ind6 ge eval_expr_prop eval_lvalue_prop
+ eval_exprlist_prop exec_stmt_prop exec_lblstmts_prop eval_funcall_prop).
+*)
+
+Lemma transl_Econst_int_correct:
+ (forall (e : Csem.env) (m : mem) (i : int) (ty : type),
+ eval_expr_prop e m (Expr (Econst_int i) ty) E0 m (Vint i)).
+Proof.
+ intros; red; intros.
+ monadInv TR. subst ta. apply make_intconst_correct.
+Qed.
+
+Lemma transl_Econst_float_correct:
+ (forall (e : Csem.env) (m : mem) (f0 : float) (ty : type),
+ eval_expr_prop e m (Expr (Econst_float f0) ty) E0 m (Vfloat f0)).
+Proof.
+ intros; red; intros.
+ monadInv TR. subst ta. apply make_floatconst_correct.
+Qed.
+
+Lemma transl_Elvalue_correct:
+ (forall (e : Csem.env) (m : mem) (a : expr_descr) (ty : type)
+ (t : trace) (m1 : mem) (loc : block) (ofs : int) (v : val),
+ eval_lvalue ge e m (Expr a ty) t m1 loc ofs ->
+ eval_lvalue_prop e m (Expr a ty) t m1 loc ofs ->
+ load_value_of_type ty m1 loc ofs = Some v ->
+ eval_expr_prop e m (Expr a ty) t m1 v).
+Proof.
+ intros; red; intros.
+ exploit transl_expr_lvalue; eauto.
+ intros [[id [EQ VARGET]] | [tb [TRLVAL MKLOAD]]].
+ (* Case a is a variable *)
+ subst a.
+ assert (t = E0 /\ m1 = m). inversion H; auto.
+ destruct H2; subst t m1.
+ eapply var_get_correct; eauto.
+ (* Case a is another lvalue *)
+ eapply make_load_correct; eauto.
+Qed.
+
+Lemma transl_Eaddrof_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t : trace)
+ (m1 : mem) (loc : block) (ofs : int) (ty : type),
+ eval_lvalue ge e m a t m1 loc ofs ->
+ eval_lvalue_prop e m a t m1 loc ofs ->
+ eval_expr_prop e m (Expr (Csyntax.Eaddrof a) ty) t m1 (Vptr loc ofs)).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR.
+ eauto.
+Qed.
+
+Lemma transl_Esizeof_correct:
+ (forall (e : Csem.env) (m : mem) (ty' ty : type),
+ eval_expr_prop e m (Expr (Esizeof ty') ty) E0 m
+ (Vint (Int.repr (Csyntax.sizeof ty')))).
+Proof.
+ intros; red; intros. monadInv TR. subst ta. apply make_intconst_correct.
+Qed.
+
+Lemma transl_Eunop_correct:
+ (forall (e : Csem.env) (m : mem) (op : unary_operation)
+ (a : Csyntax.expr) (ty : type) (t : trace) (m1 : mem) (v1 v : val),
+ Csem.eval_expr ge e m a t m1 v1 ->
+ eval_expr_prop e m a t m1 v1 ->
+ sem_unary_operation op v1 (typeof a) = Some v ->
+ eval_expr_prop e m (Expr (Eunop op a) ty) t m1 v).
+Proof.
+ intros; red; intros.
+ inversion WT; clear WT; subst.
+ monadInv TR.
+ eapply transl_unop_correct; eauto.
+Qed.
+
+Lemma transl_Ebinop_correct:
+ (forall (e : Csem.env) (m : mem) (op : binary_operation)
+ (a1 a2 : Csyntax.expr) (ty : type) (t1 : trace) (m1 : mem)
+ (v1 : val) (t2 : trace) (m2 : mem) (v2 v : val),
+ Csem.eval_expr ge e m a1 t1 m1 v1 ->
+ eval_expr_prop e m a1 t1 m1 v1 ->
+ Csem.eval_expr ge e m1 a2 t2 m2 v2 ->
+ eval_expr_prop e m1 a2 t2 m2 v2 ->
+ sem_binary_operation op v1 (typeof a1) v2 (typeof a2) m2 = Some v ->
+ eval_expr_prop e m (Expr (Ebinop op a1 a2) ty) (t1 ** t2) m2 v).
+Proof.
+ intros; red; intros.
+ inversion WT; clear WT; subst.
+ monadInv TR.
+ eapply transl_binop_correct; eauto.
+Qed.
+
+Lemma transl_Eorbool_1_correct:
+ (forall (e : Csem.env) (m : mem) (a1 a2 : Csyntax.expr) (t : trace)
+ (m1 : mem) (v1 : val) (ty : type),
+ Csem.eval_expr ge e m a1 t m1 v1 ->
+ eval_expr_prop e m a1 t m1 v1 ->
+ is_true v1 (typeof a1) ->
+ eval_expr_prop e m (Expr (Eorbool a1 a2) ty) t m1 Vtrue).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. monadInv TR.
+ rewrite <- H3; unfold make_orbool.
+ exploit make_boolean_correct_true; eauto. intros [vb [EVAL ISTRUE]].
+ eapply eval_Econdition_true; eauto.
+ unfold Vtrue; apply make_intconst_correct. traceEq.
+Qed.
+
+Lemma transl_Eorbool_2_correct:
+ (forall (e : Csem.env) (m : mem) (a1 a2 : Csyntax.expr) (ty : type)
+ (t1 : trace) (m1 : mem) (v1 : val) (t2 : trace) (m2 : mem)
+ (v2 v : val),
+ Csem.eval_expr ge e m a1 t1 m1 v1 ->
+ eval_expr_prop e m a1 t1 m1 v1 ->
+ is_false v1 (typeof a1) ->
+ Csem.eval_expr ge e m1 a2 t2 m2 v2 ->
+ eval_expr_prop e m1 a2 t2 m2 v2 ->
+ bool_of_val v2 (typeof a2) v ->
+ eval_expr_prop e m (Expr (Eorbool a1 a2) ty) (t1 ** t2) m2 v).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. monadInv TR.
+ rewrite <- H6; unfold make_orbool.
+ exploit make_boolean_correct_false. eapply H0; eauto. eauto. intros [vb [EVAL ISFALSE]].
+ eapply eval_Econdition_false; eauto.
+ inversion H4; subst.
+ exploit make_boolean_correct_true. eapply H3; eauto. eauto. intros [vc [EVAL' ISTRUE']].
+ eapply eval_Econdition_true; eauto.
+ unfold Vtrue; apply make_intconst_correct. traceEq.
+ exploit make_boolean_correct_false. eapply H3; eauto. eauto. intros [vc [EVAL' ISFALSE']].
+ eapply eval_Econdition_false; eauto.
+ unfold Vfalse; apply make_intconst_correct. traceEq.
+Qed.
+
+Lemma transl_Eandbool_1_correct:
+ (forall (e : Csem.env) (m : mem) (a1 a2 : Csyntax.expr) (t : trace)
+ (m1 : mem) (v1 : val) (ty : type),
+ Csem.eval_expr ge e m a1 t m1 v1 ->
+ eval_expr_prop e m a1 t m1 v1 ->
+ is_false v1 (typeof a1) ->
+ eval_expr_prop e m (Expr (Eandbool a1 a2) ty) t m1 Vfalse).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. monadInv TR.
+ rewrite <- H3; unfold make_andbool.
+ exploit make_boolean_correct_false; eauto. intros [vb [EVAL ISFALSE]].
+ eapply eval_Econdition_false; eauto.
+ unfold Vfalse; apply make_intconst_correct. traceEq.
+Qed.
+
+Lemma transl_Eandbool_2_correct:
+ (forall (e : Csem.env) (m : mem) (a1 a2 : Csyntax.expr) (ty : type)
+ (t1 : trace) (m1 : mem) (v1 : val) (t2 : trace) (m2 : mem)
+ (v2 v : val),
+ Csem.eval_expr ge e m a1 t1 m1 v1 ->
+ eval_expr_prop e m a1 t1 m1 v1 ->
+ is_true v1 (typeof a1) ->
+ Csem.eval_expr ge e m1 a2 t2 m2 v2 ->
+ eval_expr_prop e m1 a2 t2 m2 v2 ->
+ bool_of_val v2 (typeof a2) v ->
+ eval_expr_prop e m (Expr (Eandbool a1 a2) ty) (t1 ** t2) m2 v).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. monadInv TR.
+ rewrite <- H6; unfold make_andbool.
+ exploit make_boolean_correct_true. eapply H0; eauto. eauto. intros [vb [EVAL ISTRUE]].
+ eapply eval_Econdition_true; eauto.
+ inversion H4; subst.
+ exploit make_boolean_correct_true. eapply H3; eauto. eauto. intros [vc [EVAL' ISTRUE']].
+ eapply eval_Econdition_true; eauto.
+ unfold Vtrue; apply make_intconst_correct. traceEq.
+ exploit make_boolean_correct_false. eapply H3; eauto. eauto. intros [vc [EVAL' ISFALSE']].
+ eapply eval_Econdition_false; eauto.
+ unfold Vfalse; apply make_intconst_correct. traceEq.
+Qed.
+
+Lemma transl_Ecast_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (ty : type)
+ (t : trace) (m1 : mem) (v1 v : val),
+ Csem.eval_expr ge e m a t m1 v1 ->
+ eval_expr_prop e m a t m1 v1 ->
+ cast v1 (typeof a) ty v ->
+ eval_expr_prop e m (Expr (Ecast ty a) ty) t m1 v).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. monadInv TR. subst ta.
+ eapply make_cast_correct; eauto.
+Qed.
+
+Lemma transl_Ecall_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr)
+ (bl : Csyntax.exprlist) (ty : type) (m3 : mem) (vres : val)
+ (t1 : trace) (m1 : mem) (vf : val) (t2 : trace) (m2 : mem)
+ (vargs : list val) (f : Csyntax.fundef) (t3 : trace),
+ Csem.eval_expr ge e m a t1 m1 vf ->
+ eval_expr_prop e m a t1 m1 vf ->
+ Csem.eval_exprlist ge e m1 bl t2 m2 vargs ->
+ eval_exprlist_prop e m1 bl t2 m2 vargs ->
+ Genv.find_funct ge vf = Some f ->
+ type_of_fundef f = typeof a ->
+ Csem.eval_funcall ge m2 f vargs t3 m3 vres ->
+ eval_funcall_prop m2 f vargs t3 m3 vres ->
+ eval_expr_prop e m (Expr (Csyntax.Ecall a bl) ty) (t1 ** t2 ** t3) m3
+ vres).
+Proof.
+ intros; red; intros.
+ inversion WT; clear WT; subst.
+ simpl in TR.
+ caseEq (classify_fun (typeof a)).
+ 2: intros; rewrite H7 in TR; discriminate.
+ intros targs tres EQ. rewrite EQ in TR.
+ monadInv TR. clear TR. subst ta.
+ rewrite <- H4 in EQ.
+ exploit functions_translated; eauto. intros [tf [FIND TRL]].
+ econstructor.
+ eapply H0; eauto.
+ eapply H2; eauto.
+ eexact FIND.
+ eapply transl_fundef_sig1; eauto.
+ eapply H6; eauto.
+ eapply functions_well_typed; eauto.
+ auto.
+Qed.
+
+Lemma transl_Evar_local_correct:
+ (forall (e : Csem.env) (m : mem) (id : positive) (l : block)
+ (ty : type),
+ e ! id = Some l ->
+ eval_lvalue_prop e m (Expr (Csyntax.Evar id) ty) E0 m l Int.zero).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. monadInv TR. subst ta.
+ exploit (me_local _ _ _ MENV); eauto. intros [vk [A B]].
+ econstructor. eapply eval_var_addr_local. eauto.
+Qed.
+
+Lemma transl_Evar_global_correct:
+ (forall (e : PTree.t block) (m : mem) (id : positive) (l : block)
+ (ty : type),
+ e ! id = None ->
+ Genv.find_symbol ge id = Some l ->
+ eval_lvalue_prop e m (Expr (Csyntax.Evar id) ty) E0 m l Int.zero).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. monadInv TR. subst ta.
+ exploit (me_global _ _ _ MENV); eauto. intros [A B].
+ econstructor. eapply eval_var_addr_global. eauto.
+ rewrite symbols_preserved. auto.
+Qed.
+
+Lemma transl_Ederef_correct:
+ (forall (e : Csem.env) (m m1 : mem) (a : Csyntax.expr) (t : trace)
+ (ofs : int) (ty : type) (l : block),
+ Csem.eval_expr ge e m a t m1 (Vptr l ofs) ->
+ eval_expr_prop e m a t m1 (Vptr l ofs) ->
+ eval_lvalue_prop e m (Expr (Ederef a) ty) t m1 l ofs).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR.
+ eauto.
+Qed.
+
+Lemma transl_Eindex_correct:
+ (forall (e : Csem.env) (m : mem) (a1 : Csyntax.expr) (t1 : trace)
+ (m1 : mem) (v1 : val) (a2 : Csyntax.expr) (t2 : trace) (m2 : mem)
+ (v2 : val) (l : block) (ofs : int) (ty : type),
+ Csem.eval_expr ge e m a1 t1 m1 v1 ->
+ eval_expr_prop e m a1 t1 m1 v1 ->
+ Csem.eval_expr ge e m1 a2 t2 m2 v2 ->
+ eval_expr_prop e m1 a2 t2 m2 v2 ->
+ sem_add v1 (typeof a1) v2 (typeof a2) = Some (Vptr l ofs) ->
+ eval_lvalue_prop e m (Expr (Eindex a1 a2) ty) (t1 ** t2) m2 l ofs).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR. monadInv TR.
+ eapply (make_add_correct tprog); eauto.
+Qed.
+
+Lemma transl_Efield_struct_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t : trace)
+ (m1 : mem) (l : block) (ofs : int) (fList : fieldlist) (i : ident)
+ (ty : type) (delta : Z),
+ eval_lvalue ge e m a t m1 l ofs ->
+ eval_lvalue_prop e m a t m1 l ofs ->
+ typeof a = Tstruct fList ->
+ field_offset i fList = Some delta ->
+ eval_lvalue_prop e m (Expr (Efield a i) ty) t m1 l
+ (Int.add ofs (Int.repr delta))).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst.
+ simpl in TR. rewrite H1 in TR. monadInv TR.
+ rewrite <- H5. eapply make_binop_correct; eauto.
+ apply make_intconst_correct.
+ simpl. congruence. traceEq.
+Qed.
+
+Lemma transl_Efield_union_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t : trace)
+ (m1 : mem) (l : block) (ofs : int) (fList : fieldlist) (i : ident)
+ (ty : type),
+ eval_lvalue ge e m a t m1 l ofs ->
+ eval_lvalue_prop e m a t m1 l ofs ->
+ typeof a = Tunion fList ->
+ eval_lvalue_prop e m (Expr (Efield a i) ty) t m1 l ofs).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst.
+ simpl in TR. rewrite H1 in TR. eauto.
+Qed.
+
+Lemma transl_Enil_correct:
+ (forall (e : Csem.env) (m : mem),
+ eval_exprlist_prop e m Csyntax.Enil E0 m nil).
+Proof.
+ intros; red; intros. monadInv TR. subst tal. constructor.
+Qed.
+
+Lemma transl_Econs_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr)
+ (bl : Csyntax.exprlist) (t1 : trace) (m1 : mem) (v : val)
+ (t2 : trace) (m2 : mem) (vl : list val),
+ Csem.eval_expr ge e m a t1 m1 v ->
+ eval_expr_prop e m a t1 m1 v ->
+ Csem.eval_exprlist ge e m1 bl t2 m2 vl ->
+ eval_exprlist_prop e m1 bl t2 m2 vl ->
+ eval_exprlist_prop e m (Csyntax.Econs a bl) (t1 ** t2) m2 (v :: vl)).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst tal. econstructor; eauto.
+Qed.
+
+Lemma transl_Sskip_correct:
+ (forall (e : Csem.env) (m : mem),
+ exec_stmt_prop e m Csyntax.Sskip E0 m Csem.Out_normal).
+Proof.
+ intros; red; intros. monadInv TR. subst ts. simpl. constructor.
+Qed.
+
+Lemma transl_Sexpr_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t : trace)
+ (m1 : mem) (v : val),
+ Csem.eval_expr ge e m a t m1 v ->
+ eval_expr_prop e m a t m1 v ->
+ exec_stmt_prop e m (Csyntax.Sexpr a) t m1 Csem.Out_normal).
+Proof.
+ intros; red; intros; simpl. inversion WT; clear WT; subst.
+ monadInv TR. subst ts.
+ econstructor; eauto.
+Qed.
+
+Lemma transl_Sassign_correct:
+ (forall (e : Csem.env) (m : mem) (a1 a2 : Csyntax.expr) (t1 : trace)
+ (m1 : mem) (loc : block) (ofs : int) (t2 : trace) (m2 : mem)
+ (v2 : val) (m3 : mem),
+ eval_lvalue ge e m a1 t1 m1 loc ofs ->
+ eval_lvalue_prop e m a1 t1 m1 loc ofs ->
+ Csem.eval_expr ge e m1 a2 t2 m2 v2 ->
+ eval_expr_prop e m1 a2 t2 m2 v2 ->
+ store_value_of_type (typeof a1) m2 loc ofs v2 = Some m3 ->
+ exec_stmt_prop e m (Csyntax.Sassign a1 a2) (t1 ** t2) m3
+ Csem.Out_normal).
+Proof.
+ intros; red; intros.
+ inversion WT; subst; clear WT.
+ simpl in TR.
+ caseEq (is_variable a1).
+ (* a = variable id *)
+ intros id ISVAR. rewrite ISVAR in TR.
+ generalize (is_variable_correct _ _ ISVAR). intro EQ.
+ rewrite EQ in H; rewrite EQ in H0; rewrite EQ in H6.
+ monadInv TR.
+ eapply var_set_correct; eauto.
+ (* a is not a variable *)
+ intro ISVAR; rewrite ISVAR in TR. monadInv TR.
+ eapply make_store_correct; eauto.
+Qed.
+
+Lemma transl_Ssequence_1_correct:
+ (forall (e : Csem.env) (m : mem) (s1 s2 : statement) (t1 : trace)
+ (m1 : mem) (t2 : trace) (m2 : mem) (out : Csem.outcome),
+ Csem.exec_stmt ge e m s1 t1 m1 Csem.Out_normal ->
+ exec_stmt_prop e m s1 t1 m1 Csem.Out_normal ->
+ Csem.exec_stmt ge e m1 s2 t2 m2 out ->
+ exec_stmt_prop e m1 s2 t2 m2 out ->
+ exec_stmt_prop e m (Ssequence s1 s2) (t1 ** t2) m2 out).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts. red in H0; simpl in H0. eapply exec_Sseq_continue; eauto.
+Qed.
+
+Lemma transl_Ssequence_2_correct:
+ (forall (e : Csem.env) (m : mem) (s1 s2 : statement) (t1 : trace)
+ (m1 : mem) (out : Csem.outcome),
+ Csem.exec_stmt ge e m s1 t1 m1 out ->
+ exec_stmt_prop e m s1 t1 m1 out ->
+ out <> Csem.Out_normal ->
+ exec_stmt_prop e m (Ssequence s1 s2) t1 m1 out).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts. eapply exec_Sseq_stop; eauto.
+ destruct out; simpl; congruence.
+Qed.
+
+Lemma transl_Sifthenelse_true_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr)
+ (s1 s2 : statement) (t1 : trace) (m1 : mem) (v1 : val) (t2 : trace)
+ (m2 : mem) (out : Csem.outcome),
+ Csem.eval_expr ge e m a t1 m1 v1 ->
+ eval_expr_prop e m a t1 m1 v1 ->
+ is_true v1 (typeof a) ->
+ Csem.exec_stmt ge e m1 s1 t2 m2 out ->
+ exec_stmt_prop e m1 s1 t2 m2 out ->
+ exec_stmt_prop e m (Csyntax.Sifthenelse a s1 s2) (t1 ** t2) m2 out).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ exploit make_boolean_correct_true. eapply H0; eauto. eauto. intros [vb [EVAL ISTRUE]].
+ subst ts. eapply exec_Sifthenelse_true; eauto.
+Qed.
+
+Lemma transl_Sifthenelse_false_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr)
+ (s1 s2 : statement) (t1 : trace) (m1 : mem) (v1 : val) (t2 : trace)
+ (m2 : mem) (out : Csem.outcome),
+ Csem.eval_expr ge e m a t1 m1 v1 ->
+ eval_expr_prop e m a t1 m1 v1 ->
+ is_false v1 (typeof a) ->
+ Csem.exec_stmt ge e m1 s2 t2 m2 out ->
+ exec_stmt_prop e m1 s2 t2 m2 out ->
+ exec_stmt_prop e m (Csyntax.Sifthenelse a s1 s2) (t1 ** t2) m2 out).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ exploit make_boolean_correct_false. eapply H0; eauto. eauto. intros [vb [EVAL ISFALSE]].
+ subst ts. eapply exec_Sifthenelse_false; eauto.
+Qed.
+
+Lemma transl_Sreturn_none_correct:
+ (forall (e : Csem.env) (m : mem),
+ exec_stmt_prop e m (Csyntax.Sreturn None) E0 m (Csem.Out_return None)).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts. simpl. apply exec_Sreturn_none.
+Qed.
+
+Lemma transl_Sreturn_some_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t : trace)
+ (m1 : mem) (v : val),
+ Csem.eval_expr ge e m a t m1 v ->
+ eval_expr_prop e m a t m1 v ->
+ exec_stmt_prop e m (Csyntax.Sreturn (Some a)) t m1
+ (Csem.Out_return (Some v))).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts. simpl. eapply exec_Sreturn_some; eauto.
+Qed.
+
+Lemma transl_Sbreak_correct:
+ (forall (e : Csem.env) (m : mem),
+ exec_stmt_prop e m Sbreak E0 m Out_break).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts. simpl. apply exec_Sexit.
+Qed.
+
+Lemma transl_Scontinue_correct:
+ (forall (e : Csem.env) (m : mem),
+ exec_stmt_prop e m Scontinue E0 m Out_continue).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts. simpl. apply exec_Sexit.
+Qed.
+
+Lemma exit_if_false_true:
+ forall a ts e m1 t m2 v tyenv te,
+ exit_if_false a = Some ts ->
+ eval_expr_prop e m1 a t m2 v ->
+ match_env tyenv e te ->
+ wt_expr tyenv a ->
+ is_true v (typeof a) ->
+ exec_stmt tprog te m1 ts t m2 Out_normal.
+Proof.
+ intros. monadInv H. rewrite <- H5.
+ eapply exec_Sifthenelse_false with (v1 := Vfalse).
+ eapply make_notbool_correct with (va := v); eauto.
+ inversion H3; subst; simpl; auto.
+ rewrite Int.eq_false; auto.
+ rewrite Int.eq_false; auto.
+ rewrite Float.eq_zero_false; auto.
+ simpl; auto.
+ constructor. traceEq.
+Qed.
+
+Lemma exit_if_false_false:
+ forall a ts e m1 t m2 v tyenv te,
+ exit_if_false a = Some ts ->
+ eval_expr_prop e m1 a t m2 v ->
+ match_env tyenv e te ->
+ wt_expr tyenv a ->
+ is_false v (typeof a) ->
+ exec_stmt tprog te m1 ts t m2 (Out_exit 0).
+Proof.
+ intros. monadInv H. rewrite <- H5.
+ eapply exec_Sifthenelse_true with (v1 := Vtrue).
+ eapply make_notbool_correct with (va := v); eauto.
+ inversion H3; subst; simpl; auto.
+ rewrite Float.eq_zero_true; auto.
+ simpl; apply Int.one_not_zero.
+ constructor. traceEq.
+Qed.
+
+Lemma transl_Swhile_false_correct:
+ (forall (e : Csem.env) (m : mem) (s : statement) (a : Csyntax.expr)
+ (t : trace) (v : val) (m1 : mem),
+ Csem.eval_expr ge e m a t m1 v ->
+ eval_expr_prop e m a t m1 v ->
+ is_false v (typeof a) ->
+ exec_stmt_prop e m (Swhile a s) t m1 Csem.Out_normal).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts. simpl.
+ change Out_normal with (outcome_block (Out_exit 0)).
+ apply exec_Sblock. apply exec_Sloop_stop. apply exec_Sseq_stop.
+ eapply exit_if_false_false; eauto. congruence. congruence.
+Qed.
+
+Lemma transl_out_break_or_return:
+ forall out1 out2 nbrk ncnt,
+ out_break_or_return out1 out2 ->
+ transl_outcome nbrk ncnt out2 =
+ outcome_block (outcome_block (transl_outcome 1 0 out1)).
+Proof.
+ intros. inversion H; subst; reflexivity.
+Qed.
+
+Lemma transl_out_normal_or_continue:
+ forall out,
+ out_normal_or_continue out ->
+ Out_normal = outcome_block (transl_outcome 1 0 out).
+Proof.
+ intros; inversion H; reflexivity.
+Qed.
+
+Lemma transl_Swhile_stop_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t1 : trace)
+ (m1 : mem) (v : val) (s : statement) (m2 : mem) (t2 : trace)
+ (out2 out : Csem.outcome),
+ Csem.eval_expr ge e m a t1 m1 v ->
+ eval_expr_prop e m a t1 m1 v ->
+ is_true v (typeof a) ->
+ Csem.exec_stmt ge e m1 s t2 m2 out2 ->
+ exec_stmt_prop e m1 s t2 m2 out2 ->
+ out_break_or_return out2 out ->
+ exec_stmt_prop e m (Swhile a s) (t1 ** t2) m2 out).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts. rewrite (transl_out_break_or_return _ _ nbrk ncnt H4).
+ apply exec_Sblock. apply exec_Sloop_stop.
+ eapply exec_Sseq_continue.
+ eapply exit_if_false_true; eauto.
+ apply exec_Sblock. eauto.
+ auto. inversion H4; simpl; congruence.
+Qed.
+
+Lemma transl_Swhile_loop_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t1 : trace)
+ (m1 : mem) (v : val) (s : statement) (out2 out : Csem.outcome)
+ (t2 : trace) (m2 : mem) (t3 : trace) (m3 : mem),
+ Csem.eval_expr ge e m a t1 m1 v ->
+ eval_expr_prop e m a t1 m1 v ->
+ is_true v (typeof a) ->
+ Csem.exec_stmt ge e m1 s t2 m2 out2 ->
+ exec_stmt_prop e m1 s t2 m2 out2 ->
+ out_normal_or_continue out2 ->
+ Csem.exec_stmt ge e m2 (Swhile a s) t3 m3 out ->
+ exec_stmt_prop e m2 (Swhile a s) t3 m3 out ->
+ exec_stmt_prop e m (Swhile a s) (t1 ** t2 ** t3) m3 out).
+Proof.
+ intros; red; intros.
+ exploit H6; eauto. intro NEXTITER.
+ inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts.
+ inversion NEXTITER; subst.
+ apply exec_Sblock.
+ eapply exec_Sloop_loop. eapply exec_Sseq_continue.
+ eapply exit_if_false_true; eauto.
+ rewrite (transl_out_normal_or_continue _ H4).
+ apply exec_Sblock. eauto.
+ reflexivity. eassumption.
+ traceEq.
+Qed.
+
+Lemma transl_Sdowhile_false_correct:
+ (forall (e : Csem.env) (m : mem) (s : statement) (a : Csyntax.expr)
+ (t1 : trace) (m1 : mem) (out1 : Csem.outcome) (v : val)
+ (t2 : trace) (m2 : mem),
+ Csem.exec_stmt ge e m s t1 m1 out1 ->
+ exec_stmt_prop e m s t1 m1 out1 ->
+ out_normal_or_continue out1 ->
+ Csem.eval_expr ge e m1 a t2 m2 v ->
+ eval_expr_prop e m1 a t2 m2 v ->
+ is_false v (typeof a) ->
+ exec_stmt_prop e m (Sdowhile a s) (t1 ** t2) m2 Csem.Out_normal).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts. simpl.
+ change Out_normal with (outcome_block (Out_exit 0)).
+ apply exec_Sblock. apply exec_Sloop_stop. eapply exec_Sseq_continue.
+ rewrite (transl_out_normal_or_continue out1 H1).
+ apply exec_Sblock. eauto.
+ eapply exit_if_false_false; eauto. auto. congruence.
+Qed.
+
+Lemma transl_Sdowhile_stop_correct:
+ (forall (e : Csem.env) (m : mem) (s : statement) (a : Csyntax.expr)
+ (t : trace) (m1 : mem) (out1 out : Csem.outcome),
+ Csem.exec_stmt ge e m s t m1 out1 ->
+ exec_stmt_prop e m s t m1 out1 ->
+ out_break_or_return out1 out ->
+ exec_stmt_prop e m (Sdowhile a s) t m1 out).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts. simpl.
+ assert (outcome_block (transl_outcome 1 0 out1) <> Out_normal).
+ inversion H1; simpl; congruence.
+ rewrite (transl_out_break_or_return _ _ nbrk ncnt H1).
+ apply exec_Sblock. apply exec_Sloop_stop.
+ apply exec_Sseq_stop. apply exec_Sblock. eauto.
+ auto. auto.
+Qed.
+
+Lemma transl_Sdowhile_loop_correct:
+ (forall (e : Csem.env) (m : mem) (s : statement) (a : Csyntax.expr)
+ (m1 m2 m3 : mem) (t1 t2 t3 : trace) (out out1 : Csem.outcome)
+ (v : val),
+ Csem.exec_stmt ge e m s t1 m1 out1 ->
+ exec_stmt_prop e m s t1 m1 out1 ->
+ out_normal_or_continue out1 ->
+ Csem.eval_expr ge e m1 a t2 m2 v ->
+ eval_expr_prop e m1 a t2 m2 v ->
+ is_true v (typeof a) ->
+ Csem.exec_stmt ge e m2 (Sdowhile a s) t3 m3 out ->
+ exec_stmt_prop e m2 (Sdowhile a s) t3 m3 out ->
+ exec_stmt_prop e m (Sdowhile a s) (t1 ** t2 ** t3) m3 out).
+Proof.
+ intros; red; intros.
+ exploit H6; eauto. intro NEXTITER.
+ inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts.
+ inversion NEXTITER; subst.
+ apply exec_Sblock.
+ eapply exec_Sloop_loop. eapply exec_Sseq_continue.
+ rewrite (transl_out_normal_or_continue _ H1).
+ apply exec_Sblock. eauto.
+ eapply exit_if_false_true; eauto.
+ reflexivity. eassumption. traceEq.
+Qed.
+
+Lemma transl_Sfor_start_correct:
+ (forall (e : Csem.env) (m : mem) (s a1 : statement)
+ (a2 : Csyntax.expr) (a3 : statement) (out : Csem.outcome)
+ (m1 m2 : mem) (t1 t2 : trace),
+ Csem.exec_stmt ge e m a1 t1 m1 Csem.Out_normal ->
+ exec_stmt_prop e m a1 t1 m1 Csem.Out_normal ->
+ Csem.exec_stmt ge e m1 (Sfor Csyntax.Sskip a2 a3 s) t2 m2 out ->
+ exec_stmt_prop e m1 (Sfor Csyntax.Sskip a2 a3 s) t2 m2 out ->
+ exec_stmt_prop e m (Sfor a1 a2 a3 s) (t1 ** t2) m2 out).
+Proof.
+ intros; red; intros.
+ exploit transl_stmt_Sfor_start; eauto.
+ intros [ts1 [ts2 [A [B C]]]].
+ clear TR; subst ts.
+ inversion WT; subst.
+ assert (WT': wt_stmt tyenv (Sfor Csyntax.Sskip a2 a3 s)).
+ constructor; auto. constructor.
+ exploit H0; eauto. simpl. intro EXEC1.
+ exploit H2; eauto. intro EXEC2.
+ assert (EXEC3: exec_stmt tprog te m1 ts2 t2 m2 (transl_outcome nbrk ncnt out)).
+ inversion EXEC2; subst.
+ inversion H5; subst. rewrite E0_left; auto.
+ inversion H11; subst. congruence.
+ eapply exec_Sseq_continue; eauto.
+Qed.
+
+Lemma transl_Sfor_false_correct:
+ (forall (e : Csem.env) (m : mem) (s : statement) (a2 : Csyntax.expr)
+ (a3 : statement) (t : trace) (v : val) (m1 : mem),
+ Csem.eval_expr ge e m a2 t m1 v ->
+ eval_expr_prop e m a2 t m1 v ->
+ is_false v (typeof a2) ->
+ exec_stmt_prop e m (Sfor Csyntax.Sskip a2 a3 s) t m1 Csem.Out_normal).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts. simpl.
+ eapply exec_Sseq_continue. apply exec_Sskip.
+ change Out_normal with (outcome_block (Out_exit 0)).
+ apply exec_Sblock. apply exec_Sloop_stop.
+ apply exec_Sseq_stop. eapply exit_if_false_false; eauto.
+ congruence. congruence. traceEq.
+Qed.
+
+Lemma transl_Sfor_stop_correct:
+ (forall (e : Csem.env) (m : mem) (s : statement) (a2 : Csyntax.expr)
+ (a3 : statement) (v : val) (m1 m2 : mem) (t1 t2 : trace)
+ (out2 out : Csem.outcome),
+ Csem.eval_expr ge e m a2 t1 m1 v ->
+ eval_expr_prop e m a2 t1 m1 v ->
+ is_true v (typeof a2) ->
+ Csem.exec_stmt ge e m1 s t2 m2 out2 ->
+ exec_stmt_prop e m1 s t2 m2 out2 ->
+ out_break_or_return out2 out ->
+ exec_stmt_prop e m (Sfor Csyntax.Sskip a2 a3 s) (t1 ** t2) m2 out).
+Proof.
+ intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts. simpl.
+ assert (outcome_block (transl_outcome 1 0 out2) <> Out_normal).
+ inversion H4; simpl; congruence.
+ rewrite (transl_out_break_or_return _ _ nbrk ncnt H4).
+ eapply exec_Sseq_continue. apply exec_Sskip.
+ apply exec_Sblock. apply exec_Sloop_stop.
+ eapply exec_Sseq_continue. eapply exit_if_false_true; eauto.
+ apply exec_Sseq_stop. apply exec_Sblock. eauto.
+ auto. reflexivity. auto. traceEq.
+Qed.
+
+Lemma transl_Sfor_loop_correct:
+ (forall (e : Csem.env) (m : mem) (s : statement) (a2 : Csyntax.expr)
+ (a3 : statement) (v : val) (m1 m2 m3 m4 : mem)
+ (t1 t2 t3 t4 : trace) (out2 out : Csem.outcome),
+ Csem.eval_expr ge e m a2 t1 m1 v ->
+ eval_expr_prop e m a2 t1 m1 v ->
+ is_true v (typeof a2) ->
+ Csem.exec_stmt ge e m1 s t2 m2 out2 ->
+ exec_stmt_prop e m1 s t2 m2 out2 ->
+ out_normal_or_continue out2 ->
+ Csem.exec_stmt ge e m2 a3 t3 m3 Csem.Out_normal ->
+ exec_stmt_prop e m2 a3 t3 m3 Csem.Out_normal ->
+ Csem.exec_stmt ge e m3 (Sfor Csyntax.Sskip a2 a3 s) t4 m4 out ->
+ exec_stmt_prop e m3 (Sfor Csyntax.Sskip a2 a3 s) t4 m4 out ->
+ exec_stmt_prop e m (Sfor Csyntax.Sskip a2 a3 s)
+ (t1 ** t2 ** t3 ** t4) m4 out).
+Proof.
+ intros; red; intros.
+ exploit H8; eauto. intro NEXTITER.
+ inversion WT; clear WT; subst. simpl in TR; monadInv TR.
+ subst ts.
+ inversion NEXTITER; subst.
+ inversion H11; subst.
+ inversion H18; subst.
+ eapply exec_Sseq_continue. apply exec_Sskip.
+ apply exec_Sblock.
+ eapply exec_Sloop_loop. eapply exec_Sseq_continue.
+ eapply exit_if_false_true; eauto.
+ eapply exec_Sseq_continue.
+ rewrite (transl_out_normal_or_continue _ H4).
+ apply exec_Sblock. eauto.
+ red in H6; simpl in H6; eauto.
+ reflexivity. reflexivity. eassumption.
+ reflexivity. traceEq.
+ inversion H17. congruence.
+Qed.
+
+Lemma transl_lblstmts_switch:
+ forall e m0 t1 m1 n nbrk ncnt tyenv te t2 m2 out sl body ts,
+ exec_stmt tprog te m0 body t1 m1
+ (Out_exit (switch_target n (lblstmts_length sl) (switch_table sl 0))) ->
+ transl_lblstmts
+ (lblstmts_length sl)
+ (S (lblstmts_length sl + ncnt))
+ sl (Sblock body) = Some ts ->
+ wt_lblstmts tyenv sl ->
+ match_env tyenv e te ->
+ exec_lblstmts_prop e m1 (select_switch n sl) t2 m2 out ->
+ Csharpminor.exec_stmt tprog te m0 ts (t1 ** t2) m2
+ (transl_outcome nbrk ncnt (outcome_switch out)).
+Proof.
+ induction sl; intros.
+ simpl in H. simpl in H3.
+ eapply H3; eauto.
+ change Out_normal with (outcome_block (Out_exit 0)).
+ apply exec_Sblock. auto.
+ (* Inductive case *)
+ simpl in H. simpl in H3. rewrite Int.eq_sym in H3. destruct (Int.eq n i).
+ (* first case selected *)
+ eapply H3; eauto.
+ change Out_normal with (outcome_block (Out_exit 0)).
+ apply exec_Sblock. auto.
+ (* next case selected *)
+ inversion H1; clear H1; subst.
+ simpl in H0; monadInv H0.
+ eapply IHsl with (body := Sseq (Sblock body) s0); eauto.
+ apply exec_Sseq_stop.
+ change (Out_exit (switch_target n (lblstmts_length sl) (switch_table sl 0)))
+ with (outcome_block (Out_exit (S (switch_target n (lblstmts_length sl) (switch_table sl 0))))).
+ apply exec_Sblock.
+ rewrite switch_target_table_shift in H. auto. congruence.
+Qed.
+
+Lemma transl_Sswitch_correct:
+ (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t1 : trace)
+ (m1 : mem) (n : int) (sl : labeled_statements) (t2 : trace)
+ (m2 : mem) (out : Csem.outcome),
+ Csem.eval_expr ge e m a t1 m1 (Vint n) ->
+ eval_expr_prop e m a t1 m1 (Vint n) ->
+ exec_lblstmts ge e m1 (select_switch n sl) t2 m2 out ->
+ exec_lblstmts_prop e m1 (select_switch n sl) t2 m2 out ->
+ exec_stmt_prop e m (Csyntax.Sswitch a sl) (t1 ** t2) m2
+ (outcome_switch out)).
+Proof.
+ intros; red; intros.
+ inversion WT; clear WT; subst.
+ simpl in TR. monadInv TR; clear TR.
+ rewrite length_switch_table in EQ0.
+ replace (ncnt + lblstmts_length sl + 1)%nat
+ with (S (lblstmts_length sl + ncnt))%nat in EQ0 by omega.
+ eapply transl_lblstmts_switch; eauto.
+ constructor. eapply H0; eauto.
+Qed.
+
+Lemma transl_LSdefault_correct:
+ (forall (e : Csem.env) (m : mem) (s : statement) (t : trace)
+ (m1 : mem) (out : Csem.outcome),
+ Csem.exec_stmt ge e m s t m1 out ->
+ exec_stmt_prop e m s t m1 out ->
+ exec_lblstmts_prop e m (LSdefault s) t m1 out).
+Proof.
+ intros; red; intros.
+ inversion WT; subst.
+ simpl in TR. monadInv TR.
+ rewrite <- H3.
+ replace (transl_outcome nbrk ncnt (outcome_switch out))
+ with (outcome_block (transl_outcome 0 (S ncnt) out)).
+ constructor.
+ eapply exec_Sseq_continue. eauto.
+ eapply H0; eauto. traceEq.
+ destruct out; simpl; auto.
+Qed.
+
+Lemma transl_LScase_fallthrough_correct:
+ (forall (e : Csem.env) (m : mem) (n : int) (s : statement)
+ (ls : labeled_statements) (t1 : trace) (m1 : mem) (t2 : trace)
+ (m2 : mem) (out : Csem.outcome),
+ Csem.exec_stmt ge e m s t1 m1 Csem.Out_normal ->
+ exec_stmt_prop e m s t1 m1 Csem.Out_normal ->
+ exec_lblstmts ge e m1 ls t2 m2 out ->
+ exec_lblstmts_prop e m1 ls t2 m2 out ->
+ exec_lblstmts_prop e m (LScase n s ls) (t1 ** t2) m2 out).
+Proof.
+ intros; red; intros.
+ inversion WT; subst.
+ simpl in TR. monadInv TR; clear TR.
+ assert (exec_stmt tprog te m0 (Sblock (Sseq body s0))
+ (t0 ** t1) m1 Out_normal).
+ change Out_normal with
+ (outcome_block (transl_outcome (S (lblstmts_length ls))
+ (S (S (lblstmts_length ls + ncnt)))
+ Csem.Out_normal)).
+ apply exec_Sblock. eapply exec_Sseq_continue. eexact BODY.
+ eapply H0; eauto.
+ auto.
+ exploit H2. eauto. simpl; eauto. eauto. eauto. simpl.
+ rewrite Eapp_assoc. eauto.
+Qed.
+
+Lemma transl_LScase_stop_correct:
+ (forall (e : Csem.env) (m : mem) (n : int) (s : statement)
+ (ls : labeled_statements) (t : trace) (m1 : mem)
+ (out : Csem.outcome),
+ Csem.exec_stmt ge e m s t m1 out ->
+ exec_stmt_prop e m s t m1 out ->
+ out <> Csem.Out_normal ->
+ exec_lblstmts_prop e m (LScase n s ls) t m1 out).
+Proof.
+ intros; red; intros.
+ inversion WT; subst.
+ simpl in TR. monadInv TR; clear TR.
+ exploit H0; eauto. intro EXEC.
+ destruct out; simpl; simpl in EXEC.
+ (* out = Out_break *)
+ change Out_normal with (outcome_block (Out_exit 0)).
+ eapply transl_lblstmts_exit with (body := Sblock (Sseq body s0)); eauto.
+ rewrite plus_0_r.
+ change (Out_exit (lblstmts_length ls))
+ with (outcome_block (Out_exit (S (lblstmts_length ls)))).
+ constructor. eapply exec_Sseq_continue; eauto.
+ (* out = Out_continue *)
+ change (Out_exit ncnt) with (outcome_block (Out_exit (S ncnt))).
+ eapply transl_lblstmts_exit with (body := Sblock (Sseq body s0)); eauto.
+ replace (Out_exit (lblstmts_length ls + S ncnt))
+ with (outcome_block (Out_exit (S (S (lblstmts_length ls + ncnt))))).
+ constructor. eapply exec_Sseq_continue; eauto.
+ simpl. decEq. omega.
+ (* out = Out_normal *)
+ congruence.
+ (* out = Out_return *)
+ eapply transl_lblstmts_return with (body := Sblock (Sseq body s0)); eauto.
+ change (Out_return o)
+ with (outcome_block (Out_return o)).
+ constructor. eapply exec_Sseq_continue; eauto.
+Qed.
+
+Remark outcome_result_value_match:
+ forall out ty v nbrk ncnt,
+ Csem.outcome_result_value out ty v ->
+ Csharpminor.outcome_result_value (transl_outcome nbrk ncnt out) (opttyp_of_type ty) v.
+Proof.
+ intros until ncnt.
+ destruct out; simpl; try contradiction.
+ destruct ty; simpl; auto.
+ destruct o. intros [A B]. destruct ty; simpl; congruence.
+ destruct ty; simpl; auto.
+Qed.
+
+Lemma transl_funcall_internal_correct:
+ (forall (m : mem) (f : Csyntax.function) (vargs : list val)
+ (t : trace) (e : Csem.env) (m1 : mem) (lb : list block)
+ (m2 m3 : mem) (out : Csem.outcome) (vres : val),
+ Csem.alloc_variables Csem.empty_env m
+ (Csyntax.fn_params f ++ Csyntax.fn_vars f) e m1 lb ->
+ Csem.bind_parameters e m1 (Csyntax.fn_params f) vargs m2 ->
+ Csem.exec_stmt ge e m2 (Csyntax.fn_body f) t m3 out ->
+ exec_stmt_prop e m2 (Csyntax.fn_body f) t m3 out ->
+ Csem.outcome_result_value out (fn_return f) vres ->
+ eval_funcall_prop m (Internal f) vargs t (free_list m3 lb) vres).
+Proof.
+ intros; red; intros.
+ (* Exploitation of typing hypothesis *)
+ inversion WT; clear WT; subst.
+ inversion H6; clear H6; subst.
+ (* Exploitation of translation hypothesis *)
+ monadInv TR. subst tf. clear TR.
+ monadInv EQ. clear EQ. subst f0.
+ (* Allocation of variables *)
+ exploit match_env_alloc_variables; eauto.
+ apply match_globalenv_match_env_empty.
+ apply match_global_typenv.
+ eexact (transl_fn_variables _ _ (signature_of_function f) _ _ s EQ0 EQ1).
+ intros [te [ALLOCVARS MATCHENV]].
+ (* Execution *)
+ econstructor; simpl.
+ (* Norepet *)
+ eapply transl_names_norepet; eauto.
+ (* Alloc *)
+ eexact ALLOCVARS.
+ (* Bind *)
+ eapply bind_parameters_match; eauto.
+ (* Execution of body *)
+ eapply H2; eauto.
+ (* Outcome_result_value *)
+ apply outcome_result_value_match; auto.
+Qed.
+
+Lemma transl_funcall_external_correct:
+ (forall (m : mem) (id : ident) (targs : typelist) (tres : type)
+ (vargs : list val) (t : trace) (vres : val),
+ event_match (external_function id targs tres) vargs t vres ->
+ eval_funcall_prop m (External id targs tres) vargs t m vres).
+Proof.
+ intros; red; intros.
+ monadInv TR. subst tf. constructor. auto.
+Qed.
+
+Theorem transl_funcall_correct:
+ forall (m : mem) (f : Csyntax.fundef) (l : list val) (t : trace)
+ (m0 : mem) (v : val),
+ Csem.eval_funcall ge m f l t m0 v ->
+ eval_funcall_prop m f l t m0 v.
+Proof
+ (Csem.eval_funcall_ind6 ge
+ eval_expr_prop
+ eval_lvalue_prop
+ eval_exprlist_prop
+ exec_stmt_prop
+ exec_lblstmts_prop
+ eval_funcall_prop
+
+ transl_Econst_int_correct
+ transl_Econst_float_correct
+ transl_Elvalue_correct
+ transl_Eaddrof_correct
+ transl_Esizeof_correct
+ transl_Eunop_correct
+ transl_Ebinop_correct
+ transl_Eorbool_1_correct
+ transl_Eorbool_2_correct
+ transl_Eandbool_1_correct
+ transl_Eandbool_2_correct
+ transl_Ecast_correct
+ transl_Ecall_correct
+ transl_Evar_local_correct
+ transl_Evar_global_correct
+ transl_Ederef_correct
+ transl_Eindex_correct
+ transl_Efield_struct_correct
+ transl_Efield_union_correct
+ transl_Enil_correct
+ transl_Econs_correct
+ transl_Sskip_correct
+ transl_Sexpr_correct
+ transl_Sassign_correct
+ transl_Ssequence_1_correct
+ transl_Ssequence_2_correct
+ transl_Sifthenelse_true_correct
+ transl_Sifthenelse_false_correct
+ transl_Sreturn_none_correct
+ transl_Sreturn_some_correct
+ transl_Sbreak_correct
+ transl_Scontinue_correct
+ transl_Swhile_false_correct
+ transl_Swhile_stop_correct
+ transl_Swhile_loop_correct
+ transl_Sdowhile_false_correct
+ transl_Sdowhile_stop_correct
+ transl_Sdowhile_loop_correct
+ transl_Sfor_start_correct
+ transl_Sfor_false_correct
+ transl_Sfor_stop_correct
+ transl_Sfor_loop_correct
+ transl_Sswitch_correct
+ transl_LSdefault_correct
+ transl_LScase_fallthrough_correct
+ transl_LScase_stop_correct
+ transl_funcall_internal_correct
+ transl_funcall_external_correct).
+
+End CORRECTNESS.
+
+(** Semantic preservation for whole programs. *)
+
+Theorem transl_program_correct:
+ forall prog tprog t r,
+ transl_program prog = Some tprog ->
+ Ctyping.wt_program prog ->
+ Csem.exec_program prog t r ->
+ Csharpminor.exec_program tprog t r.
+Proof.
+ intros until r. intros TRANSL WT [b [f [m1 [FINDS [FINDF [TYP EVAL]]]]]].
+ inversion WT; subst.
+
+ assert (type_of_fundef f = Tfunction Tnil (Tint I32 Signed)).
+ apply wt_program_main.
+ change (Csyntax.prog_funct prog)
+ with (AST.prog_funct (Csyntax.program_of_program prog)).
+ eapply Genv.find_funct_ptr_symbol_inversion; eauto.
+ exploit function_ptr_translated; eauto. intros [tf [TFINDF TRANSLFD]].
+ exists b; exists tf; exists m1.
+ split.
+ rewrite (symbols_preserved _ _ TRANSL).
+ monadInv TRANSL. rewrite <- H1. simpl. auto.
+ split. auto.
+ split.
+ generalize (transl_fundef_sig2 _ _ _ _ TRANSLFD H). simpl; auto.
+ rewrite (@Genv.init_mem_transf_partial _ _ transl_fundef
+ (Csyntax.program_of_program prog)
+ (Csharpminor.program_of_program tprog)).
+ generalize (transl_funcall_correct _ _ WT TRANSL _ _ _ _ _ _ EVAL).
+ intro. eapply H0.
+ eapply function_ptr_well_typed; eauto.
+ auto.
+ apply transform_program_of_program; auto.
+Qed.
diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v
new file mode 100644
index 0000000..d3bd8d6
--- /dev/null
+++ b/cfrontend/Csyntax.v
@@ -0,0 +1,456 @@
+(** * Abstract syntax for the Clight language *)
+
+Require Import Coqlib.
+Require Import Integers.
+Require Import Floats.
+Require Import AST.
+
+(** ** Abstract syntax *)
+
+(** Types *)
+
+Inductive signedness : Set :=
+ | Signed: signedness
+ | Unsigned: signedness.
+
+Inductive intsize : Set :=
+ | I8: intsize
+ | I16: intsize
+ | I32: intsize.
+
+Inductive floatsize : Set :=
+ | F32: floatsize
+ | F64: floatsize.
+
+Inductive type : Set :=
+ | Tvoid: type
+ | Tint: intsize -> signedness -> type
+ | Tfloat: floatsize -> type
+ | Tpointer: type -> type
+ | Tarray: type -> Z -> type
+ | Tfunction: typelist -> type -> type
+ | Tstruct: fieldlist -> type
+ | Tunion: fieldlist -> type
+
+with typelist : Set :=
+ | Tnil: typelist
+ | Tcons: type -> typelist -> typelist
+
+with fieldlist : Set :=
+ | Fnil: fieldlist
+ | Fcons: ident -> type -> fieldlist -> fieldlist.
+
+(** Arithmetic and logical operators *)
+
+Inductive unary_operation : Set :=
+ | Onotbool : unary_operation
+ | Onotint : unary_operation
+ | Oneg : unary_operation.
+
+Inductive binary_operation : Set :=
+ | Oadd : binary_operation
+ | Osub : binary_operation
+ | Omul : binary_operation
+ | Odiv : binary_operation
+ | Omod : binary_operation
+ | Oand : binary_operation
+ | Oor : binary_operation
+ | Oxor : binary_operation
+ | Oshl : binary_operation
+ | Oshr : binary_operation
+ | Oeq: binary_operation
+ | One: binary_operation
+ | Olt: binary_operation
+ | Ogt: binary_operation
+ | Ole: binary_operation
+ | Oge: binary_operation.
+
+(** Expressions *)
+
+Inductive expr : Set :=
+ | Expr: expr_descr -> type -> expr
+
+with expr_descr : Set :=
+ | Econst_int: int -> expr_descr
+ | Econst_float: float -> expr_descr
+ | Evar: ident -> expr_descr
+ | Ederef: expr -> expr_descr
+ | Eaddrof: expr -> expr_descr
+ | Eunop: unary_operation -> expr -> expr_descr
+ | Ebinop: binary_operation -> expr -> expr -> expr_descr
+ | Ecast: type -> expr -> expr_descr
+ | Eindex: expr -> expr -> expr_descr
+ | Ecall: expr -> exprlist -> expr_descr
+ | Eandbool: expr -> expr -> expr_descr
+ | Eorbool: expr -> expr -> expr_descr
+ | Esizeof: type -> expr_descr
+ | Efield: expr -> ident -> expr_descr
+
+with exprlist : Set :=
+ | Enil: exprlist
+ | Econs: expr -> exprlist -> exprlist.
+
+(** Extract the type part of a type-annotated Clight expression. *)
+
+Definition typeof (e: expr) : type :=
+ match e with Expr de te => te end.
+
+(** Statements *)
+
+Inductive statement : Set :=
+ | Sskip : statement
+ | Sexpr : expr -> statement
+ | Sassign : expr -> expr -> statement
+ | Ssequence : statement -> statement -> statement
+ | Sifthenelse : expr -> statement -> statement -> statement
+ | Swhile : expr -> statement -> statement
+ | Sdowhile : expr -> statement -> statement
+ | Sfor: statement -> expr -> statement -> statement -> statement
+ | Sbreak : statement
+ | Scontinue : statement
+ | Sreturn : option expr -> statement
+ | Sswitch : expr -> labeled_statements -> statement
+
+with labeled_statements : Set :=
+ | LSdefault: statement -> labeled_statements
+ | LScase: int -> statement -> labeled_statements -> labeled_statements.
+
+(** Function definition *)
+
+Record function : Set := mkfunction {
+ fn_return: type;
+ fn_params: list (ident * type);
+ fn_vars: list (ident * type);
+ fn_body: statement
+}.
+
+Inductive fundef : Set :=
+ | Internal: function -> fundef
+ | External: ident -> typelist -> type -> fundef.
+
+(** Program *)
+
+Record program : Set := mkprogram {
+ prog_funct: list (ident * fundef);
+ prog_defs: list (ident * type * list init_data);
+ prog_main: ident
+}.
+
+(** ** Operations over types *)
+
+(** The type of a function definition *)
+
+Fixpoint type_of_params (params: list (ident * type)) : typelist :=
+ match params with
+ | nil => Tnil
+ | (id, ty) :: rem => Tcons ty (type_of_params rem)
+ end.
+
+Definition type_of_function (f: function) : type :=
+ Tfunction (type_of_params (fn_params f)) (fn_return f).
+
+Definition type_of_fundef (f: fundef) : type :=
+ match f with
+ | Internal fd => type_of_function fd
+ | External id args res => Tfunction args res
+ end.
+
+(** Natural alignment of a type *)
+
+Fixpoint alignof (t: type) : Z :=
+ match t with
+ | Tvoid => 1
+ | Tint I8 _ => 1
+ | Tint I16 _ => 2
+ | Tint I32 _ => 4
+ | Tfloat F32 => 4
+ | Tfloat F64 => 8
+ | Tpointer _ => 4
+ | Tarray t' n => alignof t'
+ | Tfunction _ _ => 1
+ | Tstruct fld => alignof_fields fld
+ | Tunion fld => alignof_fields fld
+ end
+
+with alignof_fields (f: fieldlist) : Z :=
+ match f with
+ | Fnil => 1
+ | Fcons id t f' => Zmax (alignof t) (alignof_fields f')
+ end.
+
+Scheme type_ind2 := Induction for type Sort Prop
+ with fieldlist_ind2 := Induction for fieldlist Sort Prop.
+
+Lemma alignof_fields_pos:
+ forall f, alignof_fields f > 0.
+Proof.
+ induction f; simpl.
+ omega.
+ generalize (Zmax2 (alignof t) (alignof_fields f)). omega.
+Qed.
+
+Lemma alignof_pos:
+ forall t, alignof t > 0.
+Proof.
+ induction t; simpl; auto; try omega.
+ destruct i; omega.
+ destruct f; omega.
+ apply alignof_fields_pos.
+ apply alignof_fields_pos.
+Qed.
+
+(** Size of a type (in bytes) *)
+
+Fixpoint sizeof (t: type) : Z :=
+ match t with
+ | Tvoid => 1
+ | Tint I8 _ => 1
+ | Tint I16 _ => 2
+ | Tint I32 _ => 4
+ | Tfloat F32 => 4
+ | Tfloat F64 => 8
+ | Tpointer _ => 4
+ | Tarray t' n => sizeof t' * Zmax 1 n
+ | Tfunction _ _ => 1
+ | Tstruct fld => align (Zmax 1 (sizeof_struct fld 0)) (alignof t)
+ | Tunion fld => align (Zmax 1 (sizeof_union fld)) (alignof t)
+ end
+
+with sizeof_struct (fld: fieldlist) (pos: Z) {struct fld} : Z :=
+ match fld with
+ | Fnil => pos
+ | Fcons id t fld' => sizeof_struct fld' (align pos (alignof t) + sizeof t)
+ end
+
+with sizeof_union (fld: fieldlist) : Z :=
+ match fld with
+ | Fnil => 0
+ | Fcons id t fld' => Zmax (sizeof t) (sizeof_union fld')
+ end.
+
+Lemma sizeof_pos:
+ forall t, sizeof t > 0.
+Proof.
+ intro t0.
+ apply (type_ind2 (fun t => sizeof t > 0)
+ (fun f => sizeof_union f >= 0 /\ forall pos, pos >= 0 -> sizeof_struct f pos >= 0));
+ intros; simpl; auto; try omega.
+ destruct i; omega.
+ destruct f; omega.
+ apply Zmult_gt_0_compat. auto. generalize (Zmax1 1 z); omega.
+ destruct H.
+ generalize (align_le (Zmax 1 (sizeof_struct f 0)) (alignof_fields f) (alignof_fields_pos f)).
+ generalize (Zmax1 1 (sizeof_struct f 0)). omega.
+ generalize (align_le (Zmax 1 (sizeof_union f)) (alignof_fields f) (alignof_fields_pos f)).
+ generalize (Zmax1 1 (sizeof_union f)). omega.
+ split. omega. auto.
+ destruct H0. split; intros.
+ generalize (Zmax2 (sizeof t) (sizeof_union f)). omega.
+ apply H1.
+ generalize (align_le pos (alignof t) (alignof_pos t)). omega.
+Qed.
+
+(** Byte offset for a field in a struct. *)
+
+Fixpoint field_offset_rec (id: ident) (fld: fieldlist) (pos: Z)
+ {struct fld} : option Z :=
+ match fld with
+ | Fnil => None
+ | Fcons id' t fld' =>
+ if ident_eq id id'
+ then Some (align pos (alignof t))
+ else field_offset_rec id fld' (align pos (alignof t) + sizeof t)
+ end.
+
+Definition field_offset (id: ident) (fld: fieldlist) : option Z :=
+ field_offset_rec id fld 0.
+
+(* Describe how a variable of the given type must be accessed:
+ - by value, i.e. by loading from the address of the variable
+ with the given chunk
+ - by reference, i.e. by just returning the address of the variable
+ - not at all, e.g. the [void] type. *)
+
+Inductive mode: Set :=
+ | By_value: memory_chunk -> mode
+ | By_reference: mode
+ | By_nothing: mode.
+
+Definition access_mode (ty: type) : mode :=
+ match ty with
+ | Tint I8 Signed => By_value Mint8signed
+ | Tint I8 Unsigned => By_value Mint8unsigned
+ | Tint I16 Signed => By_value Mint16signed
+ | Tint I16 Unsigned => By_value Mint16unsigned
+ | Tint I32 _ => By_value Mint32
+ | Tfloat F32 => By_value Mfloat32
+ | Tfloat F64 => By_value Mfloat64
+ | Tvoid => By_nothing
+ | Tpointer _ => By_value Mint32
+ | Tarray _ _ => By_reference
+ | Tfunction _ _ => By_reference
+ | Tstruct fList => By_nothing
+ | Tunion fList => By_nothing
+end.
+
+(** Conversion of a Clight program into an AST program *)
+
+Definition extract_global_var (id_ty_init: ident * type * list init_data) :=
+ match id_ty_init with (id, ty, init) => (id, init) end.
+
+Definition program_of_program (p: program) : AST.program fundef :=
+ AST.mkprogram
+ p.(prog_funct)
+ p.(prog_main)
+ (List.map extract_global_var p.(prog_defs)).
+
+(** Classification of arithmetic operations and comparisons *)
+
+Inductive classify_add_cases : Set :=
+ | add_case_ii: classify_add_cases (* int , int *)
+ | add_case_ff: classify_add_cases (* float , float *)
+ | add_case_pi: type -> classify_add_cases (* ptr | array, int *)
+ | add_default: classify_add_cases. (* other *)
+
+Definition classify_add (ty1: type) (ty2: type) :=
+ match ty1, ty2 with
+ | Tint _ _, Tint _ _ => add_case_ii
+ | Tfloat _, Tfloat _ => add_case_ff
+ | Tpointer ty, Tint _ _ => add_case_pi ty
+ | Tarray ty _, Tint _ _ => add_case_pi ty
+ | _, _ => add_default
+ end.
+
+Inductive classify_sub_cases : Set :=
+ | sub_case_ii: classify_sub_cases (* int , int *)
+ | sub_case_ff: classify_sub_cases (* float , float *)
+ | sub_case_pi: type -> classify_sub_cases (* ptr | array , int *)
+ | sub_case_pp: type -> classify_sub_cases (* ptr | array , ptr | array *)
+ | sub_default: classify_sub_cases . (* other *)
+
+Definition classify_sub (ty1: type) (ty2: type) :=
+ match ty1, ty2 with
+ | Tint _ _ , Tint _ _ => sub_case_ii
+ | Tfloat _ , Tfloat _ => sub_case_ff
+ | Tpointer ty , Tint _ _ => sub_case_pi ty
+ | Tarray ty _ , Tint _ _ => sub_case_pi ty
+ | Tpointer ty , Tpointer _ => sub_case_pp ty
+ | Tpointer ty , Tarray _ _=> sub_case_pp ty
+ | Tarray ty _ , Tpointer _ => sub_case_pp ty
+ | Tarray ty _ , Tarray _ _ => sub_case_pp ty
+ | _ ,_ => sub_default
+ end.
+
+Inductive classify_mul_cases : Set:=
+ | mul_case_ii: classify_mul_cases (* int , int *)
+ | mul_case_ff: classify_mul_cases (* float , float *)
+ | mul_default: classify_mul_cases . (* other *)
+
+Definition classify_mul (ty1: type) (ty2: type) :=
+ match ty1,ty2 with
+ | Tint _ _, Tint _ _ => mul_case_ii
+ | Tfloat _ , Tfloat _ => mul_case_ff
+ | _,_ => mul_default
+end.
+
+Inductive classify_div_cases : Set:=
+ | div_case_I32unsi: classify_div_cases (* uns int32 , int *)
+ | div_case_ii: classify_div_cases (* int , int *)
+ | div_case_ff: classify_div_cases (* float , float *)
+ | div_default: classify_div_cases. (* other *)
+
+Definition classify_div (ty1: type) (ty2: type) :=
+ match ty1,ty2 with
+ | Tint I32 Unsigned, Tint _ _ => div_case_I32unsi
+ | Tint _ _ , Tint I32 Unsigned => div_case_I32unsi
+ | Tint _ _ , Tint _ _ => div_case_ii
+ | Tfloat _ , Tfloat _ => div_case_ff
+ | _ ,_ => div_default
+end.
+
+Inductive classify_mod_cases : Set:=
+ | mod_case_I32unsi: classify_mod_cases (* uns I32 , int *)
+ | mod_case_ii: classify_mod_cases (* int , int *)
+ | mod_default: classify_mod_cases . (* other *)
+
+Definition classify_mod (ty1: type) (ty2: type) :=
+ match ty1,ty2 with
+ | Tint I32 Unsigned , Tint _ _ => mod_case_I32unsi
+ | Tint _ _ , Tint I32 Unsigned => mod_case_I32unsi
+ | Tint _ _ , Tint _ _ => mod_case_ii
+ | _ , _ => mod_default
+end .
+
+Inductive classify_shr_cases :Set:=
+ | shr_case_I32unsi: classify_shr_cases (* uns I32 , int *)
+ | shr_case_ii :classify_shr_cases (* int , int *)
+ | shr_default : classify_shr_cases . (* other *)
+
+Definition classify_shr (ty1: type) (ty2: type) :=
+ match ty1,ty2 with
+ | Tint I32 Unsigned , Tint _ _ => shr_case_I32unsi
+ | Tint _ _ , Tint _ _ => shr_case_ii
+ | _ , _ => shr_default
+ end.
+
+Inductive classify_cmp_cases : Set:=
+ | cmp_case_I32unsi: classify_cmp_cases (* uns I32 , int *)
+ | cmp_case_ii: classify_cmp_cases (* int , int*)
+ | cmp_case_ff: classify_cmp_cases (* float , float *)
+ | cmp_case_pi: classify_cmp_cases (* ptr | array , int *)
+ | cmp_case_pp:classify_cmp_cases (* ptr | array , ptr | array *)
+ | cmp_default: classify_cmp_cases . (* other *)
+
+Definition classify_cmp (ty1: type) (ty2: type) :=
+ match ty1,ty2 with
+ | Tint I32 Unsigned , Tint _ _ => cmp_case_I32unsi
+ | Tint _ _ , Tint I32 Unsigned => cmp_case_I32unsi
+ | Tint _ _ , Tint _ _ => cmp_case_ii
+ | Tfloat _ , Tfloat _ => cmp_case_ff
+ | Tpointer _ , Tint _ _ => cmp_case_pi
+ | Tarray _ _ , Tint _ _ => cmp_case_pi
+ | Tpointer _ , Tpointer _ => cmp_case_pp
+ | Tpointer _ , Tarray _ _ => cmp_case_pp
+ | Tarray _ _ ,Tpointer _ => cmp_case_pp
+ | Tarray _ _ ,Tarray _ _ => cmp_case_pp
+ | _ , _ => cmp_default
+ end.
+
+Inductive classify_fun_cases : Set:=
+ | fun_case_f: typelist -> type -> classify_fun_cases (* type fun | ptr fun*)
+ | fun_default: classify_fun_cases . (* other *)
+
+Definition classify_fun (ty: type) :=
+ match ty with
+ | Tfunction args res => fun_case_f args res
+ | Tpointer (Tfunction args res) => fun_case_f args res
+ | _ => fun_default
+ end.
+
+(** Mapping between Clight types and Cminor types and external functions *)
+
+Definition typ_of_type (t: type) : AST.typ :=
+ match t with
+ | Tfloat _ => AST.Tfloat
+ | _ => AST.Tint
+ end.
+
+Definition opttyp_of_type (t: type) : option AST.typ :=
+ match t with
+ | Tvoid => None
+ | Tfloat _ => Some AST.Tfloat
+ | _ => Some AST.Tint
+ end.
+
+Fixpoint typlist_of_typelist (tl: typelist) : list AST.typ :=
+ match tl with
+ | Tnil => nil
+ | Tcons hd tl => typ_of_type hd :: typlist_of_typelist tl
+ end.
+
+Definition signature_of_type (args: typelist) (res: type) : signature :=
+ mksignature (typlist_of_typelist args) (opttyp_of_type res).
+
+Definition external_function
+ (id: ident) (targs: typelist) (tres: type) : AST.external_function :=
+ mkextfun id (signature_of_type targs tres).
diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v
new file mode 100644
index 0000000..8b2f90f
--- /dev/null
+++ b/cfrontend/Ctyping.v
@@ -0,0 +1,420 @@
+(** * Type well-formedness of C programs *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Csyntax.
+
+(** ** Typing rules *)
+
+(** This ``type system'' is very coarse: we check only the typing properties
+ that matter for the translation to be correct. Essentially,
+ we need to check that the types attached to variable references
+ match the declaration types for those variables. *)
+
+Definition typenv := PTree.t type.
+
+Section TYPING.
+
+Variable env: typenv.
+
+Inductive wt_expr: expr -> Prop :=
+ | wt_Econst_int: forall i ty,
+ wt_expr (Expr (Econst_int i) ty)
+ | wt_Econst_float: forall f ty,
+ wt_expr (Expr (Econst_float f) ty)
+ | wt_Evar: forall id ty,
+ env!id = Some ty ->
+ wt_expr (Expr (Evar id) ty)
+ | wt_Ederef: forall e ty,
+ wt_expr e ->
+ wt_expr (Expr (Ederef e) ty)
+ | wt_Eaddrof: forall e ty,
+ wt_expr e ->
+ wt_expr (Expr (Eaddrof e) ty)
+ | wt_Eunop: forall op e ty,
+ wt_expr e ->
+ wt_expr (Expr (Eunop op e) ty)
+ | wt_Ebinop: forall op e1 e2 ty,
+ wt_expr e1 -> wt_expr e2 ->
+ wt_expr (Expr (Ebinop op e1 e2) ty)
+ | wt_Ecast: forall e ty ty',
+ wt_expr e ->
+ wt_expr (Expr (Ecast ty' e) ty)
+ | wt_Eindex: forall e1 e2 ty,
+ wt_expr e1 -> wt_expr e2 ->
+ wt_expr (Expr (Eindex e1 e2) ty)
+ | wt_Ecall: forall e1 el ty,
+ wt_expr e1 ->
+ wt_exprlist el ->
+ wt_expr (Expr (Ecall e1 el) ty)
+ | wt_Eandbool: forall e1 e2 ty,
+ wt_expr e1 -> wt_expr e2 ->
+ wt_expr (Expr (Eandbool e1 e2) ty)
+ | wt_Eorbool: forall e1 e2 ty,
+ wt_expr e1 -> wt_expr e2 ->
+ wt_expr (Expr (Eorbool e1 e2) ty)
+ | wt_Esizeof: forall ty' ty,
+ wt_expr (Expr (Esizeof ty') ty)
+ | wt_Efield: forall e id ty,
+ wt_expr e ->
+ wt_expr (Expr (Efield e id) ty)
+
+with wt_exprlist: exprlist -> Prop :=
+ | wt_Enil:
+ wt_exprlist Enil
+ | wt_Econs: forall e el,
+ wt_expr e -> wt_exprlist el -> wt_exprlist (Econs e el).
+
+Inductive wt_stmt: statement -> Prop :=
+ | wt_Sskip:
+ wt_stmt Sskip
+ | wt_Sexpr: forall e,
+ wt_expr e ->
+ wt_stmt (Sexpr e)
+ | wt_Sassign: forall e1 e2,
+ wt_expr e1 -> wt_expr e2 ->
+ wt_stmt (Sassign e1 e2)
+ | wt_Ssequence: forall s1 s2,
+ wt_stmt s1 -> wt_stmt s2 ->
+ wt_stmt (Ssequence s1 s2)
+ | wt_Sifthenelse: forall e s1 s2,
+ wt_expr e -> wt_stmt s1 -> wt_stmt s2 ->
+ wt_stmt (Sifthenelse e s1 s2)
+ | wt_Swhile: forall e s,
+ wt_expr e -> wt_stmt s ->
+ wt_stmt (Swhile e s)
+ | wt_Sdowhile: forall e s,
+ wt_expr e -> wt_stmt s ->
+ wt_stmt (Sdowhile e s)
+ | wt_Sfor: forall e s1 s2 s3,
+ wt_expr e -> wt_stmt s1 -> wt_stmt s2 -> wt_stmt s3 ->
+ wt_stmt (Sfor s1 e s2 s3)
+ | wt_Sbreak:
+ wt_stmt Sbreak
+ | wt_Scontinue:
+ wt_stmt Scontinue
+ | wt_Sreturn_some: forall e,
+ wt_expr e ->
+ wt_stmt (Sreturn (Some e))
+ | wt_Sreturn_none:
+ wt_stmt (Sreturn None)
+ | wt_Sswitch: forall e sl,
+ wt_expr e -> wt_lblstmts sl ->
+ wt_stmt (Sswitch e sl)
+
+with wt_lblstmts: labeled_statements -> Prop :=
+ | wt_LSdefault: forall s,
+ wt_stmt s ->
+ wt_lblstmts (LSdefault s)
+ | wt_LScase: forall n s sl,
+ wt_stmt s -> wt_lblstmts sl ->
+ wt_lblstmts (LScase n s sl).
+
+End TYPING.
+
+Definition add_var (env: typenv) (id_ty: ident * type) : typenv :=
+ PTree.set (fst id_ty) (snd id_ty) env.
+
+Definition add_vars (env: typenv) (vars: list(ident * type)) : typenv :=
+ List.fold_left add_var vars env.
+
+Definition var_names (vars: list(ident * type)) : list ident :=
+ List.map (@fst ident type) vars.
+
+Inductive wt_function: typenv -> function -> Prop :=
+ | wt_function_intro: forall env f,
+ list_norepet (var_names f.(fn_params) ++ var_names f.(fn_vars)) ->
+ wt_stmt (add_vars env (f.(fn_params) ++ f.(fn_vars))) f.(fn_body) ->
+ wt_function env f.
+
+Inductive wt_fundef: typenv -> fundef -> Prop :=
+ | wt_fundef_Internal: forall env f,
+ wt_function env f ->
+ wt_fundef env (Internal f)
+ | wt_fundef_External: forall env id args res,
+ wt_fundef env (External id args res).
+
+Definition add_global_var
+ (env: typenv) (id_ty_init: ident * type * list init_data) : typenv :=
+ match id_ty_init with (id, ty, init) => PTree.set id ty env end.
+
+Definition add_global_vars
+ (env: typenv) (vars: list(ident * type * list init_data)) : typenv :=
+ List.fold_left add_global_var vars env.
+
+Definition add_global_fun
+ (env: typenv) (id_fd: ident * fundef) : typenv :=
+ PTree.set (fst id_fd) (type_of_fundef (snd id_fd)) env.
+
+Definition add_global_funs
+ (env: typenv) (funs: list(ident * fundef)) : typenv :=
+ List.fold_left add_global_fun funs env.
+
+Definition global_typenv (p: program) :=
+ add_global_vars (add_global_funs (PTree.empty type) p.(prog_funct)) p.(prog_defs).
+
+Record wt_program (p: program) : Prop := mk_wt_program {
+ wt_program_funct:
+ forall id fd,
+ In (id, fd) p.(prog_funct) ->
+ wt_fundef (global_typenv p) fd;
+ wt_program_main:
+ forall fd,
+ In (p.(prog_main), fd) p.(prog_funct) ->
+ type_of_fundef fd = Tfunction Tnil (Tint I32 Signed)
+}.
+
+(** ** Type-checking algorithm *)
+
+Lemma eq_signedness: forall (s1 s2: signedness), {s1=s2} + {s1<>s2}.
+Proof. decide equality. Qed.
+
+Lemma eq_intsize: forall (s1 s2: intsize), {s1=s2} + {s1<>s2}.
+Proof. decide equality. Qed.
+
+Lemma eq_floatsize: forall (s1 s2: floatsize), {s1=s2} + {s1<>s2}.
+Proof. decide equality. Qed.
+
+Fixpoint eq_type (t1 t2: type) {struct t1}: bool :=
+ match t1, t2 with
+ | Tvoid, Tvoid => true
+ | Tint sz1 sg1, Tint sz2 sg2 =>
+ if eq_intsize sz1 sz2
+ then if eq_signedness sg1 sg2 then true else false
+ else false
+ | Tfloat sz1, Tfloat sz2 =>
+ if eq_floatsize sz1 sz2 then true else false
+ | Tpointer u1, Tpointer u2 => eq_type u1 u2
+ | Tarray u1 sz1, Tarray u2 sz2 =>
+ eq_type u1 u2 && if zeq sz1 sz2 then true else false
+ | Tfunction args1 res1, Tfunction args2 res2 =>
+ eq_typelist args1 args2 && eq_type res1 res2
+ | Tstruct f1, Tstruct f2 => eq_fieldlist f1 f2
+ | Tunion f1, Tunion f2 => eq_fieldlist f1 f2
+ | _, _ => false
+ end
+
+with eq_typelist (t1 t2: typelist) {struct t1} : bool :=
+ match t1, t2 with
+ | Tnil, Tnil => true
+ | Tcons u1 r1, Tcons u2 r2 => eq_type u1 u2 && eq_typelist r1 r2
+ | _, _ => false
+ end
+
+with eq_fieldlist (f1 f2: fieldlist) {struct f1} : bool :=
+ match f1, f2 with
+ | Fnil, Fnil => true
+ | Fcons id1 t1 r1, Fcons id2 t2 r2 =>
+ if ident_eq id1 id2
+ then eq_type t1 t2 && eq_fieldlist r1 r2
+ else false
+ | _, _ => false
+ end.
+
+Ltac TrueInv :=
+ match goal with
+ | [ H: ((if ?x then ?y else false) = true) |- _ ] =>
+ destruct x; [TrueInv | discriminate]
+ | [ H: (?x && ?y = true) |- _ ] =>
+ elim (andb_prop _ _ H); clear H; intros; TrueInv
+ | _ =>
+ idtac
+ end.
+
+Scheme type_ind_3 := Induction for type Sort Prop
+ with typelist_ind_3 := Induction for typelist Sort Prop
+ with fieldlist_ind_3 := Induction for fieldlist Sort Prop.
+
+Lemma eq_type_correct:
+ forall t1 t2, eq_type t1 t2 = true -> t1 = t2.
+Proof.
+ apply (type_ind_3 (fun t1 => forall t2, eq_type t1 t2 = true -> t1 = t2)
+ (fun t1 => forall t2, eq_typelist t1 t2 = true -> t1 = t2)
+ (fun t1 => forall t2, eq_fieldlist t1 t2 = true -> t1 = t2));
+ intros; destruct t2; simpl in *; try discriminate.
+ auto.
+ TrueInv. congruence.
+ TrueInv. congruence.
+ decEq; auto.
+ TrueInv. decEq; auto.
+ TrueInv. decEq; auto.
+ decEq; auto.
+ decEq; auto.
+ auto.
+ TrueInv. decEq; auto.
+ auto.
+ TrueInv. decEq; auto.
+Qed.
+
+Section TYPECHECKING.
+
+Variable env: typenv.
+
+Fixpoint typecheck_expr (a: Csyntax.expr) {struct a} : bool :=
+ match a with
+ | Expr ad aty => typecheck_exprdescr ad aty
+ end
+
+with typecheck_exprdescr (a: Csyntax.expr_descr) (ty: type) {struct a} : bool :=
+ match a with
+ | Csyntax.Econst_int n => true
+ | Csyntax.Econst_float n => true
+ | Csyntax.Evar id =>
+ match env!id with
+ | None => false
+ | Some ty' => eq_type ty ty'
+ end
+ | Csyntax.Ederef b => typecheck_expr b
+ | Csyntax.Eaddrof b => typecheck_expr b
+ | Csyntax.Eunop op b => typecheck_expr b
+ | Csyntax.Ebinop op b c => typecheck_expr b && typecheck_expr c
+ | Csyntax.Ecast ty b => typecheck_expr b
+ | Csyntax.Eindex b c => typecheck_expr b && typecheck_expr c
+ | Csyntax.Ecall b cl => typecheck_expr b && typecheck_exprlist cl
+ | Csyntax.Eandbool b c => typecheck_expr b && typecheck_expr c
+ | Csyntax.Eorbool b c => typecheck_expr b && typecheck_expr c
+ | Csyntax.Esizeof ty => true
+ | Csyntax.Efield b i => typecheck_expr b
+ end
+
+with typecheck_exprlist (al: Csyntax.exprlist): bool :=
+ match al with
+ | Csyntax.Enil => true
+ | Csyntax.Econs a1 a2 => typecheck_expr a1 && typecheck_exprlist a2
+ end.
+
+Scheme expr_ind_3 := Induction for expr Sort Prop
+ with expr_descr_ind_3 := Induction for expr_descr Sort Prop
+ with exprlist_ind_3 := Induction for exprlist Sort Prop.
+
+Lemma typecheck_expr_correct:
+ forall a, typecheck_expr a = true -> wt_expr env a.
+Proof.
+ apply (expr_ind_3 (fun a => typecheck_expr a = true -> wt_expr env a)
+ (fun a => forall ty, typecheck_exprdescr a ty = true -> wt_expr env (Expr a ty))
+ (fun a => typecheck_exprlist a = true -> wt_exprlist env a));
+ simpl; intros; TrueInv.
+ auto.
+ constructor.
+ constructor.
+ constructor. destruct (env!i). decEq; symmetry; apply eq_type_correct; auto.
+ discriminate.
+ constructor; auto.
+ constructor; auto.
+ constructor; auto.
+ constructor; auto.
+ constructor; auto.
+ constructor; auto.
+ constructor; auto.
+ constructor; auto.
+ constructor; auto.
+ auto.
+ constructor; auto.
+ constructor; auto.
+ constructor.
+ constructor; auto.
+Qed.
+
+Lemma typecheck_exprlist_correct:
+ forall a, typecheck_exprlist a = true -> wt_exprlist env a.
+Proof.
+ induction a; simpl; intros.
+ constructor.
+ TrueInv. constructor; auto. apply typecheck_expr_correct; auto.
+Qed.
+
+Fixpoint typecheck_stmt (s: Csyntax.statement) {struct s} : bool :=
+ match s with
+ | Csyntax.Sskip => true
+ | Csyntax.Sexpr e => typecheck_expr e
+ | Csyntax.Sassign b c => typecheck_expr b && typecheck_expr c
+ | Csyntax.Ssequence s1 s2 => typecheck_stmt s1 && typecheck_stmt s2
+ | Csyntax.Sifthenelse e s1 s2 =>
+ typecheck_expr e && typecheck_stmt s1 && typecheck_stmt s2
+ | Csyntax.Swhile e s1 => typecheck_expr e && typecheck_stmt s1
+ | Csyntax.Sdowhile e s1 => typecheck_expr e && typecheck_stmt s1
+ | Csyntax.Sfor e1 e2 e3 s1 =>
+ typecheck_stmt e1 && typecheck_expr e2 &&
+ typecheck_stmt e3 && typecheck_stmt s1
+ | Csyntax.Sbreak => true
+ | Csyntax.Scontinue => true
+ | Csyntax.Sreturn (Some e) => typecheck_expr e
+ | Csyntax.Sreturn None => true
+ | Csyntax.Sswitch e sl => typecheck_expr e && typecheck_lblstmts sl
+ end
+
+with typecheck_lblstmts (sl: labeled_statements) {struct sl}: bool :=
+ match sl with
+ | LSdefault s => typecheck_stmt s
+ | LScase _ s rem => typecheck_stmt s && typecheck_lblstmts rem
+ end.
+
+Scheme stmt_ind_2 := Induction for statement Sort Prop
+ with lblstmts_ind_2 := Induction for labeled_statements Sort Prop.
+
+Lemma typecheck_stmt_correct:
+ forall s, typecheck_stmt s = true -> wt_stmt env s.
+Proof.
+ generalize typecheck_expr_correct; intro.
+ apply (stmt_ind_2 (fun s => typecheck_stmt s = true -> wt_stmt env s)
+ (fun s => typecheck_lblstmts s = true -> wt_lblstmts env s));
+ simpl; intros; TrueInv; try constructor; auto.
+ destruct o; constructor; auto.
+Qed.
+
+End TYPECHECKING.
+
+Definition typecheck_function (env: typenv) (f: function) : bool :=
+ if list_norepet_dec ident_eq
+ (var_names f.(fn_params) ++ var_names f.(fn_vars))
+ then typecheck_stmt (add_vars env (f.(fn_params) ++ f.(fn_vars)))
+ f.(fn_body)
+ else false.
+
+Lemma typecheck_function_correct:
+ forall env f, typecheck_function env f = true -> wt_function env f.
+Proof.
+ unfold typecheck_function; intros; TrueInv.
+ constructor. auto. apply typecheck_stmt_correct; auto.
+Qed.
+
+Definition typecheck_fundef (main: ident) (env: typenv) (id_fd: ident * fundef) : bool :=
+ let (id, fd) := id_fd in
+ match fd with
+ | Internal f => typecheck_function env f
+ | External _ _ _ => true
+ end &&
+ if ident_eq id main
+ then eq_type (type_of_fundef fd) (Tfunction Tnil (Tint I32 Signed))
+ else true.
+
+Lemma typecheck_fundef_correct:
+ forall main env id fd,
+ typecheck_fundef main env (id, fd) = true ->
+ wt_fundef env fd /\
+ (id = main -> type_of_fundef fd = Tfunction Tnil (Tint I32 Signed)).
+Proof.
+ intros. unfold typecheck_fundef in H; TrueInv.
+ split.
+ destruct fd.
+ constructor. apply typecheck_function_correct; auto.
+ constructor.
+ intro. destruct (ident_eq id main).
+ apply eq_type_correct; auto.
+ congruence.
+Qed.
+
+Definition typecheck_program (p: program) : bool :=
+ List.forallb (typecheck_fundef p.(prog_main) (global_typenv p))
+ p.(prog_funct).
+
+Lemma typecheck_program_correct:
+ forall p, typecheck_program p = true -> wt_program p.
+Proof.
+ unfold typecheck_program; intros.
+ rewrite List.forallb_forall in H.
+ constructor; intros.
+ exploit typecheck_fundef_correct; eauto. tauto.
+ exploit typecheck_fundef_correct; eauto. tauto.
+Qed.
diff --git a/extraction/.depend b/extraction/.depend
index 9d6895d..20f0876 100644
--- a/extraction/.depend
+++ b/extraction/.depend
@@ -1,14 +1,9 @@
-../caml/Allocationaux.cmi: Locations.cmi Datatypes.cmi
../caml/CMlexer.cmi: ../caml/CMparser.cmi
../caml/CMparser.cmi: Cminor.cmi AST.cmi
../caml/CMtypecheck.cmi: Cminor.cmi
../caml/Coloringaux.cmi: Registers.cmi RTLtyping.cmi RTL.cmi Locations.cmi \
InterfGraph.cmi
../caml/PrintPPC.cmi: PPC.cmi
-../caml/Allocationaux.cmo: Locations.cmi Datatypes.cmi ../caml/Camlcoq.cmo \
- CList.cmi AST.cmi ../caml/Allocationaux.cmi
-../caml/Allocationaux.cmx: Locations.cmx Datatypes.cmx ../caml/Camlcoq.cmx \
- CList.cmx AST.cmx ../caml/Allocationaux.cmi
../caml/Camlcoq.cmo: Integers.cmi Datatypes.cmi CList.cmi BinPos.cmi \
BinInt.cmi
../caml/Camlcoq.cmx: Integers.cmx Datatypes.cmx CList.cmx BinPos.cmx \
@@ -17,24 +12,24 @@
../caml/CMlexer.cmi
../caml/CMlexer.cmx: ../caml/Camlcoq.cmx ../caml/CMparser.cmx \
../caml/CMlexer.cmi
-../caml/CMparser.cmo: Op.cmi Integers.cmi Datatypes.cmi Cminor.cmi \
+../caml/CMparser.cmo: Op.cmi Integers.cmi Int.cmi Datatypes.cmi Cminor.cmi \
Cmconstr.cmi ../caml/Camlcoq.cmo CList.cmi BinPos.cmi BinInt.cmi AST.cmi \
../caml/CMparser.cmi
-../caml/CMparser.cmx: Op.cmx Integers.cmx Datatypes.cmx Cminor.cmx \
+../caml/CMparser.cmx: Op.cmx Integers.cmx Int.cmx Datatypes.cmx Cminor.cmx \
Cmconstr.cmx ../caml/Camlcoq.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx \
../caml/CMparser.cmi
-../caml/CMtypecheck.cmo: Op.cmi Datatypes.cmi Cminor.cmi ../caml/Camlcoq.cmo \
- CList.cmi AST.cmi ../caml/CMtypecheck.cmi
-../caml/CMtypecheck.cmx: Op.cmx Datatypes.cmx Cminor.cmx ../caml/Camlcoq.cmx \
- CList.cmx AST.cmx ../caml/CMtypecheck.cmi
+../caml/CMtypecheck.cmo: Op.cmi Integers.cmi Datatypes.cmi Cminor.cmi \
+ ../caml/Camlcoq.cmo CList.cmi AST.cmi ../caml/CMtypecheck.cmi
+../caml/CMtypecheck.cmx: Op.cmx Integers.cmx Datatypes.cmx Cminor.cmx \
+ ../caml/Camlcoq.cmx CList.cmx AST.cmx ../caml/CMtypecheck.cmi
../caml/Coloringaux.cmo: Registers.cmi RTLtyping.cmi RTL.cmi Maps.cmi \
Locations.cmi InterfGraph.cmi Datatypes.cmi Conventions.cmi \
../caml/Camlcoq.cmo BinPos.cmi BinInt.cmi AST.cmi ../caml/Coloringaux.cmi
../caml/Coloringaux.cmx: Registers.cmx RTLtyping.cmx RTL.cmx Maps.cmx \
Locations.cmx InterfGraph.cmx Datatypes.cmx Conventions.cmx \
../caml/Camlcoq.cmx BinPos.cmx BinInt.cmx AST.cmx ../caml/Coloringaux.cmi
-../caml/Floataux.cmo: ../caml/Camlcoq.cmo AST.cmi
-../caml/Floataux.cmx: ../caml/Camlcoq.cmx AST.cmx
+../caml/Floataux.cmo: Integers.cmi ../caml/Camlcoq.cmo
+../caml/Floataux.cmx: Integers.cmx ../caml/Camlcoq.cmx
../caml/Main2.cmo: ../caml/PrintPPC.cmi Main.cmi Datatypes.cmi \
../caml/CMtypecheck.cmi ../caml/CMparser.cmi ../caml/CMlexer.cmi
../caml/Main2.cmx: ../caml/PrintPPC.cmx Main.cmx Datatypes.cmx \
@@ -45,18 +40,23 @@
AST.cmx ../caml/PrintPPC.cmi
../caml/RTLgenaux.cmo: Cminor.cmi
../caml/RTLgenaux.cmx: Cminor.cmx
+../caml/RTLtypingaux.cmo: Registers.cmi RTL.cmi Op.cmi Maps.cmi Datatypes.cmi \
+ ../caml/Camlcoq.cmo CList.cmi AST.cmi
+../caml/RTLtypingaux.cmx: Registers.cmx RTL.cmx Op.cmx Maps.cmx Datatypes.cmx \
+ ../caml/Camlcoq.cmx CList.cmx AST.cmx
Allocation.cmi: Specif.cmi Registers.cmi RTLtyping.cmi RTL.cmi \
Parallelmove.cmi Op.cmi Maps.cmi Locations.cmi LTL.cmi Datatypes.cmi \
Conventions.cmi Coloring.cmi CList.cmi BinPos.cmi AST.cmi
-AST.cmi: Specif.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi
+AST.cmi: Specif.cmi Integers.cmi Floats.cmi Datatypes.cmi Coqlib.cmi \
+ CList.cmi BinPos.cmi BinInt.cmi
BinInt.cmi: Datatypes.cmi BinPos.cmi BinNat.cmi
-BinNat.cmi: Datatypes.cmi BinPos.cmi
+BinNat.cmi: Specif.cmi Datatypes.cmi BinPos.cmi
BinPos.cmi: Peano.cmi Datatypes.cmi
Bool.cmi: Specif.cmi Datatypes.cmi
CList.cmi: Specif.cmi Datatypes.cmi
Cmconstr.cmi: Specif.cmi Op.cmi Integers.cmi Datatypes.cmi Compare_dec.cmi \
Cminor.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi
-Cminorgen.cmi: Zmin.cmi Specif.cmi Op.cmi Mem.cmi Maps.cmi Integers.cmi \
+Cminorgen.cmi: Zmax.cmi Specif.cmi Op.cmi Mem.cmi Maps.cmi Integers.cmi \
Datatypes.cmi Csharpminor.cmi Coqlib.cmi Cminor.cmi Cmconstr.cmi \
CList.cmi BinPos.cmi BinInt.cmi AST.cmi
Cminor.cmi: Values.cmi Op.cmi Maps.cmi Integers.cmi Globalenvs.cmi \
@@ -67,43 +67,45 @@ Coloring.cmi: Specif.cmi Registers.cmi RTLtyping.cmi RTL.cmi Op.cmi Maps.cmi \
Compare_dec.cmi: Specif.cmi Datatypes.cmi
Constprop.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Integers.cmi \
Floats.cmi Datatypes.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi
-Conventions.cmi: Locations.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \
- AST.cmi
+Conventions.cmi: Locations.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi \
+ BinInt.cmi AST.cmi
Coqlib.cmi: Zdiv.cmi ZArith_dec.cmi Wf.cmi Specif.cmi Datatypes.cmi CList.cmi \
BinPos.cmi BinInt.cmi
CSE.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Integers.cmi \
Floats.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi AST.cmi
-Csharpminor.cmi: Zmin.cmi Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi \
+Csharpminor.cmi: Zmax.cmi Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi \
Globalenvs.cmi Floats.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \
AST.cmi
-Floats.cmi: Specif.cmi Integers.cmi Datatypes.cmi AST.cmi
-FSetAVL.cmi: ZArith_dec.cmi Wf.cmi Specif.cmi Peano.cmi FSetInterface.cmi \
+Floats.cmi: Specif.cmi Integers.cmi Datatypes.cmi
+FSetAVL.cmi: Wf.cmi Specif.cmi Peano.cmi OrderedType.cmi Int.cmi \
Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi
FSetBridge.cmi: Specif.cmi FSetInterface.cmi Datatypes.cmi CList.cmi
FSetInterface.cmi: Specif.cmi Datatypes.cmi CList.cmi
-FSetList.cmi: Specif.cmi FSetInterface.cmi Datatypes.cmi CList.cmi
+FSetList.cmi: Specif.cmi OrderedType.cmi Datatypes.cmi CList.cmi
Globalenvs.cmi: Values.cmi Mem.cmi Maps.cmi Integers.cmi Datatypes.cmi \
CList.cmi BinPos.cmi BinInt.cmi AST.cmi
Integers.cmi: Zpower.cmi Zdiv.cmi Specif.cmi Datatypes.cmi Coqlib.cmi \
- CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi
-InterfGraph.cmi: Specif.cmi Registers.cmi Locations.cmi FSetInterface.cmi \
- Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi
-Kildall.cmi: Wf.cmi Specif.cmi Maps.cmi Lattice.cmi Datatypes.cmi Coqlib.cmi \
- CList.cmi BinPos.cmi
+ CList.cmi Bool.cmi BinPos.cmi BinInt.cmi
+InterfGraph.cmi: Specif.cmi Registers.cmi OrderedType.cmi Locations.cmi \
+ Int.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi
+Int.cmi: Zmax.cmi ZArith_dec.cmi Specif.cmi BinPos.cmi BinInt.cmi
+Iteration.cmi: Wf.cmi Specif.cmi Datatypes.cmi Coqlib.cmi BinPos.cmi
+Kildall.cmi: Specif.cmi Maps.cmi Lattice.cmi Iteration.cmi Datatypes.cmi \
+ Coqlib.cmi CList.cmi BinPos.cmi
Lattice.cmi: Specif.cmi Maps.cmi Datatypes.cmi BinPos.cmi
Linearize.cmi: Specif.cmi Op.cmi Maps.cmi Linear.cmi Lattice.cmi LTL.cmi \
Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi AST.cmi
Linear.cmi: Values.cmi Specif.cmi Op.cmi Locations.cmi Integers.cmi \
Globalenvs.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi \
AST.cmi
-Lineartyping.cmi: Zmin.cmi Locations.cmi Linear.cmi Datatypes.cmi \
+Lineartyping.cmi: Zmax.cmi Locations.cmi Linear.cmi Datatypes.cmi \
Conventions.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi
Locations.cmi: Values.cmi Specif.cmi Datatypes.cmi Coqlib.cmi BinPos.cmi \
BinInt.cmi AST.cmi
LTL.cmi: Values.cmi Specif.cmi Op.cmi Maps.cmi Locations.cmi Integers.cmi \
Globalenvs.cmi Datatypes.cmi Conventions.cmi CList.cmi BinPos.cmi \
BinInt.cmi AST.cmi
-Mach.cmi: Zmin.cmi Zdiv.cmi Values.cmi Specif.cmi Op.cmi Mem.cmi \
+Mach.cmi: Zmax.cmi Zdiv.cmi Values.cmi Specif.cmi Op.cmi Mem.cmi \
Locations.cmi Integers.cmi Globalenvs.cmi Datatypes.cmi Coqlib.cmi \
CList.cmi BinPos.cmi BinInt.cmi AST.cmi
Main.cmi: Tunneling.cmi Stacking.cmi RTLgen.cmi PPCgen.cmi PPC.cmi \
@@ -111,14 +113,15 @@ Main.cmi: Tunneling.cmi Stacking.cmi RTLgen.cmi PPCgen.cmi PPC.cmi \
Cminor.cmi CSE.cmi Allocation.cmi AST.cmi
Maps.cmi: Specif.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinNat.cmi \
BinInt.cmi
-Mem.cmi: Values.cmi Specif.cmi Integers.cmi Datatypes.cmi Coqlib.cmi \
+Mem.cmi: Zmax.cmi Values.cmi Specif.cmi Integers.cmi Datatypes.cmi Coqlib.cmi \
CList.cmi BinPos.cmi BinInt.cmi AST.cmi
Op.cmi: Values.cmi Specif.cmi Integers.cmi Globalenvs.cmi Floats.cmi \
Datatypes.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi
-Ordered.cmi: Specif.cmi Maps.cmi FSetInterface.cmi Datatypes.cmi Coqlib.cmi \
+Ordered.cmi: Specif.cmi OrderedType.cmi Maps.cmi Datatypes.cmi Coqlib.cmi \
BinPos.cmi
-Parallelmove.cmi: Wf.cmi Values.cmi Specif.cmi Peano.cmi Locations.cmi \
- LTL.cmi Datatypes.cmi CList.cmi AST.cmi
+OrderedType.cmi: Specif.cmi Datatypes.cmi
+Parallelmove.cmi: Parmov.cmi Locations.cmi Datatypes.cmi CList.cmi AST.cmi
+Parmov.cmi: Specif.cmi Peano.cmi Datatypes.cmi CList.cmi
Peano.cmi: Datatypes.cmi
PPCgen.cmi: Specif.cmi PPC.cmi Op.cmi Mach.cmi Locations.cmi Integers.cmi \
Datatypes.cmi Coqlib.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi
@@ -130,8 +133,8 @@ RTLgen.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Integers.cmi \
Datatypes.cmi Coqlib.cmi Cminor.cmi CList.cmi BinPos.cmi AST.cmi
RTL.cmi: Values.cmi Registers.cmi Op.cmi Maps.cmi Integers.cmi Globalenvs.cmi \
Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi
-RTLtyping.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Datatypes.cmi \
- Coqlib.cmi CList.cmi BinPos.cmi AST.cmi
+RTLtyping.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Locations.cmi \
+ Datatypes.cmi Coqlib.cmi Conventions.cmi CList.cmi AST.cmi
Sets.cmi: Specif.cmi Maps.cmi Datatypes.cmi CList.cmi
Specif.cmi: Datatypes.cmi
Stacking.cmi: Specif.cmi Op.cmi Mach.cmi Locations.cmi Lineartyping.cmi \
@@ -148,6 +151,7 @@ Zbool.cmi: Zeven.cmi ZArith_dec.cmi Sumbool.cmi Specif.cmi Datatypes.cmi \
Zdiv.cmi: Zbool.cmi ZArith_dec.cmi Specif.cmi Datatypes.cmi BinPos.cmi \
BinInt.cmi
Zeven.cmi: Specif.cmi Datatypes.cmi BinPos.cmi BinInt.cmi
+Zmax.cmi: Datatypes.cmi BinInt.cmi
Zmin.cmi: Datatypes.cmi BinInt.cmi
Zmisc.cmi: Datatypes.cmi BinPos.cmi BinInt.cmi
Zpower.cmi: Zmisc.cmi Datatypes.cmi BinPos.cmi BinInt.cmi
@@ -159,14 +163,14 @@ Allocation.cmx: Specif.cmx Registers.cmx RTLtyping.cmx RTL.cmx \
Parallelmove.cmx Op.cmx Maps.cmx Locations.cmx LTL.cmx Kildall.cmx \
Datatypes.cmx Conventions.cmx Coloring.cmx CList.cmx BinPos.cmx AST.cmx \
Allocation.cmi
-AST.cmo: Specif.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi \
- AST.cmi
-AST.cmx: Specif.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx BinInt.cmx \
- AST.cmi
+AST.cmo: Specif.cmi Integers.cmi Floats.cmi Datatypes.cmi Coqlib.cmi \
+ CList.cmi BinPos.cmi BinInt.cmi AST.cmi
+AST.cmx: Specif.cmx Integers.cmx Floats.cmx Datatypes.cmx Coqlib.cmx \
+ CList.cmx BinPos.cmx BinInt.cmx AST.cmi
BinInt.cmo: Datatypes.cmi BinPos.cmi BinNat.cmi BinInt.cmi
BinInt.cmx: Datatypes.cmx BinPos.cmx BinNat.cmx BinInt.cmi
-BinNat.cmo: Datatypes.cmi BinPos.cmi BinNat.cmi
-BinNat.cmx: Datatypes.cmx BinPos.cmx BinNat.cmi
+BinNat.cmo: Specif.cmi Datatypes.cmi BinPos.cmi BinNat.cmi
+BinNat.cmx: Specif.cmx Datatypes.cmx BinPos.cmx BinNat.cmi
BinPos.cmo: Peano.cmi Datatypes.cmi BinPos.cmi
BinPos.cmx: Peano.cmx Datatypes.cmx BinPos.cmi
Bool.cmo: Specif.cmi Datatypes.cmi Bool.cmi
@@ -177,10 +181,10 @@ Cmconstr.cmo: Specif.cmi Op.cmi Integers.cmi Datatypes.cmi Compare_dec.cmi \
Cminor.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi Cmconstr.cmi
Cmconstr.cmx: Specif.cmx Op.cmx Integers.cmx Datatypes.cmx Compare_dec.cmx \
Cminor.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx Cmconstr.cmi
-Cminorgen.cmo: Zmin.cmi Specif.cmi Sets.cmi Op.cmi Mem.cmi Maps.cmi \
+Cminorgen.cmo: Zmax.cmi Specif.cmi Sets.cmi Op.cmi Mem.cmi Maps.cmi \
Integers.cmi Datatypes.cmi Csharpminor.cmi Coqlib.cmi Cminor.cmi \
Cmconstr.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi Cminorgen.cmi
-Cminorgen.cmx: Zmin.cmx Specif.cmx Sets.cmx Op.cmx Mem.cmx Maps.cmx \
+Cminorgen.cmx: Zmax.cmx Specif.cmx Sets.cmx Op.cmx Mem.cmx Maps.cmx \
Integers.cmx Datatypes.cmx Csharpminor.cmx Coqlib.cmx Cminor.cmx \
Cmconstr.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx Cminorgen.cmi
Cminor.cmo: Values.cmi Op.cmi Maps.cmi Integers.cmi Globalenvs.cmi \
@@ -201,10 +205,10 @@ Constprop.cmo: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Lattice.cmi \
Constprop.cmx: Specif.cmx Registers.cmx RTL.cmx Op.cmx Maps.cmx Lattice.cmx \
Kildall.cmx Integers.cmx Floats.cmx Datatypes.cmx CList.cmx Bool.cmx \
BinPos.cmx BinInt.cmx AST.cmx Constprop.cmi
-Conventions.cmo: Locations.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \
- AST.cmi Conventions.cmi
-Conventions.cmx: Locations.cmx Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx \
- AST.cmx Conventions.cmi
+Conventions.cmo: Locations.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi \
+ BinInt.cmi AST.cmi Conventions.cmi
+Conventions.cmx: Locations.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx \
+ BinInt.cmx AST.cmx Conventions.cmi
Coqlib.cmo: Zdiv.cmi ZArith_dec.cmi Wf.cmi Specif.cmi Datatypes.cmi CList.cmi \
BinPos.cmi BinInt.cmi Coqlib.cmi
Coqlib.cmx: Zdiv.cmx ZArith_dec.cmx Wf.cmx Specif.cmx Datatypes.cmx CList.cmx \
@@ -215,52 +219,54 @@ CSE.cmo: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Kildall.cmi \
CSE.cmx: Specif.cmx Registers.cmx RTL.cmx Op.cmx Maps.cmx Kildall.cmx \
Integers.cmx Floats.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx \
AST.cmx CSE.cmi
-Csharpminor.cmo: Zmin.cmi Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi \
+Csharpminor.cmo: Zmax.cmi Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi \
Globalenvs.cmi Floats.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \
AST.cmi Csharpminor.cmi
-Csharpminor.cmx: Zmin.cmx Values.cmx Specif.cmx Mem.cmx Maps.cmx Integers.cmx \
+Csharpminor.cmx: Zmax.cmx Values.cmx Specif.cmx Mem.cmx Maps.cmx Integers.cmx \
Globalenvs.cmx Floats.cmx Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx \
AST.cmx Csharpminor.cmi
Datatypes.cmo: Datatypes.cmi
Datatypes.cmx: Datatypes.cmi
Floats.cmo: Specif.cmi Integers.cmi ../caml/Floataux.cmo Datatypes.cmi \
- AST.cmi Floats.cmi
+ Floats.cmi
Floats.cmx: Specif.cmx Integers.cmx ../caml/Floataux.cmx Datatypes.cmx \
- AST.cmx Floats.cmi
-FSetAVL.cmo: ZArith_dec.cmi Wf.cmi Specif.cmi Peano.cmi FSetList.cmi \
- FSetInterface.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \
- FSetAVL.cmi
-FSetAVL.cmx: ZArith_dec.cmx Wf.cmx Specif.cmx Peano.cmx FSetList.cmx \
- FSetInterface.cmx Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx \
- FSetAVL.cmi
+ Floats.cmi
+FSetAVL.cmo: Wf.cmi Specif.cmi Peano.cmi OrderedType.cmi Int.cmi FSetList.cmi \
+ Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi FSetAVL.cmi
+FSetAVL.cmx: Wf.cmx Specif.cmx Peano.cmx OrderedType.cmx Int.cmx FSetList.cmx \
+ Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx FSetAVL.cmi
FSetBridge.cmo: Specif.cmi FSetInterface.cmi Datatypes.cmi CList.cmi \
FSetBridge.cmi
FSetBridge.cmx: Specif.cmx FSetInterface.cmx Datatypes.cmx CList.cmx \
FSetBridge.cmi
FSetInterface.cmo: Specif.cmi Datatypes.cmi CList.cmi FSetInterface.cmi
FSetInterface.cmx: Specif.cmx Datatypes.cmx CList.cmx FSetInterface.cmi
-FSetList.cmo: Specif.cmi FSetInterface.cmi Datatypes.cmi CList.cmi \
- FSetList.cmi
-FSetList.cmx: Specif.cmx FSetInterface.cmx Datatypes.cmx CList.cmx \
- FSetList.cmi
+FSetList.cmo: Specif.cmi OrderedType.cmi Datatypes.cmi CList.cmi FSetList.cmi
+FSetList.cmx: Specif.cmx OrderedType.cmx Datatypes.cmx CList.cmx FSetList.cmi
Globalenvs.cmo: Values.cmi Mem.cmi Maps.cmi Integers.cmi Datatypes.cmi \
CList.cmi BinPos.cmi BinInt.cmi AST.cmi Globalenvs.cmi
Globalenvs.cmx: Values.cmx Mem.cmx Maps.cmx Integers.cmx Datatypes.cmx \
CList.cmx BinPos.cmx BinInt.cmx AST.cmx Globalenvs.cmi
Integers.cmo: Zpower.cmi Zdiv.cmi Specif.cmi Datatypes.cmi Coqlib.cmi \
- CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi Integers.cmi
+ CList.cmi Bool.cmi BinPos.cmi BinInt.cmi Integers.cmi
Integers.cmx: Zpower.cmx Zdiv.cmx Specif.cmx Datatypes.cmx Coqlib.cmx \
- CList.cmx Bool.cmx BinPos.cmx BinInt.cmx AST.cmx Integers.cmi
-InterfGraph.cmo: Specif.cmi Registers.cmi Ordered.cmi Locations.cmi \
- FSetInterface.cmi FSetBridge.cmi FSetAVL.cmi Datatypes.cmi Coqlib.cmi \
- CList.cmi BinPos.cmi BinInt.cmi InterfGraph.cmi
-InterfGraph.cmx: Specif.cmx Registers.cmx Ordered.cmx Locations.cmx \
- FSetInterface.cmx FSetBridge.cmx FSetAVL.cmx Datatypes.cmx Coqlib.cmx \
- CList.cmx BinPos.cmx BinInt.cmx InterfGraph.cmi
-Kildall.cmo: Wf.cmi Specif.cmi Maps.cmi Lattice.cmi Datatypes.cmi Coqlib.cmi \
- CList.cmi BinPos.cmi Kildall.cmi
-Kildall.cmx: Wf.cmx Specif.cmx Maps.cmx Lattice.cmx Datatypes.cmx Coqlib.cmx \
- CList.cmx BinPos.cmx Kildall.cmi
+ CList.cmx Bool.cmx BinPos.cmx BinInt.cmx Integers.cmi
+InterfGraph.cmo: Specif.cmi Registers.cmi OrderedType.cmi Ordered.cmi \
+ Locations.cmi Int.cmi FSetAVL.cmi Datatypes.cmi Coqlib.cmi CList.cmi \
+ BinPos.cmi BinInt.cmi InterfGraph.cmi
+InterfGraph.cmx: Specif.cmx Registers.cmx OrderedType.cmx Ordered.cmx \
+ Locations.cmx Int.cmx FSetAVL.cmx Datatypes.cmx Coqlib.cmx CList.cmx \
+ BinPos.cmx BinInt.cmx InterfGraph.cmi
+Int.cmo: Zmax.cmi ZArith_dec.cmi Specif.cmi BinPos.cmi BinInt.cmi Int.cmi
+Int.cmx: Zmax.cmx ZArith_dec.cmx Specif.cmx BinPos.cmx BinInt.cmx Int.cmi
+Iteration.cmo: Wf.cmi Specif.cmi Datatypes.cmi Coqlib.cmi BinPos.cmi \
+ Iteration.cmi
+Iteration.cmx: Wf.cmx Specif.cmx Datatypes.cmx Coqlib.cmx BinPos.cmx \
+ Iteration.cmi
+Kildall.cmo: Specif.cmi Maps.cmi Lattice.cmi Iteration.cmi Datatypes.cmi \
+ Coqlib.cmi CList.cmi BinPos.cmi Kildall.cmi
+Kildall.cmx: Specif.cmx Maps.cmx Lattice.cmx Iteration.cmx Datatypes.cmx \
+ Coqlib.cmx CList.cmx BinPos.cmx Kildall.cmi
Lattice.cmo: Specif.cmi Maps.cmi Datatypes.cmi BinPos.cmi Lattice.cmi
Lattice.cmx: Specif.cmx Maps.cmx Datatypes.cmx BinPos.cmx Lattice.cmi
Linearize.cmo: Specif.cmi Op.cmi Maps.cmi Linear.cmi Lattice.cmi LTL.cmi \
@@ -275,9 +281,9 @@ Linear.cmo: Values.cmi Specif.cmi Op.cmi Locations.cmi Integers.cmi \
Linear.cmx: Values.cmx Specif.cmx Op.cmx Locations.cmx Integers.cmx \
Globalenvs.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx BinInt.cmx \
AST.cmx Linear.cmi
-Lineartyping.cmo: Zmin.cmi Locations.cmi Linear.cmi Datatypes.cmi \
+Lineartyping.cmo: Zmax.cmi Locations.cmi Linear.cmi Datatypes.cmi \
Conventions.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi Lineartyping.cmi
-Lineartyping.cmx: Zmin.cmx Locations.cmx Linear.cmx Datatypes.cmx \
+Lineartyping.cmx: Zmax.cmx Locations.cmx Linear.cmx Datatypes.cmx \
Conventions.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx Lineartyping.cmi
Locations.cmo: Values.cmi Specif.cmi Datatypes.cmi Coqlib.cmi BinPos.cmi \
BinInt.cmi AST.cmi Locations.cmi
@@ -291,10 +297,10 @@ LTL.cmo: Values.cmi Specif.cmi Op.cmi Maps.cmi Locations.cmi Integers.cmi \
LTL.cmx: Values.cmx Specif.cmx Op.cmx Maps.cmx Locations.cmx Integers.cmx \
Globalenvs.cmx Datatypes.cmx Conventions.cmx CList.cmx BinPos.cmx \
BinInt.cmx AST.cmx LTL.cmi
-Mach.cmo: Zmin.cmi Zdiv.cmi Values.cmi Specif.cmi Op.cmi Mem.cmi Maps.cmi \
+Mach.cmo: Zmax.cmi Zdiv.cmi Values.cmi Specif.cmi Op.cmi Mem.cmi Maps.cmi \
Locations.cmi Integers.cmi Globalenvs.cmi Datatypes.cmi Coqlib.cmi \
CList.cmi BinPos.cmi BinInt.cmi AST.cmi Mach.cmi
-Mach.cmx: Zmin.cmx Zdiv.cmx Values.cmx Specif.cmx Op.cmx Mem.cmx Maps.cmx \
+Mach.cmx: Zmax.cmx Zdiv.cmx Values.cmx Specif.cmx Op.cmx Mem.cmx Maps.cmx \
Locations.cmx Integers.cmx Globalenvs.cmx Datatypes.cmx Coqlib.cmx \
CList.cmx BinPos.cmx BinInt.cmx AST.cmx Mach.cmi
Main.cmo: Tunneling.cmi Stacking.cmi RTLgen.cmi PPCgen.cmi PPC.cmi \
@@ -307,22 +313,26 @@ Maps.cmo: Specif.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinNat.cmi \
BinInt.cmi Maps.cmi
Maps.cmx: Specif.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx BinNat.cmx \
BinInt.cmx Maps.cmi
-Mem.cmo: Values.cmi Specif.cmi Integers.cmi Datatypes.cmi Coqlib.cmi \
+Mem.cmo: Zmax.cmi Values.cmi Specif.cmi Integers.cmi Datatypes.cmi Coqlib.cmi \
CList.cmi BinPos.cmi BinInt.cmi AST.cmi Mem.cmi
-Mem.cmx: Values.cmx Specif.cmx Integers.cmx Datatypes.cmx Coqlib.cmx \
+Mem.cmx: Zmax.cmx Values.cmx Specif.cmx Integers.cmx Datatypes.cmx Coqlib.cmx \
CList.cmx BinPos.cmx BinInt.cmx AST.cmx Mem.cmi
Op.cmo: Values.cmi Specif.cmi Integers.cmi Globalenvs.cmi Floats.cmi \
Datatypes.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi Op.cmi
Op.cmx: Values.cmx Specif.cmx Integers.cmx Globalenvs.cmx Floats.cmx \
Datatypes.cmx CList.cmx Bool.cmx BinPos.cmx BinInt.cmx AST.cmx Op.cmi
-Ordered.cmo: Specif.cmi Maps.cmi FSetInterface.cmi Datatypes.cmi Coqlib.cmi \
+Ordered.cmo: Specif.cmi OrderedType.cmi Maps.cmi Datatypes.cmi Coqlib.cmi \
BinPos.cmi Ordered.cmi
-Ordered.cmx: Specif.cmx Maps.cmx FSetInterface.cmx Datatypes.cmx Coqlib.cmx \
+Ordered.cmx: Specif.cmx OrderedType.cmx Maps.cmx Datatypes.cmx Coqlib.cmx \
BinPos.cmx Ordered.cmi
-Parallelmove.cmo: Wf.cmi Values.cmi Specif.cmi Peano.cmi Locations.cmi \
- LTL.cmi Datatypes.cmi CList.cmi AST.cmi Parallelmove.cmi
-Parallelmove.cmx: Wf.cmx Values.cmx Specif.cmx Peano.cmx Locations.cmx \
- LTL.cmx Datatypes.cmx CList.cmx AST.cmx Parallelmove.cmi
+OrderedType.cmo: Specif.cmi Datatypes.cmi OrderedType.cmi
+OrderedType.cmx: Specif.cmx Datatypes.cmx OrderedType.cmi
+Parallelmove.cmo: Parmov.cmi Locations.cmi Datatypes.cmi CList.cmi AST.cmi \
+ Parallelmove.cmi
+Parallelmove.cmx: Parmov.cmx Locations.cmx Datatypes.cmx CList.cmx AST.cmx \
+ Parallelmove.cmi
+Parmov.cmo: Specif.cmi Peano.cmi Datatypes.cmi CList.cmi Parmov.cmi
+Parmov.cmx: Specif.cmx Peano.cmx Datatypes.cmx CList.cmx Parmov.cmi
Peano.cmo: Datatypes.cmi Peano.cmi
Peano.cmx: Datatypes.cmx Peano.cmi
PPCgen.cmo: Specif.cmi PPC.cmi Op.cmi Mach.cmi Locations.cmi Integers.cmi \
@@ -351,12 +361,12 @@ RTL.cmo: Values.cmi Registers.cmi Op.cmi Maps.cmi Integers.cmi Globalenvs.cmi \
Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi RTL.cmi
RTL.cmx: Values.cmx Registers.cmx Op.cmx Maps.cmx Integers.cmx Globalenvs.cmx \
Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx RTL.cmi
-RTLtyping.cmo: union_find.cmi Specif.cmi Registers.cmi RTL.cmi Op.cmi \
- Maps.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi AST.cmi \
- RTLtyping.cmi
-RTLtyping.cmx: union_find.cmx Specif.cmx Registers.cmx RTL.cmx Op.cmx \
- Maps.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx AST.cmx \
- RTLtyping.cmi
+RTLtyping.cmo: Specif.cmi Registers.cmi ../caml/RTLtypingaux.cmo RTL.cmi \
+ Op.cmi Maps.cmi Locations.cmi Datatypes.cmi Coqlib.cmi Conventions.cmi \
+ CList.cmi AST.cmi RTLtyping.cmi
+RTLtyping.cmx: Specif.cmx Registers.cmx ../caml/RTLtypingaux.cmx RTL.cmx \
+ Op.cmx Maps.cmx Locations.cmx Datatypes.cmx Coqlib.cmx Conventions.cmx \
+ CList.cmx AST.cmx RTLtyping.cmi
Sets.cmo: Specif.cmi Maps.cmi Datatypes.cmi CList.cmi Sets.cmi
Sets.cmx: Specif.cmx Maps.cmx Datatypes.cmx CList.cmx Sets.cmi
Specif.cmo: Datatypes.cmi Specif.cmi
@@ -393,6 +403,8 @@ Zdiv.cmx: Zbool.cmx ZArith_dec.cmx Specif.cmx Datatypes.cmx BinPos.cmx \
BinInt.cmx Zdiv.cmi
Zeven.cmo: Specif.cmi Datatypes.cmi BinPos.cmi BinInt.cmi Zeven.cmi
Zeven.cmx: Specif.cmx Datatypes.cmx BinPos.cmx BinInt.cmx Zeven.cmi
+Zmax.cmo: Datatypes.cmi BinInt.cmi Zmax.cmi
+Zmax.cmx: Datatypes.cmx BinInt.cmx Zmax.cmi
Zmin.cmo: Datatypes.cmi BinInt.cmi Zmin.cmi
Zmin.cmx: Datatypes.cmx BinInt.cmx Zmin.cmi
Zmisc.cmo: Datatypes.cmi BinPos.cmi BinInt.cmi Zmisc.cmi
diff --git a/extraction/Makefile b/extraction/Makefile
index 687c5c5..6ae8e35 100644
--- a/extraction/Makefile
+++ b/extraction/Makefile
@@ -1,19 +1,20 @@
FILES=\
Datatypes.ml Logic.ml Wf.ml Peano.ml Specif.ml Compare_dec.ml \
Bool.ml CList.ml Sumbool.ml BinPos.ml BinNat.ml BinInt.ml \
- ZArith_dec.ml Zeven.ml Zmin.ml Zmisc.ml Zbool.ml Zpower.ml Zdiv.ml \
- FSetInterface.ml FSetBridge.ml FSetList.ml FSetAVL.ml \
- Coqlib.ml Maps.ml Sets.ml union_find.ml AST.ml Integers.ml \
- ../caml/Camlcoq.ml ../caml/Floataux.ml Floats.ml Values.ml \
+ ZArith_dec.ml Zeven.ml Zmax.ml Zmisc.ml Zbool.ml Zpower.ml Zdiv.ml \
+ Int.ml OrderedType.ml FSetList.ml FSetAVL.ml \
+ Coqlib.ml Maps.ml Sets.ml AST.ml Iteration.ml Integers.ml \
+ ../caml/Camlcoq.ml ../caml/Floataux.ml Floats.ml Parmov.ml Values.ml \
Mem.ml Globalenvs.ml \
Op.ml Cminor.ml Cmconstr.ml \
Csharpminor.ml Cminorgen.ml \
Registers.ml RTL.ml \
../caml/RTLgenaux.ml RTLgen.ml \
- RTLtyping.ml \
+ Locations.ml Conventions.ml \
+ ../caml/RTLtypingaux.ml RTLtyping.ml \
Lattice.ml Kildall.ml \
Constprop.ml CSE.ml \
- Locations.ml Conventions.ml LTL.ml \
+ LTL.ml \
Ordered.ml InterfGraph.ml ../caml/Coloringaux.ml Coloring.ml \
Parallelmove.ml Allocation.ml \
Tunneling.ml Linear.ml Lineartyping.ml Linearize.ml \
diff --git a/extraction/extraction.v b/extraction/extraction.v
index 1717882..47c6f36 100644
--- a/extraction/extraction.v
+++ b/extraction/extraction.v
@@ -1,9 +1,8 @@
+Require Iteration.
Require Floats.
-Require Kildall.
Require RTLgen.
Require Coloring.
Require Allocation.
-Require Cmconstr.
Require Main.
(* Standard lib *)
@@ -28,9 +27,22 @@ Extract Constant Floats.Float.div => "( /. )".
Extract Constant Floats.Float.cmp => "Floataux.cmp".
Extract Constant Floats.Float.eq_dec => "fun (x: float) (y: float) -> x = y".
+(* Iteration *)
+Extract Constant Iteration.dependent_description' =>
+ "fun x -> assert false".
+
+Extract Constant Iteration.GenIter.iterate =>
+ "let rec iter f a =
+ match f a with Coq_inl b -> Some b | Coq_inr a' -> iter f a'
+ in iter".
+
+
(* RTLgen *)
Extract Constant RTLgen.more_likely => "RTLgenaux.more_likely".
+(* RTLtyping *)
+Extract Constant RTLtyping.infer_type_environment => "RTLtypingaux.infer_type_environment".
+
(* Coloring *)
Extract Constant Coloring.graph_coloring => "Coloringaux.graph_coloring".
@@ -49,5 +61,3 @@ Extract Constant PPC.preg_eq => "fun (x: preg) (y: preg) -> x = y".
(* Go! *)
Recursive Extraction Library Main.
-(*Extraction Library Compare_dec.
- Extraction Library Cmconstr.*)
diff --git a/lib/Coqlib.v b/lib/Coqlib.v
index 039dd03..3bcc8a6 100644
--- a/lib/Coqlib.v
+++ b/lib/Coqlib.v
@@ -33,20 +33,7 @@ Ltac destructEq name :=
Ltac decEq :=
match goal with
- | [ |- (_, _) = (_, _) ] =>
- apply injective_projections; unfold fst,snd; try reflexivity
- | [ |- (@Some ?T _ = @Some ?T _) ] =>
- apply (f_equal (@Some T)); try reflexivity
- | [ |- (?X _ _ _ _ _ = ?X _ _ _ _ _) ] =>
- apply (f_equal5 X); try reflexivity
- | [ |- (?X _ _ _ _ = ?X _ _ _ _) ] =>
- apply (f_equal4 X); try reflexivity
- | [ |- (?X _ _ _ = ?X _ _ _) ] =>
- apply (f_equal3 X); try reflexivity
- | [ |- (?X _ _ = ?X _ _) ] =>
- apply (f_equal2 X); try reflexivity
- | [ |- (?X _ = ?X _) ] =>
- apply (f_equal X); try reflexivity
+ | [ |- _ = _ ] => f_equal
| [ |- (?X ?A <> ?X ?B) ] =>
cut (A <> B); [intro; congruence | try discriminate]
end.
@@ -57,6 +44,46 @@ Ltac byContradiction :=
Ltac omegaContradiction :=
cut False; [contradiction|omega].
+Lemma modusponens: forall (P Q: Prop), P -> (P -> Q) -> Q.
+Proof. auto. Qed.
+
+Ltac exploit x :=
+ refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _ _) _)
+ || refine (modusponens _ _ (x _ _ _) _)
+ || refine (modusponens _ _ (x _ _) _)
+ || refine (modusponens _ _ (x _) _).
+
(** * Definitions and theorems over the type [positive] *)
Definition peq (x y: positive): {x = y} + {x <> y}.
@@ -510,6 +537,13 @@ Proof.
induction l; simpl. reflexivity. rewrite IHl; reflexivity.
Qed.
+Lemma list_map_identity:
+ forall (A: Set) (l: list A),
+ List.map (fun (x:A) => x) l = l.
+Proof.
+ induction l; simpl; congruence.
+Qed.
+
Lemma list_map_nth:
forall (A B: Set) (f: A -> B) (l: list A) (n: nat),
nth_error (List.map f l) n = option_map f (nth_error l n).
@@ -546,6 +580,27 @@ Proof.
auto. rewrite IHl1. auto.
Qed.
+(** Properties of list membership. *)
+
+Lemma in_cns:
+ forall (A: Set) (x y: A) (l: list A), In x (y :: l) <-> y = x \/ In x l.
+Proof.
+ intros. simpl. tauto.
+Qed.
+
+Lemma in_app:
+ forall (A: Set) (x: A) (l1 l2: list A), In x (l1 ++ l2) <-> In x l1 \/ In x l2.
+Proof.
+ intros. split; intro. apply in_app_or. auto. apply in_or_app. auto.
+Qed.
+
+Lemma list_in_insert:
+ forall (A: Set) (x: A) (l1 l2: list A) (y: A),
+ In x (l1 ++ l2) -> In x (l1 ++ y :: l2).
+Proof.
+ intros. apply in_or_app; simpl. elim (in_app_or _ _ _ H); intro; auto.
+Qed.
+
(** [list_disjoint l1 l2] holds iff [l1] and [l2] have no elements
in common. *)
@@ -644,35 +699,42 @@ Proof.
red; intro; elim H3. apply in_or_app. tauto.
Qed.
+Lemma list_norepet_app:
+ forall (A: Set) (l1 l2: list A),
+ list_norepet (l1 ++ l2) <->
+ list_norepet l1 /\ list_norepet l2 /\ list_disjoint l1 l2.
+Proof.
+ induction l1; simpl; intros; split; intros.
+ intuition. constructor. red;simpl;auto.
+ tauto.
+ inversion H; subst. rewrite IHl1 in H3. rewrite in_app in H2.
+ intuition.
+ constructor; auto. red; intros. elim H2; intro. congruence. auto.
+ destruct H as [B [C D]]. inversion B; subst.
+ constructor. rewrite in_app. intuition. elim (D a a); auto. apply in_eq.
+ rewrite IHl1. intuition. red; intros. apply D; auto. apply in_cons; auto.
+Qed.
+
Lemma list_norepet_append:
forall (A: Set) (l1 l2: list A),
list_norepet l1 -> list_norepet l2 -> list_disjoint l1 l2 ->
list_norepet (l1 ++ l2).
Proof.
- induction l1; simpl; intros.
- auto.
- inversion H. subst hd tl.
- constructor. red; intro. apply (H1 a a). auto with coqlib.
- elim (in_app_or _ _ _ H2); tauto. auto.
- apply IHl1. auto. auto.
- red; intros; apply H1; auto with coqlib.
+ generalize list_norepet_app; firstorder.
Qed.
Lemma list_norepet_append_right:
forall (A: Set) (l1 l2: list A),
list_norepet (l1 ++ l2) -> list_norepet l2.
Proof.
- induction l1; intros.
- assumption.
- simpl in H. inversion H. eauto.
+ generalize list_norepet_app; firstorder.
Qed.
Lemma list_norepet_append_left:
forall (A: Set) (l1 l2: list A),
list_norepet (l1 ++ l2) -> list_norepet l1.
Proof.
- intros. apply list_norepet_append_right with l2.
- apply list_norepet_append_commut. auto.
+ generalize list_norepet_app; firstorder.
Qed.
(** [list_forall2 P [x1 ... xN] [y1 ... yM] holds iff [N = M] and
@@ -707,3 +769,37 @@ Proof.
constructor. auto with coqlib. apply IHlist_forall2; auto.
intros. auto with coqlib.
Qed.
+
+(** Dropping the first or first two elements of a list. *)
+
+Definition list_drop1 (A: Set) (x: list A) :=
+ match x with nil => nil | hd :: tl => tl end.
+Definition list_drop2 (A: Set) (x: list A) :=
+ match x with nil => nil | hd :: nil => nil | hd1 :: hd2 :: tl => tl end.
+
+Lemma list_drop1_incl:
+ forall (A: Set) (x: A) (l: list A), In x (list_drop1 l) -> In x l.
+Proof.
+ intros. destruct l. elim H. simpl in H. auto with coqlib.
+Qed.
+
+Lemma list_drop2_incl:
+ forall (A: Set) (x: A) (l: list A), In x (list_drop2 l) -> In x l.
+Proof.
+ intros. destruct l. elim H. destruct l. elim H.
+ simpl in H. auto with coqlib.
+Qed.
+
+Lemma list_drop1_norepet:
+ forall (A: Set) (l: list A), list_norepet l -> list_norepet (list_drop1 l).
+Proof.
+ intros. destruct l; simpl. constructor. inversion H. auto.
+Qed.
+
+Lemma list_drop2_norepet:
+ forall (A: Set) (l: list A), list_norepet l -> list_norepet (list_drop2 l).
+Proof.
+ intros. destruct l; simpl. constructor.
+ destruct l; simpl. constructor. inversion H. inversion H3. auto.
+Qed.
+
diff --git a/lib/Floats.v b/lib/Floats.v
index b95789e..67b0e53 100644
--- a/lib/Floats.v
+++ b/lib/Floats.v
@@ -6,7 +6,6 @@
and the associated operations. *)
Require Import Bool.
-Require Import AST.
Require Import Integers.
Parameter float: Set.
diff --git a/lib/Integers.v b/lib/Integers.v
index 6b605bd..5a18dc0 100644
--- a/lib/Integers.v
+++ b/lib/Integers.v
@@ -1,29 +1,48 @@
(** Formalizations of integers modulo $2^32$ #2<sup>32</sup>#. *)
Require Import Coqlib.
-Require Import AST.
Definition wordsize : nat := 32%nat.
Definition modulus : Z := two_power_nat wordsize.
Definition half_modulus : Z := modulus / 2.
+(** * Comparisons *)
+
+Inductive comparison : Set :=
+ | Ceq : comparison (**r same *)
+ | Cne : comparison (**r different *)
+ | Clt : comparison (**r less than *)
+ | Cle : comparison (**r less than or equal *)
+ | Cgt : comparison (**r greater than *)
+ | Cge : comparison. (**r greater than or equal *)
+
+Definition negate_comparison (c: comparison): comparison :=
+ match c with
+ | Ceq => Cne
+ | Cne => Ceq
+ | Clt => Cge
+ | Cle => Cgt
+ | Cgt => Cle
+ | Cge => Clt
+ end.
+
+Definition swap_comparison (c: comparison): comparison :=
+ match c with
+ | Ceq => Ceq
+ | Cne => Cne
+ | Clt => Cgt
+ | Cle => Cge
+ | Cgt => Clt
+ | Cge => Cle
+ end.
+
(** * Representation of machine integers *)
(** A machine integer (type [int]) is represented as a Coq arbitrary-precision
integer (type [Z]) plus a proof that it is in the range 0 (included) to
[modulus] (excluded. *)
-Definition in_range (x: Z) :=
- match x ?= 0 with
- | Lt => False
- | _ =>
- match x ?= modulus with
- | Lt => True
- | _ => False
- end
- end.
-
-Record int: Set := mkint { intval: Z; intrange: in_range intval }.
+Record int: Set := mkint { intval: Z; intrange: 0 <= intval < modulus }.
Module Int.
@@ -43,14 +62,10 @@ Definition signed (n: int) : Z :=
else unsigned n - modulus.
Lemma mod_in_range:
- forall x, in_range (Zmod x modulus).
+ forall x, 0 <= Zmod x modulus < modulus.
Proof.
intro.
- generalize (Z_mod_lt x modulus (two_power_nat_pos wordsize)).
- intros [A B].
- assert (C: x mod modulus >= 0). omega.
- red. red in C. red in B.
- rewrite B. destruct (x mod modulus ?= 0); auto.
+ exact (Z_mod_lt x modulus (two_power_nat_pos wordsize)).
Qed.
(** Conversely, [repr] takes a Coq integer and returns the corresponding
@@ -550,26 +565,10 @@ Proof.
apply eqmod_refl. red; exists (-1); ring.
Qed.
-Lemma in_range_range:
- forall z, in_range z -> 0 <= z < modulus.
-Proof.
- intros.
- assert (z >= 0 /\ z < modulus).
- generalize H. unfold in_range, Zge, Zlt.
- destruct (z ?= 0).
- destruct (z ?= modulus); try contradiction.
- intuition congruence.
- contradiction.
- destruct (z ?= modulus); try contradiction.
- intuition congruence.
- omega.
-Qed.
-
Theorem unsigned_range:
forall i, 0 <= unsigned i < modulus.
Proof.
- destruct i; simpl.
- apply in_range_range. auto.
+ destruct i; simpl. auto.
Qed.
Hint Resolve unsigned_range: ints.
@@ -597,7 +596,7 @@ Theorem repr_unsigned:
forall i, repr (unsigned i) = i.
Proof.
destruct i; simpl. unfold repr. apply mkint_eq.
- apply Zmod_small. apply in_range_range; auto.
+ apply Zmod_small. auto.
Qed.
Hint Resolve repr_unsigned: ints.
diff --git a/lib/Iteration.v b/lib/Iteration.v
new file mode 100644
index 0000000..85c5ded
--- /dev/null
+++ b/lib/Iteration.v
@@ -0,0 +1,293 @@
+(* Bounded and unbounded iterators *)
+
+Require Import Coqlib.
+Require Import Classical.
+Require Import Max.
+
+Module Type ITER.
+Variable iterate
+ : forall A B : Set, (A -> B + A) -> A -> option B.
+Hypothesis iterate_prop
+ : forall (A B : Set) (step : A -> B + A) (P : A -> Prop) (Q : B -> Prop),
+ (forall a : A, P a ->
+ match step a with inl b => Q b | inr a' => P a' end) ->
+ forall (a : A) (b : B), iterate A B step a = Some b -> P a -> Q b.
+End ITER.
+
+Axiom
+ dependent_description' :
+ forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop),
+ (forall x:A,
+ exists y : B x, R x y /\ (forall y':B x, R x y' -> y = y')) ->
+ sigT (fun f : forall x:A, B x => (forall x:A, R x (f x))).
+
+(* A constructive implementation using bounded iteration. *)
+
+Module PrimIter: ITER.
+
+Section ITERATION.
+
+Variables A B: Set.
+Variable step: A -> B + A.
+
+(** The [step] parameter represents one step of the iteration. From a
+ current iteration state [a: A], it either returns a value of type [B],
+ meaning that iteration is over and that this [B] value is the final
+ result of the iteration, or a value [a' : A] which is the next state
+ of the iteration.
+
+ The naive way to define the iteration is:
+<<
+Fixpoint iterate (a: A) : B :=
+ match step a with
+ | inl b => b
+ | inr a' => iterate a'
+ end.
+>>
+ However, this is a general recursion, not guaranteed to terminate,
+ and therefore not expressible in Coq. The standard way to work around
+ this difficulty is to use Noetherian recursion (Coq module [Wf]).
+ This requires that we equip the type [A] with a well-founded ordering [<]
+ (no infinite ascending chains) and we demand that [step] satisfies
+ [step a = inr a' -> a < a']. For the types [A] that are of interest to us
+ in this development, it is however very painful to define adequate
+ well-founded orderings, even though we know our iterations always
+ terminate.
+
+ Instead, we choose to bound the number of iterations by an arbitrary
+ constant. [iterate] then becomes a function that can fail,
+ of type [A -> option B]. The [None] result denotes failure to reach
+ a result in the number of iterations prescribed, or, in other terms,
+ failure to find a solution to the dataflow problem. The compiler
+ passes that exploit dataflow analysis (the [Constprop], [CSE] and
+ [Allocation] passes) will, in this case, either fail ([Allocation])
+ or turn off the optimization pass ([Constprop] and [CSE]).
+
+ Since we know (informally) that our computations terminate, we can
+ take a very large constant as the maximal number of iterations.
+ Failure will therefore never happen in practice, but of
+ course our proofs also cover the failure case and show that
+ nothing bad happens in this hypothetical case either. *)
+
+Definition num_iterations := 1000000000000%positive.
+
+(** The simple definition of bounded iteration is:
+<<
+Fixpoint iterate (niter: nat) (a: A) {struct niter} : option B :=
+ match niter with
+ | O => None
+ | S niter' =>
+ match step a with
+ | inl b => b
+ | inr a' => iterate niter' a'
+ end
+ end.
+>>
+ This function is structural recursive over the parameter [niter]
+ (number of iterations), represented here as a Peano integer (type [nat]).
+ However, we want to use very large values of [niter]. As Peano integers,
+ these values would be much too large to fit in memory. Therefore,
+ we must express iteration counts as a binary integer (type [positive]).
+ However, Peano induction over type [positive] is not structural recursion,
+ so we cannot define [iterate] as a Coq fixpoint and must use
+ Noetherian recursion instead. *)
+
+Definition iter_step (x: positive)
+ (next: forall y, Plt y x -> A -> option B)
+ (s: A) : option B :=
+ match peq x xH with
+ | left EQ => None
+ | right NOTEQ =>
+ match step s with
+ | inl res => Some res
+ | inr s' => next (Ppred x) (Ppred_Plt x NOTEQ) s'
+ end
+ end.
+
+Definition iter: positive -> A -> option B :=
+ Fix Plt_wf (fun _ => A -> option B) iter_step.
+
+(** We then prove the expected unrolling equations for [iter]. *)
+
+Remark unroll_iter:
+ forall x, iter x = iter_step x (fun y _ => iter y).
+Proof.
+ unfold iter; apply (Fix_eq Plt_wf (fun _ => A -> option B) iter_step).
+ intros. unfold iter_step. apply extensionality. intro s.
+ case (peq x xH); intro. auto.
+ rewrite H. auto.
+Qed.
+
+(** The [iterate] function is defined as [iter] up to
+ [num_iterations] through the loop. *)
+
+Definition iterate := iter num_iterations.
+
+(** We now prove the invariance property [iterate_prop]. *)
+
+Variable P: A -> Prop.
+Variable Q: B -> Prop.
+
+Hypothesis step_prop:
+ forall a : A, P a ->
+ match step a with inl b => Q b | inr a' => P a' end.
+
+Lemma iter_prop:
+ forall n a b, P a -> iter n a = Some b -> Q b.
+Proof.
+ apply (well_founded_ind Plt_wf
+ (fun p => forall a b, P a -> iter p a = Some b -> Q b)).
+ intros until b. intro. rewrite unroll_iter.
+ unfold iter_step. case (peq x 1); intro. congruence.
+ generalize (step_prop a H0).
+ case (step a); intros. congruence.
+ apply H with (Ppred x) a0. apply Ppred_Plt; auto. auto. auto.
+Qed.
+
+Lemma iterate_prop:
+ forall a b, iterate a = Some b -> P a -> Q b.
+Proof.
+ intros. apply iter_prop with num_iterations a; assumption.
+Qed.
+
+End ITERATION.
+
+End PrimIter.
+
+(* An implementation using classical logic and unbounded iteration,
+ in the style of Yves Bertot's paper, "Extending the Calculus
+ of Constructions with Tarski's fix-point theorem". *)
+
+Module GenIter: ITER.
+
+Section ITERATION.
+
+Variables A B: Set.
+Variable step: A -> B + A.
+
+Definition B_le (x y: option B) : Prop := x = None \/ y = x.
+Definition F_le (x y: A -> option B) : Prop := forall a, B_le (x a) (y a).
+
+Definition F_iter (next: A -> option B) (a: A) : option B :=
+ match step a with
+ | inl b => Some b
+ | inr a' => next a'
+ end.
+
+Lemma F_iter_monot:
+ forall f g, F_le f g -> F_le (F_iter f) (F_iter g).
+Proof.
+ intros; red; intros. unfold F_iter.
+ destruct (step a) as [b | a']. red; auto. apply H.
+Qed.
+
+Fixpoint iter (n: nat) : A -> option B :=
+ match n with
+ | O => (fun a => None)
+ | S m => F_iter (iter m)
+ end.
+
+Lemma iter_monot:
+ forall p q, (p <= q)%nat -> F_le (iter p) (iter q).
+Proof.
+ induction p; intros.
+ simpl. red; intros; red; auto.
+ destruct q. elimtype False; omega.
+ simpl. apply F_iter_monot. apply IHp. omega.
+Qed.
+
+Lemma iter_either:
+ forall a,
+ (exists n, exists b, iter n a = Some b) \/
+ (forall n, iter n a = None).
+Proof.
+ intro a. elim (classic (forall n, iter n a = None)); intro.
+ right; assumption.
+ left. generalize (not_all_ex_not nat (fun n => iter n a = None) H).
+ intros [n D]. exists n. generalize D.
+ case (iter n a); intros. exists b; auto. congruence.
+Qed.
+
+Definition converges_to (a: A) (b: option B) : Prop :=
+ exists n, forall m, (n <= m)%nat -> iter m a = b.
+
+Lemma converges_to_Some:
+ forall a n b, iter n a = Some b -> converges_to a (Some b).
+Proof.
+ intros. exists n. intros.
+ assert (B_le (iter n a) (iter m a)). apply iter_monot. auto.
+ elim H1; intro; congruence.
+Qed.
+
+Lemma converges_to_exists:
+ forall a, exists b, converges_to a b.
+Proof.
+ intros. elim (iter_either a).
+ intros [n [b EQ]]. exists (Some b). apply converges_to_Some with n. assumption.
+ intro. exists (@None B). exists O. intros. auto.
+Qed.
+
+Lemma converges_to_unique:
+ forall a b, converges_to a b -> forall b', converges_to a b' -> b = b'.
+Proof.
+ intros a b [n C] b' [n' C'].
+ rewrite <- (C (max n n')). rewrite <- (C' (max n n')). auto.
+ apply le_max_r. apply le_max_l.
+Qed.
+
+Lemma converges_to_exists_uniquely:
+ forall a, exists b, converges_to a b /\ forall b', converges_to a b' -> b = b'.
+Proof.
+ intro. destruct (converges_to_exists a) as [b CT].
+ exists b. split. assumption. exact (converges_to_unique _ _ CT).
+Qed.
+
+Definition exists_iterate :=
+ dependent_description' A (fun _ => option B)
+ converges_to converges_to_exists_uniquely.
+
+Definition iterate : A -> option B :=
+ match exists_iterate with existT f P => f end.
+
+Lemma converges_to_iterate:
+ forall a b, converges_to a b -> iterate a = b.
+Proof.
+ intros. unfold iterate. destruct exists_iterate as [f P].
+ apply converges_to_unique with a. apply P. auto.
+Qed.
+
+Lemma iterate_converges_to:
+ forall a, converges_to a (iterate a).
+Proof.
+ intros. unfold iterate. destruct exists_iterate as [f P]. apply P.
+Qed.
+
+(** Invariance property. *)
+
+Variable P: A -> Prop.
+Variable Q: B -> Prop.
+
+Hypothesis step_prop:
+ forall a : A, P a ->
+ match step a with inl b => Q b | inr a' => P a' end.
+
+Lemma iter_prop:
+ forall n a b, P a -> iter n a = Some b -> Q b.
+Proof.
+ induction n; intros until b; intro H; simpl.
+ congruence.
+ unfold F_iter. generalize (step_prop a H).
+ case (step a); intros. congruence.
+ apply IHn with a0; auto.
+Qed.
+
+Lemma iterate_prop:
+ forall a b, iterate a = Some b -> P a -> Q b.
+Proof.
+ intros. destruct (iterate_converges_to a) as [n IT].
+ rewrite H in IT. apply iter_prop with n a. auto. apply IT. auto.
+Qed.
+
+End ITERATION.
+
+End GenIter.
diff --git a/lib/Ordered.v b/lib/Ordered.v
index 1747bbb..ad47314 100644
--- a/lib/Ordered.v
+++ b/lib/Ordered.v
@@ -1,7 +1,7 @@
(** Constructions of ordered types, for use with the [FSet] functors
for finite sets. *)
-Require Import FSet.
+Require Import FSets.
Require Import Coqlib.
Require Import Maps.
@@ -26,10 +26,10 @@ Proof Plt_ne.
Lemma compare : forall x y : t, Compare lt eq x y.
Proof.
intros. case (plt x y); intro.
- apply Lt. auto.
+ apply LT. auto.
case (peq x y); intro.
- apply Eq. auto.
- apply Gt. red; unfold Plt in *.
+ apply EQ. auto.
+ apply GT. red; unfold Plt in *.
assert (Zpos x <> Zpos y). congruence. omega.
Qed.
@@ -64,9 +64,9 @@ Qed.
Lemma compare : forall x y : t, Compare lt eq x y.
Proof.
intros. case (OrderedPositive.compare (A.index x) (A.index y)); intro.
- apply Lt. exact l.
- apply Eq. red; red in e. apply A.index_inj; auto.
- apply Gt. exact l.
+ apply LT. exact l.
+ apply EQ. red; red in e. apply A.index_inj; auto.
+ apply GT. exact l.
Qed.
End OrderedIndexed.
@@ -144,12 +144,12 @@ Lemma compare : forall x y : t, Compare lt eq x y.
Proof.
intros.
case (A.compare (fst x) (fst y)); intro.
- apply Lt. red. left. auto.
+ apply LT. red. left. auto.
case (B.compare (snd x) (snd y)); intro.
- apply Lt. red. right. tauto.
- apply Eq. red. tauto.
- apply Gt. red. right. split. apply A.eq_sym. auto. auto.
- apply Gt. red. left. auto.
+ apply LT. red. right. tauto.
+ apply EQ. red. tauto.
+ apply GT. red. right. split. apply A.eq_sym. auto. auto.
+ apply GT. red. left. auto.
Qed.
End OrderedPair.
diff --git a/lib/Parmov.v b/lib/Parmov.v
new file mode 100644
index 0000000..cd24dd9
--- /dev/null
+++ b/lib/Parmov.v
@@ -0,0 +1,1206 @@
+(** Translation of parallel moves into sequences of individual moves *)
+
+(** The ``parallel move'' problem, also known as ``parallel assignment'',
+ is the following. We are given a list of (source, destination) pairs
+ of locations. The goal is to find a sequence of elementary
+ moves ([loc <- loc] assignments) such that, at the end of the sequence,
+ location [dst] contains the value of location [src] at the beginning of
+ the sequence, for each ([src], [dst]) pairs in the given problem.
+ Moreover, other locations should keep their values, except one register
+ of each type, which can be used as temporaries in the generated sequences.
+
+ The parallel move problem is trivial if the sources and destinations do
+ not overlap. For instance,
+<<
+ (R1, R2) <- (R3, R4) becomes R1 <- R3; R2 <- R4
+>>
+ However, arbitrary overlap is allowed between sources and destinations.
+ This requires some care in ordering the individual moves, as in
+<<
+ (R1, R2) <- (R3, R1) becomes R2 <- R1; R1 <- R3
+>>
+ Worse, cycles (permutations) can require the use of temporaries, as in
+<<
+ (R1, R2, R3) <- (R2, R3, R1) becomes T <- R1; R1 <- R2; R2 <- R3; R3 <- T;
+>>
+ An amazing fact is that for any parallel move problem, at most one temporary
+ (or in our case one integer temporary and one float temporary) is needed.
+
+ The development in this section was contributed by Laurence Rideau and
+ Bernard Serpette. It is described in their paper
+ ``Coq à la conquête des moulins'', JFLA 2005,
+ #<A HREF="http://www-sop.inria.fr/lemme/Laurence.Rideau/RideauSerpetteJFLA05.ps">#
+ http://www-sop.inria.fr/lemme/Laurence.Rideau/RideauSerpetteJFLA05.ps
+ #</A>#
+*)
+
+Require Import Coqlib.
+Require Recdef.
+
+Section PARMOV.
+
+Variable reg: Set.
+Variable temp: reg -> reg.
+
+Definition moves := (list (reg * reg))%type. (* src -> dst *)
+
+Definition srcs (m: moves) := List.map (@fst reg reg) m.
+Definition dests (m: moves) := List.map (@snd reg reg) m.
+
+(* Semantics of moves *)
+
+Variable val: Set.
+Definition env := reg -> val.
+Variable reg_eq : forall (r1 r2: reg), {r1=r2} + {r1<>r2}.
+
+Lemma env_ext:
+ forall (e1 e2: env),
+ (forall r, e1 r = e2 r) -> e1 = e2.
+Proof (extensionality reg val).
+
+Definition update (r: reg) (v: val) (e: env) : env :=
+ fun r' => if reg_eq r' r then v else e r'.
+
+Lemma update_s:
+ forall r v e, update r v e r = v.
+Proof.
+ unfold update; intros. destruct (reg_eq r r). auto. congruence.
+Qed.
+
+Lemma update_o:
+ forall r v e r', r' <> r -> update r v e r' = e r'.
+Proof.
+ unfold update; intros. destruct (reg_eq r' r). congruence. auto.
+Qed.
+
+Lemma update_ident:
+ forall r e, update r (e r) e = e.
+Proof.
+ intros. apply env_ext; intro. unfold update. destruct (reg_eq r0 r); congruence.
+Qed.
+
+Lemma update_commut:
+ forall r1 v1 r2 v2 e,
+ r1 <> r2 ->
+ update r1 v1 (update r2 v2 e) = update r2 v2 (update r1 v1 e).
+Proof.
+ intros. apply env_ext; intro; unfold update.
+ destruct (reg_eq r r1); destruct (reg_eq r r2); auto.
+ congruence.
+Qed.
+
+Lemma update_twice:
+ forall r v e,
+ update r v (update r v e) = update r v e.
+Proof.
+ intros. apply env_ext; intro; unfold update.
+ destruct (reg_eq r0 r); auto.
+Qed.
+
+Fixpoint exec_par (m: moves) (e: env) {struct m}: env :=
+ match m with
+ | nil => e
+ | (s, d) :: m' => update d (e s) (exec_par m' e)
+ end.
+
+Fixpoint exec_seq (m: moves) (e: env) {struct m}: env :=
+ match m with
+ | nil => e
+ | (s, d) :: m' => exec_seq m' (update d (e s) e)
+ end.
+
+Fixpoint exec_seq_rev (m: moves) (e: env) {struct m}: env :=
+ match m with
+ | nil => e
+ | (s, d) :: m' =>
+ let e' := exec_seq_rev m' e in
+ update d (e' s) e'
+ end.
+
+(* Specification of the parallel move *)
+
+Definition no_read (mu: moves) (d: reg) : Prop :=
+ ~In d (srcs mu).
+
+Inductive transition: moves -> moves -> moves
+ -> moves -> moves -> moves -> Prop :=
+ | tr_nop: forall mu1 r mu2 sigma tau,
+ transition (mu1 ++ (r, r) :: mu2) sigma tau
+ (mu1 ++ mu2) sigma tau
+ | tr_start: forall mu1 s d mu2 tau,
+ transition (mu1 ++ (s, d) :: mu2) nil tau
+ (mu1 ++ mu2) ((s, d) :: nil) tau
+ | tr_push: forall mu1 d r mu2 s sigma tau,
+ transition (mu1 ++ (d, r) :: mu2) ((s, d) :: sigma) tau
+ (mu1 ++ mu2) ((d, r) :: (s, d) :: sigma) tau
+ | tr_loop: forall mu sigma s d tau,
+ transition mu (sigma ++ (s, d) :: nil) tau
+ mu (sigma ++ (temp s, d) :: nil) ((s, temp s) :: tau)
+ | tr_pop: forall mu s0 d0 s1 d1 sigma tau,
+ no_read mu d1 -> d1 <> s0 ->
+ transition mu ((s1, d1) :: sigma ++ (s0, d0) :: nil) tau
+ mu (sigma ++ (s0, d0) :: nil) ((s1, d1) :: tau)
+ | tr_last: forall mu s d tau,
+ no_read mu d ->
+ transition mu ((s, d) :: nil) tau
+ mu nil ((s, d) :: tau).
+
+Inductive transitions: moves -> moves -> moves
+ -> moves -> moves -> moves -> Prop :=
+ | tr_refl:
+ forall mu sigma tau,
+ transitions mu sigma tau mu sigma tau
+ | tr_one:
+ forall mu1 sigma1 tau1 mu2 sigma2 tau2,
+ transition mu1 sigma1 tau1 mu2 sigma2 tau2 ->
+ transitions mu1 sigma1 tau1 mu2 sigma2 tau2
+ | tr_trans:
+ forall mu1 sigma1 tau1 mu2 sigma2 tau2 mu3 sigma3 tau3,
+ transitions mu1 sigma1 tau1 mu2 sigma2 tau2 ->
+ transitions mu2 sigma2 tau2 mu3 sigma3 tau3 ->
+ transitions mu1 sigma1 tau1 mu3 sigma3 tau3.
+
+(* Well-formedness properties *)
+
+Definition is_mill (m: moves) : Prop :=
+ list_norepet (dests m).
+
+Definition is_not_temp (r: reg) : Prop :=
+ forall d, r <> temp d.
+
+Definition move_no_temp (m: moves) : Prop :=
+ forall s d, In (s, d) m -> is_not_temp s /\ is_not_temp d.
+
+Definition temp_last (m: moves) : Prop :=
+ match List.rev m with
+ | nil => True
+ | (s, d) :: m' => is_not_temp d /\ move_no_temp m'
+ end.
+
+Definition is_first_dest (m: moves) (d: reg) : Prop :=
+ match m with
+ | nil => True
+ | (s0, d0) :: _ => d = d0
+ end.
+
+Inductive is_path: moves -> Prop :=
+ | is_path_nil:
+ is_path nil
+ | is_path_cons: forall s d m,
+ is_first_dest m s ->
+ is_path m ->
+ is_path ((s, d) :: m).
+
+Definition state_wf (mu sigma tau: moves) : Prop :=
+ is_mill (mu ++ sigma)
+ /\ move_no_temp mu
+ /\ temp_last sigma
+ /\ is_path sigma.
+
+(* Some properties of srcs and dests *)
+
+Lemma dests_append:
+ forall m1 m2, dests (m1 ++ m2) = dests m1 ++ dests m2.
+Proof.
+ intros. unfold dests. apply map_app.
+Qed.
+
+Lemma dests_decomp:
+ forall m1 s d m2, dests (m1 ++ (s, d) :: m2) = dests m1 ++ d :: dests m2.
+Proof.
+ intros. unfold dests. rewrite map_app. reflexivity.
+Qed.
+
+Lemma srcs_append:
+ forall m1 m2, srcs (m1 ++ m2) = srcs m1 ++ srcs m2.
+Proof.
+ intros. unfold srcs. apply map_app.
+Qed.
+
+Lemma srcs_decomp:
+ forall m1 s d m2, srcs (m1 ++ (s, d) :: m2) = srcs m1 ++ s :: srcs m2.
+Proof.
+ intros. unfold srcs. rewrite map_app. reflexivity.
+Qed.
+
+Lemma srcs_dests_combine:
+ forall s d,
+ List.length s = List.length d ->
+ srcs (List.combine s d) = s /\
+ dests (List.combine s d) = d.
+Proof.
+ induction s; destruct d; simpl; intros.
+ tauto.
+ discriminate.
+ discriminate.
+ elim (IHs d); intros. split; congruence. congruence.
+Qed.
+
+(* Some properties of is_mill and dests_disjoint *)
+
+Definition dests_disjoint (m1 m2: moves) : Prop :=
+ list_disjoint (dests m1) (dests m2).
+
+Lemma dests_disjoint_sym:
+ forall m1 m2,
+ dests_disjoint m1 m2 <-> dests_disjoint m2 m1.
+Proof.
+ unfold dests_disjoint; intros.
+ split; intros; apply list_disjoint_sym; auto.
+Qed.
+
+Lemma dests_disjoint_cons_left:
+ forall m1 s d m2,
+ dests_disjoint ((s, d) :: m1) m2 <->
+ dests_disjoint m1 m2 /\ ~In d (dests m2).
+Proof.
+ unfold dests_disjoint, list_disjoint.
+ simpl; intros; split; intros.
+ split. auto. firstorder.
+ destruct H. elim H0; intro.
+ red; intro; subst. contradiction.
+ apply H; auto.
+Qed.
+
+Lemma dests_disjoint_cons_right:
+ forall m1 s d m2,
+ dests_disjoint m1 ((s, d) :: m2) <->
+ dests_disjoint m1 m2 /\ ~In d (dests m1).
+Proof.
+ intros. rewrite dests_disjoint_sym. rewrite dests_disjoint_cons_left.
+ rewrite dests_disjoint_sym. tauto.
+Qed.
+
+Lemma dests_disjoint_append_left:
+ forall m1 m2 m3,
+ dests_disjoint (m1 ++ m2) m3 <->
+ dests_disjoint m1 m3 /\ dests_disjoint m2 m3.
+Proof.
+ unfold dests_disjoint, list_disjoint.
+ intros; split; intros. split; intros.
+ apply H; eauto. rewrite dests_append. apply in_or_app. auto.
+ apply H; eauto. rewrite dests_append. apply in_or_app. auto.
+ destruct H.
+ rewrite dests_append in H0. elim (in_app_or _ _ _ H0); auto.
+Qed.
+
+Lemma dests_disjoint_append_right:
+ forall m1 m2 m3,
+ dests_disjoint m1 (m2 ++ m3) <->
+ dests_disjoint m1 m2 /\ dests_disjoint m1 m3.
+Proof.
+ intros. rewrite dests_disjoint_sym. rewrite dests_disjoint_append_left.
+ intuition; rewrite dests_disjoint_sym; assumption.
+Qed.
+
+Lemma is_mill_cons:
+ forall s d m,
+ is_mill ((s, d) :: m) <->
+ is_mill m /\ ~In d (dests m).
+Proof.
+ unfold is_mill, dests_disjoint; intros. simpl.
+ split; intros.
+ inversion H; tauto.
+ constructor; tauto.
+Qed.
+
+Lemma is_mill_append:
+ forall m1 m2,
+ is_mill (m1 ++ m2) <->
+ is_mill m1 /\ is_mill m2 /\ dests_disjoint m1 m2.
+Proof.
+ unfold is_mill, dests_disjoint; intros. rewrite dests_append.
+ apply list_norepet_app.
+Qed.
+
+(* Some properties of move_no_temp *)
+
+Lemma move_no_temp_append:
+ forall m1 m2,
+ move_no_temp m1 -> move_no_temp m2 -> move_no_temp (m1 ++ m2).
+Proof.
+ intros; red; intros. elim (in_app_or _ _ _ H1); intro.
+ apply H; auto. apply H0; auto.
+Qed.
+
+Lemma move_no_temp_rev:
+ forall m, move_no_temp (List.rev m) -> move_no_temp m.
+Proof.
+ intros; red; intros. apply H. rewrite <- List.In_rev. auto.
+Qed.
+
+(* Some properties of temp_last *)
+
+Lemma temp_last_change_last_source:
+ forall s d s' sigma,
+ temp_last (sigma ++ (s, d) :: nil) ->
+ temp_last (sigma ++ (s', d) :: nil).
+Proof.
+ intros until sigma. unfold temp_last.
+ repeat rewrite rev_unit. auto.
+Qed.
+
+Lemma temp_last_push:
+ forall s1 d1 s2 d2 sigma,
+ temp_last ((s2, d2) :: sigma) ->
+ is_not_temp s1 -> is_not_temp d1 ->
+ temp_last ((s1, d1) :: (s2, d2) :: sigma).
+Proof.
+ unfold temp_last; intros. simpl. simpl in H.
+ destruct (rev sigma); simpl in *.
+ intuition. red; simpl; intros.
+ elim H; intros. inversion H4. subst; tauto. tauto.
+ destruct p as [sN dN]. intuition.
+ red; intros. elim (in_app_or _ _ _ H); intros.
+ apply H3; auto.
+ elim H4; intros. inversion H5; subst; tauto. elim H5.
+Qed.
+
+Lemma temp_last_pop:
+ forall s1 d1 sigma s2 d2,
+ temp_last ((s1, d1) :: sigma ++ (s2, d2) :: nil) ->
+ temp_last (sigma ++ (s2, d2) :: nil).
+Proof.
+ intros until d2.
+ change ((s1, d1) :: sigma ++ (s2, d2) :: nil)
+ with ((((s1, d1) :: nil) ++ sigma) ++ ((s2, d2) :: nil)).
+ unfold temp_last. repeat rewrite rev_unit.
+ intuition. simpl in H1. red; intros. apply H1.
+ apply in_or_app. auto.
+Qed.
+
+(* Some properties of is_path *)
+
+Lemma is_path_pop:
+ forall s d m,
+ is_path ((s, d) :: m) -> is_path m.
+Proof.
+ intros. inversion H; subst. auto.
+Qed.
+
+Lemma is_path_change_last_source:
+ forall s s' d sigma,
+ is_path (sigma ++ (s, d) :: nil) ->
+ is_path (sigma ++ (s', d) :: nil).
+Proof.
+ induction sigma; simpl; intros.
+ constructor. red; auto. constructor.
+ inversion H; subst; clear H.
+ constructor.
+ destruct sigma as [ | [s1 d1] sigma']; simpl; simpl in H2; auto.
+ auto.
+Qed.
+
+Lemma path_sources_dests:
+ forall s0 d0 sigma,
+ is_path (sigma ++ (s0, d0) :: nil) ->
+ List.incl (srcs (sigma ++ (s0, d0) :: nil))
+ (s0 :: dests (sigma ++ (s0, d0) :: nil)).
+Proof.
+ induction sigma; simpl; intros.
+ red; simpl; tauto.
+ inversion H; subst; clear H. simpl.
+ assert (In s (dests (sigma ++ (s0, d0) :: nil))).
+ destruct sigma as [ | [s1 d1] sigma']; simpl; simpl in H2; intuition.
+ apply incl_cons. simpl; tauto.
+ apply incl_tran with (s0 :: dests (sigma ++ (s0, d0) :: nil)).
+ eapply IHsigma; eauto.
+ red; simpl; tauto.
+Qed.
+
+Lemma no_read_path:
+ forall d1 sigma s0 d0,
+ d1 <> s0 ->
+ is_path (sigma ++ (s0, d0) :: nil) ->
+ ~In d1 (dests (sigma ++ (s0, d0) :: nil)) ->
+ no_read (sigma ++ (s0, d0) :: nil) d1.
+Proof.
+ intros.
+ generalize (path_sources_dests _ _ _ H0). intro.
+ intro. elim H1. elim (H2 _ H3); intro. congruence. auto.
+Qed.
+
+(* Populating a rewrite database. *)
+
+Lemma notin_dests_cons:
+ forall x s d m,
+ ~In x (dests ((s, d) :: m)) <-> x <> d /\ ~In x (dests m).
+Proof.
+ intros. simpl. intuition auto.
+Qed.
+
+Lemma notin_dests_append:
+ forall d m1 m2,
+ ~In d (dests (m1 ++ m2)) <-> ~In d (dests m1) /\ ~In d (dests m2).
+Proof.
+ intros. rewrite dests_append. rewrite in_app. tauto.
+Qed.
+
+Hint Rewrite is_mill_cons is_mill_append
+ dests_disjoint_cons_left dests_disjoint_cons_right
+ dests_disjoint_append_left dests_disjoint_append_right
+ notin_dests_cons notin_dests_append: pmov.
+
+(* Preservation of well-formedness *)
+
+Lemma transition_preserves_wf:
+ forall mu sigma tau mu' sigma' tau',
+ transition mu sigma tau mu' sigma' tau' ->
+ state_wf mu sigma tau -> state_wf mu' sigma' tau'.
+Proof.
+ induction 1; unfold state_wf; intros [A [B [C D]]];
+ autorewrite with pmov in A; autorewrite with pmov.
+
+ (* Nop *)
+ split. tauto.
+ split. red; intros. apply B. apply list_in_insert; auto.
+ split; auto.
+
+ (* Start *)
+ split. tauto.
+ split. red; intros. apply B. apply list_in_insert; auto.
+ split. red. simpl. split. elim (B s d). auto.
+ apply in_or_app. right. apply in_eq.
+ red; simpl; tauto.
+ constructor. exact I. constructor.
+
+ (* Push *)
+ split. intuition.
+ split. red; intros. apply B. apply list_in_insert; auto.
+ split. elim (B d r). apply temp_last_push; auto.
+ apply in_or_app; right; apply in_eq.
+ constructor. simpl. auto. auto.
+
+ (* Loop *)
+ split. tauto.
+ split. auto.
+ split. eapply temp_last_change_last_source; eauto.
+ eapply is_path_change_last_source; eauto.
+
+ (* Pop *)
+ split. intuition.
+ split. auto.
+ split. eapply temp_last_pop; eauto.
+ eapply is_path_pop; eauto.
+
+ (* Last *)
+ split. intuition.
+ split. auto.
+ split. unfold temp_last. simpl. auto.
+ constructor.
+Qed.
+
+Lemma transitions_preserve_wf:
+ forall mu sigma tau mu' sigma' tau',
+ transitions mu sigma tau mu' sigma' tau' ->
+ state_wf mu sigma tau -> state_wf mu' sigma' tau'.
+Proof.
+ induction 1; intros; eauto.
+ eapply transition_preserves_wf; eauto.
+Qed.
+
+(* Properties of exec_ *)
+
+Lemma exec_par_outside:
+ forall m e r, ~In r (dests m) -> exec_par m e r = e r.
+Proof.
+ induction m; simpl; intros. auto.
+ destruct a as [s d]. rewrite update_o. apply IHm. tauto.
+ simpl in H. intuition.
+Qed.
+
+Lemma exec_par_lift:
+ forall m1 s d m2 e,
+ ~In d (dests m1) ->
+ exec_par (m1 ++ (s, d) :: m2) e = exec_par ((s, d) :: m1 ++ m2) e.
+Proof.
+ induction m1; simpl; intros.
+ auto.
+ destruct a as [s0 d0]. simpl in H. rewrite IHm1. simpl.
+ apply update_commut. tauto. tauto.
+Qed.
+
+Lemma exec_par_ident:
+ forall m1 r m2 e,
+ is_mill (m1 ++ (r, r) :: m2) ->
+ exec_par (m1 ++ (r, r) :: m2) e = exec_par (m1 ++ m2) e.
+Proof.
+ intros. autorewrite with pmov in H.
+ rewrite exec_par_lift. simpl.
+ replace (e r) with (exec_par (m1 ++ m2) e r). apply update_ident.
+ apply exec_par_outside. autorewrite with pmov. tauto. tauto.
+Qed.
+
+Lemma exec_seq_app:
+ forall m1 m2 e,
+ exec_seq (m1 ++ m2) e = exec_seq m2 (exec_seq m1 e).
+Proof.
+ induction m1; simpl; intros. auto.
+ destruct a as [s d]. rewrite IHm1. auto.
+Qed.
+
+Lemma exec_seq_rev_app:
+ forall m1 m2 e,
+ exec_seq_rev (m1 ++ m2) e = exec_seq_rev m1 (exec_seq_rev m2 e).
+Proof.
+ induction m1; simpl; intros. auto.
+ destruct a as [s d]. rewrite IHm1. auto.
+Qed.
+
+Lemma exec_seq_exec_seq_rev:
+ forall m e,
+ exec_seq_rev m e = exec_seq (List.rev m) e.
+Proof.
+ induction m; simpl; intros.
+ auto.
+ destruct a as [s d]. rewrite exec_seq_app. simpl. rewrite IHm. auto.
+Qed.
+
+Lemma exec_seq_rev_exec_seq:
+ forall m e,
+ exec_seq m e = exec_seq_rev (List.rev m) e.
+Proof.
+ intros. generalize (exec_seq_exec_seq_rev (List.rev m) e).
+ rewrite List.rev_involutive. auto.
+Qed.
+
+Lemma exec_par_update_no_read:
+ forall s d m e,
+ no_read m d ->
+ ~In d (dests m) ->
+ exec_par m (update d (e s) e) =
+ update d (e s) (exec_par m e).
+Proof.
+ unfold no_read; induction m; simpl; intros.
+ auto.
+ destruct a as [s0 d0]; simpl in *. rewrite IHm.
+ rewrite update_commut. f_equal. f_equal.
+ apply update_o. tauto. tauto. tauto. tauto.
+Qed.
+
+Lemma exec_par_append_eq:
+ forall m1 m2 m3 e2 e3,
+ exec_par m2 e2 = exec_par m3 e3 ->
+ (forall r, In r (srcs m1) -> e2 r = e3 r) ->
+ exec_par (m1 ++ m2) e2 = exec_par (m1 ++ m3) e3.
+Proof.
+ induction m1; simpl; intros.
+ auto. destruct a as [s d]. f_equal; eauto.
+Qed.
+
+Lemma exec_par_combine:
+ forall e sl dl,
+ List.length sl = List.length dl ->
+ list_norepet dl ->
+ let e' := exec_par (combine sl dl) e in
+ List.map e' dl = List.map e sl /\
+ (forall l, ~In l dl -> e' l = e l).
+Proof.
+ induction sl; destruct dl; simpl; intros; try discriminate.
+ split; auto.
+ inversion H0; subst; clear H0.
+ injection H; intro; clear H.
+ destruct (IHsl dl H0 H4) as [A B].
+ set (e' := exec_par (combine sl dl) e) in *.
+ split.
+ decEq. apply update_s.
+ rewrite <- A. apply list_map_exten; intros.
+ rewrite update_o. auto. congruence.
+ intros. rewrite update_o. apply B. tauto. intuition.
+Qed.
+
+(* Semantics of triples (mu, sigma, tau) *)
+
+Definition statemove (mu sigma tau: moves) (e: env) :=
+ exec_par (mu ++ sigma) (exec_seq_rev tau e).
+
+(* Equivalence over non-temp regs *)
+
+Definition env_equiv (e1 e2: env) : Prop :=
+ forall r, is_not_temp r -> e1 r = e2 r.
+
+Lemma env_equiv_refl:
+ forall e, env_equiv e e.
+Proof.
+ unfold env_equiv; auto.
+Qed.
+
+Lemma env_equiv_refl':
+ forall e1 e2, e1 = e2 -> env_equiv e1 e2.
+Proof.
+ unfold env_equiv; intros. rewrite H. auto.
+Qed.
+
+Lemma env_equiv_sym:
+ forall e1 e2, env_equiv e1 e2 -> env_equiv e2 e1.
+Proof.
+ unfold env_equiv; intros. symmetry; auto.
+Qed.
+
+Lemma env_equiv_trans:
+ forall e1 e2 e3, env_equiv e1 e2 -> env_equiv e2 e3 -> env_equiv e1 e3.
+Proof.
+ unfold env_equiv; intros. transitivity (e2 r); auto.
+Qed.
+
+Lemma exec_par_env_equiv:
+ forall m e1 e2,
+ move_no_temp m ->
+ env_equiv e1 e2 ->
+ env_equiv (exec_par m e1) (exec_par m e2).
+Proof.
+ unfold move_no_temp; induction m; simpl; intros.
+ auto.
+ destruct a as [s d].
+ red; intros. unfold update. destruct (reg_eq r d).
+ apply H0. elim (H s d); tauto.
+ apply IHm; auto.
+Qed.
+
+(* Preservation of semantics by transformations. *)
+
+Lemma transition_preserves_semantics:
+ forall mu1 sigma1 tau1 mu2 sigma2 tau2 e,
+ transition mu1 sigma1 tau1 mu2 sigma2 tau2 ->
+ state_wf mu1 sigma1 tau1 ->
+ env_equiv (statemove mu2 sigma2 tau2 e) (statemove mu1 sigma1 tau1 e).
+Proof.
+ induction 1; intros [A [B [C D]]].
+
+ (* nop *)
+ apply env_equiv_refl'. unfold statemove.
+ repeat rewrite app_ass. simpl. symmetry. apply exec_par_ident.
+ rewrite app_ass in A. exact A.
+
+ (* start *)
+ apply env_equiv_refl'. unfold statemove.
+ autorewrite with pmov in A.
+ rewrite exec_par_lift. repeat rewrite app_ass. simpl. rewrite exec_par_lift. reflexivity.
+ tauto. autorewrite with pmov. tauto.
+
+ (* push *)
+ apply env_equiv_refl'. unfold statemove.
+ autorewrite with pmov in A.
+ rewrite exec_par_lift. rewrite exec_par_lift. simpl.
+ rewrite exec_par_lift. repeat rewrite app_ass. simpl. rewrite exec_par_lift.
+ simpl. apply update_commut. intuition.
+ tauto. autorewrite with pmov; tauto.
+ autorewrite with pmov; intuition.
+ autorewrite with pmov; intuition.
+
+ (* loop *)
+ unfold statemove. simpl exec_seq_rev.
+ set (e1 := exec_seq_rev tau e).
+ autorewrite with pmov in A.
+ repeat rewrite <- app_ass.
+ assert (~In d (dests (mu ++ sigma))). autorewrite with pmov. tauto.
+ repeat rewrite exec_par_lift; auto. simpl.
+ repeat rewrite <- app_nil_end.
+ assert (move_no_temp (mu ++ sigma)).
+ red in C. rewrite rev_unit in C. destruct C.
+ apply move_no_temp_append; auto. apply move_no_temp_rev; auto.
+ set (e2 := update (temp s) (e1 s) e1).
+ set (e3 := exec_par (mu ++ sigma) e1).
+ set (e4 := exec_par (mu ++ sigma) e2).
+ assert (env_equiv e2 e1).
+ unfold e2; red; intros. apply update_o. apply H1.
+ assert (env_equiv e4 e3).
+ unfold e4, e3. apply exec_par_env_equiv; auto.
+ red; intros. unfold update. destruct (reg_eq r d).
+ unfold e2. apply update_s. apply H2. auto.
+
+ (* pop *)
+ apply env_equiv_refl'. unfold statemove. simpl exec_seq_rev.
+ set (e1 := exec_seq_rev tau e).
+ autorewrite with pmov in A.
+ apply exec_par_append_eq. simpl.
+ apply exec_par_update_no_read.
+ apply no_read_path; auto. eapply is_path_pop; eauto.
+ autorewrite with pmov; tauto.
+ autorewrite with pmov; tauto.
+ intros. apply update_o. red; intro; subst r. elim (H H1).
+
+ (* last *)
+ apply env_equiv_refl'. unfold statemove. simpl exec_seq_rev.
+ set (e1 := exec_seq_rev tau e).
+ apply exec_par_append_eq. simpl. auto.
+ intros. apply update_o. red; intro; subst r. elim (H H0).
+Qed.
+
+Lemma transitions_preserve_semantics:
+ forall mu1 sigma1 tau1 mu2 sigma2 tau2 e,
+ transitions mu1 sigma1 tau1 mu2 sigma2 tau2 ->
+ state_wf mu1 sigma1 tau1 ->
+ env_equiv (statemove mu2 sigma2 tau2 e) (statemove mu1 sigma1 tau1 e).
+Proof.
+ induction 1; intros.
+ apply env_equiv_refl.
+ eapply transition_preserves_semantics; eauto.
+ apply env_equiv_trans with (statemove mu2 sigma2 tau2 e).
+ apply IHtransitions2. eapply transitions_preserve_wf; eauto.
+ apply IHtransitions1. auto.
+Qed.
+
+Lemma state_wf_start:
+ forall mu,
+ move_no_temp mu ->
+ is_mill mu ->
+ state_wf mu nil nil.
+Proof.
+ split. rewrite <- app_nil_end. auto.
+ split. auto.
+ split. red. simpl. auto.
+ constructor.
+Qed.
+
+Theorem transitions_correctness:
+ forall mu tau,
+ move_no_temp mu ->
+ is_mill mu ->
+ transitions mu nil nil nil nil tau ->
+ forall e, env_equiv (exec_seq (List.rev tau) e) (exec_par mu e).
+Proof.
+ intros.
+ generalize (transitions_preserve_semantics _ _ _ _ _ _ e H1
+ (state_wf_start _ H H0)).
+ unfold statemove. simpl. rewrite <- app_nil_end.
+ rewrite exec_seq_exec_seq_rev. auto.
+Qed.
+
+(* Determinisation of the transition relation *)
+
+Inductive dtransition: moves -> moves -> moves
+ -> moves -> moves -> moves -> Prop :=
+ | dtr_nop: forall r mu tau,
+ dtransition ((r, r) :: mu) nil tau
+ mu nil tau
+ | dtr_start: forall s d mu tau,
+ s <> d ->
+ dtransition ((s, d) :: mu) nil tau
+ mu ((s, d) :: nil) tau
+ | dtr_push: forall mu1 d r mu2 s sigma tau,
+ no_read mu1 d ->
+ dtransition (mu1 ++ (d, r) :: mu2) ((s, d) :: sigma) tau
+ (mu1 ++ mu2) ((d, r) :: (s, d) :: sigma) tau
+ | dtr_loop_pop: forall mu s r0 d sigma tau,
+ no_read mu r0 ->
+ dtransition mu ((s, r0) :: sigma ++ (r0, d) :: nil) tau
+ mu (sigma ++ (temp r0, d) :: nil) ((s, r0) :: (r0, temp r0) :: tau)
+ | dtr_pop: forall mu s0 d0 s1 d1 sigma tau,
+ no_read mu d1 -> d1 <> s0 ->
+ dtransition mu ((s1, d1) :: sigma ++ (s0, d0) :: nil) tau
+ mu (sigma ++ (s0, d0) :: nil) ((s1, d1) :: tau)
+ | dtr_last: forall mu s d tau,
+ no_read mu d ->
+ dtransition mu ((s, d) :: nil) tau
+ mu nil ((s, d) :: tau).
+
+Inductive dtransitions: moves -> moves -> moves
+ -> moves -> moves -> moves -> Prop :=
+ | dtr_refl:
+ forall mu sigma tau,
+ dtransitions mu sigma tau mu sigma tau
+ | dtr_one:
+ forall mu1 sigma1 tau1 mu2 sigma2 tau2,
+ dtransition mu1 sigma1 tau1 mu2 sigma2 tau2 ->
+ dtransitions mu1 sigma1 tau1 mu2 sigma2 tau2
+ | dtr_trans:
+ forall mu1 sigma1 tau1 mu2 sigma2 tau2 mu3 sigma3 tau3,
+ dtransitions mu1 sigma1 tau1 mu2 sigma2 tau2 ->
+ dtransitions mu2 sigma2 tau2 mu3 sigma3 tau3 ->
+ dtransitions mu1 sigma1 tau1 mu3 sigma3 tau3.
+
+Lemma transition_determ:
+ forall mu1 sigma1 tau1 mu2 sigma2 tau2,
+ dtransition mu1 sigma1 tau1 mu2 sigma2 tau2 ->
+ state_wf mu1 sigma1 tau1 ->
+ transitions mu1 sigma1 tau1 mu2 sigma2 tau2.
+Proof.
+ induction 1; intro.
+ apply tr_one. exact (tr_nop nil r mu nil tau).
+ apply tr_one. exact (tr_start nil s d mu tau).
+ apply tr_one. apply tr_push.
+ eapply tr_trans.
+ apply tr_one.
+ change ((s, r0) :: sigma ++ (r0, d) :: nil)
+ with (((s, r0) :: sigma) ++ (r0, d) :: nil).
+ apply tr_loop.
+ apply tr_one. simpl. apply tr_pop. auto.
+ destruct H0 as [A [B [C D]]].
+ generalize C.
+ change ((s, r0) :: sigma ++ (r0, d) :: nil)
+ with (((s, r0) :: sigma) ++ (r0, d) :: nil).
+ unfold temp_last; rewrite List.rev_unit. intros [E F].
+ elim (F s r0). unfold is_not_temp. auto.
+ rewrite <- List.In_rev. apply in_eq.
+ apply tr_one. apply tr_pop. auto. auto.
+ apply tr_one. apply tr_last. auto.
+Qed.
+
+Lemma transitions_determ:
+ forall mu1 sigma1 tau1 mu2 sigma2 tau2,
+ dtransitions mu1 sigma1 tau1 mu2 sigma2 tau2 ->
+ state_wf mu1 sigma1 tau1 ->
+ transitions mu1 sigma1 tau1 mu2 sigma2 tau2.
+Proof.
+ induction 1; intros.
+ apply tr_refl.
+ eapply transition_determ; eauto.
+ eapply tr_trans.
+ apply IHdtransitions1. auto.
+ apply IHdtransitions2. eapply transitions_preserve_wf; eauto.
+Qed.
+
+Theorem dtransitions_correctness:
+ forall mu tau,
+ move_no_temp mu ->
+ is_mill mu ->
+ dtransitions mu nil nil nil nil tau ->
+ forall e, env_equiv (exec_seq (List.rev tau) e) (exec_par mu e).
+Proof.
+ intros.
+ eapply transitions_correctness; eauto.
+ apply transitions_determ. auto. apply state_wf_start; auto.
+Qed.
+
+(* Transition function *)
+
+Function split_move (m: moves) (r: reg) {struct m} : option (moves * reg * moves) :=
+ match m with
+ | nil => None
+ | (s, d) :: tl =>
+ if reg_eq s r
+ then Some (nil, d, tl)
+ else match split_move tl r with
+ | None => None
+ | Some (before, d', after) => Some ((s, d) :: before, d', after)
+ end
+ end.
+
+Function is_last_source (r: reg) (m: moves) {struct m} : bool :=
+ match m with
+ | nil => false
+ | (s, d) :: nil =>
+ if reg_eq s r then true else false
+ | (s, d) :: tl =>
+ is_last_source r tl
+ end.
+
+Function replace_last_source (r: reg) (m: moves) {struct m} : moves :=
+ match m with
+ | nil => nil
+ | (s, d) :: nil => (r, d) :: nil
+ | s_d :: tl => s_d :: replace_last_source r tl
+ end.
+
+Inductive state : Set := State: moves -> moves -> moves -> state.
+
+Definition final_state (st: state) : bool :=
+ match st with
+ | State nil nil _ => true
+ | _ => false
+ end.
+
+Function parmove_step (st: state) : state :=
+ match st with
+ | State nil nil _ => st
+ | State ((s, d) :: tl) nil l =>
+ if reg_eq s d
+ then State tl nil l
+ else State tl ((s, d) :: nil) l
+ | State t ((s, d) :: b) l =>
+ match split_move t d with
+ | Some (t1, r, t2) =>
+ State (t1 ++ t2) ((d, r) :: (s, d) :: b) l
+ | None =>
+ match b with
+ | nil => State t nil ((s, d) :: l)
+ | _ =>
+ if is_last_source d b
+ then State t (replace_last_source (temp d) b) ((s, d) :: (d, temp d) :: l)
+ else State t b ((s, d) :: l)
+ end
+ end
+ end.
+
+(* Correctness properties of these functions *)
+
+Lemma split_move_charact:
+ forall m r,
+ match split_move m r with
+ | Some (before, d, after) => m = before ++ (r, d) :: after /\ no_read before r
+ | None => no_read m r
+ end.
+Proof.
+ unfold no_read. intros m r. functional induction (split_move m r).
+ red; simpl. tauto.
+ rewrite _x. split. reflexivity. simpl;auto.
+ rewrite e1 in IHo. simpl. intuition.
+ rewrite e1 in IHo. destruct IHo. split. rewrite H. reflexivity.
+ simpl. intuition.
+Qed.
+
+Lemma is_last_source_charact:
+ forall r s d m,
+ if is_last_source r (m ++ (s, d) :: nil)
+ then s = r
+ else s <> r.
+Proof.
+ induction m; simpl.
+ destruct (reg_eq s r); congruence.
+ destruct a as [s0 d0]. case_eq (m ++ (s, d) :: nil); intros.
+ generalize (app_cons_not_nil m nil (s, d)). congruence.
+ rewrite <- H. auto.
+Qed.
+
+Lemma replace_last_source_charact:
+ forall s d s' m,
+ replace_last_source s' (m ++ (s, d) :: nil) =
+ m ++ (s', d) :: nil.
+Proof.
+ induction m; simpl.
+ auto.
+ destruct a as [s0 d0]. case_eq (m ++ (s, d) :: nil); intros.
+ generalize (app_cons_not_nil m nil (s, d)). congruence.
+ rewrite <- H. congruence.
+Qed.
+
+Lemma parmove_step_compatible:
+ forall mu sigma tau mu' sigma' tau',
+ final_state (State mu sigma tau) = false ->
+ parmove_step (State mu sigma tau) = State mu' sigma' tau' ->
+ dtransition mu sigma tau mu' sigma' tau'.
+Proof.
+ intros until tau'. intro NOTFINAL.
+ unfold parmove_step.
+ case_eq mu; [intros MEQ | intros [ms md] mtl MEQ].
+ case_eq sigma; [intros SEQ | intros [ss sd] stl SEQ].
+ subst mu sigma. discriminate.
+ simpl.
+ case_eq stl; [intros STLEQ | intros xx1 xx2 STLEQ].
+ intro R; inversion R; clear R; subst.
+ apply dtr_last. red; simpl; auto.
+ elim (@exists_last _ stl). 2:congruence. intros sigma1 [[ss1 sd1] SEQ2].
+ rewrite <- STLEQ. clear STLEQ xx1 xx2.
+ generalize (is_last_source_charact sd ss1 sd1 sigma1).
+ rewrite SEQ2. destruct (is_last_source sd (sigma1 ++ (ss1, sd1) :: nil)).
+ intro. subst ss1. intro R; inversion R; clear R; subst.
+ rewrite replace_last_source_charact. apply dtr_loop_pop.
+ red; simpl; auto.
+ intro. intro R; inversion R; clear R; subst.
+ apply dtr_pop. red; simpl; auto. auto.
+
+ case_eq sigma; [intros SEQ | intros [ss sd] stl SEQ].
+ destruct (reg_eq ms md); intro R; inversion R; clear R; subst.
+ apply dtr_nop.
+ apply dtr_start. auto.
+
+ generalize (split_move_charact ((ms, md) :: mtl) sd).
+ case (split_move ((ms, md) :: mtl) sd); [intros [[before r] after] | idtac].
+ intros [MEQ2 NOREAD]. intro R; inversion R; clear R; subst.
+ rewrite MEQ2. apply dtr_push. auto.
+ intro NOREAD.
+ case_eq stl; [intros STLEQ | intros xx1 xx2 STLEQ].
+ intro R; inversion R; clear R; subst.
+ apply dtr_last. auto.
+ elim (@exists_last _ stl). 2:congruence. intros sigma1 [[ss1 sd1] SEQ2].
+ rewrite <- STLEQ. clear STLEQ xx1 xx2.
+ generalize (is_last_source_charact sd ss1 sd1 sigma1).
+ rewrite SEQ2. destruct (is_last_source sd (sigma1 ++ (ss1, sd1) :: nil)).
+ intro. subst ss1. intro R; inversion R; clear R; subst.
+ rewrite replace_last_source_charact. apply dtr_loop_pop. auto.
+ intro. intro R; inversion R; clear R; subst.
+ apply dtr_pop. auto. auto.
+Qed.
+
+(* Decreasing measure over states *)
+
+Open Scope nat_scope.
+
+Definition measure (st: state) : nat :=
+ match st with
+ | State mu sigma tau => 2 * List.length mu + List.length sigma
+ end.
+
+Lemma measure_decreasing_1:
+ forall mu1 sigma1 tau1 mu2 sigma2 tau2,
+ dtransition mu1 sigma1 tau1 mu2 sigma2 tau2 ->
+ measure (State mu2 sigma2 tau2) < measure (State mu1 sigma1 tau1).
+Proof.
+ induction 1; repeat (simpl; rewrite List.app_length); simpl; omega.
+Qed.
+
+Lemma measure_decreasing_2:
+ forall st,
+ final_state st = false ->
+ measure (parmove_step st) < measure st.
+Proof.
+ intros. destruct st as [mu sigma tau].
+ case_eq (parmove_step (State mu sigma tau)). intros mu' sigma' tau' EQ.
+ apply measure_decreasing_1.
+ apply parmove_step_compatible; auto.
+Qed.
+
+(* Compilation function for parallel moves *)
+
+Function parmove_aux (st: state) {measure measure st} : moves :=
+ if final_state st
+ then match st with State _ _ tau => tau end
+ else parmove_aux (parmove_step st).
+Proof.
+ intros. apply measure_decreasing_2. auto.
+Qed.
+
+Lemma parmove_aux_transitions:
+ forall mu sigma tau,
+ dtransitions mu sigma tau nil nil (parmove_aux (State mu sigma tau)).
+Proof.
+ assert (forall st,
+ match st with State mu sigma tau =>
+ dtransitions mu sigma tau nil nil (parmove_aux st)
+ end).
+ intro st. functional induction (parmove_aux st).
+ destruct _x; destruct _x0; simpl in e; discriminate || apply dtr_refl.
+ case_eq (parmove_step st). intros mu' sigma' tau' PSTEP.
+ destruct st as [mu sigma tau].
+ eapply dtr_trans. apply dtr_one. apply parmove_step_compatible; eauto.
+ rewrite PSTEP in IHm. auto.
+
+ intros. apply (H (State mu sigma tau)).
+Qed.
+
+Definition parmove (mu: moves) : moves :=
+ List.rev (parmove_aux (State mu nil nil)).
+
+Theorem parmove_correctness:
+ forall mu,
+ move_no_temp mu -> is_mill mu ->
+ forall e,
+ env_equiv (exec_seq (parmove mu) e) (exec_par mu e).
+Proof.
+ intros. unfold parmove. apply dtransitions_correctness; auto.
+ apply parmove_aux_transitions.
+Qed.
+
+Definition parmove2 (sl dl: list reg) : moves :=
+ parmove (List.combine sl dl).
+
+Theorem parmove2_correctness:
+ forall sl dl,
+ List.length sl = List.length dl ->
+ list_norepet dl ->
+ (forall r, In r sl -> is_not_temp r) ->
+ (forall r, In r dl -> is_not_temp r) ->
+ forall e,
+ let e' := exec_seq (parmove2 sl dl) e in
+ List.map e' dl = List.map e sl /\
+ forall r, ~In r dl -> is_not_temp r -> e' r = e r.
+Proof.
+ intros.
+ destruct (srcs_dests_combine sl dl H) as [A B].
+ assert (env_equiv e' (exec_par (List.combine sl dl) e)).
+ unfold e', parmove2. apply parmove_correctness.
+ red; intros; split.
+ apply H1. eapply List.in_combine_l; eauto.
+ apply H2. eapply List.in_combine_r; eauto.
+ red. rewrite B. auto.
+ destruct (exec_par_combine e sl dl H H0) as [C D].
+ set (e1 := exec_par (combine sl dl) e) in *.
+ split. rewrite <- C. apply list_map_exten; intros.
+ symmetry. apply H3. auto.
+ intros. transitivity (e1 r); auto.
+Qed.
+
+(* Additional properties on the generated sequence of moves. *)
+
+Section PROPERTIES.
+
+Variable initial_move: moves.
+
+Inductive wf_move: reg -> reg -> Prop :=
+ | wf_move_same: forall s d,
+ In (s, d) initial_move -> wf_move s d
+ | wf_move_temp_left: forall s d,
+ wf_move s d -> wf_move (temp s) d
+ | wf_move_temp_right: forall s d,
+ wf_move s d -> wf_move s (temp s).
+
+Definition wf_moves (m: moves) : Prop :=
+ forall s d, In (s, d) m -> wf_move s d.
+
+Lemma wf_moves_cons: forall s d m,
+ wf_moves ((s, d) :: m) <-> wf_move s d /\ wf_moves m.
+Proof.
+ unfold wf_moves; intros; simpl. firstorder.
+ inversion H0; subst s0 d0. auto.
+Qed.
+
+Lemma wf_moves_append: forall m1 m2,
+ wf_moves (m1 ++ m2) <-> wf_moves m1 /\ wf_moves m2.
+Proof.
+ unfold wf_moves; intros. split; intros.
+ split; intros; apply H; apply in_or_app; auto.
+ destruct H. elim (in_app_or _ _ _ H0); intro; auto.
+Qed.
+
+Hint Rewrite wf_moves_cons wf_moves_append: pmov.
+
+Definition wf_state (mu sigma tau: moves) : Prop :=
+ wf_moves mu /\ wf_moves sigma /\ wf_moves tau.
+
+Lemma dtransition_preserves_wf_state:
+ forall mu1 sigma1 tau1 mu2 sigma2 tau2,
+ dtransition mu1 sigma1 tau1 mu2 sigma2 tau2 ->
+ wf_state mu1 sigma1 tau1 -> wf_state mu2 sigma2 tau2.
+Proof.
+ induction 1; intros [A [B C]]; unfold wf_state;
+ autorewrite with pmov in A; autorewrite with pmov in B;
+ autorewrite with pmov in C; autorewrite with pmov.
+
+ tauto.
+
+ tauto.
+
+ tauto.
+
+ intuition. apply wf_move_temp_left; auto.
+ eapply wf_move_temp_right; eauto.
+
+ intuition.
+
+ intuition.
+Qed.
+
+Lemma dtransitions_preserve_wf_state:
+ forall mu1 sigma1 tau1 mu2 sigma2 tau2,
+ dtransitions mu1 sigma1 tau1 mu2 sigma2 tau2 ->
+ wf_state mu1 sigma1 tau1 -> wf_state mu2 sigma2 tau2.
+Proof.
+ induction 1; intros; eauto.
+ eapply dtransition_preserves_wf_state; eauto.
+Qed.
+
+End PROPERTIES.
+
+Lemma parmove_wf_moves:
+ forall mu, wf_moves mu (parmove mu).
+Proof.
+ intros.
+ assert (wf_state mu mu nil nil).
+ split. red; intros. apply wf_move_same. auto.
+ split. red; simpl; tauto. red; simpl; tauto.
+ generalize (dtransitions_preserve_wf_state mu
+ _ _ _ _ _ _
+ (parmove_aux_transitions mu nil nil) H).
+ intros [A [B C]].
+ unfold parmove. red; intros. apply C.
+ rewrite List.In_rev. auto.
+Qed.
+
+Lemma parmove2_wf_moves:
+ forall sl dl, wf_moves (List.combine sl dl) (parmove2 sl dl).
+Proof.
+ intros. unfold parmove2. apply parmove_wf_moves.
+Qed.
+
+End PARMOV.
diff --git a/lib/union_find.v b/lib/union_find.v
index 61817d7..452459f 100644
--- a/lib/union_find.v
+++ b/lib/union_find.v
@@ -1,6 +1,7 @@
(** A purely functional union-find algorithm *)
Require Import Wf.
+Require Recdef.
(** The ``union-find'' algorithm is used to represent equivalence classes
over a given type. It maintains a data structure representing a partition
@@ -27,21 +28,6 @@ Require Import Wf.
presentation where the mapping is a separate functional data structure.
*)
-Ltac CaseEq name :=
- generalize (refl_equal name); pattern name at -1 in |- *; case name.
-
-Ltac IntroElim :=
- match goal with
- | |- (forall id : exists x : _, _, _) =>
- intro id; elim id; clear id; IntroElim
- | |- (forall id : _ /\ _, _) => intro id; elim id; clear id; IntroElim
- | |- (forall id : _ \/ _, _) => intro id; elim id; clear id; IntroElim
- | |- (_ -> _) => intro; IntroElim
- | _ => idtac
- end.
-
-Ltac MyElim n := elim n; IntroElim.
-
(** The elements of equivalence classes are represented by the following
signature: a type with a decidable equality. *)
@@ -139,82 +125,47 @@ Definition repr_order (m: M.T) (a a': elt) : Prop :=
(** The canonical representative of an element.
Needs Noetherian recursion. *)
-Lemma option_sum:
- forall (x: option elt), {y: elt | x = Some y} + {x = None}.
-Proof.
- intro x. case x.
- left. exists e. auto.
- right. auto.
-Qed.
+Section REPR.
+
+Variable m: M.T.
+Variable wf: well_founded (repr_order m).
-Definition repr_rec
- (m: M.T) (a: elt) (rec: forall b: elt, repr_order m b a -> elt) :=
- match option_sum (M.get a m) with
- | inleft (exist b P) => rec b P
- | inright _ => a
- end.
-
-Definition repr_aux
- (m: M.T) (wf: well_founded (repr_order m)) (a: elt) : elt :=
- Fix wf (fun (_: elt) => elt) (repr_rec m) a.
-
-Lemma repr_rec_ext:
- forall (m: M.T) (x: elt) (f g: forall y:elt, repr_order m y x -> elt),
- (forall (y: elt) (p: repr_order m y x), f y p = g y p) ->
- repr_rec m x f = repr_rec m x g.
+Function repr_aux (a: elt) {wf (repr_order m) a} : elt :=
+ match M.get a m with
+ | Some a' => repr_aux a'
+ | None => a
+ end.
Proof.
- intros. unfold repr_rec.
- case (option_sum (M.get x m)).
- intros. elim s; intros. apply H.
- intros. auto.
+ intros. assumption.
+ assumption.
Qed.
Lemma repr_aux_none:
- forall (m: M.T) (wf: well_founded (repr_order m)) (a: elt),
+ forall (a: elt),
M.get a m = None ->
- repr_aux m wf a = a.
+ repr_aux a = a.
Proof.
- intros.
- generalize (Fix_eq wf (fun (_:elt) => elt) (repr_rec m) (repr_rec_ext m) a).
- intro. unfold repr_aux. rewrite H0.
- unfold repr_rec.
- case (option_sum (M.get a m)).
- intro s; elim s; intros.
- rewrite H in p; discriminate.
- intros. auto.
+ intros. rewrite repr_aux_equation. rewrite H. auto.
Qed.
Lemma repr_aux_some:
- forall (m: M.T) (wf: well_founded (repr_order m)) (a a': elt),
+ forall (a a': elt),
M.get a m = Some a' ->
- repr_aux m wf a = repr_aux m wf a'.
+ repr_aux a = repr_aux a'.
Proof.
- intros.
- generalize (Fix_eq wf (fun (_:elt) => elt) (repr_rec m) (repr_rec_ext m) a).
- intro. unfold repr_aux. rewrite H0. unfold repr_rec.
- case (option_sum (M.get a m)).
- intro s; elim s; intros.
- rewrite H in p. injection p; intros. rewrite H1. auto.
- intros. rewrite H in e. discriminate.
+ intros. rewrite repr_aux_equation. rewrite H. auto.
Qed.
-
+
Lemma repr_aux_canon:
- forall (m: M.T) (wf: well_founded (repr_order m)) (a: elt),
- M.get (repr_aux m wf a) m = None.
+ forall (a: elt), M.get (repr_aux a) m = None.
Proof.
- intros.
- apply (well_founded_ind wf (fun (a: elt) => M.get (repr_aux m wf a) m = None)).
- intros.
- generalize (Fix_eq wf (fun (_:elt) => elt) (repr_rec m) (repr_rec_ext m) x).
- intro. unfold repr_aux. rewrite H0.
- unfold repr_rec.
- case (option_sum (M.get x m)).
- intro s; elim s; intros.
- unfold repr_aux in H. apply H.
- unfold repr_order. auto.
- intro. auto.
+ intros a0.
+ apply (repr_aux_ind (fun a a' => M.get a' m = None)).
+ auto. auto.
Qed.
+End REPR.
+
(** The empty partition (each element in its own class) is well founded. *)
Lemma wf_empty:
@@ -282,11 +233,9 @@ Proof.
induction 1.
apply Acc_intro. intros.
- MyElim (identify_base_repr_order y x H1).
+ destruct (identify_base_repr_order y x H1) as [A | [A B]].
apply H0; auto.
- rewrite H3.
- apply Acc_intro.
- intros z H4.
+ subst x y. apply Acc_intro. intros z H4.
red in H4. rewrite identify_base_b_canon in H4. discriminate.
Qed.
@@ -312,31 +261,29 @@ Lemma identify_base_repr:
repr_aux identify_base identify_base_order_wf x =
(if E.eq (repr_aux m mwf x) a then b else repr_aux m mwf x).
Proof.
- intro x0.
apply (well_founded_ind mwf
(fun (x: elt) =>
repr_aux identify_base identify_base_order_wf x =
(if E.eq (repr_aux m mwf x) a then b else repr_aux m mwf x)));
intros.
- MyElim (identify_aux_decomp x).
+ destruct (identify_aux_decomp x) as [[A B] | [[A [B C]] | [y [A B]]]].
- rewrite (repr_aux_none identify_base).
- rewrite (repr_aux_none m mwf x).
+ rewrite (repr_aux_none identify_base); auto.
+ rewrite (repr_aux_none m mwf x); auto.
case (E.eq x a); intro.
subst x.
- rewrite identify_base_a_maps_to_b in H1.
- discriminate.
- auto. auto. auto.
+ rewrite identify_base_a_maps_to_b in B. discriminate.
+ auto.
subst x. rewrite (repr_aux_none m mwf a); auto.
case (E.eq a a); intro.
- rewrite (repr_aux_some identify_base identify_base_order_wf a b).
- rewrite (repr_aux_none identify_base identify_base_order_wf b).
- auto. apply identify_base_b_canon. auto.
+ rewrite (repr_aux_some identify_base identify_base_order_wf a b); auto.
+ rewrite (repr_aux_none identify_base identify_base_order_wf b); auto.
+ apply identify_base_b_canon.
tauto.
- rewrite (repr_aux_some identify_base identify_base_order_wf x x1); auto.
- rewrite (repr_aux_some m mwf x x1); auto.
+ rewrite (repr_aux_some identify_base identify_base_order_wf x y); auto.
+ rewrite (repr_aux_some m mwf x y); auto.
Qed.
Lemma identify_base_sameclass_1:
diff --git a/test/cminor/Makefile b/test/cminor/Makefile
index 35d3e07..f9b863e 100644
--- a/test/cminor/Makefile
+++ b/test/cminor/Makefile
@@ -1,10 +1,11 @@
CCOMP=../../ccomp
CPP=cpp -P
CC=gcc
-CFLAGS=-g
+CFLAGS=-arch ppc -g
+ASFLAGS=-arch ppc
VPATH=../harness ../lib
-PROGS=fib integr qsort fft sha1 aes almabench manyargs
+PROGS=fib integr qsort fft sha1 aes almabench manyargs lists
all_s: $(PROGS:%=%.s)
@@ -27,13 +28,13 @@ qsort: qsort.o mainqsort.o
clean::
rm -f qsort
-fft: fft.o mainfft.o staticlib.o
- $(CC) $(CFLAGS) -o fft fft.o mainfft.o staticlib.o -lm
+fft: fft.o mainfft.o
+ $(CC) $(CFLAGS) -o fft fft.o mainfft.o -lm
clean::
rm -f fft
-sha1: sha1.o mainsha1.o staticlib.o
- $(CC) $(CFLAGS) -o sha1 sha1.o mainsha1.o staticlib.o
+sha1: sha1.o mainsha1.o
+ $(CC) $(CFLAGS) -o sha1 sha1.o mainsha1.o
clean::
rm -f sha1 sha1.cm
@@ -42,8 +43,8 @@ aes: aes.o mainaes.o
clean::
rm -f aes aes.cm
-almabench: almabench.o mainalmabench.o staticlib.o
- $(CC) $(CFLAGS) -o almabench almabench.o mainalmabench.o staticlib.o -lm
+almabench: almabench.o mainalmabench.o
+ $(CC) $(CFLAGS) -o almabench almabench.o mainalmabench.o -lm
clean::
rm -f almabench almabench.cm
@@ -52,6 +53,11 @@ manyargs: manyargs.o mainmanyargs.o
clean::
rm -f manyargs
+lists: lists.o mainlists.o
+ $(CC) $(CFLAGS) -o lists lists.o mainlists.o
+clean::
+ rm -f lists
+
.SUFFIXES:
.SUFFIXES: .cmp .cm .s .o .c .S
diff --git a/test/cminor/almabench.cmp b/test/cminor/almabench.cmp
index e9e8392..bafcb5d 100644
--- a/test/cminor/almabench.cmp
+++ b/test/cminor/almabench.cmp
@@ -28,12 +28,20 @@
#define sl(x,y) float64["sl" + ((x) * 80 + (y) * 8)]
/* Function calls */
-#define cos(x) ("cos_static"(x): float -> float)
-#define sin(x) ("sin_static"(x): float -> float)
-#define atan2(x,y) ("atan2_static"(x,y): float -> float -> float)
-#define asin(x) ("asin_static"(x): float -> float)
-#define sqrt(x) ("sqrt_static"(x): float -> float)
-#define fmod(x,y) ("fmod_static"(x,y): float -> float -> float)
+
+extern "cos": float -> float
+extern "sin": float -> float
+extern "atan2": float -> float -> float
+extern "asin": float -> float
+extern "sqrt": float -> float
+extern "fmod": float -> float -> float
+
+#define cos(x) ("cos"(x): float -> float)
+#define sin(x) ("sin"(x): float -> float)
+#define atan2(x,y) ("atan2"(x,y): float -> float -> float)
+#define asin(x) ("asin"(x): float -> float)
+#define sqrt(x) ("sqrt"(x): float -> float)
+#define fmod(x,y) ("fmod"(x,y): float -> float -> float)
#define anpm(x) ("anpm"(x) : float -> float)
"anpm"(a): float -> float
@@ -90,7 +98,7 @@
k = k + 1;
} }}
- dl = "fmod_static"(dl,TWOPI) : float -> float -> float;
+ dl = "fmod"(dl,TWOPI) : float -> float -> float;
am = dl -f dp;
ae = am +f de *f sin(am);
diff --git a/test/cminor/fft.cm b/test/cminor/fft.cm
index b4e6a40..ed3b103 100644
--- a/test/cminor/fft.cm
+++ b/test/cminor/fft.cm
@@ -5,6 +5,9 @@
/* Length is n. */
/********************************************************/
+extern "cos" : float -> float
+extern "sin" : float -> float
+
"dfft"(x, y, np): int /*float ptr*/ -> int /*float ptr*/ -> int -> int
{
var px, py, /*float ptr*/
@@ -48,11 +51,11 @@
j = 1;
{{ loop {
if (! (j <= n4)) exit;
- cc1 = "cos_static"(a) : float -> float;
- ss1 = "sin_static"(a) : float -> float;
+ cc1 = "cos"(a) : float -> float;
+ ss1 = "sin"(a) : float -> float;
a3 = 3.0 *f a;
- cc3 = "cos_static"(a3) : float -> float;
- ss3 = "sin_static"(a3) : float -> float;
+ cc3 = "cos"(a3) : float -> float;
+ ss3 = "sin"(a3) : float -> float;
a = e *f floatofint(j);
is = j;
id = 2 * n2;
diff --git a/test/cminor/lists.cm b/test/cminor/lists.cm
new file mode 100644
index 0000000..c445623
--- /dev/null
+++ b/test/cminor/lists.cm
@@ -0,0 +1,27 @@
+/* List manipulations */
+
+"buildlist"(n): int -> int
+{
+ var b;
+
+ if (n < 0) return 0;
+ b = alloc 8;
+ int32[b] = n;
+ int32[b+4] = "buildlist"(n - 1) : int -> int;
+ return b;
+}
+
+"reverselist"(l): int -> int
+{
+ var r, r2;
+ r = 0;
+ loop {
+ if (l == 0) return r;
+ r2 = alloc 8;
+ int32[r2] = int32[l];
+ int32[r2+4] = r;
+ r = r2;
+ l = int32[l+4];
+ }
+}
+
diff --git a/test/cminor/sha1.cmp b/test/cminor/sha1.cmp
index 9a588e4..ca24544 100644
--- a/test/cminor/sha1.cmp
+++ b/test/cminor/sha1.cmp
@@ -3,6 +3,9 @@
/* To be preprocessed by cpp -P */
+extern "memcpy" : int -> int -> int -> void
+extern "memset" : int -> int -> int -> void
+
#define ARCH_BIG_ENDIAN
#define rol1(x) (((x) << 1) | ((x) >>u 31))
@@ -12,7 +15,7 @@
"SHA1_copy_and_swap"(src, dst, numwords) : int -> int -> int -> void
{
#ifdef ARCH_BIG_ENDIAN
- "memcpy_static"(dst, src, numwords * 4) : int -> int -> int -> void;
+ "memcpy"(dst, src, numwords * 4) : int -> int -> int -> void;
#else
var s, d, a, b;
s = src;
@@ -134,12 +137,12 @@
if (context_numbytes(ctx) != 0) {
t = 64 - context_numbytes(ctx);
if (len <u t) {
- "memcpy_static"(context_buffer(ctx) + context_numbytes(ctx), data, len)
+ "memcpy"(context_buffer(ctx) + context_numbytes(ctx), data, len)
: int -> int -> int -> void;
context_numbytes(ctx) = context_numbytes(ctx) + len;
return;
}
- "memcpy_static"(context_buffer(ctx) + context_numbytes(ctx), data, t)
+ "memcpy"(context_buffer(ctx) + context_numbytes(ctx), data, t)
: int -> int -> int -> void;
"SHA1_transform"(ctx) : int -> void;
data = data + t;
@@ -148,14 +151,14 @@
/* Munge data in 64-byte chunks */
{{ loop {
if (! (len >=u 64)) exit;
- "memcpy_static"(context_buffer(ctx), data, 64)
+ "memcpy"(context_buffer(ctx), data, 64)
: int -> int -> int -> void;
"SHA1_transform"(ctx) : int -> void;
data = data + 64;
len = len - 64;
} }}
/* Save remaining data */
- "memcpy_static"(context_buffer(ctx), data, len)
+ "memcpy"(context_buffer(ctx), data, len)
: int -> int -> int -> void;
context_numbytes(ctx) = len;
}
@@ -170,13 +173,13 @@
/* If we do not have room for the length (8 bytes), pad to 64 bytes
with zeroes and munge the data block */
if (i > 56) {
- "memset_static"(context_buffer(ctx) + i, 0, 64 - i)
+ "memset"(context_buffer(ctx) + i, 0, 64 - i)
: int -> int -> int -> void;
"SHA1_transform"(ctx) : int -> void;
i = 0;
}
/* Pad to byte 56 with zeroes */
- "memset_static"(context_buffer(ctx) + i, 0, 56 - i)
+ "memset"(context_buffer(ctx) + i, 0, 56 - i)
: int -> int -> int -> void;
/* Add length in big-endian */
"SHA1_copy_and_swap"(context_length(ctx), context_buffer(ctx) + 56, 2)
diff --git a/test/harness/mainlists.c b/test/harness/mainlists.c
new file mode 100644
index 0000000..ef11f6e
--- /dev/null
+++ b/test/harness/mainlists.c
@@ -0,0 +1,40 @@
+#include <stdio.h>
+#include <stddef.h>
+#include <stdlib.h>
+
+void * compcert_alloc(int sz)
+{
+ return malloc(sz);
+}
+
+struct cons { int hd; struct cons * tl; };
+typedef struct cons * list;
+
+extern list buildlist(int n);
+extern list reverselist(list l);
+
+int checklist(int n, list l)
+{
+ int i;
+ for (i = 0; i <= n; i++) {
+ if (l == NULL) return 0;
+ if (l->hd != i) return 0;
+ l = l->tl;
+ }
+ return (l == NULL);
+}
+
+int main(int argc, char ** argv)
+{
+ int n;
+
+ if (argc >= 2) n = atoi(argv[1]); else n = 10;
+ if (checklist(n, reverselist(buildlist(n)))) {
+ printf("OK\n");
+ return 0;
+ } else {
+ printf("Bug!\n");
+ return 2;
+ }
+}
+