summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e>2013-03-01 15:32:13 +0000
committerGravatar xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e>2013-03-01 15:32:13 +0000
commit5020a5a07da3fd690f5d171a48d0c73ef48f9430 (patch)
tree3ddd75a3ef65543de814f2e0881f8467df73e089
parentf401437a97b09726d029e3a1b65143f34baaea70 (diff)
Revised Stacking and Asmgen passes and Mach semantics:
- no more prediction of return addresses (Asmgenretaddr is gone) - instead, punch a hole for the retaddr in Mach stack frame and fill this hole with the return address in the Asmgen proof. git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@2129 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e
Diffstat
-rw-r--r--.depend17
-rw-r--r--Changelog3
-rw-r--r--Makefile7
-rw-r--r--arm/Asm.v213
-rw-r--r--arm/Asmgen.v456
-rw-r--r--arm/Asmgenproof.v1648
-rw-r--r--arm/Asmgenproof1.v1240
-rw-r--r--arm/Asmgenretaddr.v217
-rw-r--r--arm/PrintAsm.ml7
-rw-r--r--backend/Asmgenproof0.v844
-rw-r--r--backend/Mach.v247
-rw-r--r--backend/Machsem.v108
-rw-r--r--backend/Stackingproof.v445
-rw-r--r--backend/Stackingtyping.v250
-rw-r--r--driver/Compiler.v5
-rw-r--r--ia32/Asm.v33
-rw-r--r--ia32/Asmgen.v2
-rw-r--r--ia32/Asmgenproof.v933
-rw-r--r--ia32/Asmgenproof1.v794
-rw-r--r--ia32/Asmgenretaddr.v259
-rw-r--r--powerpc/Asm.v263
-rw-r--r--powerpc/Asmgen.v503
-rw-r--r--powerpc/Asmgenproof.v1723
-rw-r--r--powerpc/Asmgenproof1.v1424
-rw-r--r--powerpc/Asmgenretaddr.v204
-rw-r--r--powerpc/PrintAsm.ml3
26 files changed, 4809 insertions, 7039 deletions
diff --git a/.depend b/.depend
index bfaf24f..fddfe89 100644
--- a/.depend
+++ b/.depend
@@ -6,7 +6,7 @@ lib/Heaps.vo lib/Heaps.glob lib/Heaps.v.beautified: lib/Heaps.v lib/Coqlib.vo li
lib/Lattice.vo lib/Lattice.glob lib/Lattice.v.beautified: lib/Lattice.v lib/Coqlib.vo lib/Maps.vo
lib/Ordered.vo lib/Ordered.glob lib/Ordered.v.beautified: lib/Ordered.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo
lib/Iteration.vo lib/Iteration.glob lib/Iteration.v.beautified: lib/Iteration.v lib/Axioms.vo lib/Coqlib.vo lib/Wfsimpl.vo
-lib/Integers.vo lib/Integers.glob lib/Integers.v.beautified: lib/Integers.v lib/Axioms.vo lib/Coqlib.vo
+lib/Integers.vo lib/Integers.glob lib/Integers.v.beautified: lib/Integers.v lib/Coqlib.vo
lib/Floats.vo lib/Floats.glob lib/Floats.v.beautified: lib/Floats.v lib/Axioms.vo lib/Coqlib.vo lib/Integers.vo flocq/Appli/Fappli_IEEE.vo flocq/Appli/Fappli_IEEE_bits.vo flocq/Core/Fcore.vo flocq/Calc/Fcalc_round.vo flocq/Calc/Fcalc_bracket.vo flocq/Prop/Fprop_Sterbenz.vo
lib/Parmov.vo lib/Parmov.glob lib/Parmov.v.beautified: lib/Parmov.v lib/Axioms.vo lib/Coqlib.vo
lib/UnionFind.vo lib/UnionFind.glob lib/UnionFind.v.beautified: lib/UnionFind.v lib/Coqlib.vo
@@ -85,19 +85,16 @@ backend/Reloadtyping.vo backend/Reloadtyping.glob backend/Reloadtyping.v.beautif
backend/RRE.vo backend/RRE.glob backend/RRE.v.beautified: backend/RRE.v lib/Coqlib.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo
backend/RREproof.vo backend/RREproof.glob backend/RREproof.v.beautified: backend/RREproof.v lib/Axioms.vo lib/Coqlib.vo common/AST.vo common/Values.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo backend/RRE.vo
backend/RREtyping.vo backend/RREtyping.glob backend/RREtyping.v.beautified: backend/RREtyping.v lib/Coqlib.vo common/AST.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo backend/RRE.vo backend/RREproof.vo
-backend/Mach.vo backend/Mach.glob backend/Mach.v.beautified: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo
-backend/Machtyping.vo backend/Machtyping.glob backend/Machtyping.v.beautified: backend/Machtyping.v lib/Coqlib.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo
+backend/Mach.vo backend/Mach.glob backend/Mach.v.beautified: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo
backend/Bounds.vo backend/Bounds.glob backend/Bounds.v.beautified: backend/Bounds.v lib/Coqlib.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo
$(ARCH)/$(VARIANT)/Stacklayout.vo $(ARCH)/$(VARIANT)/Stacklayout.glob $(ARCH)/$(VARIANT)/Stacklayout.v.beautified: $(ARCH)/$(VARIANT)/Stacklayout.v lib/Coqlib.vo backend/Bounds.vo
backend/Stacking.vo backend/Stacking.glob backend/Stacking.v.beautified: backend/Stacking.v lib/Coqlib.vo common/Errors.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Bounds.vo backend/Mach.vo backend/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo
-backend/Stackingproof.vo backend/Stackingproof.glob backend/Stackingproof.v.beautified: backend/Stackingproof.v lib/Coqlib.vo common/Errors.vo common/AST.vo lib/Integers.vo common/Values.vo $(ARCH)/Op.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machsem.vo backend/Bounds.vo backend/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo
-backend/Stackingtyping.vo backend/Stackingtyping.glob backend/Stackingtyping.v.beautified: backend/Stackingtyping.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machtyping.vo backend/Bounds.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo backend/Stackingproof.vo
-backend/Machsem.vo backend/Machsem.glob backend/Machsem.v.beautified: backend/Machsem.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Stacklayout.vo $(ARCH)/Asmgenretaddr.vo
+backend/Stackingproof.vo backend/Stackingproof.glob backend/Stackingproof.v.beautified: backend/Stackingproof.v lib/Coqlib.vo common/Errors.vo common/AST.vo lib/Integers.vo common/Values.vo $(ARCH)/Op.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Bounds.vo backend/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo
$(ARCH)/Asm.vo $(ARCH)/Asm.glob $(ARCH)/Asm.v.beautified: $(ARCH)/Asm.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Conventions.vo
$(ARCH)/Asmgen.vo $(ARCH)/Asmgen.glob $(ARCH)/Asmgen.v.beautified: $(ARCH)/Asmgen.v lib/Coqlib.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo
-$(ARCH)/Asmgenretaddr.vo $(ARCH)/Asmgenretaddr.glob $(ARCH)/Asmgenretaddr.v.beautified: $(ARCH)/Asmgenretaddr.v lib/Coqlib.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo
-$(ARCH)/Asmgenproof1.vo $(ARCH)/Asmgenproof1.glob $(ARCH)/Asmgenproof1.v.beautified: $(ARCH)/Asmgenproof1.v lib/Coqlib.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machsem.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Conventions.vo
-$(ARCH)/Asmgenproof.vo $(ARCH)/Asmgenproof.glob $(ARCH)/Asmgenproof.v.beautified: $(ARCH)/Asmgenproof.v lib/Coqlib.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machsem.vo backend/Machtyping.vo backend/Conventions.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo $(ARCH)/Asmgenretaddr.vo $(ARCH)/Asmgenproof1.vo
+backend/Asmgenproof0.vo backend/Asmgenproof0.glob backend/Asmgenproof0.v.beautified: backend/Asmgenproof0.v lib/Coqlib.vo lib/Intv.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Conventions.vo
+$(ARCH)/Asmgenproof1.vo $(ARCH)/Asmgenproof1.glob $(ARCH)/Asmgenproof1.v.beautified: $(ARCH)/Asmgenproof1.v lib/Coqlib.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Asmgenproof0.vo backend/Conventions.vo
+$(ARCH)/Asmgenproof.vo $(ARCH)/Asmgenproof.glob $(ARCH)/Asmgenproof.v.beautified: $(ARCH)/Asmgenproof.v lib/Coqlib.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Conventions.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Asmgenproof0.vo $(ARCH)/Asmgenproof1.vo
cfrontend/Ctypes.vo cfrontend/Ctypes.glob cfrontend/Ctypes.v.beautified: cfrontend/Ctypes.v lib/Coqlib.vo common/AST.vo common/Errors.vo
cfrontend/Cop.vo cfrontend/Cop.glob cfrontend/Cop.v.beautified: cfrontend/Cop.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo cfrontend/Ctypes.vo
cfrontend/Csyntax.vo cfrontend/Csyntax.glob cfrontend/Csyntax.v.beautified: cfrontend/Csyntax.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo
@@ -118,7 +115,7 @@ cfrontend/Cshmgenproof.vo cfrontend/Cshmgenproof.glob cfrontend/Cshmgenproof.v.b
cfrontend/Csharpminor.vo cfrontend/Csharpminor.glob cfrontend/Csharpminor.v.beautified: cfrontend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo backend/Cminor.vo common/Smallstep.vo
cfrontend/Cminorgen.vo cfrontend/Cminorgen.glob cfrontend/Cminorgen.v.beautified: cfrontend/Cminorgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo lib/Floats.vo cfrontend/Csharpminor.vo backend/Cminor.vo
cfrontend/Cminorgenproof.vo cfrontend/Cminorgenproof.glob cfrontend/Cminorgenproof.v.beautified: cfrontend/Cminorgenproof.v lib/Coqlib.vo lib/Intv.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo cfrontend/Csharpminor.vo backend/Cminor.vo cfrontend/Cminorgen.vo
-driver/Compiler.vo driver/Compiler.glob driver/Compiler.v.beautified: driver/Compiler.v lib/Coqlib.vo common/Errors.vo common/AST.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Cexec.vo cfrontend/Clight.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/LTLin.vo backend/Linear.vo backend/Mach.vo backend/Machsem.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/SimplLocals.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/Inlining.vo backend/Renumber.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Reload.vo backend/RRE.vo backend/Stacking.vo $(ARCH)/Asmgen.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/LTLintyping.vo backend/Lineartyping.vo backend/Machtyping.vo cfrontend/SimplExprproof.vo cfrontend/SimplLocalsproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/Inliningproof.vo backend/Renumberproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/CleanupLabelsproof.vo backend/CleanupLabelstyping.vo backend/Reloadproof.vo backend/Reloadtyping.vo backend/RREproof.vo backend/RREtyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo $(ARCH)/Asmgenproof.vo
+driver/Compiler.vo driver/Compiler.glob driver/Compiler.v.beautified: driver/Compiler.v lib/Coqlib.vo common/Errors.vo common/AST.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Cexec.vo cfrontend/Clight.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/LTLin.vo backend/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/SimplLocals.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/Inlining.vo backend/Renumber.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Reload.vo backend/RRE.vo backend/Stacking.vo $(ARCH)/Asmgen.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/LTLintyping.vo backend/Lineartyping.vo cfrontend/SimplExprproof.vo cfrontend/SimplLocalsproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/Inliningproof.vo backend/Renumberproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/CleanupLabelsproof.vo backend/CleanupLabelstyping.vo backend/Reloadproof.vo backend/Reloadtyping.vo backend/RREproof.vo backend/RREtyping.vo backend/Stackingproof.vo $(ARCH)/Asmgenproof.vo
driver/Complements.vo driver/Complements.glob driver/Complements.v.beautified: driver/Complements.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Behaviors.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo backend/Cminor.vo backend/RTL.vo $(ARCH)/Asm.vo driver/Compiler.vo common/Errors.vo
flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_float_prop.glob flocq/Core/Fcore_float_prop.v.beautified: flocq/Core/Fcore_float_prop.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo
flocq/Core/Fcore_Zaux.vo flocq/Core/Fcore_Zaux.glob flocq/Core/Fcore_Zaux.v.beautified: flocq/Core/Fcore_Zaux.v
diff --git a/Changelog b/Changelog
index cfb516d..93046d9 100644
--- a/Changelog
+++ b/Changelog
@@ -13,6 +13,9 @@ Development version
- Arguments to __builtin_annot() that are compile-time constants
are now replaced by their (integer or float) value in the annotation
generated in the assembly file.
+- Revised handling of return addresses in the Stacking and Asmgen passes.
+- ARM and PowerPC ports: more efficient access to function parameters
+ that are passed on the call stack.
Release 1.12.1, 2013-01-29
diff --git a/Makefile b/Makefile
index 4992098..4dfbe48 100644
--- a/Makefile
+++ b/Makefile
@@ -86,10 +86,9 @@ BACKEND=\
Linear.v Lineartyping.v \
Parallelmove.v Reload.v Reloadproof.v Reloadtyping.v \
RRE.v RREproof.v RREtyping.v \
- Mach.v Machtyping.v \
- Bounds.v Stacklayout.v Stacking.v Stackingproof.v Stackingtyping.v \
- Machsem.v \
- Asm.v Asmgen.v Asmgenretaddr.v Asmgenproof1.v Asmgenproof.v
+ Mach.v \
+ Bounds.v Stacklayout.v Stacking.v Stackingproof.v \
+ Asm.v Asmgen.v Asmgenproof0.v Asmgenproof1.v Asmgenproof.v
# C front-end modules (in cfrontend/)
diff --git a/arm/Asm.v b/arm/Asm.v
index 1e4bfa0..cad7188 100644
--- a/arm/Asm.v
+++ b/arm/Asm.v
@@ -89,8 +89,13 @@ End PregEq.
Module Pregmap := EMap(PregEq).
+(** Conventional names for stack pointer ([SP]) and return address ([RA]) *)
+
+Notation "'SP'" := IR13 (only parsing).
+Notation "'RA'" := IR14 (only parsing).
+
(** The instruction set. Most instructions correspond exactly to
- actual instructions of the PowerPC processor. See the PowerPC
+ actual instructions of the ARM processor. See the ARM
reference manuals for more details. Some instructions,
described below, are pseudo-instructions: they expand to
canned instruction sequences during the printing of the assembly
@@ -202,9 +207,9 @@ lbl: .word symbol
stack pointer to the address of the bottom of this block.
In the printed ASM assembly code, this allocation is:
<<
- mov r12, sp
+ mov r10, sp
sub sp, sp, #sz
- str r12, [sp, #pos]
+ str r10, [sp, #pos]
>>
This cannot be expressed in our memory model, which does not reflect
the fact that stack frames are adjacent and allocated/freed
@@ -248,6 +253,14 @@ Definition genv := Genv.t fundef unit.
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).
+(** Undefining some registers *)
+
+Fixpoint undef_regs (l: list preg) (rs: regset) : regset :=
+ match l with
+ | nil => rs
+ | r :: l' => undef_regs l' (rs#r <- Vundef)
+ end.
+
Section RELSEM.
(** Looking up instructions in a code sequence by position. *)
@@ -285,13 +298,13 @@ Variable ge: genv.
(** The semantics is purely small-step and defined as a function
from the current state (a register set + a memory state)
- to either [OK rs' m'] where [rs'] and [m'] are the updated register
+ to either [Next rs' m'] where [rs'] and [m'] are the updated register
set and memory state after execution of the instruction at [rs#PC],
- or [Error] if the processor is stuck. *)
+ or [Stuck] if the processor is stuck. *)
Inductive outcome: Type :=
- | OK: regset -> mem -> outcome
- | Error: outcome.
+ | Next: regset -> mem -> outcome
+ | Stuck: outcome.
(** Manipulations over the [PC] register: continuing with the next
instruction ([nextinstr]) or branching to a label ([goto_label]). *)
@@ -299,13 +312,13 @@ Inductive outcome: Type :=
Definition nextinstr (rs: regset) :=
rs#PC <- (Val.add rs#PC Vone).
-Definition goto_label (c: code) (lbl: label) (rs: regset) (m: mem) :=
- match label_pos lbl 0 c with
- | None => Error
+Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) :=
+ match label_pos lbl 0 (fn_code f) with
+ | None => Stuck
| Some pos =>
match rs#PC with
- | Vptr b ofs => OK (rs#PC <- (Vptr b (Int.repr pos))) m
- | _ => Error
+ | Vptr b ofs => Next (rs#PC <- (Vptr b (Int.repr pos))) m
+ | _ => Stuck
end
end.
@@ -343,15 +356,15 @@ Definition eval_shift_addr (sa: shift_addr) (rs: regset) :=
Definition exec_load (chunk: memory_chunk) (addr: val) (r: preg)
(rs: regset) (m: mem) :=
match Mem.loadv chunk m addr with
- | None => Error
- | Some v => OK (nextinstr (rs#r <- v)) m
+ | None => Stuck
+ | Some v => Next (nextinstr (rs#r <- v)) m
end.
Definition exec_store (chunk: memory_chunk) (addr: val) (r: preg)
(rs: regset) (m: mem) :=
match Mem.storev chunk m addr (rs r) with
- | None => Error
- | Some m' => OK (nextinstr rs) m'
+ | None => Stuck
+ | Some m' => Next (nextinstr rs) m'
end.
(** Operations over condition bits. *)
@@ -411,33 +424,33 @@ Definition symbol_offset (id: ident) (ofs: int) : val :=
| None => Vundef
end.
-Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome :=
+Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : outcome :=
match i with
| Padd r1 r2 so =>
- OK (nextinstr (rs#r1 <- (Val.add rs#r2 (eval_shift_op so rs)))) m
+ Next (nextinstr (rs#r1 <- (Val.add rs#r2 (eval_shift_op so rs)))) m
| Pand r1 r2 so =>
- OK (nextinstr (rs#r1 <- (Val.and rs#r2 (eval_shift_op so rs)))) m
+ Next (nextinstr (rs#r1 <- (Val.and rs#r2 (eval_shift_op so rs)))) m
| Pb lbl =>
- goto_label c lbl rs m
+ goto_label f lbl rs m
| Pbc bit lbl =>
match rs#bit with
- | Vint n => if Int.eq n Int.zero then OK (nextinstr rs) m else goto_label c lbl rs m
- | _ => Error
+ | Vint n => if Int.eq n Int.zero then Next (nextinstr rs) m else goto_label f lbl rs m
+ | _ => Stuck
end
| Pbsymb id sg =>
- OK (rs#PC <- (symbol_offset id Int.zero)) m
+ Next (rs#PC <- (symbol_offset id Int.zero)) m
| Pbreg r sg =>
- OK (rs#PC <- (rs#r)) m
+ Next (rs#PC <- (rs#r)) m
| Pblsymb id sg =>
- OK (rs#IR14 <- (Val.add rs#PC Vone) #PC <- (symbol_offset id Int.zero)) m
+ Next (rs#IR14 <- (Val.add rs#PC Vone) #PC <- (symbol_offset id Int.zero)) m
| Pblreg r sg =>
- OK (rs#IR14 <- (Val.add rs#PC Vone) #PC <- (rs#r)) m
+ Next (rs#IR14 <- (Val.add rs#PC Vone) #PC <- (rs#r)) m
| Pbic r1 r2 so =>
- OK (nextinstr (rs#r1 <- (Val.and rs#r2 (Val.notint (eval_shift_op so rs))))) m
+ Next (nextinstr (rs#r1 <- (Val.and rs#r2 (Val.notint (eval_shift_op so rs))))) m
| Pcmp r1 so =>
- OK (nextinstr (compare_int rs rs#r1 (eval_shift_op so rs) m)) m
+ Next (nextinstr (compare_int rs rs#r1 (eval_shift_op so rs) m)) m
| Peor r1 r2 so =>
- OK (nextinstr (rs#r1 <- (Val.xor rs#r2 (eval_shift_op so rs)))) m
+ Next (nextinstr (rs#r1 <- (Val.xor rs#r2 (eval_shift_op so rs)))) m
| Pldr r1 r2 sa =>
exec_load Mint32 (Val.add rs#r2 (eval_shift_addr sa rs)) r1 rs m
| Pldrb r1 r2 sa =>
@@ -449,22 +462,22 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
| Pldrsh r1 r2 sa =>
exec_load Mint16signed (Val.add rs#r2 (eval_shift_addr sa rs)) r1 rs m
| Pmov r1 so =>
- OK (nextinstr (rs#r1 <- (eval_shift_op so rs))) m
+ Next (nextinstr (rs#r1 <- (eval_shift_op so rs))) m
| Pmovc bit r1 so =>
match rs#bit with
| Vint n => if Int.eq n Int.zero
- then OK (nextinstr rs) m
- else OK (nextinstr (rs#r1 <- (eval_shift_op so rs))) m
- | _ => OK (nextinstr (rs#r1 <- Vundef)) m
+ then Next (nextinstr rs) m
+ else Next (nextinstr (rs#r1 <- (eval_shift_op so rs))) m
+ | _ => Next (nextinstr (rs#r1 <- Vundef)) m
end
| Pmul r1 r2 r3 =>
- OK (nextinstr (rs#r1 <- (Val.mul rs#r2 rs#r3))) m
+ Next (nextinstr (rs#r1 <- (Val.mul rs#r2 rs#r3))) m
| Pmvn r1 so =>
- OK (nextinstr (rs#r1 <- (Val.notint (eval_shift_op so rs)))) m
+ Next (nextinstr (rs#r1 <- (Val.notint (eval_shift_op so rs)))) m
| Porr r1 r2 so =>
- OK (nextinstr (rs#r1 <- (Val.or rs#r2 (eval_shift_op so rs)))) m
+ Next (nextinstr (rs#r1 <- (Val.or rs#r2 (eval_shift_op so rs)))) m
| Prsb r1 r2 so =>
- OK (nextinstr (rs#r1 <- (Val.sub (eval_shift_op so rs) rs#r2))) m
+ Next (nextinstr (rs#r1 <- (Val.sub (eval_shift_op so rs) rs#r2))) m
| Pstr r1 r2 sa =>
exec_store Mint32 (Val.add rs#r2 (eval_shift_addr sa rs)) r1 rs m
| Pstrb r1 r2 sa =>
@@ -473,47 +486,47 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
exec_store Mint16unsigned (Val.add rs#r2 (eval_shift_addr sa rs)) r1 rs m
| Psdiv rd r1 r2 =>
match Val.divs rs#r1 rs#r2 with
- | Some v => OK (nextinstr (rs#rd <- v)) m
- | None => Error
+ | Some v => Next (nextinstr (rs#rd <- v)) m
+ | None => Stuck
end
| Psub r1 r2 so =>
- OK (nextinstr (rs#r1 <- (Val.sub rs#r2 (eval_shift_op so rs)))) m
+ Next (nextinstr (rs#r1 <- (Val.sub rs#r2 (eval_shift_op so rs)))) m
| Pudiv rd r1 r2 =>
match Val.divu rs#r1 rs#r2 with
- | Some v => OK (nextinstr (rs#rd <- v)) m
- | None => Error
+ | Some v => Next (nextinstr (rs#rd <- v)) m
+ | None => Stuck
end
(* Floating-point coprocessor instructions *)
| Pfcpyd r1 r2 =>
- OK (nextinstr (rs#r1 <- (rs#r2))) m
+ Next (nextinstr (rs#r1 <- (rs#r2))) m
| Pfabsd r1 r2 =>
- OK (nextinstr (rs#r1 <- (Val.absf rs#r2))) m
+ Next (nextinstr (rs#r1 <- (Val.absf rs#r2))) m
| Pfnegd r1 r2 =>
- OK (nextinstr (rs#r1 <- (Val.negf rs#r2))) m
+ Next (nextinstr (rs#r1 <- (Val.negf rs#r2))) m
| Pfaddd r1 r2 r3 =>
- OK (nextinstr (rs#r1 <- (Val.addf rs#r2 rs#r3))) m
+ Next (nextinstr (rs#r1 <- (Val.addf rs#r2 rs#r3))) m
| Pfdivd r1 r2 r3 =>
- OK (nextinstr (rs#r1 <- (Val.divf rs#r2 rs#r3))) m
+ Next (nextinstr (rs#r1 <- (Val.divf rs#r2 rs#r3))) m
| Pfmuld r1 r2 r3 =>
- OK (nextinstr (rs#r1 <- (Val.mulf rs#r2 rs#r3))) m
+ Next (nextinstr (rs#r1 <- (Val.mulf rs#r2 rs#r3))) m
| Pfsubd r1 r2 r3 =>
- OK (nextinstr (rs#r1 <- (Val.subf rs#r2 rs#r3))) m
+ Next (nextinstr (rs#r1 <- (Val.subf rs#r2 rs#r3))) m
| Pflid r1 f =>
- OK (nextinstr (rs#r1 <- (Vfloat f))) m
+ Next (nextinstr (rs#r1 <- (Vfloat f))) m
| Pfcmpd r1 r2 =>
- OK (nextinstr (compare_float rs rs#r1 rs#r2)) m
+ Next (nextinstr (compare_float rs rs#r1 rs#r2)) m
| Pfcmpzd r1 =>
- OK (nextinstr (compare_float rs rs#r1 (Vfloat Float.zero))) m
+ Next (nextinstr (compare_float rs rs#r1 (Vfloat Float.zero))) m
| Pfsitod r1 r2 =>
- OK (nextinstr (rs#r1 <- (Val.maketotal (Val.floatofint rs#r2)))) m
+ Next (nextinstr (rs#r1 <- (Val.maketotal (Val.floatofint rs#r2)))) m
| Pfuitod r1 r2 =>
- OK (nextinstr (rs#r1 <- (Val.maketotal (Val.floatofintu rs#r2)))) m
+ Next (nextinstr (rs#r1 <- (Val.maketotal (Val.floatofintu rs#r2)))) m
| Pftosizd r1 r2 =>
- OK (nextinstr (rs#r1 <- (Val.maketotal (Val.intoffloat rs#r2)))) m
+ Next (nextinstr (rs#r1 <- (Val.maketotal (Val.intoffloat rs#r2)))) m
| Pftouizd r1 r2 =>
- OK (nextinstr (rs#r1 <- (Val.maketotal (Val.intuoffloat rs#r2)))) m
+ Next (nextinstr (rs#r1 <- (Val.maketotal (Val.intuoffloat rs#r2)))) m
| Pfcvtsd r1 r2 =>
- OK (nextinstr (rs#r1 <- (Val.singleoffloat rs#r2))) m
+ Next (nextinstr (rs#r1 <- (Val.singleoffloat rs#r2))) m
| Pfldd r1 r2 n =>
exec_load Mfloat64al32 (Val.add rs#r2 (Vint n)) r1 rs m
| Pflds r1 r2 n =>
@@ -522,85 +535,63 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
exec_store Mfloat64al32 (Val.add rs#r2 (Vint n)) r1 rs m
| Pfsts r1 r2 n =>
match exec_store Mfloat32 (Val.add rs#r2 (Vint n)) r1 rs m with
- | OK rs' m' => OK (rs'#FR7 <- Vundef) m'
- | Error => Error
+ | Next rs' m' => Next (rs'#FR7 <- Vundef) m'
+ | Stuck => Stuck
end
(* Pseudo-instructions *)
| Pallocframe sz pos =>
let (m1, stk) := Mem.alloc m 0 sz in
let sp := (Vptr stk Int.zero) in
match Mem.storev Mint32 m1 (Val.add sp (Vint pos)) rs#IR13 with
- | None => Error
- | Some m2 => OK (nextinstr (rs #IR12 <- (rs#IR13) #IR13 <- sp)) m2
+ | None => Stuck
+ | Some m2 => Next (nextinstr (rs #IR10 <- (rs#IR13) #IR13 <- sp)) m2
end
| Pfreeframe sz pos =>
match Mem.loadv Mint32 m (Val.add rs#IR13 (Vint pos)) with
- | None => Error
+ | None => Stuck
| Some v =>
match rs#IR13 with
| Vptr stk ofs =>
match Mem.free m stk 0 sz with
- | None => Error
- | Some m' => OK (nextinstr (rs#IR13 <- v)) m'
+ | None => Stuck
+ | Some m' => Next (nextinstr (rs#IR13 <- v)) m'
end
- | _ => Error
+ | _ => Stuck
end
end
| Plabel lbl =>
- OK (nextinstr rs) m
+ Next (nextinstr rs) m
| Ploadsymbol r1 lbl ofs =>
- OK (nextinstr (rs#r1 <- (symbol_offset lbl ofs))) m
+ Next (nextinstr (rs#r1 <- (symbol_offset lbl ofs))) m
| Pbtbl r tbl =>
match rs#r with
| Vint n =>
- let pos := Int.unsigned n in
- if zeq (Zmod pos 4) 0 then
- match list_nth_z tbl (pos / 4) with
- | None => Error
- | Some lbl => goto_label c lbl rs m
- end
- else Error
- | _ => Error
+ match list_nth_z tbl (Int.unsigned n) with
+ | None => Stuck
+ | Some lbl => goto_label f lbl (rs#IR14 <- Vundef) m
+ end
+ | _ => Stuck
end
- | Pbuiltin ef args res => Error (**r treated specially below *)
- | Pannot ef args => Error (**r treated specially below *)
+ | Pbuiltin ef args res => Stuck (**r treated specially below *)
+ | Pannot ef args => Stuck (**r treated specially below *)
end.
(** Translation of the LTL/Linear/Mach view of machine registers
- to the ARM view. ARM has two different types for registers
- (integer and float) while LTL et al have only one. The
- [ireg_of] and [freg_of] are therefore partial in principle.
- To keep things simpler, we make them return nonsensical
- results when applied to a LTL register of the wrong type.
- The proof in [ARMgenproof] will show that this never happens.
-
- Note that no LTL register maps to [IR14].
+ to the ARM view. Note that no LTL register maps to [IR14].
This register is reserved as temporary, to be used
by the generated ARM code. *)
-Definition ireg_of (r: mreg) : ireg :=
+Definition preg_of (r: mreg) : preg :=
match r with
| R0 => IR0 | R1 => IR1 | R2 => IR2 | R3 => IR3
| R4 => IR4 | R5 => IR5 | R6 => IR6 | R7 => IR7
| R8 => IR8 | R9 => IR9 | R11 => IR11
| IT1 => IR10 | IT2 => IR12
- | _ => IR0 (* should not happen *)
- end.
-
-Definition freg_of (r: mreg) : freg :=
- match r with
| F0 => FR0 | F1 => FR1 | F2 => FR2 | F3 => FR3
| F4 => FR4 | F5 => FR5
| F8 => FR8 | F9 => FR9 | F10 => FR10 | F11 => FR11
| F12 => FR12 | F13 => FR13 | F14 => FR14 | F15 => FR15
| FT1 => FR6 | FT2 => FR7
- | _ => FR0 (* should not happen *)
- end.
-
-Definition preg_of (r: mreg) :=
- match mreg_type r with
- | Tint => IR (ireg_of r)
- | Tfloat => FR (freg_of r)
end.
(** Extract the values of the arguments of an external call.
@@ -651,7 +642,7 @@ Inductive step: state -> trace -> state -> Prop :=
rs PC = Vptr b ofs ->
Genv.find_funct_ptr ge b = Some (Internal f) ->
find_instr (Int.unsigned ofs) (fn_code f) = Some i ->
- exec_instr (fn_code f) i rs m = OK rs' m' ->
+ exec_instr f i rs m = Next rs' m' ->
step (State rs m) E0 (State rs' m')
| exec_step_builtin:
forall b ofs f ef args res rs m t v m',
@@ -765,3 +756,27 @@ Ltac Equalities :=
(* final states *)
inv H; inv H0. congruence.
Qed.
+
+(** Classification functions for processor registers (used in Asmgenproof). *)
+
+Definition data_preg (r: preg) : bool :=
+ match r with
+ | IR IR14 => false
+ | IR _ => true
+ | FR _ => true
+ | CR _ => false
+ | PC => false
+ end.
+
+Definition nontemp_preg (r: preg) : bool :=
+ match r with
+ | IR IR14 => false
+ | IR IR10 => false
+ | IR IR12 => false
+ | IR _ => true
+ | FR FR6 => false
+ | FR FR7 => false
+ | FR _ => true
+ | CR _ => false
+ | PC => false
+ end.
diff --git a/arm/Asmgen.v b/arm/Asmgen.v
index 05e7010..562cf22 100644
--- a/arm/Asmgen.v
+++ b/arm/Asmgen.v
@@ -22,6 +22,17 @@ Require Import Locations.
Require Import Mach.
Require Import Asm.
+Open Local Scope string_scope.
+Open Local Scope error_monad_scope.
+
+(** Extracting integer or float registers. *)
+
+Definition ireg_of (r: mreg) : res ireg :=
+ match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end.
+
+Definition freg_of (r: mreg) : res freg :=
+ match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end.
+
(** Recognition of integer immediate arguments.
- For arithmetic operations, immediates are
8-bit quantities zero-extended and rotated right by 0, 2, 4, ... 30 bits.
@@ -130,33 +141,43 @@ Definition transl_cond
(cond: condition) (args: list mreg) (k: code) :=
match cond, args with
| Ccomp c, a1 :: a2 :: nil =>
- Pcmp (ireg_of a1) (SOreg (ireg_of a2)) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pcmp r1(SOreg r2) :: k)
| Ccompu c, a1 :: a2 :: nil =>
- Pcmp (ireg_of a1) (SOreg (ireg_of a2)) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pcmp r1 (SOreg r2) :: k)
| Ccompshift c s, a1 :: a2 :: nil =>
- Pcmp (ireg_of a1) (transl_shift s (ireg_of a2)) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pcmp r1 (transl_shift s r2) :: k)
| Ccompushift c s, a1 :: a2 :: nil =>
- Pcmp (ireg_of a1) (transl_shift s (ireg_of a2)) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pcmp r1 (transl_shift s r2) :: k)
| Ccompimm c n, a1 :: nil =>
- if is_immed_arith n then
- Pcmp (ireg_of a1) (SOimm n) :: k
- else
- loadimm IR14 n (Pcmp (ireg_of a1) (SOreg IR14) :: k)
+ do r1 <- ireg_of a1;
+ OK (if is_immed_arith n then
+ Pcmp r1 (SOimm n) :: k
+ else
+ loadimm IR14 n (Pcmp r1 (SOreg IR14) :: k))
| Ccompuimm c n, a1 :: nil =>
- if is_immed_arith n then
- Pcmp (ireg_of a1) (SOimm n) :: k
- else
- loadimm IR14 n (Pcmp (ireg_of a1) (SOreg IR14) :: k)
+ do r1 <- ireg_of a1;
+ OK (if is_immed_arith n then
+ Pcmp r1 (SOimm n) :: k
+ else
+ loadimm IR14 n (Pcmp r1 (SOreg IR14) :: k))
| Ccompf cmp, a1 :: a2 :: nil =>
- Pfcmpd (freg_of a1) (freg_of a2) :: k
+ do r1 <- freg_of a1; do r2 <- freg_of a2;
+ OK (Pfcmpd r1 r2 :: k)
| Cnotcompf cmp, a1 :: a2 :: nil =>
- Pfcmpd (freg_of a1) (freg_of a2) :: k
+ do r1 <- freg_of a1; do r2 <- freg_of a2;
+ OK (Pfcmpd r1 r2 :: k)
| Ccompfzero cmp, a1 :: nil =>
- Pfcmpzd (freg_of a1) :: k
+ do r1 <- freg_of a1;
+ OK (Pfcmpzd r1 :: k)
| Cnotcompfzero cmp, a1 :: nil =>
- Pfcmpzd (freg_of a1) :: k
+ do r1 <- freg_of a1;
+ OK (Pfcmpzd r1 :: k)
| _, _ =>
- k (**r never happens for well-typed code *)
+ Error(msg "Asmgen.transl_cond")
end.
Definition crbit_for_signed_cmp (cmp: comparison) :=
@@ -217,115 +238,159 @@ Definition crbit_for_cond (cond: condition) :=
The corresponding instructions are prepended to [k]. *)
Definition transl_op
- (op: operation) (args: list mreg) (r: mreg) (k: code) :=
+ (op: operation) (args: list mreg) (res: mreg) (k: code) :=
match op, args with
| Omove, a1 :: nil =>
- match mreg_type a1 with
- | Tint => Pmov (ireg_of r) (SOreg (ireg_of a1)) :: k
- | Tfloat => Pfcpyd (freg_of r) (freg_of a1) :: k
+ match preg_of res, preg_of a1 with
+ | IR r, IR a => OK (Pmov r (SOreg a) :: k)
+ | FR r, FR a => OK (Pfcpyd r a :: k)
+ | _ , _ => Error(msg "Asmgen.Omove")
end
| Ointconst n, nil =>
- loadimm (ireg_of r) n k
+ do r <- ireg_of res;
+ OK (loadimm r n k)
| Ofloatconst f, nil =>
- Pflid (freg_of r) f :: k
+ do r <- freg_of res;
+ OK (Pflid r f :: k)
| Oaddrsymbol s ofs, nil =>
- Ploadsymbol (ireg_of r) s ofs :: k
+ do r <- ireg_of res;
+ OK (Ploadsymbol r s ofs :: k)
| Oaddrstack n, nil =>
- addimm (ireg_of r) IR13 n k
+ do r <- ireg_of res;
+ OK (addimm r IR13 n k)
| Oadd, a1 :: a2 :: nil =>
- Padd (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Padd r r1 (SOreg r2) :: k)
| Oaddshift s, a1 :: a2 :: nil =>
- Padd (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Padd r r1 (transl_shift s r2) :: k)
| Oaddimm n, a1 :: nil =>
- addimm (ireg_of r) (ireg_of a1) n k
+ do r <- ireg_of res; do r1 <- ireg_of a1;
+ OK (addimm r r1 n k)
| Osub, a1 :: a2 :: nil =>
- Psub (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Psub r r1 (SOreg r2) :: k)
| Osubshift s, a1 :: a2 :: nil =>
- Psub (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Psub r r1 (transl_shift s r2) :: k)
| Orsubshift s, a1 :: a2 :: nil =>
- Prsb (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Prsb r r1 (transl_shift s r2) :: k)
| Orsubimm n, a1 :: nil =>
- rsubimm (ireg_of r) (ireg_of a1) n k
+ do r <- ireg_of res; do r1 <- ireg_of a1;
+ OK (rsubimm r r1 n k)
| Omul, a1 :: a2 :: nil =>
- if ireg_eq (ireg_of r) (ireg_of a1)
- || ireg_eq (ireg_of r) (ireg_of a2)
- then Pmul IR14 (ireg_of a1) (ireg_of a2) :: Pmov (ireg_of r) (SOreg IR14) :: k
- else Pmul (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (if ireg_eq r r1 || ireg_eq r r2
+ then Pmul IR14 r1 r2 :: Pmov r (SOreg IR14) :: k
+ else Pmul r r1 r2 :: k)
| Odiv, a1 :: a2 :: nil =>
- Psdiv (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Psdiv r r1 r2 :: k)
| Odivu, a1 :: a2 :: nil =>
- Pudiv (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pudiv r r1 r2 :: k)
| Oand, a1 :: a2 :: nil =>
- Pand (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pand r r1 (SOreg r2) :: k)
| Oandshift s, a1 :: a2 :: nil =>
- Pand (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pand r r1 (transl_shift s r2) :: k)
| Oandimm n, a1 :: nil =>
- andimm (ireg_of r) (ireg_of a1) n k
+ do r <- ireg_of res; do r1 <- ireg_of a1;
+ OK (andimm r r1 n k)
| Oor, a1 :: a2 :: nil =>
- Porr (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Porr r r1 (SOreg r2) :: k)
| Oorshift s, a1 :: a2 :: nil =>
- Porr (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Porr r r1 (transl_shift s r2) :: k)
| Oorimm n, a1 :: nil =>
- orimm (ireg_of r) (ireg_of a1) n k
+ do r <- ireg_of res; do r1 <- ireg_of a1;
+ OK (orimm r r1 n k)
| Oxor, a1 :: a2 :: nil =>
- Peor (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Peor r r1 (SOreg r2) :: k)
| Oxorshift s, a1 :: a2 :: nil =>
- Peor (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Peor r r1 (transl_shift s r2) :: k)
| Oxorimm n, a1 :: nil =>
- xorimm (ireg_of r) (ireg_of a1) n k
+ do r <- ireg_of res; do r1 <- ireg_of a1;
+ OK (xorimm r r1 n k)
| Obic, a1 :: a2 :: nil =>
- Pbic (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pbic r r1 (SOreg r2) :: k)
| Obicshift s, a1 :: a2 :: nil =>
- Pbic (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pbic r r1 (transl_shift s r2) :: k)
| Onot, a1 :: nil =>
- Pmvn (ireg_of r) (SOreg (ireg_of a1)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Pmvn r (SOreg r1) :: k)
| Onotshift s, a1 :: nil =>
- Pmvn (ireg_of r) (transl_shift s (ireg_of a1)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Pmvn r (transl_shift s r1) :: k)
| Oshl, a1 :: a2 :: nil =>
- Pmov (ireg_of r) (SOlslreg (ireg_of a1) (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pmov r (SOlslreg r1 r2) :: k)
| Oshr, a1 :: a2 :: nil =>
- Pmov (ireg_of r) (SOasrreg (ireg_of a1) (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pmov r (SOasrreg r1 r2) :: k)
| Oshru, a1 :: a2 :: nil =>
- Pmov (ireg_of r) (SOlsrreg (ireg_of a1) (ireg_of a2)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pmov r (SOlsrreg r1 r2) :: k)
| Oshift s, a1 :: nil =>
- Pmov (ireg_of r) (transl_shift s (ireg_of a1)) :: k
+ do r <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Pmov r (transl_shift s r1) :: k)
| Oshrximm n, a1 :: nil =>
- Pcmp (ireg_of a1) (SOimm Int.zero) ::
- addimm IR14 (ireg_of a1) (Int.sub (Int.shl Int.one n) Int.one)
- (Pmovc CRge IR14 (SOreg (ireg_of a1)) ::
- Pmov (ireg_of r) (SOasrimm IR14 n) :: k)
+ do r <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Pcmp r1 (SOimm Int.zero) ::
+ addimm IR14 r1 (Int.sub (Int.shl Int.one n) Int.one)
+ (Pmovc CRge IR14 (SOreg r1) ::
+ Pmov r (SOasrimm IR14 n) :: k))
| Onegf, a1 :: nil =>
- Pfnegd (freg_of r) (freg_of a1) :: k
+ do r <- freg_of res; do r1 <- freg_of a1;
+ OK (Pfnegd r r1 :: k)
| Oabsf, a1 :: nil =>
- Pfabsd (freg_of r) (freg_of a1) :: k
+ do r <- freg_of res; do r1 <- freg_of a1;
+ OK (Pfabsd r r1 :: k)
| Oaddf, a1 :: a2 :: nil =>
- Pfaddd (freg_of r) (freg_of a1) (freg_of a2) :: k
+ do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
+ OK (Pfaddd r r1 r2 :: k)
| Osubf, a1 :: a2 :: nil =>
- Pfsubd (freg_of r) (freg_of a1) (freg_of a2) :: k
+ do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
+ OK (Pfsubd r r1 r2 :: k)
| Omulf, a1 :: a2 :: nil =>
- Pfmuld (freg_of r) (freg_of a1) (freg_of a2) :: k
+ do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
+ OK (Pfmuld r r1 r2 :: k)
| Odivf, a1 :: a2 :: nil =>
- Pfdivd (freg_of r) (freg_of a1) (freg_of a2) :: k
+ do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
+ OK (Pfdivd r r1 r2 :: k)
| Osingleoffloat, a1 :: nil =>
- Pfcvtsd (freg_of r) (freg_of a1) :: k
+ do r <- freg_of res; do r1 <- freg_of a1;
+ OK (Pfcvtsd r r1 :: k)
| Ointoffloat, a1 :: nil =>
- Pftosizd (ireg_of r) (freg_of a1) :: k
+ do r <- ireg_of res; do r1 <- freg_of a1;
+ OK (Pftosizd r r1 :: k)
| Ointuoffloat, a1 :: nil =>
- Pftouizd (ireg_of r) (freg_of a1) :: k
+ do r <- ireg_of res; do r1 <- freg_of a1;
+ OK (Pftouizd r r1 :: k)
| Ofloatofint, a1 :: nil =>
- Pfsitod (freg_of r) (ireg_of a1) :: k
+ do r <- freg_of res; do r1 <- ireg_of a1;
+ OK (Pfsitod r r1 :: k)
| Ofloatofintu, a1 :: nil =>
- Pfuitod (freg_of r) (ireg_of a1) :: k
+ do r <- freg_of res; do r1 <- ireg_of a1;
+ OK (Pfuitod r r1 :: k)
| Ocmp cmp, _ =>
+ do r <- ireg_of res;
transl_cond cmp args
- (Pmov (ireg_of r) (SOimm Int.zero) ::
- Pmovc (crbit_for_cond cmp) (ireg_of r) (SOimm Int.one) ::
+ (Pmov r (SOimm Int.zero) ::
+ Pmovc (crbit_for_cond cmp) r (SOimm Int.one) ::
k)
| _, _ =>
- k (**r never happens for well-typed code *)
+ Error(msg "Asmgen.transl_op")
end.
-(** Common code to translate [Mload] and [Mstore] instructions. *)
+(** Translation of memory accesses: loads and stores. *)
Definition transl_shift_addr (s: shift) (r: ireg) : shift_addr :=
match s with
@@ -335,62 +400,106 @@ Definition transl_shift_addr (s: shift) (r: ireg) : shift_addr :=
| Sror n => SAror r (s_amount n)
end.
-Definition transl_load_store
+Definition transl_memory_access
(mk_instr_imm: ireg -> int -> instruction)
(mk_instr_gen: option (ireg -> shift_addr -> instruction))
(is_immed: int -> bool)
- (addr: addressing) (args: list mreg) (k: code) : code :=
+ (addr: addressing) (args: list mreg) (k: code) :=
match addr, args with
| Aindexed n, a1 :: nil =>
- if is_immed n then
- mk_instr_imm (ireg_of a1) n :: k
- else
- addimm IR14 (ireg_of a1) n
- (mk_instr_imm IR14 Int.zero :: k)
+ do r1 <- ireg_of a1;
+ OK (if is_immed n then
+ mk_instr_imm r1 n :: k
+ else
+ addimm IR14 r1 n
+ (mk_instr_imm IR14 Int.zero :: k))
| Aindexed2, a1 :: a2 :: nil =>
- match mk_instr_gen with
- | Some f =>
- f (ireg_of a1) (SAreg (ireg_of a2)) :: k
- | None =>
- Padd IR14 (ireg_of a1) (SOreg (ireg_of a2)) ::
- mk_instr_imm IR14 Int.zero :: k
- end
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (match mk_instr_gen with
+ | Some f =>
+ f r1 (SAreg r2) :: k
+ | None =>
+ Padd IR14 r1 (SOreg r2) ::
+ mk_instr_imm IR14 Int.zero :: k
+ end)
| Aindexed2shift s, a1 :: a2 :: nil =>
- match mk_instr_gen with
- | Some f =>
- f (ireg_of a1) (transl_shift_addr s (ireg_of a2)) :: k
- | None =>
- Padd IR14 (ireg_of a1) (transl_shift s (ireg_of a2)) ::
- mk_instr_imm IR14 Int.zero :: k
- end
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (match mk_instr_gen with
+ | Some f =>
+ f r1 (transl_shift_addr s r2) :: k
+ | None =>
+ Padd IR14 r1 (transl_shift s r2) ::
+ mk_instr_imm IR14 Int.zero :: k
+ end)
| Ainstack n, nil =>
- if is_immed n then
- mk_instr_imm IR13 n :: k
- else
- addimm IR14 IR13 n
- (mk_instr_imm IR14 Int.zero :: k)
+ OK (if is_immed n then
+ mk_instr_imm IR13 n :: k
+ else
+ addimm IR14 IR13 n (mk_instr_imm IR14 Int.zero :: k))
| _, _ =>
- (* should not happen *) k
+ Error(msg "Asmgen.transl_memory_access")
end.
-Definition transl_load_store_int
+Definition transl_memory_access_int
(mk_instr: ireg -> ireg -> shift_addr -> instruction)
(is_immed: int -> bool)
- (rd: mreg) (addr: addressing) (args: list mreg) (k: code) :=
- transl_load_store
- (fun r n => mk_instr (ireg_of rd) r (SAimm n))
- (Some (mk_instr (ireg_of rd)))
+ (dst: mreg) (addr: addressing) (args: list mreg) (k: code) :=
+ do rd <- ireg_of dst;
+ transl_memory_access
+ (fun r n => mk_instr rd r (SAimm n))
+ (Some (mk_instr rd))
is_immed addr args k.
-Definition transl_load_store_float
+Definition transl_memory_access_float
(mk_instr: freg -> ireg -> int -> instruction)
(is_immed: int -> bool)
- (rd: mreg) (addr: addressing) (args: list mreg) (k: code) :=
- transl_load_store
- (mk_instr (freg_of rd))
+ (dst: mreg) (addr: addressing) (args: list mreg) (k: code) :=
+ do rd <- freg_of dst;
+ transl_memory_access
+ (mk_instr rd)
None
is_immed addr args k.
+Definition transl_load (chunk: memory_chunk) (addr: addressing)
+ (args: list mreg) (dst: mreg) (k: code) :=
+ match chunk with
+ | Mint8signed =>
+ transl_memory_access_int Pldrsb is_immed_mem_small dst addr args k
+ | Mint8unsigned =>
+ transl_memory_access_int Pldrb is_immed_mem_word dst addr args k
+ | Mint16signed =>
+ transl_memory_access_int Pldrsh is_immed_mem_small dst addr args k
+ | Mint16unsigned =>
+ transl_memory_access_int Pldrh is_immed_mem_small dst addr args k
+ | Mint32 =>
+ transl_memory_access_int Pldr is_immed_mem_word dst addr args k
+ | Mfloat32 =>
+ transl_memory_access_float Pflds is_immed_mem_float dst addr args k
+ | Mfloat64 | Mfloat64al32 =>
+ transl_memory_access_float Pfldd is_immed_mem_float dst addr args k
+ end.
+
+Definition transl_store (chunk: memory_chunk) (addr: addressing)
+ (args: list mreg) (src: mreg) (k: code) :=
+ match chunk with
+ | Mint8signed =>
+ transl_memory_access_int Pstrb is_immed_mem_small src addr args k
+ | Mint8unsigned =>
+ transl_memory_access_int Pstrb is_immed_mem_word src addr args k
+ | Mint16signed =>
+ transl_memory_access_int Pstrh is_immed_mem_small src addr args k
+ | Mint16unsigned =>
+ transl_memory_access_int Pstrh is_immed_mem_small src addr args k
+ | Mint32 =>
+ transl_memory_access_int Pstr is_immed_mem_word src addr args k
+ | Mfloat32 =>
+ transl_memory_access_float Pfsts is_immed_mem_float src addr args k
+ | Mfloat64 | Mfloat64al32 =>
+ transl_memory_access_float Pfstd is_immed_mem_float src addr args k
+ end.
+
+(** Accessing data in the stack frame. *)
+
Definition loadind_int (base: ireg) (ofs: int) (dst: ireg) (k: code) :=
if is_immed_mem_word ofs then
Pldr dst base (SAimm ofs) :: k
@@ -407,8 +516,8 @@ Definition loadind_float (base: ireg) (ofs: int) (dst: freg) (k: code) :=
Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) :=
match ty with
- | Tint => loadind_int base ofs (ireg_of dst) k
- | Tfloat => loadind_float base ofs (freg_of dst) k
+ | Tint => do r <- ireg_of dst; OK (loadind_int base ofs r k)
+ | Tfloat => do r <- freg_of dst; OK (loadind_float base ofs r k)
end.
Definition storeind_int (src: ireg) (base: ireg) (ofs: int) (k: code) :=
@@ -427,8 +536,8 @@ Definition storeind_float (src: freg) (base: ireg) (ofs: int) (k: code) :=
Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) :=
match ty with
- | Tint => storeind_int (ireg_of src) base ofs k
- | Tfloat => storeind_float (freg_of src) base ofs k
+ | Tint => do r <- ireg_of src; OK (storeind_int r base ofs k)
+ | Tfloat => do r <- freg_of src; OK (storeind_float r base ofs k)
end.
(** Translation of arguments to annotations *)
@@ -441,80 +550,71 @@ Definition transl_annot_param (p: Mach.annot_param) : Asm.annot_param :=
(** Translation of a Mach instruction. *)
-Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) :=
+Definition transl_instr (f: Mach.function) (i: Mach.instruction)
+ (r10_is_parent: bool) (k: code) :=
match i with
| Mgetstack ofs ty dst =>
loadind IR13 ofs ty dst k
| Msetstack src ofs ty =>
storeind src IR13 ofs ty k
| Mgetparam ofs ty dst =>
- loadind_int IR13 f.(fn_link_ofs) IR14 (loadind IR14 ofs ty dst k)
+ do c <- loadind IR10 ofs ty dst k;
+ OK (if r10_is_parent
+ then c
+ else loadind_int IR13 f.(fn_link_ofs) IR10 c)
| Mop op args res =>
transl_op op args res k
| Mload chunk addr args dst =>
- match chunk with
- | Mint8signed =>
- transl_load_store_int Pldrsb is_immed_mem_small dst addr args k
- | Mint8unsigned =>
- transl_load_store_int Pldrb is_immed_mem_word dst addr args k
- | Mint16signed =>
- transl_load_store_int Pldrsh is_immed_mem_small dst addr args k
- | Mint16unsigned =>
- transl_load_store_int Pldrh is_immed_mem_small dst addr args k
- | Mint32 =>
- transl_load_store_int Pldr is_immed_mem_word dst addr args k
- | Mfloat32 =>
- transl_load_store_float Pflds is_immed_mem_float dst addr args k
- | Mfloat64 | Mfloat64al32 =>
- transl_load_store_float Pfldd is_immed_mem_float dst addr args k
- end
+ transl_load chunk addr args dst k
| Mstore chunk addr args src =>
- match chunk with
- | Mint8signed =>
- transl_load_store_int Pstrb is_immed_mem_small src addr args k
- | Mint8unsigned =>
- transl_load_store_int Pstrb is_immed_mem_word src addr args k
- | Mint16signed =>
- transl_load_store_int Pstrh is_immed_mem_small src addr args k
- | Mint16unsigned =>
- transl_load_store_int Pstrh is_immed_mem_small src addr args k
- | Mint32 =>
- transl_load_store_int Pstr is_immed_mem_word src addr args k
- | Mfloat32 =>
- transl_load_store_float Pfsts is_immed_mem_float src addr args k
- | Mfloat64 | Mfloat64al32 =>
- transl_load_store_float Pfstd is_immed_mem_float src addr args k
- end
- | Mcall sig (inl r) =>
- Pblreg (ireg_of r) sig :: k
+ transl_store chunk addr args src k
+ | Mcall sig (inl arg) =>
+ do r <- ireg_of arg; OK (Pblreg r sig :: k)
| Mcall sig (inr symb) =>
- Pblsymb symb sig :: k
- | Mtailcall sig (inl r) =>
- loadind_int IR13 f.(fn_retaddr_ofs) IR14
- (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbreg (ireg_of r) sig :: k)
+ OK (Pblsymb symb sig :: k)
+ | Mtailcall sig (inl arg) =>
+ do r <- ireg_of arg;
+ OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14
+ (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbreg r sig :: k))
| Mtailcall sig (inr symb) =>
- loadind_int IR13 f.(fn_retaddr_ofs) IR14
- (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbsymb symb sig :: k)
+ OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14
+ (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbsymb symb sig :: k))
| Mbuiltin ef args res =>
- Pbuiltin ef (map preg_of args) (preg_of res) :: k
+ OK (Pbuiltin ef (map preg_of args) (preg_of res) :: k)
| Mannot ef args =>
- Pannot ef (map transl_annot_param args) :: k
+ OK (Pannot ef (map transl_annot_param args) :: k)
| Mlabel lbl =>
- Plabel lbl :: k
+ OK (Plabel lbl :: k)
| Mgoto lbl =>
- Pb lbl :: k
+ OK (Pb lbl :: k)
| Mcond cond args lbl =>
transl_cond cond args (Pbc (crbit_for_cond cond) lbl :: k)
| Mjumptable arg tbl =>
- Pmov IR14 (SOlslimm (ireg_of arg) (Int.repr 2)) ::
- Pbtbl IR14 tbl :: k
+ do r <- ireg_of arg;
+ OK (Pbtbl r tbl :: k)
| Mreturn =>
- loadind_int IR13 f.(fn_retaddr_ofs) IR14
- (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbreg IR14 f.(Mach.fn_sig) :: k)
+ OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14
+ (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::
+ Pbreg IR14 f.(Mach.fn_sig) :: k))
end.
-Definition transl_code (f: Mach.function) (il: list Mach.instruction) :=
- List.fold_right (transl_instr f) nil il.
+(** Translation of a code sequence *)
+
+Definition r10_is_parent (before: bool) (i: Mach.instruction) : bool :=
+ match i with
+ | Msetstack src ofs ty => before
+ | Mgetparam ofs ty dst => negb (mreg_eq dst IT1)
+ | Mop Omove args res => before && negb (mreg_eq res IT1)
+ | _ => false
+ end.
+
+Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (r10p: bool) :=
+ match il with
+ | nil => OK nil
+ | i1 :: il' =>
+ do k <- transl_code f il' (r10_is_parent r10p i1);
+ transl_instr f i1 r10p k
+ end.
(** Translation of a whole function. Note that we must check
that the generated code contains less than [2^32] instructions,
@@ -522,24 +622,16 @@ Definition transl_code (f: Mach.function) (il: list Mach.instruction) :=
around, leading to incorrect executions. *)
Definition transl_function (f: Mach.function) :=
- mkfunction f.(Mach.fn_sig)
- (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::
- Pstr IR14 IR13 (SAimm f.(fn_retaddr_ofs)) ::
- transl_code f f.(Mach.fn_code)).
-
-Fixpoint code_size (c: code) : Z :=
- match c with
- | nil => 0
- | instr :: c' => code_size c' + 1
- end.
-
-Open Local Scope string_scope.
+ do c <- transl_code f f.(Mach.fn_code) true;
+ OK (mkfunction f.(Mach.fn_sig)
+ (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::
+ Pstr IR14 IR13 (SAimm f.(fn_retaddr_ofs)) :: c)).
Definition transf_function (f: Mach.function) : res Asm.function :=
- let tf := transl_function f in
- if zlt Int.max_unsigned (code_size tf.(fn_code))
- then Errors.Error (msg "code size exceeded")
- else Errors.OK tf.
+ do tf <- transl_function f;
+ if zlt Int.max_unsigned (list_length_z tf.(fn_code))
+ then Error (msg "code size exceeded")
+ else OK tf.
Definition transf_fundef (f: Mach.fundef) : res Asm.fundef :=
transf_partial_fundef transf_function f.
diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v
index 365917c..21becf1 100644
--- a/arm/Asmgenproof.v
+++ b/arm/Asmgenproof.v
@@ -27,11 +27,9 @@ Require Import Op.
Require Import Locations.
Require Import Conventions.
Require Import Mach.
-Require Import Machsem.
-Require Import Machtyping.
Require Import Asm.
Require Import Asmgen.
-Require Import Asmgenretaddr.
+Require Import Asmgenproof0.
Require Import Asmgenproof1.
Section PRESERVATION.
@@ -59,27 +57,14 @@ Proof
(Genv.find_funct_ptr_transf_partial transf_fundef _ TRANSF).
Lemma functions_transl:
- forall f b,
+ forall f b tf,
Genv.find_funct_ptr ge b = Some (Internal f) ->
- Genv.find_funct_ptr tge b = Some (Internal (transl_function f)).
+ transf_function f = OK tf ->
+ Genv.find_funct_ptr tge b = Some (Internal tf).
Proof.
intros.
- 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 (fn_code (transl_function f)))); simpl; intro.
- congruence. intro. inv B0. auto.
-Qed.
-
-Lemma functions_transl_no_overflow:
- forall b f,
- Genv.find_funct_ptr ge b = Some (Internal f) ->
- code_size (fn_code (transl_function f)) <= Int.max_unsigned.
-Proof.
- 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 (fn_code (transl_function f)))); simpl; intro.
- congruence. intro; omega.
+ destruct (functions_translated _ _ H) as [tf' [A B]].
+ rewrite A. monadInv B. f_equal. congruence.
Qed.
Lemma varinfo_preserved:
@@ -92,191 +77,40 @@ Qed.
(** * Properties of control flow *)
-Lemma find_instr_in:
- forall c pos i,
- find_instr pos c = Some i -> In i c.
-Proof.
- induction c; simpl. intros; discriminate.
- intros until i. case (zeq pos 0); intros.
- left; congruence. right; eauto.
-Qed.
-
-Lemma find_instr_tail:
- forall c1 i c2 pos,
- code_tail pos c1 (i :: c2) ->
- find_instr pos c1 = Some i.
-Proof.
- induction c1; simpl; intros.
- inv H.
- destruct (zeq pos 0). subst pos.
- inv H. auto. generalize (code_tail_pos _ _ _ H4). intro. omegaContradiction.
- inv H. congruence. replace (pos0 + 1 - 1) with pos0 by omega.
- eauto.
-Qed.
-
-Remark code_size_pos:
- forall fn, code_size fn >= 0.
+Lemma transf_function_no_overflow:
+ forall f tf,
+ transf_function f = OK tf -> list_length_z (fn_code tf) <= Int.max_unsigned.
Proof.
- induction fn; simpl; omega.
-Qed.
-
-Remark code_tail_bounds:
- forall fn ofs i c,
- code_tail ofs fn (i :: c) -> 0 <= ofs < code_size fn.
-Proof.
- assert (forall ofs fn c, code_tail ofs fn c ->
- forall i c', c = i :: c' -> 0 <= ofs < code_size fn).
- induction 1; intros; simpl.
- rewrite H. simpl. generalize (code_size_pos c'). omega.
- generalize (IHcode_tail _ _ H0). omega.
- eauto.
-Qed.
-
-Lemma code_tail_next:
- forall fn ofs i c,
- code_tail ofs fn (i :: c) ->
- code_tail (ofs + 1) fn c.
-Proof.
- assert (forall ofs fn c, code_tail ofs fn c ->
- forall i c', c = i :: c' -> code_tail (ofs + 1) fn c').
- induction 1; intros.
- subst c. constructor. constructor.
- constructor. eauto.
- eauto.
-Qed.
-
-Lemma code_tail_next_int:
- forall fn ofs i c,
- code_size fn <= Int.max_unsigned ->
- code_tail (Int.unsigned ofs) fn (i :: c) ->
- code_tail (Int.unsigned (Int.add ofs Int.one)) fn c.
-Proof.
- intros. rewrite Int.add_unsigned.
- change (Int.unsigned Int.one) with 1.
- rewrite Int.unsigned_repr. apply code_tail_next with i; auto.
- generalize (code_tail_bounds _ _ _ _ H0). omega.
-Qed.
-
-(** [transl_code_at_pc pc fn c] holds if the code pointer [pc] points
- within the ARM code generated by translating Mach function [fn],
- and [c] is the tail of the generated code at the position corresponding
- to the code pointer [pc]. *)
-
-Inductive transl_code_at_pc: val -> block -> Mach.function -> Mach.code -> Prop :=
- transl_code_at_pc_intro:
- forall b ofs f c,
- Genv.find_funct_ptr ge b = Some (Internal f) ->
- code_tail (Int.unsigned ofs) (fn_code (transl_function f)) (transl_code f c) ->
- transl_code_at_pc (Vptr b ofs) b f c.
-
-(** The following lemmas show that straight-line executions
- (predicate [exec_straight]) correspond to correct ARM executions
- (predicate [exec_steps]) under adequate [transl_code_at_pc] hypotheses. *)
-
-Lemma exec_straight_steps_1:
- forall fn c rs m c' rs' m',
- exec_straight tge (fn_code fn) c rs m c' rs' m' ->
- code_size (fn_code fn) <= Int.max_unsigned ->
- forall b ofs,
- rs#PC = Vptr b ofs ->
- Genv.find_funct_ptr tge b = Some (Internal fn) ->
- code_tail (Int.unsigned ofs) (fn_code fn) c ->
- plus step tge (State rs m) E0 (State rs' m').
-Proof.
- induction 1; intros.
- apply plus_one.
- econstructor; eauto.
- eapply find_instr_tail. eauto.
- eapply plus_left'.
- econstructor; eauto.
- eapply find_instr_tail. eauto.
- 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:
- forall fn c rs m c' rs' m',
- exec_straight tge (fn_code fn) c rs m c' rs' m' ->
- code_size (fn_code fn) <= Int.max_unsigned ->
- forall b ofs,
- rs#PC = Vptr b ofs ->
- Genv.find_funct_ptr tge b = Some (Internal fn) ->
- code_tail (Int.unsigned ofs) (fn_code fn) c ->
- exists ofs',
- rs'#PC = Vptr b ofs'
- /\ code_tail (Int.unsigned ofs') (fn_code fn) c'.
-Proof.
- induction 1; intros.
- exists (Int.add ofs Int.one). split.
- rewrite H0. rewrite H2. auto.
- apply code_tail_next_int with i1; auto.
- apply IHexec_straight with (Int.add ofs Int.one).
- auto. rewrite H0. rewrite H3. reflexivity. auto.
- apply code_tail_next_int with i; auto.
+ intros. monadInv H. destruct (zlt Int.max_unsigned (list_length_z (fn_code x))); inv EQ0. omega.
Qed.
Lemma exec_straight_exec:
- forall fb f c c' rs m rs' m',
- transl_code_at_pc (rs PC) fb f c ->
- exec_straight tge (fn_code (transl_function f))
- (transl_code f c) rs m c' rs' m' ->
+ forall f c ep tf tc c' rs m rs' m',
+ transl_code_at_pc ge (rs PC) f c ep tf tc ->
+ exec_straight tge tf tc rs m c' rs' m' ->
plus step tge (State rs m) E0 (State rs' m').
Proof.
- intros. inversion H. subst.
+ intros. inv H.
eapply exec_straight_steps_1; eauto.
- eapply functions_transl_no_overflow; eauto.
- eapply functions_transl; eauto.
+ eapply transf_function_no_overflow; eauto.
+ eapply functions_transl; eauto.
Qed.
Lemma exec_straight_at:
- forall fb f c c' rs m rs' m',
- transl_code_at_pc (rs PC) fb f c ->
- exec_straight tge (fn_code (transl_function f))
- (transl_code f c) rs m (transl_code f c') rs' m' ->
- transl_code_at_pc (rs' PC) fb f c'.
+ forall f c ep tf tc c' ep' tc' rs m rs' m',
+ transl_code_at_pc ge (rs PC) f c ep tf tc ->
+ transl_code f c' ep' = OK tc' ->
+ exec_straight tge tf tc rs m tc' rs' m' ->
+ transl_code_at_pc ge (rs' PC) f c' ep' tf tc'.
Proof.
- intros. inversion H. subst.
- generalize (functions_transl_no_overflow _ _ H2). intro.
- generalize (functions_transl _ _ H2). intro.
- generalize (exec_straight_steps_2 _ _ _ _ _ _ _
- H0 H4 _ _ (sym_equal H1) H5 H3).
+ intros. inv H.
+ exploit exec_straight_steps_2; eauto.
+ eapply transf_function_no_overflow; eauto.
+ eapply functions_transl; eauto.
intros [ofs' [PC' CT']].
rewrite PC'. constructor; auto.
Qed.
-(** Correctness of the return addresses predicted by
- [ARMgen.return_address_offset]. *)
-
-Remark code_tail_no_bigger:
- forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat.
-Proof.
- induction 1; simpl; omega.
-Qed.
-
-Remark code_tail_unique:
- forall fn c pos pos',
- code_tail pos fn c -> code_tail pos' fn c -> pos = pos'.
-Proof.
- induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto.
- generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega.
- generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega.
- f_equal. eauto.
-Qed.
-
-Lemma return_address_offset_correct:
- forall b ofs fb f c ofs',
- transl_code_at_pc (Vptr b ofs) fb f c ->
- return_address_offset f c ofs' ->
- ofs' = ofs.
-Proof.
- intros. inv H0. inv H.
- generalize (code_tail_unique _ _ _ _ H1 H7). intro. rewrite H.
- apply Int.repr_unsigned.
-Qed.
-
(** The [find_label] function returns the code tail starting at the
given label. A connection with [code_tail] is then established. *)
@@ -293,7 +127,7 @@ Lemma label_pos_code_tail:
exists pos',
label_pos lbl pos c = Some pos'
/\ code_tail (pos' - pos) c c'
- /\ pos < pos' <= pos + code_size c.
+ /\ pos < pos' <= pos + list_length_z c.
Proof.
induction c.
simpl; intros. discriminate.
@@ -302,12 +136,12 @@ Proof.
intro EQ; injection EQ; intro; subst c'.
exists (pos + 1). split. auto. split.
replace (pos + 1 - pos) with (0 + 1) by omega. constructor. constructor.
- generalize (code_size_pos c). omega.
+ rewrite list_length_z_cons. generalize (list_length_z_pos c). omega.
intros. generalize (IHc (pos + 1) c' H). intros [pos' [A [B C]]].
exists pos'. split. auto. split.
replace (pos' - pos) with ((pos' - (pos + 1)) + 1) by omega.
constructor. auto.
- omega.
+ rewrite list_length_z_cons. omega.
Qed.
(** The following lemmas show that the translation from Mach to ARM
@@ -399,9 +233,9 @@ Proof.
Qed.
Remark loadind_label:
- forall base ofs ty dst k, find_label lbl (loadind base ofs ty dst k) = find_label lbl k.
+ forall base ofs ty dst k c, loadind base ofs ty dst k = OK c -> find_label lbl c = find_label lbl k.
Proof.
- intros; unfold loadind. destruct ty.
+ intros. destruct ty; monadInv H.
apply loadind_int_label.
unfold loadind_float.
destruct (is_immed_mem_float ofs); autorewrite with labels; auto.
@@ -415,102 +249,115 @@ Proof.
Qed.
Remark storeind_label:
- forall base ofs ty src k, find_label lbl (storeind src base ofs ty k) = find_label lbl k.
+ forall base ofs ty src k c, storeind src base ofs ty k = OK c -> find_label lbl c = find_label lbl k.
Proof.
- intros; unfold storeind. destruct ty.
+ intros. destruct ty; monadInv H.
apply storeind_int_label.
unfold storeind_float.
destruct (is_immed_mem_float ofs); autorewrite with labels; auto.
Qed.
+
Hint Rewrite loadind_int_label loadind_label storeind_int_label storeind_label: labels.
+Ltac ArgsInv :=
+ repeat (match goal with
+ | [ H: Error _ = OK _ |- _ ] => discriminate
+ | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args
+ | [ H: bind _ _ = OK _ |- _ ] => monadInv H
+ | [ H: assertion _ = OK _ |- _ ] => monadInv H
+ end).
+
Remark transl_cond_label:
- forall cond args k, find_label lbl (transl_cond cond args k) = find_label lbl k.
+ forall cond args k c, transl_cond cond args k = OK c -> find_label lbl c = find_label lbl k.
Proof.
- intros; unfold transl_cond.
- destruct cond; (destruct args;
- [try reflexivity | destruct args;
- [try reflexivity | destruct args; try reflexivity]]).
+ unfold transl_cond; intros; destruct cond; ArgsInv; auto.
destruct (is_immed_arith i); autorewrite with labels; auto.
destruct (is_immed_arith i); autorewrite with labels; auto.
Qed.
-Hint Rewrite transl_cond_label: labels.
Remark transl_op_label:
- forall op args r k, find_label lbl (transl_op op args r k) = find_label lbl k.
+ forall op args r k c, transl_op op args r k = OK c -> find_label lbl c = find_label lbl k.
Proof.
- intros; unfold transl_op;
- destruct op; destruct args; try (destruct args); try (destruct args); try (destruct args);
- try reflexivity; autorewrite with labels; try reflexivity.
- case (mreg_type m); reflexivity.
- case (ireg_eq (ireg_of r) (ireg_of m) || ireg_eq (ireg_of r) (ireg_of m0)); reflexivity.
- transitivity (find_label lbl
- (addimm IR14 (ireg_of m) (Int.sub (Int.shl Int.one i) Int.one)
- (Pmovc CRge IR14 (SOreg (ireg_of m))
- :: Pmov (ireg_of r) (SOasrimm IR14 i) :: k))).
- unfold find_label; auto. autorewrite with labels. reflexivity.
+ unfold transl_op; intros; destruct op; ArgsInv; autorewrite with labels; auto.
+ destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; auto.
+ destruct (ireg_eq x x0 || ireg_eq x x1); auto.
+ simpl. autorewrite with labels; auto.
+ erewrite transl_cond_label by eauto; auto.
Qed.
-Hint Rewrite transl_op_label: labels.
-Remark transl_load_store_label:
+Remark transl_memory_access_label:
forall (mk_instr_imm: ireg -> int -> instruction)
(mk_instr_gen: option (ireg -> shift_addr -> instruction))
(is_immed: int -> bool)
- (addr: addressing) (args: list mreg) (k: code),
+ (addr: addressing) (args: list mreg) c k,
+ transl_memory_access mk_instr_imm mk_instr_gen is_immed addr args k = OK c ->
(forall r n, is_label lbl (mk_instr_imm r n) = false) ->
(match mk_instr_gen with
| None => True
| Some f => forall r sa, is_label lbl (f r sa) = false
end) ->
- find_label lbl (transl_load_store mk_instr_imm mk_instr_gen is_immed addr args k) = find_label lbl k.
+ find_label lbl c = find_label lbl k.
Proof.
- intros; unfold transl_load_store.
- destruct addr; destruct args; try (destruct args); try (destruct args);
- try reflexivity.
- destruct (is_immed i); autorewrite with labels; simpl; rewrite H; auto.
- destruct mk_instr_gen. simpl. rewrite H0. auto.
- simpl. rewrite H. auto.
- destruct mk_instr_gen. simpl. rewrite H0. auto.
- simpl. rewrite H. auto.
- destruct (is_immed i); autorewrite with labels; simpl; rewrite H; auto.
+ unfold transl_memory_access; intros; destruct addr; ArgsInv; auto.
+ destruct (is_immed i); autorewrite with labels; simpl; rewrite H0; auto.
+ destruct mk_instr_gen. simpl. rewrite H1. auto.
+ simpl. rewrite H0. auto.
+ destruct mk_instr_gen. simpl. rewrite H1. auto.
+ simpl. rewrite H0. auto.
+ destruct (is_immed i); inv H; autorewrite with labels; simpl; rewrite H0; auto.
Qed.
-Hint Rewrite transl_load_store_label: labels.
Lemma transl_instr_label:
- forall f i k,
- find_label lbl (transl_instr f i k) =
- if Mach.is_label lbl i then Some k else find_label lbl k.
+ forall f i ep k c,
+ transl_instr f i ep k = OK c ->
+ find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k.
Proof.
- intros. generalize (Mach.is_label_correct lbl i).
- case (Mach.is_label lbl i); intro.
- subst i. simpl. rewrite peq_true. auto.
- destruct i; simpl; autorewrite with labels; try reflexivity.
- unfold transl_load_store_int, transl_load_store_float.
- destruct m; rewrite transl_load_store_label; intros; auto.
- unfold transl_load_store_int, transl_load_store_float.
- destruct m; rewrite transl_load_store_label; intros; auto.
- destruct s0; reflexivity.
- destruct s0; simpl; autorewrite with labels; reflexivity.
- rewrite peq_false. auto. congruence.
+ unfold transl_instr, Mach.is_label; intros. destruct i; try (monadInv H).
+ eapply loadind_label; eauto.
+ eapply storeind_label; eauto.
+ destruct ep; autorewrite with labels; eapply loadind_label; eauto.
+ eapply transl_op_label; eauto.
+ destruct m; simpl in H; monadInv H; eapply transl_memory_access_label; eauto; simpl; auto.
+ destruct m; simpl in H; monadInv H; eapply transl_memory_access_label; eauto; simpl; auto.
+ destruct s0; monadInv H; auto.
+ destruct s0; monadInv H; autorewrite with labels; auto.
+ auto.
+ auto.
+ simpl. auto.
+ auto.
+ erewrite transl_cond_label. 2: eauto. auto.
+ auto.
+ autorewrite with labels; auto.
Qed.
Lemma transl_code_label:
- forall f c,
- find_label lbl (transl_code f c) =
- option_map (transl_code f) (Mach.find_label lbl c).
+ forall f c ep tc,
+ transl_code f c ep = OK tc ->
+ match Mach.find_label lbl c with
+ | None => find_label lbl tc = None
+ | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc'
+ end.
Proof.
induction c; simpl; intros.
- auto. rewrite transl_instr_label.
- case (Mach.is_label lbl a). reflexivity.
- auto.
+ inv H. auto.
+ monadInv H. rewrite (transl_instr_label _ _ _ _ _ EQ0).
+ generalize (Mach.is_label_correct lbl a).
+ destruct (Mach.is_label lbl a); intros.
+ subst a. simpl in EQ. exists x; auto.
+ eapply IHc; eauto.
Qed.
Lemma transl_find_label:
- forall f,
- find_label lbl (fn_code (transl_function f)) =
- option_map (transl_code f) (Mach.find_label lbl (Mach.fn_code f)).
+ forall f tf,
+ transf_function f = OK tf ->
+ match Mach.find_label lbl f.(Mach.fn_code) with
+ | None => find_label lbl (fn_code tf) = None
+ | Some c => exists tc, find_label lbl (fn_code tf) = Some tc /\ transl_code f c false = OK tc
+ end.
Proof.
- intros. unfold transl_function. simpl. autorewrite with labels. apply transl_code_label.
+ intros. monadInv H. destruct (zlt Int.max_unsigned (list_length_z (fn_code x))); inv EQ0.
+ monadInv EQ. simpl.
+ eapply transl_code_label; eauto.
Qed.
End TRANSL_LABEL.
@@ -518,29 +365,30 @@ End TRANSL_LABEL.
(** A valid branch in a piece of Mach code translates to a valid ``go to''
transition in the generated ARM code. *)
+(** A valid branch in a piece of Mach code translates to a valid ``go to''
+ transition in the generated PPC code. *)
+
Lemma find_label_goto_label:
- forall f lbl rs m c' b ofs,
+ forall f tf lbl rs m c' b ofs,
Genv.find_funct_ptr ge b = Some (Internal f) ->
+ transf_function f = OK tf ->
rs PC = Vptr b ofs ->
- Mach.find_label lbl (Mach.fn_code f) = Some c' ->
- exists rs',
- goto_label (fn_code (transl_function f)) lbl rs m = OK rs' m
- /\ transl_code_at_pc (rs' PC) b f c'
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
+ exists tc', exists rs',
+ goto_label tf lbl rs m = Next rs' m
+ /\ transl_code_at_pc ge (rs' PC) f c' false tf tc'
/\ forall r, r <> PC -> rs'#r = rs#r.
Proof.
- intros.
- generalize (transl_find_label lbl f).
- rewrite H1. unfold option_map. intro.
- generalize (label_pos_code_tail lbl (fn_code (transl_function f)) 0
- (transl_code f c') H2).
- intros [pos' [A [B C]]].
- exists (rs#PC <- (Vptr b (Int.repr pos'))).
- split. unfold goto_label. rewrite A. rewrite H0. auto.
+ intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2.
+ intros [tc [A B]].
+ exploit label_pos_code_tail; eauto. instantiate (1 := 0).
+ intros [pos' [P [Q R]]].
+ exists tc; exists (rs#PC <- (Vptr b (Int.repr pos'))).
+ split. unfold goto_label. rewrite P. rewrite H1. auto.
split. rewrite Pregmap.gss. constructor; auto.
- rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in B.
- auto. omega.
- generalize (functions_transl_no_overflow _ _ H).
- omega.
+ rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in Q.
+ auto. omega.
+ generalize (transf_function_no_overflow _ _ H0). omega.
intros. apply Pregmap.gso; auto.
Qed.
@@ -562,90 +410,92 @@ Qed.
- Mach register values and ARM register values agree.
*)
-Inductive match_stack: list Machsem.stackframe -> Prop :=
- | match_stack_nil:
- match_stack nil
- | match_stack_cons: forall fb sp ra c s f,
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- wt_function f ->
- incl c (Mach.fn_code f) ->
- transl_code_at_pc ra fb f c ->
- sp <> Vundef ->
- ra <> Vundef ->
- match_stack s ->
- match_stack (Stackframe fb sp ra c :: s).
-
-Inductive match_states: Machsem.state -> Asm.state -> Prop :=
+Inductive match_states: Mach.state -> Asm.state -> Prop :=
| match_states_intro:
- forall s fb sp c ms m rs f m'
- (STACKS: match_stack s)
- (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
- (WTF: wt_function f)
- (INCL: incl c (Mach.fn_code f))
- (AT: transl_code_at_pc (rs PC) fb f c)
- (AG: agree ms sp rs)
- (MEXT: Mem.extends m m'),
- match_states (Machsem.State s fb sp c ms m)
+ forall s f sp c ep ms m m' rs tf tc ra
+ (STACKS: match_stack ge s m m' ra sp)
+ (MEXT: Mem.extends m m')
+ (AT: transl_code_at_pc ge (rs PC) f c ep tf tc)
+ (AG: agree ms (Vptr sp Int.zero) rs)
+ (RSA: retaddr_stored_at m m' sp (Int.unsigned f.(fn_retaddr_ofs)) ra)
+ (DXP: ep = true -> rs#IR10 = parent_sp s),
+ match_states (Mach.State s f (Vptr sp Int.zero) c ms m)
(Asm.State rs m')
| match_states_call:
- forall s fb ms m rs m'
- (STACKS: match_stack s)
+ forall s fd ms m m' rs fb
+ (STACKS: match_stack ge s m m' rs#(IR IR14) (Mem.nextblock m))
+ (MEXT: Mem.extends m m')
(AG: agree ms (parent_sp s) rs)
(ATPC: rs PC = Vptr fb Int.zero)
- (ATLR: rs IR14 = parent_ra s)
- (MEXT: Mem.extends m m'),
- match_states (Machsem.Callstate s fb ms m)
+ (FUNCT: Genv.find_funct_ptr ge fb = Some fd)
+ (WTRA: Val.has_type rs#(IR IR14) Tint),
+ match_states (Mach.Callstate s fd ms m)
(Asm.State rs m')
| match_states_return:
- forall s ms m rs m'
- (STACKS: match_stack s)
- (AG: agree ms (parent_sp s) rs)
- (ATPC: rs PC = parent_ra s)
- (MEXT: Mem.extends m m'),
- match_states (Machsem.Returnstate s ms m)
+ forall s ms m m' rs
+ (STACKS: match_stack ge s m m' (rs PC) (Mem.nextblock m))
+ (MEXT: Mem.extends m m')
+ (AG: agree ms (parent_sp s) rs),
+ match_states (Mach.Returnstate s ms m)
(Asm.State rs m').
Lemma exec_straight_steps:
- forall s fb sp m1 m1' f c1 rs1 c2 m2 ms2,
- match_stack s ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- wt_function f ->
- incl c2 (Mach.fn_code f) ->
- transl_code_at_pc (rs1 PC) fb f c1 ->
- Mem.extends m1 m1' ->
- (exists m2',
- Mem.extends m2 m2' /\
- exists rs2,
- exec_straight tge (fn_code (transl_function f)) (transl_code f c1) rs1 m1' (transl_code f c2) rs2 m2'
- /\ agree ms2 sp rs2) ->
+ forall s f rs1 i c ep tf tc m1' m2 m2' sp ms2 ra,
+ match_stack ge s m2 m2' ra sp ->
+ Mem.extends m2 m2' ->
+ retaddr_stored_at m2 m2' sp (Int.unsigned f.(fn_retaddr_ofs)) ra ->
+ transl_code_at_pc ge (rs1 PC) f (i :: c) ep tf tc ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
+ exists rs2,
+ exec_straight tge tf c rs1 m1' k rs2 m2'
+ /\ agree ms2 (Vptr sp Int.zero) rs2
+ /\ (r10_is_parent ep i = true -> rs2#IR10 = parent_sp s)) ->
exists st',
plus step tge (State rs1 m1') E0 st' /\
- match_states (Machsem.State s fb sp c2 ms2 m2) st'.
+ match_states (Mach.State s f (Vptr sp Int.zero) c ms2 m2) st'.
Proof.
- intros. destruct H5 as [m2' [A [rs2 [B C]]]].
+ intros. inversion H2; subst. monadInv H7.
+ exploit H3; eauto. intros [rs2 [A [B C]]].
exists (State rs2 m2'); split.
- eapply exec_straight_exec; eauto.
+ eapply exec_straight_exec; eauto.
econstructor; eauto. eapply exec_straight_at; eauto.
Qed.
-Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef.
-Proof. induction 1; simpl. congruence. auto. Qed.
-
-Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef.
-Proof. induction 1; simpl. unfold Vzero. congruence. auto. Qed.
-
-Lemma lessdef_parent_sp:
- forall s v,
- match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s.
-Proof.
- intros. inv H0. auto. exploit parent_sp_def; eauto. tauto.
-Qed.
-
-Lemma lessdef_parent_ra:
- forall s v,
- match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s.
+Lemma exec_straight_steps_goto:
+ forall s f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c' ra,
+ match_stack ge s m2 m2' ra sp ->
+ Mem.extends m2 m2' ->
+ retaddr_stored_at m2 m2' sp (Int.unsigned f.(fn_retaddr_ofs)) ra ->
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
+ transl_code_at_pc ge (rs1 PC) f (i :: c) ep tf tc ->
+ r10_is_parent ep i = false ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
+ exists jmp, exists k', exists rs2,
+ exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2'
+ /\ agree ms2 (Vptr sp Int.zero) rs2
+ /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') ->
+ exists st',
+ plus step tge (State rs1 m1') E0 st' /\
+ match_states (Mach.State s f (Vptr sp Int.zero) c' ms2 m2) st'.
Proof.
- intros. inv H0. auto. exploit parent_ra_def; eauto. tauto.
+ intros. inversion H3; subst. monadInv H9.
+ exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]].
+ generalize (functions_transl _ _ _ H7 H8); intro FN.
+ generalize (transf_function_no_overflow _ _ H8); intro NOOV.
+ exploit exec_straight_steps_2; eauto.
+ intros [ofs' [PC2 CT2]].
+ exploit find_label_goto_label; eauto.
+ intros [tc' [rs3 [GOTO [AT' OTH]]]].
+ exists (State rs3 m2'); split.
+ eapply plus_right'.
+ eapply exec_straight_steps_1; eauto.
+ econstructor; eauto.
+ eapply find_instr_tail. eauto.
+ rewrite C. eexact GOTO.
+ traceEq.
+ econstructor; eauto.
+ apply agree_exten with rs2; auto with asmgen.
+ congruence.
Qed.
(** We need to show that, in the simulation diagram, we cannot
@@ -656,381 +506,280 @@ Qed.
So, the following integer measure will suffice to rule out
the unwanted behaviour. *)
-Definition measure (s: Machsem.state) : nat :=
+Definition measure (s: Mach.state) : nat :=
match s with
- | Machsem.State _ _ _ _ _ _ => 0%nat
- | Machsem.Callstate _ _ _ _ => 0%nat
- | Machsem.Returnstate _ _ _ => 1%nat
+ | Mach.State _ _ _ _ _ _ => 0%nat
+ | Mach.Callstate _ _ _ _ => 0%nat
+ | Mach.Returnstate _ _ _ => 1%nat
end.
-(** We show the simulation diagram by case analysis on the Mach transition
- on the left. Since the proof is large, we break it into one lemma
- per transition. *)
-
-Definition exec_instr_prop (s1: Machsem.state) (t: trace) (s2: Machsem.state) : Prop :=
- forall s1' (MS: match_states s1 s1'),
- (exists s2', plus step tge s1' t s2' /\ match_states s2 s2')
- \/ (measure s2 < measure s1 /\ t = E0 /\ match_states s2 s1')%nat.
-
-
-Lemma exec_Mlabel_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset)
- (m : mem),
- exec_instr_prop (Machsem.State s fb sp (Mlabel lbl :: c) ms m) E0
- (Machsem.State s fb sp c ms m).
+Remark preg_of_not_R10: forall r, negb (mreg_eq r IT1) = true -> IR IR10 <> preg_of r.
Proof.
- intros; red; intros; inv MS.
- left; eapply exec_straight_steps; eauto with coqlib.
- exists m'; split; auto.
- exists (nextinstr rs); split.
- simpl. apply exec_straight_one. reflexivity. reflexivity.
- apply agree_nextinstr; auto.
+ intros. change (IR IR10) with (preg_of IT1). red; intros.
+ exploit preg_of_injective; eauto. intros; subst r.
+ unfold proj_sumbool in H; rewrite dec_eq_true in H; discriminate.
Qed.
-Lemma exec_Mgetstack_prop:
- forall (s : list stackframe) (fb : block) (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 (Machsem.State s fb sp (Mgetstack ofs ty dst :: c) ms m) E0
- (Machsem.State s fb sp c (Regmap.set dst v ms) m).
-Proof.
- intros; red; intros; inv MS.
- unfold load_stack in H.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
- exploit Mem.loadv_extends; eauto. intros [v' [A B]].
- rewrite (sp_val _ _ _ AG) in A.
- exploit loadind_correct. eexact A. reflexivity.
- intros [rs2 [EX [RES OTH]]].
- left; eapply exec_straight_steps. auto. eauto. auto. eauto with coqlib. eauto. eauto.
- exists m'; split; auto.
- simpl. exists rs2; split. eauto.
- apply agree_set_mreg with rs; auto. congruence. auto with ppcgen.
-Qed.
+(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *)
-Lemma exec_Msetstack_prop:
- forall (s : list stackframe) (fb : block) (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 (Machsem.State s fb sp (Msetstack src ofs ty :: c) ms m) E0
- (Machsem.State s fb sp c ms m').
+Theorem step_simulation:
+ forall S1 t S2, Mach.step ge S1 t S2 ->
+ forall S1' (MS: match_states S1 S1'),
+ (exists S2', plus step tge S1' t S2' /\ match_states S2 S2')
+ \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
Proof.
- intros; red; intros; inv MS.
- unfold store_stack in H.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
- exploit preg_val; eauto. instantiate (1 := src). intros A.
- exploit Mem.storev_extends; eauto. intros [m2 [B C]].
- rewrite (sp_val _ _ _ AG) in B.
- exploit storeind_correct. eexact B. reflexivity. congruence.
- intros [rs2 [EX OTH]].
- left; eapply exec_straight_steps. auto. eauto. auto. eauto with coqlib. eauto. eauto.
- exists m2; split; auto.
- simpl. exists rs2; split. eauto.
- apply agree_exten with rs; auto with ppcgen.
-Qed.
+ induction 1; intros; inv MS.
-Lemma exec_Mgetparam_prop:
- forall (s : list stackframe) (fb : block) (f: Mach.function) (sp : val)
- (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction)
- (ms : Mach.regset) (m : mem) (v : val),
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- load_stack m sp Tint f.(fn_link_ofs) = Some (parent_sp s) ->
- load_stack m (parent_sp s) ty ofs = Some v ->
- exec_instr_prop (Machsem.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0
- (Machsem.State s fb sp c (Regmap.set dst v (Regmap.set IT1 Vundef ms)) m).
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI. auto.
- unfold load_stack in *.
- exploit Mem.loadv_extends. eauto. eexact H0. eauto.
- intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A.
- assert (parent' = parent_sp s). inv B. auto. rewrite <- H3 in H1; discriminate. subst parent'.
- exploit Mem.loadv_extends. eauto. eexact H1. eauto.
- intros [v' [C D]].
- exploit (loadind_int_correct tge (fn_code (transl_function f)) IR13 f.(fn_link_ofs) IR14
- rs m' (parent_sp s) (loadind IR14 ofs (mreg_type dst) dst (transl_code f c))).
- auto.
- intros [rs1 [EX1 [RES1 OTH1]]].
- exploit (loadind_correct tge (fn_code (transl_function f)) IR14 ofs (mreg_type dst) dst
- (transl_code f c) rs1 m' v').
- rewrite RES1. auto. auto.
- intros [rs2 [EX2 [RES2 OTH2]]].
- left; eapply exec_straight_steps. auto. eauto. auto. eauto with coqlib. eauto. eauto.
- exists m'; split; auto.
- exists rs2; split; simpl.
- eapply exec_straight_trans; eauto.
- apply agree_set_mreg with rs1.
- apply agree_set_mreg with rs. auto. auto. auto with ppcgen.
- congruence. auto with ppcgen.
-Qed.
-
-Lemma exec_Mop_prop:
- forall (s : list stackframe) (fb : block) (sp : val) (op : operation)
- (args : list mreg) (res : mreg) (c : list Mach.instruction)
- (ms : mreg -> val) (m : mem) (v : val),
- eval_operation ge sp op ms ## args m = Some v ->
- exec_instr_prop (Machsem.State s fb sp (Mop op args res :: c) ms m) E0
- (Machsem.State s fb sp c (Regmap.set res v (undef_op op ms)) m).
-Proof.
- intros; red; intros; inv MS.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI.
- exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eauto.
- intros [v' [A B]].
- assert (C: eval_operation tge sp op rs ## (preg_of ## args) m' = Some v').
- rewrite <- A. apply eval_operation_preserved. exact symbols_preserved.
- rewrite (sp_val _ _ _ AG) in C.
- exploit transl_op_correct; eauto. intros [rs' [P [Q R]]].
- left; eapply exec_straight_steps. auto. eauto. auto. eauto with coqlib. eauto. eauto.
- exists m'; split; auto.
- exists rs'; split. simpl. eexact P.
- assert (agree (Regmap.set res v ms) sp rs').
- apply agree_set_mreg with rs; auto. eapply Val.lessdef_trans; eauto.
- assert (agree (Regmap.set res v (undef_temps ms)) sp rs').
- apply agree_set_undef_mreg with rs; auto. eapply Val.lessdef_trans; eauto.
- auto with ppcgen.
- destruct op; assumption.
-Qed.
+- (* Mlabel *)
+ left; eapply exec_straight_steps; eauto; intros.
+ monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ split. apply agree_nextinstr; auto. simpl; congruence.
-Lemma exec_Mload_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (chunk : memory_chunk) (addr : addressing) (args : list mreg)
- (dst : mreg) (c : list Mach.instruction) (ms : mreg -> val)
- (m : mem) (a v : val),
- eval_addressing ge sp addr ms ## args = Some a ->
- Mem.loadv chunk m a = Some v ->
- exec_instr_prop (Machsem.State s fb sp (Mload chunk addr args dst :: c) ms m)
- E0 (Machsem.State s fb sp c (Regmap.set dst v (undef_temps ms)) m).
-Proof.
- intros; red; intros; inv MS.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI; inv WTI.
- assert (eval_addressing tge sp addr ms##args = Some a).
+- (* Mgetstack *)
+ unfold load_stack in H.
+ exploit Mem.loadv_extends; eauto. intros [v' [A B]].
+ rewrite (sp_val _ _ _ AG) in A.
+ left; eapply exec_straight_steps; eauto. intros. simpl in TR.
+ exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]].
+ exists rs'; split. eauto.
+ split. eapply agree_set_mreg; eauto with asmgen. congruence.
+ simpl; congruence.
+
+- (* Msetstack *)
+ unfold store_stack in H.
+ assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto.
+ exploit Mem.storev_extends; eauto. intros [m2' [A B]].
+ left; eapply exec_straight_steps; eauto.
+ eapply match_stack_storev; eauto.
+ eapply retaddr_stored_at_storev; eauto.
+ rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR.
+ exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]].
+ exists rs'; split. eauto.
+ split. change (undef_setstack rs) with rs. apply agree_exten with rs0; auto with asmgen.
+ simpl; intros. rewrite Q; auto with asmgen.
+
+- (* Mgetparam *)
+ unfold load_stack in *.
+ exploit Mem.loadv_extends. eauto. eexact H. auto.
+ intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'.
+ exploit Mem.loadv_extends. eauto. eexact H0. auto.
+ intros [v' [C D]].
+Opaque loadind.
+ left; eapply exec_straight_steps; eauto; intros.
+ destruct ep; monadInv TR.
+(* R10 contains parent *)
+ exploit loadind_correct. eexact EQ.
+ instantiate (2 := rs0). rewrite DXP; eauto.
+ intros [rs1 [P [Q R]]].
+ exists rs1; split. eauto.
+ split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen.
+ simpl; intros. rewrite R; auto with asmgen.
+ apply preg_of_not_R10; auto.
+(* GPR11 does not contain parent *)
+ exploit loadind_int_correct. eexact A. instantiate (1 := IR10). intros [rs1 [P [Q R]]].
+ exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. intros [rs2 [S [T U]]].
+ exists rs2; split. eapply exec_straight_trans; eauto.
+ split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto.
+ instantiate (1 := rs1#IR10 <- (rs2#IR10)). intros.
+ rewrite Pregmap.gso; auto with asmgen.
+ congruence. intros. unfold Pregmap.set. destruct (PregEq.eq r' IR10). congruence. auto with asmgen.
+ simpl; intros. rewrite U; auto with asmgen.
+ apply preg_of_not_R10; auto.
+
+- (* Mop *)
+ assert (eval_operation tge (Vptr sp0 Int.zero) op rs##args m = Some v).
+ rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
+ exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0.
+ intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ left; eapply exec_straight_steps; eauto; intros. simpl in TR.
+ exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]].
+ assert (S: Val.lessdef v (rs2 (preg_of res))) by (eapply Val.lessdef_trans; eauto).
+ exists rs2; split. eauto. split.
+ assert (agree (Regmap.set res v (undef_temps rs)) (Vptr sp0 Int.zero) rs2).
+ eapply agree_set_undef_mreg; eauto with asmgen.
+ unfold undef_op; destruct op; auto.
+ change (undef_move rs) with rs. eapply agree_set_mreg; eauto.
+ simpl. destruct op; try congruence. destruct ep; simpl; try congruence. intros.
+ rewrite R; auto. apply preg_of_not_R10; auto.
+
+- (* Mload *)
+ assert (eval_addressing tge (Vptr sp0 Int.zero) addr rs##args = Some a).
rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
- left; eapply exec_straight_steps; eauto with coqlib.
- exists m'; split; auto.
- destruct chunk; simpl; simpl in H6;
- try (generalize (Mem.loadv_float64al32 _ _ _ H0); intros);
- (eapply transl_load_int_correct || eapply transl_load_float_correct);
- eauto; intros; reflexivity.
-Qed.
-
-Lemma storev_8_signed_unsigned: forall m a v, Mem.storev Mint8signed m a v = Mem.storev Mint8unsigned m a v. Proof. intros. unfold Mem.storev.
- destruct a; auto. apply Mem.store_signed_unsigned_8. Qed.
- Lemma storev_16_signed_unsigned: forall m a v, Mem.storev Mint16signed m a v = Mem.storev Mint16unsigned m a v. Proof. intros. unfold Mem.storev. destruct a; auto. apply Mem.store_signed_unsigned_16. Qed.
-
-Lemma exec_Mstore_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (chunk : memory_chunk) (addr : addressing) (args : list mreg)
- (src : mreg) (c : list Mach.instruction) (ms : mreg -> val)
- (m m' : mem) (a : val),
- eval_addressing ge sp addr ms ## args = Some a ->
- Mem.storev chunk m a (ms src) = Some m' ->
- exec_instr_prop (Machsem.State s fb sp (Mstore chunk addr args src :: c) ms m) E0
- (Machsem.State s fb sp c (undef_temps ms) m').
-Proof.
- intros; red; intros; inv MS.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI; inv WTI.
- assert (eval_addressing tge sp addr ms##args = Some a).
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit Mem.loadv_extends; eauto. intros [v' [C D]].
+ left; eapply exec_straight_steps; eauto; intros. simpl in TR.
+ exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]].
+ exists rs2; split. eauto.
+ split. eapply agree_set_undef_mreg; eauto. congruence.
+ simpl; congruence.
+
+- (* Mstore *)
+ assert (eval_addressing tge (Vptr sp0 Int.zero) addr rs##args = Some a).
rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
- left; eapply exec_straight_steps. auto. eauto. auto. eauto with coqlib. eauto. eauto.
- destruct chunk; simpl; simpl in H6;
- try (rewrite storev_8_signed_unsigned in H0);
- try (rewrite storev_16_signed_unsigned in H0);
- try (generalize (Mem.storev_float64al32 _ _ _ _ H0); intros);
- simpl;
- (eapply transl_store_int_correct || eapply transl_store_float_correct);
- eauto; intros; simpl; auto.
- econstructor; split. rewrite H2. eauto. intros. apply Pregmap.gso; auto.
-Qed.
-
-Lemma exec_Mcall_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (sig : signature) (ros : mreg + ident) (c : Mach.code)
- (ms : Mach.regset) (m : mem) (f : Mach.function) (f' : block)
- (ra : int),
- find_function_ptr ge ros ms = Some f' ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- return_address_offset f c ra ->
- exec_instr_prop (Machsem.State s fb sp (Mcall sig ros :: c) ms m) E0
- (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) f' ms m).
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto.
+ exploit Mem.storev_extends; eauto. intros [m2' [C D]].
+ left; eapply exec_straight_steps; eauto.
+ eapply match_stack_storev; eauto.
+ eapply retaddr_stored_at_storev; eauto.
+ intros. simpl in TR.
+ exploit transl_store_correct; eauto. intros [rs2 [P Q]].
+ exists rs2; split. eauto.
+ split. eapply agree_exten_temps; eauto.
+ simpl; congruence.
+
+- (* Mcall *)
inv AT.
- assert (NOOV: code_size (fn_code (transl_function f)) <= Int.max_unsigned).
- eapply functions_transl_no_overflow; eauto.
- assert (CT: code_tail (Int.unsigned (Int.add ofs Int.one)) (fn_code (transl_function f)) (transl_code f c)).
- destruct ros; simpl in H5; eapply code_tail_next_int; eauto.
- set (rs2 := rs #IR14 <- (Val.add rs#PC Vone) #PC <- (Vptr f' Int.zero)).
- exploit return_address_offset_correct; eauto. constructor; eauto.
- intro RA_EQ.
- assert (ATLR: rs2 IR14 = Vptr fb ra).
- rewrite RA_EQ.
- unfold rs2. rewrite <- H2. reflexivity.
- assert (AG3: agree ms sp rs2).
- unfold rs2. apply agree_set_other; auto. apply agree_set_other; auto.
- left; exists (State rs2 m'); split.
- apply plus_one.
- destruct ros; simpl in H5.
- econstructor. eauto. apply functions_transl. eexact H0.
- eapply find_instr_tail. eauto.
- simpl.
- assert (rs (ireg_of m0) = Vptr f' Int.zero).
- generalize (ireg_val _ _ _ m0 AG H3). intro LD. simpl in H. inv LD.
- destruct (ms m0); try congruence.
- generalize H. predSpec Int.eq Int.eq_spec i Int.zero; congruence.
- rewrite <- H7 in H; congruence.
- rewrite H6. auto.
- econstructor. eauto. apply functions_transl. eexact H0.
- eapply find_instr_tail. eauto.
- simpl. unfold symbol_offset. rewrite symbols_preserved.
- simpl in H. rewrite H. auto.
+ assert (NOOV: list_length_z (fn_code tf) <= Int.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ destruct ros as [rf|fid]; simpl in H; monadInv H3.
++ (* Indirect call *)
+ exploit Genv.find_funct_inv; eauto. intros [bf EQ2].
+ rewrite EQ2 in H; rewrite Genv.find_funct_find_funct_ptr in H.
+ assert (rs0 x0 = Vptr bf Int.zero).
+ exploit ireg_val; eauto. rewrite EQ2; intros LD; inv LD; auto.
+ generalize (code_tail_next_int _ _ _ _ NOOV H4). intro CT1.
+ assert (TCA: transl_code_at_pc ge (Vptr b (Int.add ofs Int.one)) f c false tf x).
+ econstructor; eauto.
+ left; econstructor; split.
+ apply plus_one. eapply exec_step_internal. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. eauto.
+ econstructor; eauto.
econstructor; eauto.
- econstructor; eauto with coqlib.
- rewrite RA_EQ. econstructor; eauto.
- eapply agree_sp_def; eauto. congruence.
-Qed.
-
-Lemma agree_change_sp:
- forall ms sp rs sp',
- agree ms sp rs -> sp' <> Vundef ->
- agree ms sp' (rs#IR13 <- sp').
-Proof.
- intros. inv H. split. apply Pregmap.gss. auto.
- intros. rewrite Pregmap.gso; auto with ppcgen.
-Qed.
-
-Lemma exec_Mtailcall_prop:
- forall (s : list stackframe) (fb stk : block) (soff : int)
- (sig : signature) (ros : mreg + ident) (c : list Mach.instruction)
- (ms : Mach.regset) (m : mem) (f: Mach.function) (f' : block) m',
- find_function_ptr ge ros ms = Some f' ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
- load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
- Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
- exec_instr_prop
- (Machsem.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0
- (Callstate s f' ms m').
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
- set (call_instr :=
- match ros with inl r => Pbreg (ireg_of r) sig | inr symb => Pbsymb symb sig end).
- assert (TR: transl_code f (Mtailcall sig ros :: c) =
- loadind_int IR13 (fn_retaddr_ofs f) IR14
- (Pfreeframe f.(fn_stacksize) (fn_link_ofs f) :: call_instr :: transl_code f c)).
- unfold call_instr; destruct ros; auto.
- unfold load_stack in *.
- exploit Mem.loadv_extends. eauto. eexact H1. auto.
- intros [parent' [A B]].
- exploit lessdef_parent_sp; eauto. intros. subst parent'.
- exploit Mem.loadv_extends. eauto. eexact H2. auto.
- intros [ra' [C D]].
- exploit lessdef_parent_ra; eauto. intros. subst ra'.
- exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]].
- destruct (loadind_int_correct tge (fn_code (transl_function f)) IR13 f.(fn_retaddr_ofs) IR14
- rs m'0 (parent_ra s)
- (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: call_instr :: transl_code f c))
- as [rs1 [EXEC1 [RES1 OTH1]]].
- rewrite <- (sp_val ms (Vptr stk soff) rs); auto.
- set (rs2 := nextinstr (rs1#IR13 <- (parent_sp s))).
- assert (EXEC2: exec_straight tge (fn_code (transl_function f))
- (transl_code f (Mtailcall sig ros :: c)) rs m'0
- (call_instr :: transl_code f c) rs2 m2').
- rewrite TR. eapply exec_straight_trans. eexact EXEC1.
- apply exec_straight_one. simpl.
- rewrite OTH1; auto with ppcgen.
- rewrite <- (sp_val ms (Vptr stk soff) rs); auto.
- simpl chunk_of_type in A. rewrite A.
- rewrite P. auto. auto.
- set (rs3 := rs2#PC <- (Vptr f' Int.zero)).
- left. exists (State rs3 m2'); split.
- (* Execution *)
- eapply plus_right'. eapply exec_straight_exec; eauto.
- inv AT. exploit exec_straight_steps_2; eauto.
- eapply functions_transl_no_overflow; eauto.
- eapply functions_transl; eauto.
- intros [ofs2 [RS2PC CT]].
+ Simpl. rewrite <- H0; eexact TCA.
+ change (Mem.valid_block m sp0). eapply retaddr_stored_at_valid; eauto.
+ simpl. eapply agree_exten; eauto. intros. Simpl.
+ Simpl. rewrite <- H0. exact I.
++ (* Direct call *)
+ destruct (Genv.find_symbol ge fid) as [bf|] eqn:FS; try discriminate.
+ generalize (code_tail_next_int _ _ _ _ NOOV H4). intro CT1.
+ assert (TCA: transl_code_at_pc ge (Vptr b (Int.add ofs Int.one)) f c false tf x).
+ econstructor; eauto.
+ left; econstructor; split.
+ apply plus_one. eapply exec_step_internal. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. unfold symbol_offset. rewrite symbols_preserved. rewrite FS. eauto.
+ econstructor; eauto.
+ econstructor; eauto.
+ rewrite <- H0. eexact TCA.
+ change (Mem.valid_block m sp0). eapply retaddr_stored_at_valid; eauto.
+ simpl. eapply agree_exten; eauto. intros. Simpl.
+ auto.
+ rewrite <- H0. exact I.
+
+- (* Mtailcall *)
+ inversion AT; subst.
+ assert (NOOV: list_length_z (fn_code tf) <= Int.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *.
+ exploit Mem.loadv_extends. eauto. eexact H0. auto. simpl. intros [parent' [A B]].
+ exploit lessdef_parent_sp; eauto. intros. subst parent'. clear B.
+ assert (C: Mem.loadv Mint32 m'0 (Val.add (rs0 SP) (Vint (fn_retaddr_ofs f))) = Some ra).
+Opaque Int.repr.
+ erewrite agree_sp; eauto. simpl. rewrite Int.add_zero_l.
+ eapply rsa_contains; eauto.
+ exploit retaddr_stored_at_can_free; eauto. intros [m2' [E F]].
+ assert (M: match_stack ge s m'' m2' ra (Mem.nextblock m'')).
+ apply match_stack_change_bound with stk.
+ eapply match_stack_free_left; eauto.
+ eapply match_stack_free_left; eauto.
+ eapply match_stack_free_right; eauto.
+ omega.
+ apply Z.lt_le_incl. change (Mem.valid_block m'' stk).
+ eapply Mem.valid_block_free_1; eauto. eapply Mem.valid_block_free_1; eauto.
+ eapply retaddr_stored_at_valid; eauto.
+ assert (X: forall k, exists rs2,
+ exec_straight tge tf
+ (loadind_int IR13 (fn_retaddr_ofs f) IR14
+ (Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: k)) rs0 m'0
+ k rs2 m2'
+ /\ rs2#SP = parent_sp s
+ /\ rs2#RA = ra
+ /\ forall r, r <> PC -> r <> SP -> r <> IR14 -> rs2#r = rs0#r).
+ {
+ intros.
+ exploit loadind_int_correct. eexact C. intros [rs1 [P [Q R]]].
+ econstructor; split.
+ eapply exec_straight_trans. eexact P. apply exec_straight_one.
+ simpl. rewrite R; auto with asmgen. rewrite A.
+ rewrite <- (sp_val _ _ _ AG). rewrite E. eauto. auto.
+ split. Simpl.
+ split. Simpl.
+ intros. Simpl.
+ }
+ destruct ros as [rf|fid]; simpl in H; monadInv H6.
++ (* Indirect call *)
+ exploit Genv.find_funct_inv; eauto. intros [bf EQ2].
+ rewrite EQ2 in H; rewrite Genv.find_funct_find_funct_ptr in H.
+ assert (rs0 x0 = Vptr bf Int.zero).
+ exploit ireg_val; eauto. rewrite EQ2; intros LD; inv LD; auto.
+ destruct (X (Pbreg x0 sig :: x)) as [rs2 [P [Q [R S]]]].
+ exploit exec_straight_steps_2. eexact P. eauto. eauto. eapply functions_transl; eauto. eauto.
+ intros [ofs' [Y Z]].
+ left; econstructor; split.
+ eapply plus_right'. eapply exec_straight_exec; eauto.
econstructor. eauto. eapply functions_transl; eauto.
- eapply find_instr_tail; eauto.
- unfold call_instr; destruct ros; simpl in H; simpl.
- replace (rs2 (ireg_of m0)) with (Vptr f' Int.zero). auto.
- unfold rs2. rewrite nextinstr_inv; auto with ppcgen.
- rewrite Pregmap.gso. rewrite OTH1; auto with ppcgen.
- generalize (ireg_val _ _ _ m0 AG H7). intro LD. inv LD.
- destruct (ms m0); try congruence.
- generalize H. predSpec Int.eq Int.eq_spec i Int.zero; congruence.
- rewrite <- H10 in H; congruence.
- auto with ppcgen.
- unfold symbol_offset. rewrite symbols_preserved. rewrite H. auto.
+ eapply find_instr_tail; eauto.
+ simpl. reflexivity.
traceEq.
- (* Match states *)
- constructor; auto.
- unfold rs3. apply agree_set_other; auto.
- unfold rs2. apply agree_nextinstr. apply agree_change_sp with (Vptr stk soff).
- apply agree_exten with rs; auto with ppcgen.
- apply parent_sp_def. auto.
-Qed.
-
-Lemma exec_Mbuiltin_prop:
- forall (s : list stackframe) (f : block) (sp : val)
- (ms : Mach.regset) (m : mem) (ef : external_function)
- (args : list mreg) (res : mreg) (b : list Mach.instruction)
- (t : trace) (v : val) (m' : mem),
- external_call ef ge ms ## args m t v m' ->
- exec_instr_prop (Machsem.State s f sp (Mbuiltin ef args res :: b) ms m) t
- (Machsem.State s f sp b (Regmap.set res v (undef_temps ms)) m').
-Proof.
- intros; red; intros; inv MS.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
+ econstructor; eauto.
+ Simpl. rewrite R; auto.
+ constructor; intros. Simpl.
+ Simpl. rewrite S; auto with asmgen. eapply preg_val; eauto.
+ Simpl. rewrite S; auto with asmgen.
+ rewrite <- (ireg_of_eq _ _ EQ1); auto with asmgen.
+ rewrite <- (ireg_of_eq _ _ EQ1); auto with asmgen.
+ Simpl. rewrite R. eapply retaddr_stored_at_type; eauto.
++ (* Direct call *)
+ destruct (Genv.find_symbol ge fid) as [bf|] eqn:FS; try discriminate.
+ destruct (X (Pbsymb fid sig :: x)) as [rs2 [P [Q [R S]]]].
+ exploit exec_straight_steps_2. eexact P. eauto. eauto. eapply functions_transl; eauto. eauto.
+ intros [ofs' [Y Z]].
+ left; econstructor; split.
+ eapply plus_right'. eapply exec_straight_exec; eauto.
+ econstructor. eauto. eapply functions_transl; eauto.
+ eapply find_instr_tail; eauto.
+ simpl. unfold symbol_offset. rewrite symbols_preserved. rewrite FS. reflexivity.
+ traceEq.
+ econstructor; eauto.
+ Simpl. rewrite R; auto.
+ constructor; intros. Simpl.
+ Simpl. rewrite S; auto with asmgen. eapply preg_val; eauto.
+ Simpl.
+ Simpl. rewrite R. eapply retaddr_stored_at_type; eauto.
+
+- (* Mbuiltin *)
+ inv AT. monadInv H3.
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H2); intro NOOV.
exploit external_call_mem_extends; eauto. eapply preg_vals; eauto.
intros [vres' [m2' [A [B [C D]]]]].
- inv AT. simpl in H3.
- generalize (functions_transl _ _ FIND); intro FN.
- generalize (functions_transl_no_overflow _ _ FIND); intro NOOV.
left. econstructor; split. apply plus_one.
eapply exec_step_builtin. eauto. eauto.
- eapply find_instr_tail; eauto.
- eapply external_call_symbols_preserved; eauto.
- eexact symbols_preserved. eexact varinfo_preserved.
- econstructor; eauto with coqlib.
- unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso.
- rewrite <- H0. simpl. constructor; auto.
- eapply code_tail_next_int; eauto.
- apply sym_not_equal. auto with ppcgen.
+ eapply find_instr_tail; eauto.
+ eapply external_call_symbols_preserved; eauto.
+ exact symbols_preserved. exact varinfo_preserved.
+ econstructor; eauto.
+ eapply match_stack_extcall; eauto.
+ intros; eapply external_call_max_perm; eauto.
+ instantiate (2 := tf); instantiate (1 := x).
+ Simpl. rewrite <- H0. simpl. econstructor; eauto.
+ eapply code_tail_next_int; eauto.
apply agree_nextinstr. eapply agree_set_undef_mreg; eauto.
- rewrite Pregmap.gss; auto.
- intros. rewrite Pregmap.gso; auto.
-Qed.
-
-Lemma exec_Mannot_prop:
- forall (s : list stackframe) (f : block) (sp : val)
- (ms : Mach.regset) (m : mem) (ef : external_function)
- (args : list Mach.annot_param) (b : list Mach.instruction)
- (vargs: list val) (t : trace) (v : val) (m' : mem),
- Machsem.annot_arguments ms m sp args vargs ->
- external_call ef ge vargs m t v m' ->
- exec_instr_prop (Machsem.State s f sp (Mannot ef args :: b) ms m) t
- (Machsem.State s f sp b ms m').
-Proof.
- intros; red; intros; inv MS.
- inv AT. simpl in H3.
- generalize (functions_transl _ _ FIND); intro FN.
- generalize (functions_transl_no_overflow _ _ FIND); intro NOOV.
+ rewrite Pregmap.gss. auto.
+ intros. Simpl.
+ eapply retaddr_stored_at_extcall; eauto.
+ intros; eapply external_call_max_perm; eauto.
+ congruence.
+
+- (* Mannot *)
+ inv AT. monadInv H4.
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H3); intro NOOV.
exploit annot_arguments_match; eauto. intros [vargs' [P Q]].
exploit external_call_mem_extends; eauto.
intros [vres' [m2' [A [B [C D]]]]].
@@ -1039,360 +788,220 @@ Proof.
eapply find_instr_tail; eauto. eauto.
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
- econstructor; eauto with coqlib.
+ eapply match_states_intro with (ep := false); eauto with coqlib.
+ eapply match_stack_extcall; eauto.
+ intros; eapply external_call_max_perm; eauto.
unfold nextinstr. rewrite Pregmap.gss.
- rewrite <- H1; simpl. econstructor; auto.
+ rewrite <- H1; simpl. econstructor; eauto.
eapply code_tail_next_int; eauto.
apply agree_nextinstr. auto.
-Qed.
-
-Lemma exec_Mgoto_prop:
- forall (s : list stackframe) (fb : block) (f : Mach.function) (sp : val)
- (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset)
- (m : mem) (c' : Mach.code),
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mach.find_label lbl (Mach.fn_code f) = Some c' ->
- exec_instr_prop (Machsem.State s fb sp (Mgoto lbl :: c) ms m) E0
- (Machsem.State s fb sp c' ms m).
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- inv AT. simpl in H3.
- generalize (find_label_goto_label f lbl rs m' _ _ _ FIND (sym_equal H1) H0).
- intros [rs2 [GOTO [AT2 INV]]].
- left; exists (State rs2 m'); split.
+ eapply retaddr_stored_at_extcall; eauto.
+ intros; eapply external_call_max_perm; eauto.
+ congruence.
+
+- (* Mgoto *)
+ inv AT. monadInv H3.
+ exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]].
+ left; exists (State rs' m'); split.
apply plus_one. econstructor; eauto.
- apply functions_transl; eauto.
+ eapply functions_transl; eauto.
eapply find_instr_tail; eauto.
- simpl; auto.
- econstructor; eauto.
- eapply Mach.find_label_incl; eauto.
- apply agree_exten with rs; auto with ppcgen.
-Qed.
-
-Lemma exec_Mcond_true_prop:
- forall (s : list stackframe) (fb : block) (f : Mach.function) (sp : val)
- (cond : condition) (args : list mreg) (lbl : Mach.label)
- (c : list Mach.instruction) (ms : mreg -> val) (m : mem)
- (c' : Mach.code),
- eval_condition cond ms ## args m = Some true ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mach.find_label lbl (Mach.fn_code f) = Some c' ->
- exec_instr_prop (Machsem.State s fb sp (Mcond cond args lbl :: c) ms m) E0
- (Machsem.State s fb sp c' (undef_temps ms) m).
-Proof.
- intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
- exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto.
- intros A.
- exploit transl_cond_correct. eauto. eauto.
- instantiate (1 := rs). instantiate (1 := m').
- rewrite A || (unfold PregEq.t; rewrite A).
- intros [rs2 [EX [RES OTH]]].
- inv AT. simpl in H5.
- generalize (functions_transl _ _ H4); intro FN.
- generalize (functions_transl_no_overflow _ _ H4); intro NOOV.
- exploit exec_straight_steps_2; eauto.
- intros [ofs' [PC2 CT2]].
- generalize (find_label_goto_label f lbl rs2 m' _ _ _ FIND PC2 H1).
- intros [rs3 [GOTO [AT3 INV3]]].
- left; exists (State rs3 m'); split.
- eapply plus_right'.
- eapply exec_straight_steps_1; eauto.
+ simpl; eauto.
econstructor; eauto.
- eapply find_instr_tail. eauto.
- simpl. rewrite RES. simpl. auto.
- traceEq.
- econstructor; eauto.
- eapply Mach.find_label_incl; eauto.
- apply agree_exten_temps with rs; auto. intros.
- rewrite INV3; auto with ppcgen.
-Qed.
-
-Lemma exec_Mcond_false_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (cond : condition) (args : list mreg) (lbl : Mach.label)
- (c : list Mach.instruction) (ms : mreg -> val) (m : mem),
- eval_condition cond ms ## args m = Some false ->
- exec_instr_prop (Machsem.State s fb sp (Mcond cond args lbl :: c) ms m) E0
- (Machsem.State s fb sp c (undef_temps ms) m).
-Proof.
- intros; red; intros; inv MS.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
- exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto.
- intros A.
- exploit transl_cond_correct. eauto.
- instantiate (1 := rs). instantiate (1 := m').
- rewrite A || (unfold PregEq.t; rewrite A).
- intros [rs2 [EX [RES OTH]]].
- left; eapply exec_straight_steps; eauto with coqlib.
- exists m'; split; auto.
- exists (nextinstr rs2); split.
- simpl. eapply exec_straight_trans. eexact EX.
- apply exec_straight_one. simpl. rewrite RES. reflexivity. reflexivity.
- apply agree_nextinstr. apply agree_exten_temps with rs; auto with ppcgen.
-Qed.
-
-Lemma exec_Mjumptable_prop:
- forall (s : list stackframe) (fb : block) (f : Mach.function) (sp : val)
- (arg : mreg) (tbl : list Mach.label) (c : list Mach.instruction)
- (ms : mreg -> val) (m : mem) (n : int) (lbl : Mach.label)
- (c' : Mach.code),
- ms arg = Vint n ->
- list_nth_z tbl (Int.unsigned n) = Some lbl ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mach.find_label lbl (Mach.fn_code f) = Some c' ->
- exec_instr_prop
- (Machsem.State s fb sp (Mjumptable arg tbl :: c) ms m) E0
- (Machsem.State s fb sp c' (undef_temps ms) m).
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
- exploit list_nth_z_range; eauto. intro RANGE.
- assert (SHIFT: Int.unsigned (Int.shl n (Int.repr 2)) = Int.unsigned n * 4).
- rewrite Int.shl_mul.
- unfold Int.mul.
- apply Int.unsigned_repr.
- omega.
- inv AT. simpl in H7.
- set (k1 := Pbtbl IR14 tbl :: transl_code f c).
- set (rs1 := nextinstr (rs # IR14 <- (Vint (Int.shl n (Int.repr 2))))).
- generalize (functions_transl _ _ H4); intro FN.
- generalize (functions_transl_no_overflow _ _ H4); intro NOOV.
- assert (rs (ireg_of arg) = Vint n).
- exploit ireg_val; eauto. intros LD. inv LD. auto. congruence.
- assert (exec_straight tge (fn_code (transl_function f))
- (Pmov IR14 (SOlslimm (ireg_of arg) (Int.repr 2)) :: k1) rs m'
- k1 rs1 m').
- apply exec_straight_one.
- simpl. rewrite H8. reflexivity. reflexivity.
- exploit exec_straight_steps_2; eauto.
- intros [ofs' [PC1 CT1]].
- generalize (find_label_goto_label f lbl rs1 m' _ _ _ FIND PC1 H2).
- intros [rs3 [GOTO [AT3 INV3]]].
- left; exists (State rs3 m'); split.
- eapply plus_right'.
- eapply exec_straight_steps_1; eauto.
- econstructor; eauto.
- eapply find_instr_tail. unfold k1 in CT1. eauto.
- unfold exec_instr.
- change (rs1 IR14) with (Vint (Int.shl n (Int.repr 2))).
- lazy iota beta. rewrite SHIFT.
- rewrite Z_mod_mult. rewrite zeq_true. rewrite Z_div_mult.
- change label with Mach.label; rewrite H0. exact GOTO. omega. traceEq.
+ eapply agree_exten; eauto with asmgen.
+ congruence.
+
+- (* Mcond true *)
+ exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
+ left; eapply exec_straight_steps_goto; eauto.
+ intros. simpl in TR.
+ destruct (transl_cond_correct tge tf cond args _ rs0 m' _ TR) as [rs' [A [B C]]].
+ rewrite EC in B.
+ econstructor; econstructor; econstructor; split. eexact A.
+ split. eapply agree_exten_temps; eauto with asmgen.
+ simpl. rewrite B. reflexivity.
+
+- (* Mcond false *)
+ exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
+ left; eapply exec_straight_steps; eauto. intros. simpl in TR.
+ destruct (transl_cond_correct tge tf cond args _ rs0 m' _ TR) as [rs' [A [B C]]].
+ rewrite EC in B.
+ econstructor; split.
+ eapply exec_straight_trans. eexact A.
+ apply exec_straight_one. simpl. rewrite B. reflexivity. auto.
+ split. eapply agree_exten_temps; eauto with asmgen.
+ intros; Simpl.
+ simpl. congruence.
+
+- (* Mjumptable *)
+ inv AT. monadInv H5.
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H4); intro NOOV.
+ exploit find_label_goto_label. eauto. eauto.
+ instantiate (2 := rs0#IR14 <- Vundef).
+ Simpl. eauto.
+ eauto.
+ intros [tc' [rs' [A [B C]]]].
+ exploit ireg_val; eauto. rewrite H. intros LD; inv LD.
+ left; econstructor; split.
+ apply plus_one. econstructor; eauto.
+ eapply find_instr_tail; eauto.
+ simpl. rewrite <- H8. unfold Mach.label in H0; unfold label; rewrite H0. eexact A.
econstructor; eauto.
- eapply Mach.find_label_incl; eauto.
- apply agree_exten with rs1; auto with ppcgen.
- unfold rs1. apply agree_nextinstr. apply agree_set_other; auto with ppcgen.
- apply agree_undef_temps; auto.
-Qed.
-
-Lemma exec_Mreturn_prop:
- forall (s : list stackframe) (fb stk : block) (soff : int)
- (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: Mach.function) m',
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
- load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
- Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
- exec_instr_prop (Machsem.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0
- (Returnstate s ms m').
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- unfold load_stack in *.
- exploit Mem.loadv_extends. eauto. eexact H0. auto.
- intros [parent' [A B]].
- exploit lessdef_parent_sp; eauto. intros. subst parent'.
- exploit Mem.loadv_extends. eauto. eexact H1. auto.
- intros [ra' [C D]].
- exploit lessdef_parent_ra; eauto. intros. subst ra'.
- exploit Mem.free_parallel_extends; eauto. intros [m2' [E F]].
-
- exploit (loadind_int_correct tge (fn_code (transl_function f)) IR13 f.(fn_retaddr_ofs) IR14
- rs m'0 (parent_ra s)
- (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbreg IR14 f.(Mach.fn_sig) :: transl_code f c)).
- rewrite <- (sp_val ms (Vptr stk soff) rs); auto.
- intros [rs1 [EXEC1 [RES1 OTH1]]].
- set (rs2 := nextinstr (rs1#IR13 <- (parent_sp s))).
- assert (EXEC2: exec_straight tge (fn_code (transl_function f))
- (loadind_int IR13 (fn_retaddr_ofs f) IR14
- (Pfreeframe f.(fn_stacksize) (fn_link_ofs f) :: Pbreg IR14 f.(Mach.fn_sig) :: transl_code f c))
- rs m'0 (Pbreg IR14 f.(Mach.fn_sig) :: transl_code f c) rs2 m2').
- eapply exec_straight_trans. eexact EXEC1.
- apply exec_straight_one. simpl. rewrite OTH1; try congruence.
- rewrite <- (sp_val ms (Vptr stk soff) rs); auto.
- simpl chunk_of_type in A. rewrite A. rewrite E. auto. auto.
- set (rs3 := rs2#PC <- (parent_ra s)).
- left; exists (State rs3 m2'); split.
- (* execution *)
- eapply plus_right'. eapply exec_straight_exec; eauto.
- inv AT. exploit exec_straight_steps_2; eauto.
- eapply functions_transl_no_overflow; eauto.
- eapply functions_transl; eauto.
- intros [ofs2 [RS2PC CT]].
+ eapply agree_exten_temps; eauto. intros. rewrite C; auto with asmgen. Simpl.
+ congruence.
+
+- (* Mreturn *)
+ inversion AT; subst.
+ assert (NOOV: list_length_z (fn_code tf) <= Int.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *.
+ exploit Mem.loadv_extends. eauto. eexact H. auto. simpl. intros [parent' [A B]].
+ exploit lessdef_parent_sp; eauto. intros. subst parent'. clear B.
+ assert (C: Mem.loadv Mint32 m'0 (Val.add (rs0 SP) (Vint (fn_retaddr_ofs f))) = Some ra).
+Opaque Int.repr.
+ erewrite agree_sp; eauto. simpl. rewrite Int.add_zero_l.
+ eapply rsa_contains; eauto.
+ exploit retaddr_stored_at_can_free; eauto. intros [m2' [E F]].
+ assert (M: match_stack ge s m'' m2' ra (Mem.nextblock m'')).
+ apply match_stack_change_bound with stk.
+ eapply match_stack_free_left; eauto.
+ eapply match_stack_free_left; eauto.
+ eapply match_stack_free_right; eauto. omega.
+ apply Z.lt_le_incl. change (Mem.valid_block m'' stk).
+ eapply Mem.valid_block_free_1; eauto. eapply Mem.valid_block_free_1; eauto.
+ eapply retaddr_stored_at_valid; eauto.
+ monadInv H5.
+ assert (X: forall k, exists rs2,
+ exec_straight tge tf
+ (loadind_int IR13 (fn_retaddr_ofs f) IR14
+ (Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: k)) rs0 m'0
+ k rs2 m2'
+ /\ rs2#SP = parent_sp s
+ /\ rs2#RA = ra
+ /\ forall r, r <> PC -> r <> SP -> r <> IR14 -> rs2#r = rs0#r).
+ {
+ intros.
+ exploit loadind_int_correct. eexact C. intros [rs1 [P [Q R]]].
+ econstructor; split.
+ eapply exec_straight_trans. eexact P. apply exec_straight_one.
+ simpl. rewrite R; auto with asmgen. rewrite A.
+ rewrite <- (sp_val _ _ _ AG). rewrite E. eauto. auto.
+ split. Simpl.
+ split. Simpl.
+ intros. Simpl.
+ }
+ destruct (X (Pbreg IR14 (Mach.fn_sig f) :: x)) as [rs2 [P [Q [R S]]]].
+ exploit exec_straight_steps_2. eexact P. eauto. eauto. eapply functions_transl; eauto. eauto.
+ intros [ofs' [Y Z]].
+ left; econstructor; split.
+ eapply plus_right'. eapply exec_straight_exec; eauto.
econstructor. eauto. eapply functions_transl; eauto.
- eapply find_instr_tail; eauto.
- simpl. unfold rs3. decEq. decEq. unfold rs2. rewrite nextinstr_inv; auto with ppcgen.
+ eapply find_instr_tail; eauto.
+ simpl. reflexivity.
traceEq.
- (* match states *)
- constructor. auto.
- apply agree_exten with rs2.
- unfold rs2. apply agree_nextinstr. apply agree_change_sp with (Vptr stk soff).
- apply agree_exten with rs; auto with ppcgen.
- apply parent_sp_def. auto.
- intros. unfold rs3. apply Pregmap.gso; auto with ppcgen.
- unfold rs3. apply Pregmap.gss.
- auto.
-Qed.
-
-Hypothesis wt_prog: wt_program prog.
-
-Lemma exec_function_internal_prop:
- forall (s : list stackframe) (fb : block) (ms : Mach.regset)
- (m : mem) (f : Mach.function) (m1 m2 m3 : mem) (stk : block),
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mem.alloc m 0 (fn_stacksize f) = (m1, stk) ->
- let sp := Vptr stk Int.zero in
- store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 ->
- store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 ->
- exec_instr_prop (Machsem.Callstate s fb ms m) E0
- (Machsem.State s fb sp (Mach.fn_code f) (undef_temps ms) m3).
-Proof.
- intros; red; intros; inv MS.
- assert (WTF: wt_function f).
- generalize (Genv.find_funct_ptr_prop wt_fundef _ _ wt_prog H); intro TY.
- inversion TY; auto.
- exploit functions_transl; eauto. intro TFIND.
- generalize (functions_transl_no_overflow _ _ H); intro NOOV.
- set (rs2 := nextinstr (rs#IR12 <- (rs#IR13) #IR13 <- sp)).
- set (rs3 := nextinstr rs2).
- exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl.
- intros [m1' [A B]].
- unfold store_stack in *; simpl chunk_of_type in *.
- exploit Mem.storev_extends. eexact B. eauto. auto. auto.
- intros [m2' [C D]].
- exploit Mem.storev_extends. eexact D. eauto. auto. auto.
- intros [m3' [E F]].
+ econstructor; eauto.
+ Simpl. rewrite R; auto.
+ constructor; intros. Simpl.
+ Simpl. rewrite S; auto with asmgen. eapply preg_val; eauto.
+
+- (* internal function *)
+ exploit functions_translated; eauto. intros [tf [A B]]. monadInv B.
+ generalize EQ; intros EQ'. monadInv EQ'.
+ destruct (zlt Int.max_unsigned (list_length_z (fn_code x0))); inversion EQ1. clear EQ1.
+ monadInv EQ0.
+ unfold store_stack in *.
+ exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl.
+ intros [m1' [C D]].
+ assert (E: Mem.extends m2 m1') by (eapply Mem.free_left_extends; eauto).
+ exploit Mem.storev_extends. eexact E. eexact H1. eauto. eauto.
+ intros [m2' [F G]].
+ exploit retaddr_stored_at_can_alloc. eexact H. eauto. eauto. eauto. eauto.
+ auto. auto. auto. auto. eauto.
+ intros [m3' [P [Q R]]].
(* Execution of function prologue *)
+ set (rs2 := nextinstr (rs0#IR10 <- (parent_sp s) #IR13 <- (Vptr stk Int.zero))).
+ set (rs3 := nextinstr rs2).
assert (EXEC_PROLOGUE:
- exec_straight tge (fn_code (transl_function f))
- (fn_code (transl_function f)) rs m'
- (transl_code f f.(Mach.fn_code)) rs3 m3').
- unfold transl_function at 2.
+ exec_straight tge x
+ (fn_code x) rs0 m'
+ x1 rs3 m3').
+ rewrite <- H5 at 2; unfold fn_code.
apply exec_straight_two with rs2 m2'.
- unfold exec_instr. rewrite A. fold sp.
- rewrite (sp_val ms (parent_sp s) rs) in C; auto. rewrite C. auto.
- unfold exec_instr. unfold eval_shift_addr. unfold exec_store.
- change (rs2 IR13) with sp. change (rs2 IR14) with (rs IR14). rewrite ATLR.
- rewrite E. auto.
- auto. auto.
- (* Agreement at end of prologue *)
- assert (AT3: transl_code_at_pc rs3#PC fb f f.(Mach.fn_code)).
- change (rs3 PC) with (Val.add (Val.add (rs PC) Vone) Vone).
- rewrite ATPC. simpl. constructor. auto.
- eapply code_tail_next_int; auto.
- eapply code_tail_next_int; auto.
- change (Int.unsigned Int.zero) with 0.
- unfold transl_function. constructor.
- assert (AG3: agree (undef_temps ms) sp rs3).
- unfold rs3. apply agree_nextinstr.
- unfold rs2. apply agree_nextinstr.
- apply agree_change_sp with (parent_sp s).
- apply agree_exten_temps with rs; auto.
- intros. apply Pregmap.gso; auto with ppcgen.
- unfold sp. congruence.
+ unfold exec_instr. rewrite C. fold sp.
+ rewrite <- (sp_val _ _ _ AG). unfold chunk_of_type in F. rewrite F. auto.
+ simpl. auto.
+ simpl. unfold exec_store. change (rs2 IR14) with (rs0 IR14).
+ rewrite Int.add_zero_l. simpl. rewrite P. auto. auto. auto.
left; exists (State rs3 m3'); split.
- (* execution *)
- eapply exec_straight_steps_1; eauto.
- change (Int.unsigned Int.zero) with 0. constructor.
- (* match states *)
- econstructor; eauto with coqlib.
-Qed.
-
-Lemma exec_function_external_prop:
- forall (s : list stackframe) (fb : block) (ms : Mach.regset)
- (m : mem) (t0 : trace) (ms' : RegEq.t -> val)
- (ef : external_function) (args : list val) (res : val) (m': mem),
- Genv.find_funct_ptr ge fb = Some (External ef) ->
- external_call ef ge args m t0 res m' ->
- Machsem.extcall_arguments ms m (parent_sp s) (ef_sig ef) args ->
- ms' = Regmap.set (loc_result (ef_sig ef)) res ms ->
- exec_instr_prop (Machsem.Callstate s fb ms m)
- t0 (Machsem.Returnstate s ms' m').
-Proof.
- intros; red; intros; inv MS.
+ eapply exec_straight_steps_1; eauto. omega. constructor.
+ econstructor; eauto.
+ assert (STK: stk = Mem.nextblock m) by (eapply Mem.alloc_result; eauto).
+ rewrite <- STK in STACKS. simpl in F. simpl in H1.
+ eapply match_stack_invariant; eauto.
+ intros. eapply Mem.perm_alloc_4; eauto. eapply Mem.perm_free_3; eauto.
+ eapply Mem.perm_store_2; eauto. unfold block; omega.
+ intros. eapply Mem.perm_store_1; eauto. eapply Mem.perm_store_1; eauto.
+ eapply Mem.perm_alloc_1; eauto.
+ intros. erewrite Mem.load_store_other. 2: eauto.
+ erewrite Mem.load_store_other. 2: eauto.
+ eapply Mem.load_alloc_other; eauto.
+ left; unfold block; omega.
+ left; unfold block; omega.
+ change (rs3 PC) with (Val.add (Val.add (rs0 PC) Vone) Vone).
+ rewrite ATPC. simpl. constructor; eauto.
+ subst x. eapply code_tail_next_int. omega.
+ eapply code_tail_next_int. omega. constructor.
+ unfold rs3, rs2.
+ apply agree_nextinstr. apply agree_nextinstr.
+ eapply agree_change_sp.
+ apply agree_exten_temps with rs0; eauto.
+ intros. Simpl. congruence.
+
+- (* external function *)
exploit functions_translated; eauto.
intros [tf [A B]]. simpl in B. inv B.
exploit extcall_arguments_match; eauto.
intros [args' [C D]].
- exploit external_call_mem_extends; eauto.
- intros [vres' [m2' [P [Q [R S]]]]].
- left; exists (State (rs#(loc_external_result (ef_sig ef)) <- vres' #PC <- (rs IR14))
- m2'); split.
- apply plus_one. eapply exec_step_external; eauto.
- eapply external_call_symbols_preserved; eauto.
+ exploit external_call_mem_extends; eauto.
+ intros [res' [m2' [P [Q [R S]]]]].
+ left; econstructor; split.
+ apply plus_one. eapply exec_step_external; eauto.
+ eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
- econstructor; eauto.
- unfold loc_external_result.
+ econstructor; eauto.
+ rewrite Pregmap.gss. apply match_stack_change_bound with (Mem.nextblock m).
+ eapply match_stack_extcall; eauto.
+ intros. eapply external_call_max_perm; eauto.
+ eapply external_call_nextblock; eauto.
+ unfold loc_external_result.
eapply agree_set_mreg; eauto.
- rewrite Pregmap.gso; auto with ppcgen. rewrite Pregmap.gss. auto.
- intros. repeat rewrite Pregmap.gso; auto with ppcgen.
-Qed.
+ rewrite Pregmap.gso; auto with asmgen. rewrite Pregmap.gss. auto.
+ intros; Simpl.
-Lemma exec_return_prop:
- forall (s : list stackframe) (fb : block) (sp ra : val)
- (c : Mach.code) (ms : Mach.regset) (m : mem),
- exec_instr_prop (Machsem.Returnstate (Stackframe fb sp ra c :: s) ms m) E0
- (Machsem.State s fb sp c ms m).
-Proof.
- intros; red; intros; inv MS. inv STACKS. simpl in *.
+- (* return *)
+ inv STACKS. simpl in *.
right. split. omega. split. auto.
- econstructor; eauto. rewrite ATPC; auto.
+ econstructor; eauto. congruence.
Qed.
-Theorem transf_instr_correct:
- forall s1 t s2, Machsem.step ge s1 t s2 ->
- exec_instr_prop s1 t s2.
-Proof
- (Machsem.step_ind ge exec_instr_prop
- exec_Mlabel_prop
- exec_Mgetstack_prop
- exec_Msetstack_prop
- exec_Mgetparam_prop
- exec_Mop_prop
- exec_Mload_prop
- exec_Mstore_prop
- exec_Mcall_prop
- exec_Mtailcall_prop
- exec_Mbuiltin_prop
- exec_Mannot_prop
- exec_Mgoto_prop
- exec_Mcond_true_prop
- exec_Mcond_false_prop
- exec_Mjumptable_prop
- exec_Mreturn_prop
- exec_function_internal_prop
- exec_function_external_prop
- exec_return_prop).
-
Lemma transf_initial_states:
- forall st1, Machsem.initial_state prog st1 ->
+ forall st1, Mach.initial_state prog st1 ->
exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2.
Proof.
intros. inversion H. unfold ge0 in *.
+ exploit functions_translated; eauto. intros [tf [A B]].
econstructor; split.
econstructor.
- eapply Genv.init_mem_transf_partial; eauto.
+ eapply Genv.init_mem_transf_partial; eauto.
replace (symbol_offset (Genv.globalenv tprog) (prog_main tprog) Int.zero)
- with (Vptr fb Int.zero).
- econstructor; eauto. constructor.
- split. auto. intros. repeat rewrite Pregmap.gso; auto with ppcgen.
- intros. unfold Regmap.init. auto.
+ with (Vptr b Int.zero).
+ econstructor; eauto.
+ constructor.
apply Mem.extends_refl.
+ split. auto. intros. rewrite Regmap.gi. auto.
+ reflexivity.
+ exact I.
unfold symbol_offset.
rewrite (transform_partial_program_main _ _ TRANSF).
rewrite symbols_preserved. unfold ge; rewrite H1. auto.
@@ -1400,21 +1009,22 @@ Qed.
Lemma transf_final_states:
forall st1 st2 r,
- match_states st1 st2 -> Machsem.final_state st1 r -> Asm.final_state st2 r.
+ match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r.
Proof.
- intros. inv H0. inv H. constructor. auto.
- compute in H1. exploit ireg_val; eauto. instantiate (1 := R0); auto.
- simpl. intros LD. inv LD; congruence.
+ intros. inv H0. inv H. inv STACKS. constructor.
+ auto.
+ compute in H1.
+ generalize (preg_val _ _ _ R0 AG). rewrite H1. intros LD; inv LD. auto.
Qed.
Theorem transf_program_correct:
- forward_simulation (Machsem.semantics prog) (Asm.semantics tprog).
+ forward_simulation (Mach.semantics prog) (Asm.semantics tprog).
Proof.
eapply forward_simulation_star with (measure := measure).
eexact symbols_preserved.
eexact transf_initial_states.
eexact transf_final_states.
- exact transf_instr_correct.
+ exact step_simulation.
Qed.
End PRESERVATION.
diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v
index 658fc98..8fc8a7e 100644
--- a/arm/Asmgenproof1.v
+++ b/arm/Asmgenproof1.v
@@ -12,8 +12,9 @@
(** Correctness proof for ARM code generation: auxiliary results. *)
-Require Import Axioms.
+(*Require Import Axioms.*)
Require Import Coqlib.
+Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
@@ -24,455 +25,44 @@ Require Import Globalenvs.
Require Import Op.
Require Import Locations.
Require Import Mach.
-Require Import Machsem.
-Require Import Machtyping.
Require Import Asm.
Require Import Asmgen.
Require Import Conventions.
+Require Import Asmgenproof0.
-(** * Correspondence between Mach registers and PPC registers *)
+(** Useful properties of the R14 registers. *)
-Hint Extern 2 (_ <> _) => discriminate: ppcgen.
-
-(** Mapping from Mach registers to PPC registers. *)
-
-Lemma preg_of_injective:
- forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2.
-Proof.
- destruct r1; destruct r2; simpl; intros; reflexivity || discriminate.
-Qed.
-
-Lemma ireg_of_not_IR13:
- forall r, ireg_of r <> IR13.
-Proof.
- destruct r; simpl; congruence.
-Qed.
-
-Lemma ireg_of_not_IR14:
- forall r, ireg_of r <> IR14.
-Proof.
- destruct r; simpl; congruence.
-Qed.
-
-Lemma preg_of_not_IR13:
- forall r, preg_of r <> IR13.
-Proof.
- unfold preg_of; intros. destruct (mreg_type r).
- generalize (ireg_of_not_IR13 r); congruence.
- congruence.
-Qed.
-
-Lemma preg_of_not_IR14:
- forall r, preg_of r <> IR14.
-Proof.
- unfold preg_of; intros. destruct (mreg_type r).
- generalize (ireg_of_not_IR14 r); congruence.
- congruence.
-Qed.
-
-Lemma preg_of_not_PC:
- forall r, preg_of r <> PC.
-Proof.
- intros. unfold preg_of. destruct (mreg_type r); congruence.
-Qed.
-
-Lemma ireg_diff:
- forall r1 r2, r1 <> r2 -> IR r1 <> IR r2.
-Proof. intros; congruence. Qed.
-
-Hint Resolve ireg_of_not_IR13 ireg_of_not_IR14
- preg_of_not_IR13 preg_of_not_IR14
- preg_of_not_PC ireg_diff: ppcgen.
-
-(** Agreement between Mach register sets and ARM register sets. *)
-
-Record agree (ms: Mach.regset) (sp: val) (rs: Asm.regset) : Prop := mkagree {
- agree_sp: rs#IR13 = sp;
- agree_sp_def: sp <> Vundef;
- agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r))
-}.
-
-Lemma preg_val:
- forall ms sp rs r,
- agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r).
-Proof.
- intros. destruct H. auto.
-Qed.
-
-Lemma preg_vals:
- forall ms sp rs, agree ms sp rs ->
- forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)).
-Proof.
- induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto.
-Qed.
-
-Lemma ireg_val:
- forall ms sp rs r,
- agree ms sp rs ->
- mreg_type r = Tint ->
- Val.lessdef (ms r) rs#(ireg_of r).
-Proof.
- intros. generalize (preg_val _ _ _ r H). unfold preg_of. rewrite H0. auto.
-Qed.
-
-Lemma freg_val:
- forall ms sp rs r,
- agree ms sp rs ->
- mreg_type r = Tfloat ->
- Val.lessdef (ms r) rs#(freg_of r).
-Proof.
- intros. generalize (preg_val _ _ _ r H). unfold preg_of. rewrite H0. auto.
-Qed.
-
-Lemma sp_val:
- forall ms sp rs,
- agree ms sp rs ->
- sp = rs#IR13.
-Proof.
- intros. destruct H; auto.
-Qed.
-
-Hint Resolve preg_val ireg_val freg_val sp_val: ppcgen.
-
-Definition important_preg (r: preg) : bool :=
- match r with
- | IR IR14 => false
- | IR _ => true
- | FR _ => true
- | CR _ => false
- | PC => false
- end.
-
-Lemma preg_of_important:
- forall r, important_preg (preg_of r) = true.
-Proof.
- intros. destruct r; reflexivity.
-Qed.
-
-Lemma important_diff:
- forall r r',
- important_preg r = true -> important_preg r' = false -> r <> r'.
-Proof.
- congruence.
-Qed.
-Hint Resolve important_diff: ppcgen.
-
-Lemma agree_exten:
- forall ms sp rs rs',
- agree ms sp rs ->
- (forall r, important_preg r = true -> rs'#r = rs#r) ->
- agree ms sp rs'.
-Proof.
- intros. destruct H. split.
- rewrite H0; auto. auto.
- intros. rewrite H0; auto. apply preg_of_important.
-Qed.
-
-(** Preservation of register agreement under various assignments. *)
-
-Lemma agree_set_mreg:
- forall ms sp rs r v rs',
- agree ms sp rs ->
- Val.lessdef v (rs'#(preg_of r)) ->
- (forall r', important_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') ->
- agree (Regmap.set r v ms) sp rs'.
-Proof.
- intros. destruct H. split.
- rewrite H1; auto. apply sym_not_equal. apply preg_of_not_IR13.
- auto.
- intros. unfold Regmap.set. destruct (RegEq.eq r0 r). congruence.
- rewrite H1. auto. apply preg_of_important.
- red; intros; elim n. eapply preg_of_injective; eauto.
-Qed.
-
-Lemma agree_set_other:
- forall ms sp rs r v,
- agree ms sp rs ->
- important_preg r = false ->
- agree ms sp (rs#r <- v).
-Proof.
- intros. apply agree_exten with rs. auto.
- intros. apply Pregmap.gso. congruence.
-Qed.
-
-Lemma agree_nextinstr:
- forall ms sp rs,
- agree ms sp rs -> agree ms sp (nextinstr rs).
+Lemma ireg_of_not_R14:
+ forall m r, ireg_of m = OK r -> IR r <> IR IR14.
Proof.
- intros. unfold nextinstr. apply agree_set_other. auto. auto.
+ intros. erewrite <- ireg_of_eq; eauto with asmgen.
Qed.
+Hint Resolve ireg_of_not_R14: asmgen.
-Definition nontemp_preg (r: preg) : bool :=
- match r with
- | IR IR14 => false
- | IR IR10 => false
- | IR IR12 => false
- | IR _ => true
- | FR FR6 => false
- | FR FR7 => false
- | FR _ => true
- | CR _ => false
- | PC => false
- end.
-
-Lemma nontemp_diff:
- forall r r',
- nontemp_preg r = true -> nontemp_preg r' = false -> r <> r'.
-Proof.
- congruence.
-Qed.
-
-Hint Resolve nontemp_diff: ppcgen.
-
-Lemma nontemp_important:
- forall r, nontemp_preg r = true -> important_preg r = true.
+Lemma ireg_of_not_R14':
+ forall m r, ireg_of m = OK r -> r <> IR14.
Proof.
- unfold nontemp_preg, important_preg; destruct r; auto. destruct i; auto.
+ intros. generalize (ireg_of_not_R14 _ _ H). congruence.
Qed.
+Hint Resolve ireg_of_not_R14': asmgen.
-Hint Resolve nontemp_important: ppcgen.
+(** Useful simplification tactic *)
-Remark undef_regs_1:
- forall l ms r, ms r = Vundef -> Mach.undef_regs l ms r = Vundef.
-Proof.
- induction l; simpl; intros. auto. apply IHl. unfold Regmap.set.
- destruct (RegEq.eq r a); congruence.
-Qed.
+Ltac Simplif :=
+ ((rewrite nextinstr_inv by eauto with asmgen)
+ || (rewrite nextinstr_inv1 by eauto with asmgen)
+ || (rewrite Pregmap.gss)
+ || (rewrite nextinstr_pc)
+ || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen.
-Remark undef_regs_2:
- forall l ms r, In r l -> Mach.undef_regs l ms r = Vundef.
-Proof.
- induction l; simpl; intros. contradiction.
- destruct H. subst. apply undef_regs_1. apply Regmap.gss.
- auto.
-Qed.
-
-Remark undef_regs_3:
- forall l ms r, ~In r l -> Mach.undef_regs l ms r = ms r.
-Proof.
- induction l; simpl; intros. auto.
- rewrite IHl. apply Regmap.gso. intuition. intuition.
-Qed.
-
-Lemma agree_exten_temps:
- forall ms sp rs rs',
- agree ms sp rs ->
- (forall r, nontemp_preg r = true -> rs'#r = rs#r) ->
- agree (undef_temps ms) sp rs'.
-Proof.
- intros. destruct H. split.
- rewrite H0; auto. auto.
- intros. unfold undef_temps.
- destruct (In_dec mreg_eq r (int_temporaries ++ float_temporaries)).
- rewrite undef_regs_2; auto.
- rewrite undef_regs_3; auto. rewrite H0; auto.
- simpl in n. destruct r; auto; intuition.
-Qed.
-
-Lemma agree_set_undef_mreg:
- forall ms sp rs r v rs',
- agree ms sp rs ->
- Val.lessdef v (rs'#(preg_of r)) ->
- (forall r', nontemp_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') ->
- agree (Regmap.set r v (undef_temps ms)) sp rs'.
-Proof.
- intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto.
- eapply agree_exten_temps; eauto.
- intros. unfold Pregmap.set. destruct (PregEq.eq r0 (preg_of r)).
- congruence. auto.
- intros. rewrite Pregmap.gso; auto.
-Qed.
+Ltac Simpl := repeat Simplif.
-Lemma agree_undef_temps:
- forall ms sp rs,
- agree ms sp rs ->
- agree (undef_temps ms) sp rs.
-Proof.
- intros. eapply agree_exten_temps; eauto.
-Qed.
-
-(** Useful properties of the PC register. *)
-
-Lemma nextinstr_inv:
- forall r rs,
- r <> PC ->
- (nextinstr rs)#r = rs#r.
-Proof.
- intros. unfold nextinstr. apply Pregmap.gso. red; intro; subst. auto.
-Qed.
-
-Lemma nextinstr_inv2:
- forall r rs,
- nontemp_preg r = true ->
- (nextinstr rs)#r = rs#r.
-Proof.
- intros. apply nextinstr_inv. red; intro; subst; discriminate.
-Qed.
-
-Lemma nextinstr_set_preg:
- forall rs m v,
- (nextinstr (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone.
-Proof.
- intros. unfold nextinstr. rewrite Pregmap.gss.
- rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_PC.
-Qed.
-
-(** Connection between Mach and Asm calling conventions for external
- functions. *)
-
-Lemma extcall_arg_match:
- forall ms sp rs m m' l v,
- agree ms sp rs ->
- Machsem.extcall_arg ms m sp l v ->
- Mem.extends m m' ->
- exists v', Asm.extcall_arg rs m' l v' /\ Val.lessdef v v'.
-Proof.
- intros. inv H0.
- exists (rs#(preg_of r)); split. constructor. eauto with ppcgen.
- unfold load_stack in H2.
- exploit Mem.loadv_extends; eauto. intros [v' [A B]].
- rewrite (sp_val _ _ _ H) in A.
- exists v'; split; auto. destruct ty; econstructor; eauto.
-Qed.
-
-Lemma extcall_args_match:
- forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' ->
- forall ll vl,
- list_forall2 (Machsem.extcall_arg ms m sp) ll vl ->
- exists vl', list_forall2 (Asm.extcall_arg rs m') ll vl' /\ Val.lessdef_list vl vl'.
-Proof.
- induction 3; intros.
- exists (@nil val); split. constructor. constructor.
- exploit extcall_arg_match; eauto. intros [v1' [A B]].
- destruct IHlist_forall2 as [vl' [C D]].
- exists (v1' :: vl'); split; constructor; auto.
-Qed.
-
-Lemma extcall_arguments_match:
- forall ms m sp rs sg args m',
- agree ms sp rs ->
- Machsem.extcall_arguments ms m sp sg args ->
- Mem.extends m m' ->
- exists args', Asm.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'.
-Proof.
- unfold Machsem.extcall_arguments, Asm.extcall_arguments; intros.
- eapply extcall_args_match; eauto.
-Qed.
-
-(** Translation of arguments to annotations. *)
-
-Lemma annot_arg_match:
- forall ms sp rs m m' p v,
- agree ms sp rs ->
- Mem.extends m m' ->
- Machsem.annot_arg ms m sp p v ->
- exists v', Asm.annot_arg rs m' (transl_annot_param p) v' /\ Val.lessdef v v'.
-Proof.
- intros. inv H1; simpl.
-(* reg *)
- exists (rs (preg_of r)); split. constructor. eapply preg_val; eauto.
-(* stack *)
- exploit Mem.load_extends; eauto. intros [v' [A B]].
- exists v'; split; auto.
- inv H. econstructor; eauto.
-Qed.
-
-Lemma annot_arguments_match:
- forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' ->
- forall pl vl,
- Machsem.annot_arguments ms m sp pl vl ->
- exists vl', Asm.annot_arguments rs m' (map transl_annot_param pl) vl'
- /\ Val.lessdef_list vl vl'.
-Proof.
- induction 3; intros.
- exists (@nil val); split. constructor. constructor.
- exploit annot_arg_match; eauto. intros [v1' [A B]].
- destruct IHlist_forall2 as [vl' [C D]].
- exists (v1' :: vl'); split; constructor; auto.
-Qed.
-
-(** * Execution of straight-line code *)
+(** * Correctness of ARM constructor functions *)
-Section STRAIGHTLINE.
+Section CONSTRUCTORS.
Variable ge: genv.
-Variable fn: code.
-
-(** Straight-line code is composed of PPC instructions that execute
- in sequence (no branches, no function calls and returns).
- The following inductive predicate relates the machine states
- before and after executing a straight-line sequence of instructions.
- Instructions are taken from the first list instead of being fetched
- from memory. *)
-
-Inductive exec_straight: code -> regset -> mem ->
- code -> regset -> mem -> Prop :=
- | exec_straight_one:
- forall i1 c rs1 m1 rs2 m2,
- exec_instr ge fn i1 rs1 m1 = OK rs2 m2 ->
- rs2#PC = Val.add rs1#PC Vone ->
- exec_straight (i1 :: c) rs1 m1 c rs2 m2
- | exec_straight_step:
- forall i c rs1 m1 rs2 m2 c' rs3 m3,
- exec_instr ge fn i rs1 m1 = OK rs2 m2 ->
- rs2#PC = Val.add rs1#PC Vone ->
- exec_straight c rs2 m2 c' rs3 m3 ->
- exec_straight (i :: c) rs1 m1 c' rs3 m3.
-
-Lemma exec_straight_trans:
- forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3,
- exec_straight c1 rs1 m1 c2 rs2 m2 ->
- exec_straight c2 rs2 m2 c3 rs3 m3 ->
- exec_straight c1 rs1 m1 c3 rs3 m3.
-Proof.
- induction 1; intros.
- apply exec_straight_step with rs2 m2; auto.
- apply exec_straight_step with rs2 m2; auto.
-Qed.
-
-Lemma exec_straight_two:
- forall i1 i2 c rs1 m1 rs2 m2 rs3 m3,
- exec_instr ge fn i1 rs1 m1 = OK rs2 m2 ->
- exec_instr ge fn i2 rs2 m2 = OK rs3 m3 ->
- rs2#PC = Val.add rs1#PC Vone ->
- rs3#PC = Val.add rs2#PC Vone ->
- exec_straight (i1 :: i2 :: c) rs1 m1 c rs3 m3.
-Proof.
- intros. apply exec_straight_step with rs2 m2; auto.
- apply exec_straight_one; auto.
-Qed.
-
-Lemma exec_straight_three:
- forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4,
- exec_instr ge fn i1 rs1 m1 = OK rs2 m2 ->
- exec_instr ge fn i2 rs2 m2 = OK rs3 m3 ->
- exec_instr ge fn i3 rs3 m3 = OK rs4 m4 ->
- rs2#PC = Val.add rs1#PC Vone ->
- rs3#PC = Val.add rs2#PC Vone ->
- rs4#PC = Val.add rs3#PC Vone ->
- exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4.
-Proof.
- intros. apply exec_straight_step with rs2 m2; auto.
- eapply exec_straight_two; eauto.
-Qed.
-
-Lemma exec_straight_four:
- forall i1 i2 i3 i4 c rs1 m1 rs2 m2 rs3 m3 rs4 m4 rs5 m5,
- exec_instr ge fn i1 rs1 m1 = OK rs2 m2 ->
- exec_instr ge fn i2 rs2 m2 = OK rs3 m3 ->
- exec_instr ge fn i3 rs3 m3 = OK rs4 m4 ->
- exec_instr ge fn i4 rs4 m4 = OK rs5 m5 ->
- rs2#PC = Val.add rs1#PC Vone ->
- rs3#PC = Val.add rs2#PC Vone ->
- rs4#PC = Val.add rs3#PC Vone ->
- rs5#PC = Val.add rs4#PC Vone ->
- exec_straight (i1 :: i2 :: i3 :: i4 :: c) rs1 m1 c rs5 m5.
-Proof.
- intros. apply exec_straight_step with rs2 m2; auto.
- eapply exec_straight_three; eauto.
-Qed.
-
-(** * Correctness of ARM constructor functions *)
+Variable fn: function.
(** Decomposition of an integer constant *)
@@ -606,12 +196,12 @@ Lemma iterate_op_correct:
forall op1 op2 (f: val -> int -> val) (rs: regset) (r: ireg) m v0 n k,
(forall (rs:regset) n,
exec_instr ge fn (op2 (SOimm n)) rs m =
- OK (nextinstr (rs#r <- (f (rs#r) n))) m) ->
+ Next (nextinstr (rs#r <- (f (rs#r) n))) m) ->
(forall n,
exec_instr ge fn (op1 (SOimm n)) rs m =
- OK (nextinstr (rs#r <- (f v0 n))) m) ->
+ Next (nextinstr (rs#r <- (f v0 n))) m) ->
exists rs',
- exec_straight (iterate_op op1 op2 (decompose_int n) k) rs m k rs' m
+ exec_straight ge fn (iterate_op op1 op2 (decompose_int n) k) rs m k rs' m
/\ rs'#r = List.fold_left f (decompose_int n) v0
/\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'.
Proof.
@@ -623,8 +213,7 @@ Proof.
(* base case *)
intros; simpl. econstructor.
split. apply exec_straight_one. rewrite SEM1. reflexivity. reflexivity.
- split. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. auto.
- intros. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gso; auto with ppcgen.
+ intuition Simpl.
(* inductive case *)
intros.
rewrite List.map_app. simpl. rewrite app_ass. simpl.
@@ -632,9 +221,8 @@ Proof.
econstructor.
split. eapply exec_straight_trans. eexact A. apply exec_straight_one.
rewrite SEM2. reflexivity. reflexivity.
- split. rewrite fold_left_app; simpl. rewrite nextinstr_inv; auto with ppcgen.
- rewrite Pregmap.gss. rewrite B. auto.
- intros. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gso; auto with ppcgen.
+ split. rewrite fold_left_app; simpl. Simpl. rewrite B. auto.
+ intros; Simpl.
Qed.
(** Loading a constant. *)
@@ -642,7 +230,7 @@ Qed.
Lemma loadimm_correct:
forall r n k rs m,
exists rs',
- exec_straight (loadimm r n k) rs m k rs' m
+ exec_straight ge fn (loadimm r n k) rs m k rs' m
/\ rs'#r = Vint n
/\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'.
Proof.
@@ -667,7 +255,7 @@ Qed.
Lemma addimm_correct:
forall r1 r2 n k rs m,
exists rs',
- exec_straight (addimm r1 r2 n k) rs m k rs' m
+ exec_straight ge fn (addimm r1 r2 n k) rs m k rs' m
/\ rs'#r1 = Val.add rs#r2 (Vint n)
/\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
@@ -693,9 +281,8 @@ Qed.
Lemma andimm_correct:
forall r1 r2 n k rs m,
- r2 <> IR14 ->
exists rs',
- exec_straight (andimm r1 r2 n k) rs m k rs' m
+ exec_straight ge fn (andimm r1 r2 n k) rs m k rs' m
/\ rs'#r1 = Val.and rs#r2 (Vint n)
/\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
@@ -704,7 +291,7 @@ Proof.
case (is_immed_arith n).
exists (nextinstr (rs#r1 <- (Val.and rs#r2 (Vint n)))).
split. apply exec_straight_one; auto.
- split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
+ split. rewrite nextinstr_inv; auto with asmgen. apply Pregmap.gss.
intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
(* bic - bic* *)
replace (Val.and (rs r2) (Vint n))
@@ -720,7 +307,7 @@ Qed.
Lemma rsubimm_correct:
forall r1 r2 n k rs m,
exists rs',
- exec_straight (rsubimm r1 r2 n k) rs m k rs' m
+ exec_straight ge fn (rsubimm r1 r2 n k) rs m k rs' m
/\ rs'#r1 = Val.sub (Vint n) rs#r2
/\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
@@ -741,7 +328,7 @@ Qed.
Lemma orimm_correct:
forall r1 r2 n k rs m,
exists rs',
- exec_straight (orimm r1 r2 n k) rs m k rs' m
+ exec_straight ge fn (orimm r1 r2 n k) rs m k rs' m
/\ rs'#r1 = Val.or rs#r2 (Vint n)
/\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
@@ -760,7 +347,7 @@ Qed.
Lemma xorimm_correct:
forall r1 r2 n k rs m,
exists rs',
- exec_straight (xorimm r1 r2 n k) rs m k rs' m
+ exec_straight ge fn (xorimm r1 r2 n k) rs m k rs' m
/\ rs'#r1 = Val.xor rs#r2 (Vint n)
/\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
@@ -780,7 +367,7 @@ Lemma loadind_int_correct:
forall (base: ireg) ofs dst (rs: regset) m v k,
Mem.loadv Mint32 m (Val.add rs#base (Vint ofs)) = Some v ->
exists rs',
- exec_straight (loadind_int base ofs dst k) rs m k rs' m
+ exec_straight ge fn (loadind_int base ofs dst k) rs m k rs' m
/\ rs'#dst = v
/\ forall r, r <> PC -> r <> IR14 -> r <> dst -> rs'#r = rs#r.
Proof.
@@ -788,23 +375,21 @@ Proof.
exists (nextinstr (rs#dst <- v)).
split. apply exec_straight_one. simpl.
unfold exec_load. rewrite H. auto. auto.
- split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
- intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+ intuition Simpl.
exploit addimm_correct. intros [rs' [A [B C]]].
exists (nextinstr (rs'#dst <- v)).
split. eapply exec_straight_trans. eauto. apply exec_straight_one.
simpl. unfold exec_load. rewrite B.
rewrite Val.add_assoc. simpl. rewrite Int.add_zero.
rewrite H. auto. auto.
- split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
- intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+ intuition Simpl.
Qed.
Lemma loadind_float_correct:
forall (base: ireg) ofs dst (rs: regset) m v k,
Mem.loadv Mfloat64al32 m (Val.add rs#base (Vint ofs)) = Some v ->
exists rs',
- exec_straight (loadind_float base ofs dst k) rs m k rs' m
+ exec_straight ge fn (loadind_float base ofs dst k) rs m k rs' m
/\ rs'#dst = v
/\ forall r, r <> PC -> r <> IR14 -> r <> dst -> rs'#r = rs#r.
Proof.
@@ -812,33 +397,29 @@ Proof.
exists (nextinstr (rs#dst <- v)).
split. apply exec_straight_one. simpl.
unfold exec_load. rewrite H. auto. auto.
- split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
- intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+ intuition Simpl.
exploit addimm_correct. eauto. intros [rs' [A [B C]]].
exists (nextinstr (rs'#dst <- v)).
split. eapply exec_straight_trans. eauto. apply exec_straight_one.
simpl. unfold exec_load. rewrite B.
rewrite Val.add_assoc. simpl.
rewrite Int.add_zero. rewrite H. auto. auto.
- split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
- intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+ intuition Simpl.
Qed.
Lemma loadind_correct:
- forall (base: ireg) ofs ty dst k (rs: regset) m v,
+ forall (base: ireg) ofs ty dst k c (rs: regset) m v,
+ loadind base ofs ty dst k = OK c ->
Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v ->
- mreg_type dst = ty ->
exists rs',
- exec_straight (loadind base ofs ty dst k) rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ rs'#(preg_of dst) = v
/\ forall r, r <> PC -> r <> IR14 -> r <> preg_of dst -> rs'#r = rs#r.
Proof.
- intros. unfold loadind.
- assert (preg_of dst <> PC).
- unfold preg_of. case (mreg_type dst); discriminate.
- unfold preg_of. rewrite H0. destruct ty.
- apply loadind_int_correct; auto.
- apply loadind_float_correct; auto.
+ unfold loadind; intros.
+ destruct ty; monadInv H.
+ erewrite ireg_of_eq by eauto. apply loadind_int_correct; auto.
+ erewrite freg_of_eq by eauto. apply loadind_float_correct; auto.
Qed.
(** Indexed memory stores. *)
@@ -848,37 +429,36 @@ Lemma storeind_int_correct:
Mem.storev Mint32 m (Val.add rs#base (Vint ofs)) (rs#src) = Some m' ->
src <> IR14 ->
exists rs',
- exec_straight (storeind_int src base ofs k) rs m k rs' m'
+ exec_straight ge fn (storeind_int src base ofs k) rs m k rs' m'
/\ forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r.
Proof.
intros; unfold storeind_int. destruct (is_immed_mem_word ofs).
exists (nextinstr rs).
split. apply exec_straight_one. simpl.
unfold exec_store. rewrite H. auto. auto.
- intros. rewrite nextinstr_inv; auto.
+ intuition Simpl.
exploit addimm_correct. eauto. intros [rs' [A [B C]]].
exists (nextinstr rs').
split. eapply exec_straight_trans. eauto. apply exec_straight_one.
simpl. unfold exec_store. rewrite B.
rewrite C. rewrite Val.add_assoc. simpl. rewrite Int.add_zero.
rewrite H. auto.
- congruence. auto with ppcgen. auto.
- intros. rewrite nextinstr_inv; auto.
+ congruence. auto with asmgen. auto.
+ intuition Simpl.
Qed.
Lemma storeind_float_correct:
forall (base: ireg) ofs (src: freg) (rs: regset) m m' k,
Mem.storev Mfloat64al32 m (Val.add rs#base (Vint ofs)) (rs#src) = Some m' ->
- base <> IR14 ->
exists rs',
- exec_straight (storeind_float src base ofs k) rs m k rs' m'
+ exec_straight ge fn (storeind_float src base ofs k) rs m k rs' m'
/\ forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r.
Proof.
intros; unfold storeind_float. destruct (is_immed_mem_float ofs).
exists (nextinstr rs).
split. apply exec_straight_one. simpl.
unfold exec_store. rewrite H. auto. auto.
- intros. rewrite nextinstr_inv; auto.
+ intuition Simpl.
exploit addimm_correct. eauto. intros [rs' [A [B C]]].
exists (nextinstr rs').
split. eapply exec_straight_trans. eauto. apply exec_straight_one.
@@ -886,22 +466,23 @@ Proof.
rewrite C. rewrite Val.add_assoc. simpl. rewrite Int.add_zero.
rewrite H. auto.
congruence. congruence.
- auto with ppcgen.
- intros. rewrite nextinstr_inv; auto.
+ auto with asmgen.
+ intuition Simpl.
Qed.
Lemma storeind_correct:
- forall (base: ireg) ofs ty src k (rs: regset) m m',
+ forall (base: ireg) ofs ty src k c (rs: regset) m m',
+ storeind src base ofs ty k = OK c ->
Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' ->
- mreg_type src = ty ->
- base <> IR14 ->
exists rs',
- exec_straight (storeind src base ofs ty k) rs m k rs' m'
+ exec_straight ge fn c rs m k rs' m'
/\ forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r.
Proof.
- intros. unfold storeind. unfold preg_of in H. rewrite H0 in H. destruct ty.
- apply storeind_int_correct. auto. auto. auto with ppcgen.
- apply storeind_float_correct. auto. auto.
+ unfold storeind; intros.
+ destruct ty; monadInv H.
+ erewrite ireg_of_eq in H0 by eauto. apply storeind_int_correct; auto.
+ assert (IR x <> IR IR14) by eauto with asmgen. congruence.
+ erewrite freg_of_eq in H0 by eauto. apply storeind_float_correct; auto.
Qed.
(** Translation of shift immediates *)
@@ -935,11 +516,10 @@ Lemma compare_int_spec:
/\ rs1#CRlt = (Val.cmp Clt v1 v2)
/\ rs1#CRgt = (Val.cmp Cgt v1 v2)
/\ rs1#CRle = (Val.cmp Cle v1 v2)
- /\ forall r', important_preg r' = true -> rs1#r' = rs#r'.
+ /\ forall r', data_preg r' = true -> rs1#r' = rs#r'.
Proof.
- intros. unfold rs1. intuition; try reflexivity.
- rewrite nextinstr_inv; auto with ppcgen.
- unfold compare_int. repeat rewrite Pregmap.gso; auto with ppcgen.
+ intros. unfold rs1. intuition; try reflexivity.
+ unfold compare_int. Simpl.
Qed.
Lemma compare_float_spec:
@@ -955,43 +535,43 @@ Lemma compare_float_spec:
/\ rs'#CRlt = (Val.notbool (Val.cmpf Cge v1 v2))
/\ rs'#CRgt = (Val.cmpf Cgt v1 v2)
/\ rs'#CRle = (Val.notbool (Val.cmpf Cgt v1 v2))
- /\ forall r', important_preg r' = true -> rs'#r' = rs#r'.
-Proof.
- intros. unfold rs'. intuition; try reflexivity.
- rewrite nextinstr_inv; auto with ppcgen.
- unfold compare_float. repeat rewrite Pregmap.gso; auto with ppcgen.
-Qed.
-
-Ltac TypeInv1 :=
- match goal with
- | H: (List.map ?f ?x = nil) |- _ =>
- destruct x; inv H; TypeInv1
- | H: (List.map ?f ?x = ?hd :: ?tl) |- _ =>
- destruct x; simpl in H; simplify_eq H; clear H; intros; TypeInv1
- | _ => idtac
- end.
-
-Ltac TypeInv2 :=
- match goal with
- | H: (mreg_type _ = Tint) |- _ => try (rewrite H in *); clear H; TypeInv2
- | H: (mreg_type _ = Tfloat) |- _ => try (rewrite H in *); clear H; TypeInv2
- | _ => idtac
- end.
-
-Ltac TypeInv := TypeInv1; simpl in *; unfold preg_of in *; TypeInv2.
+ /\ forall r', data_preg r' = true -> rs'#r' = rs#r'.
+Proof.
+ intros. unfold rs'. intuition; try reflexivity.
+ unfold compare_float. Simpl.
+Qed.
+
+Definition lock {A: Type} (x: A) := x.
+
+Ltac ArgsInv :=
+ repeat (match goal with
+ | [ H: Error _ = OK _ |- _ ] => discriminate
+ | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args
+ | [ H: bind _ _ = OK _ |- _ ] => monadInv H
+ | [ H: assertion _ = OK _ |- _ ] => monadInv H
+ end);
+ subst;
+ repeat (match goal with
+ | [ H: ireg_of ?x = OK ?y |- _ ] =>
+ simpl in *; rewrite (ireg_of_eq _ _ H) in *
+(*; change H with (lock (ireg_of x) = OK y)*)
+ | [ H: freg_of ?x = OK ?y |- _ ] =>
+ simpl in *; rewrite (freg_of_eq _ _ H) in *
+(*; change H with (lock (freg_of x) = OK y)*)
+ end).
Lemma transl_cond_correct:
- forall cond args k rs m,
- map mreg_type args = type_of_condition cond ->
+ forall cond args k rs m c,
+ transl_cond cond args k = OK c ->
exists rs',
- exec_straight (transl_cond cond args k) rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ match eval_condition cond (map rs (map preg_of args)) m with
| Some b => rs'#(CR (crbit_for_cond cond)) = Val.of_bool b
| None => True
end
- /\ forall r, important_preg r = true -> rs'#r = rs r.
+ /\ forall r, data_preg r = true -> rs'#r = rs r.
Proof.
- intros until m; intros TY.
+ intros until c; intros TR.
assert (MATCH: forall v ob,
v = Val.of_optbool ob ->
match ob with Some b => v = Val.of_bool b | None => True end).
@@ -1006,268 +586,251 @@ Proof.
intros. destruct v1; simpl; auto; destruct v2; simpl; auto.
unfold Val.cmpu, Val.cmpu_bool in H. subst v. destruct H0; subst cmp; auto.
- destruct cond; simpl in TY; TypeInv; simpl.
- (* Ccomp *)
- generalize (compare_int_spec rs (rs (ireg_of m0)) (rs (ireg_of m1)) m).
- intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
+ unfold transl_cond in TR; destruct cond; ArgsInv.
+- (* Ccomp *)
+ generalize (compare_int_spec rs (rs x) (rs x0) m).
+ intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
econstructor.
split. apply exec_straight_one. simpl. eauto. auto.
- split. destruct c; (apply MATCH; assumption) || (apply MATCH2; auto).
+ split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
auto.
- (* Ccompu *)
- generalize (compare_int_spec rs (rs (ireg_of m0)) (rs (ireg_of m1)) m).
- intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
+- (* Ccompu *)
+ generalize (compare_int_spec rs (rs x) (rs x0) m).
+ intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
econstructor.
split. apply exec_straight_one. simpl. eauto. auto.
- split. destruct c; apply MATCH; assumption.
+ split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
auto.
- (* Ccompshift *)
- generalize (compare_int_spec rs (rs (ireg_of m0)) (eval_shift s (rs (ireg_of m1))) m).
- intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
+- (* Ccompshift *)
+ generalize (compare_int_spec rs (rs x) (eval_shift s (rs x0)) m).
+ intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
econstructor.
split. apply exec_straight_one. simpl. eauto. auto.
- split. rewrite transl_shift_correct. destruct c; (apply MATCH; assumption) || (apply MATCH2; auto).
- rewrite transl_shift_correct. auto.
- (* Ccompushift *)
- generalize (compare_int_spec rs (rs (ireg_of m0)) (eval_shift s (rs (ireg_of m1))) m).
- intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
+ rewrite transl_shift_correct.
+ split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
+ auto.
+- (* Ccompushift *)
+ generalize (compare_int_spec rs (rs x) (eval_shift s (rs x0)) m).
+ intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
econstructor.
split. apply exec_straight_one. simpl. eauto. auto.
- split. rewrite transl_shift_correct. destruct c; apply MATCH; assumption.
- rewrite transl_shift_correct. auto.
- (* Ccompimm *)
+ rewrite transl_shift_correct.
+ split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
+ auto.
+- (* Ccompimm *)
destruct (is_immed_arith i).
- generalize (compare_int_spec rs (rs (ireg_of m0)) (Vint i) m).
- intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
+ generalize (compare_int_spec rs (rs x) (Vint i) m).
+ intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
econstructor.
split. apply exec_straight_one. simpl. eauto. auto.
- split. destruct c; (apply MATCH; assumption) || (apply MATCH2; auto).
+ split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
auto.
exploit (loadimm_correct IR14). intros [rs' [P [Q R]]].
- generalize (compare_int_spec rs' (rs (ireg_of m0)) (Vint i) m).
- intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
+ generalize (compare_int_spec rs' (rs x) (Vint i) m).
+ intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
econstructor.
split. eapply exec_straight_trans. eexact P. apply exec_straight_one. simpl.
- rewrite Q. rewrite R; eauto with ppcgen. auto.
- split. destruct c; (apply MATCH; assumption) || (apply MATCH2; auto).
- intros. rewrite K; auto with ppcgen.
- (* Ccompuimm *)
+ rewrite Q. rewrite R; eauto with asmgen. auto.
+ split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
+ intros. rewrite C; auto with asmgen.
+- (* Ccompuimm *)
destruct (is_immed_arith i).
- generalize (compare_int_spec rs (rs (ireg_of m0)) (Vint i) m).
- intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
+ generalize (compare_int_spec rs (rs x) (Vint i) m).
+ intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
econstructor.
split. apply exec_straight_one. simpl. eauto. auto.
- split. destruct c; apply MATCH; assumption.
+ split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
auto.
exploit (loadimm_correct IR14). intros [rs' [P [Q R]]].
- generalize (compare_int_spec rs' (rs (ireg_of m0)) (Vint i) m).
- intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
+ generalize (compare_int_spec rs' (rs x) (Vint i) m).
+ intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
econstructor.
split. eapply exec_straight_trans. eexact P. apply exec_straight_one. simpl.
- rewrite Q. rewrite R; eauto with ppcgen. auto.
- split. destruct c; apply MATCH; assumption.
- intros. rewrite K; auto with ppcgen.
- (* Ccompf *)
- generalize (compare_float_spec rs (rs (freg_of m0)) (rs (freg_of m1))).
- intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
+ rewrite Q. rewrite R; eauto with asmgen. auto.
+ split. destruct c0; (apply MATCH; assumption) || (apply MATCH2; auto).
+ intros. rewrite C; auto with asmgen.
+- (* Ccompf *)
+ generalize (compare_float_spec rs (rs x) (rs x0)).
+ intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
econstructor.
split. apply exec_straight_one. simpl. eauto. auto.
- split. case c; apply MATCH; assumption.
+ split. case c0; apply MATCH; assumption.
auto.
- (* Cnotcompf *)
- generalize (compare_float_spec rs (rs (freg_of m0)) (rs (freg_of m1))).
- intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
+- (* Cnotcompf *)
+ generalize (compare_float_spec rs (rs x) (rs x0)).
+ intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
econstructor.
split. apply exec_straight_one. simpl. eauto. auto.
- split. rewrite <- Val.negate_cmpf_ne in B. rewrite <- Val.negate_cmpf_eq in A.
- destruct c; apply MATCH; simpl; rewrite Val.notbool_negb_3; auto.
+ split. rewrite <- Val.negate_cmpf_ne in C2. rewrite <- Val.negate_cmpf_eq in C1.
+ destruct c0; apply MATCH; simpl; rewrite Val.notbool_negb_3; auto.
auto.
- (* Ccompfzero *)
- generalize (compare_float_spec rs (rs (freg_of m0)) (Vfloat Float.zero)).
- intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
+- (* Ccompfzero *)
+ generalize (compare_float_spec rs (rs x) (Vfloat Float.zero)).
+ intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
econstructor.
split. apply exec_straight_one. simpl. eauto. auto.
- split. case c; apply MATCH; assumption.
+ split. case c0; apply MATCH; assumption.
auto.
- (* Cnotcompf *)
- generalize (compare_float_spec rs (rs (freg_of m0)) (Vfloat Float.zero)).
- intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
+- (* Cnotcompf *)
+ generalize (compare_float_spec rs (rs x) (Vfloat Float.zero)).
+ intros (C1 & C2 & C3 & C4 & C5 & C6 & C7 & C8 & C9 & C10 & C).
econstructor.
split. apply exec_straight_one. simpl. eauto. auto.
- split. rewrite <- Val.negate_cmpf_ne in B. rewrite <- Val.negate_cmpf_eq in A.
- destruct c; apply MATCH; simpl; rewrite Val.notbool_negb_3; auto.
+ split. rewrite <- Val.negate_cmpf_ne in C2. rewrite <- Val.negate_cmpf_eq in C1.
+ destruct c0; apply MATCH; simpl; rewrite Val.notbool_negb_3; auto.
auto.
Qed.
(** Translation of arithmetic operations. *)
-Ltac Simpl :=
- match goal with
- | [ |- context[nextinstr _ _] ] => rewrite nextinstr_inv; [auto | auto with ppcgen]
- | [ |- context[Pregmap.get ?x (Pregmap.set ?x _ _)] ] => rewrite Pregmap.gss; auto
- | [ |- context[Pregmap.set ?x _ _ ?x] ] => rewrite Pregmap.gss; auto
- | [ |- context[Pregmap.get _ (Pregmap.set _ _ _)] ] => rewrite Pregmap.gso; [auto | auto with ppcgen]
- | [ |- context[Pregmap.set _ _ _ _] ] => rewrite Pregmap.gso; [auto | auto with ppcgen]
- end.
-
Ltac TranslOpSimpl :=
econstructor; split;
[ apply exec_straight_one; [simpl; eauto | reflexivity ]
| split; [try rewrite transl_shift_correct; repeat Simpl | intros; repeat Simpl] ].
Lemma transl_op_correct_same:
- forall op args res k (rs: regset) m v,
- wt_instr (Mop op args res) ->
+ forall op args res k c (rs: regset) m v,
+ transl_op op args res k = OK c ->
eval_operation ge rs#IR13 op (map rs (map preg_of args)) m = Some v ->
match op with Ocmp _ => False | _ => True end ->
exists rs',
- exec_straight (transl_op op args res k) rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ rs'#(preg_of res) = v
- /\ forall r, important_preg r = true -> r <> preg_of res -> rs'#r = rs#r.
+ /\ forall r, data_preg r = true -> r <> preg_of res -> rs'#r = rs#r.
Proof.
- intros. inv H.
+ intros until v; intros TR EV NOCMP.
+ unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; inv EV; try (TranslOpSimpl; fail).
(* Omove *)
- simpl in *. inv H0.
- exists (nextinstr (rs#(preg_of res) <- (rs#(preg_of r1)))).
- split. unfold preg_of; rewrite <- H3.
- destruct (mreg_type r1); apply exec_straight_one; auto.
- split. Simpl. Simpl.
- intros. Simpl. Simpl.
- (* Other instructions *)
- destruct op; simpl in H6; inv H6; TypeInv; simpl in H0; inv H0; try (TranslOpSimpl; fail).
+ exists (nextinstr (rs#(preg_of res) <- (rs#(preg_of m0)))).
+ split.
+ destruct (preg_of res) eqn:RES; try discriminate;
+ destruct (preg_of m0) eqn:ARG; inv TR.
+ apply exec_straight_one; auto.
+ apply exec_straight_one; auto.
+ intuition Simpl.
(* Ointconst *)
- generalize (loadimm_correct (ireg_of res) i k rs m). intros [rs' [A [B C]]].
- exists rs'. split. auto. split. rewrite B; auto. intros. auto with ppcgen.
+ generalize (loadimm_correct x i k rs m). intros [rs' [A [B C]]].
+ exists rs'; auto with asmgen.
(* Oaddrstack *)
- generalize (addimm_correct (ireg_of res) IR13 i k rs m).
+ generalize (addimm_correct x IR13 i k rs m).
intros [rs' [EX [RES OTH]]].
- exists rs'. split. auto. split. auto. auto with ppcgen.
+ exists rs'; auto with asmgen.
(* Oaddimm *)
- generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m).
+ generalize (addimm_correct x x0 i k rs m).
intros [rs' [A [B C]]].
- exists rs'. split. auto. split. auto. auto with ppcgen.
+ exists rs'; auto with asmgen.
(* Orsbimm *)
- generalize (rsubimm_correct (ireg_of res) (ireg_of m0) i k rs m).
+ generalize (rsubimm_correct x x0 i k rs m).
intros [rs' [A [B C]]].
- exists rs'.
- split. eauto. split. rewrite B. auto.
- auto with ppcgen.
+ exists rs'; auto with asmgen.
(* Omul *)
- destruct (ireg_eq (ireg_of res) (ireg_of m0) || ireg_eq (ireg_of res) (ireg_of m1)).
+ destruct (ireg_eq x x0 || ireg_eq x x1).
econstructor; split.
eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto.
- split. repeat Simpl.
- intros. repeat Simpl.
+ intuition Simpl.
TranslOpSimpl.
(* divs *)
- econstructor. split. apply exec_straight_one. simpl. rewrite H2. reflexivity. auto.
- split. repeat Simpl. intros. repeat Simpl.
+ econstructor. split. apply exec_straight_one. simpl. rewrite H0. reflexivity. auto.
+ intuition Simpl.
(* divu *)
- econstructor. split. apply exec_straight_one. simpl. rewrite H2. reflexivity. auto.
- split. repeat Simpl. intros. repeat Simpl.
+ econstructor. split. apply exec_straight_one. simpl. rewrite H0. reflexivity. auto.
+ intuition Simpl.
(* Oandimm *)
- generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m
- (ireg_of_not_IR14 m0)).
+ generalize (andimm_correct x x0 i k rs m).
intros [rs' [A [B C]]].
- exists rs'; auto with ppcgen.
+ exists rs'; auto with asmgen.
(* Oorimm *)
- generalize (orimm_correct (ireg_of res) (ireg_of m0) i k rs m).
+ generalize (orimm_correct x x0 i k rs m).
intros [rs' [A [B C]]].
- exists rs'; auto with ppcgen.
+ exists rs'; auto with asmgen.
(* Oxorimm *)
- generalize (xorimm_correct (ireg_of res) (ireg_of m0) i k rs m).
+ generalize (xorimm_correct x x0 i k rs m).
intros [rs' [A [B C]]].
- exists rs'; auto with ppcgen.
+ exists rs'; auto with asmgen.
(* Oshrximm *)
exploit Val.shrx_shr; eauto. intros [n [i' [ARG1 [ARG2 RES]]]].
injection ARG2; intro ARG2'; subst i'; clear ARG2.
set (islt := Int.lt n Int.zero) in *.
set (rs1 := nextinstr (compare_int rs (Vint n) (Vint Int.zero) m)).
- assert (OTH1: forall r', important_preg r' = true -> rs1#r' = rs#r').
+ assert (OTH1: forall r', data_preg r' = true -> rs1#r' = rs#r').
generalize (compare_int_spec rs (Vint n) (Vint Int.zero) m).
fold rs1. intros [A B]. intuition.
- exploit (addimm_correct IR14 (ireg_of m0) (Int.sub (Int.shl Int.one i) Int.one)).
+ exploit (addimm_correct IR14 x0 (Int.sub (Int.shl Int.one i) Int.one)).
intros [rs2 [EXEC2 [RES2 OTH2]]].
set (rs3 := nextinstr (if islt then rs2 else rs2#IR14 <- (Vint n))).
- set (rs4 := nextinstr (rs3#(ireg_of res) <- (Val.shr rs3#IR14 (Vint i)))).
+ set (rs4 := nextinstr (rs3#x <- (Val.shr rs3#IR14 (Vint i)))).
exists rs4; split.
apply exec_straight_step with rs1 m.
simpl. rewrite ARG1. auto. auto.
eapply exec_straight_trans. eexact EXEC2.
apply exec_straight_two with rs3 m.
- simpl. rewrite OTH2. change (rs1 CRge) with (Val.cmp Cge (Vint n) (Vint Int.zero)).
+ simpl. rewrite OTH2; eauto with asmgen.
+ change (rs1 CRge) with (Val.cmp Cge (Vint n) (Vint Int.zero)).
unfold Val.cmp, Val.cmp_bool. change (Int.cmp Cge n Int.zero) with (negb islt).
- rewrite OTH2. rewrite OTH1. rewrite ARG1.
+ rewrite OTH2; eauto with asmgen. rewrite OTH1. rewrite ARG1.
unfold rs3. case islt; reflexivity.
- destruct m0; reflexivity. auto with ppcgen. auto with ppcgen. discriminate. discriminate.
- simpl. auto.
- auto. unfold rs3. case islt; auto. auto.
- split. unfold rs4. repeat Simpl. unfold rs3. Simpl. destruct islt.
- rewrite RES2. change (rs1 (IR (ireg_of m0))) with (rs (IR (ireg_of m0))). auto.
- Simpl. rewrite <- ARG1; auto.
- intros. unfold rs4; repeat Simpl. unfold rs3; repeat Simpl.
- transitivity (rs2 r). destruct islt; auto. Simpl.
- rewrite OTH2; auto with ppcgen.
+ rewrite <- (ireg_of_eq _ _ EQ1). auto with asmgen.
+ auto.
+ unfold rs3. destruct islt; auto. auto.
+ split. unfold rs4; Simpl. unfold rs3. destruct islt.
+ Simpl. rewrite RES2. unfold rs1. Simpl.
+ Simpl. congruence.
+ intros. unfold rs4, rs3; Simpl. destruct islt; Simpl; rewrite OTH2; auto with asmgen.
(* intoffloat *)
- econstructor; split. apply exec_straight_one; simpl. rewrite H2; simpl. eauto. auto.
- split; intros; repeat Simpl.
+ econstructor; split. apply exec_straight_one; simpl. rewrite H0; simpl. eauto. auto.
+ intuition Simpl.
(* intuoffloat *)
- econstructor; split. apply exec_straight_one; simpl. rewrite H2; simpl. eauto. auto.
- split; intros; repeat Simpl.
+ econstructor; split. apply exec_straight_one; simpl. rewrite H0; simpl. eauto. auto.
+ intuition Simpl.
(* floatofint *)
- econstructor; split. apply exec_straight_one; simpl. rewrite H2; simpl. eauto. auto.
- split; intros; repeat Simpl.
+ econstructor; split. apply exec_straight_one; simpl. rewrite H0; simpl. eauto. auto.
+ intuition Simpl.
(* floatofintu *)
- econstructor; split. apply exec_straight_one; simpl. rewrite H2; simpl. eauto. auto.
- split; intros; repeat Simpl.
+ econstructor; split. apply exec_straight_one; simpl. rewrite H0; simpl. eauto. auto.
+ intuition Simpl.
(* Ocmp *)
contradiction.
Qed.
Lemma transl_op_correct:
- forall op args res k (rs: regset) m v,
- wt_instr (Mop op args res) ->
+ forall op args res k c (rs: regset) m v,
+ transl_op op args res k = OK c ->
eval_operation ge rs#IR13 op (map rs (map preg_of args)) m = Some v ->
exists rs',
- exec_straight (transl_op op args res k) rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ Val.lessdef v rs'#(preg_of res)
- /\ forall r, important_preg r = true -> r <> preg_of res -> rs'#r = rs#r.
+ /\ forall r, data_preg r = true -> r <> preg_of res -> rs'#r = rs#r.
Proof.
intros.
assert (EITHER: match op with Ocmp _ => False | _ => True end \/ exists cmp, op = Ocmp cmp).
- destruct op; auto. right; exists c; auto.
- destruct EITHER as [A | [c A]].
+ destruct op; auto. right; exists c0; auto.
+ destruct EITHER as [A | [cmp A]].
exploit transl_op_correct_same; eauto. intros [rs' [P [Q R]]].
subst v. exists rs'; eauto.
(* Ocmp *)
- subst op. inv H. simpl in H5. inv H5. simpl in H0. inv H0.
- destruct (transl_cond_correct c args
- (Pmov (ireg_of res) (SOimm Int.zero)
- :: Pmovc (crbit_for_cond c) (ireg_of res) (SOimm Int.one) :: k)
- rs m H1)
- as [rs1 [A [B C]]].
- set (rs2 := nextinstr (rs1#(ireg_of res) <- (Vint Int.zero))).
- set (v := match rs2#(crbit_for_cond c) with
- | Vint n => if Int.eq n Int.zero then Vint Int.zero else Vint Int.one
- | _ => Vundef
- end).
- set (rs3 := nextinstr (rs2#(ireg_of res) <- v)).
+ subst op. simpl in H. monadInv H. simpl in H0. inv H0.
+ rewrite (ireg_of_eq _ _ EQ).
+ exploit transl_cond_correct; eauto. instantiate (1 := rs). instantiate (1 := m). intros [rs1 [A [B C]]].
+ set (rs2 := nextinstr (rs1#x <- (Vint Int.zero))).
+ set (rs3 := nextinstr (match rs2#(crbit_for_cond cmp) with
+ | Vint n => if Int.eq n Int.zero then rs2 else rs2#x <- Vone
+ | _ => rs2#x <- Vundef
+ end)).
exists rs3; split.
- eapply exec_straight_trans. eauto.
- apply exec_straight_two with rs2 m; auto.
- simpl. unfold rs3, v.
- destruct (rs2 (crbit_for_cond c)) eqn:?; auto.
- destruct (Int.eq i Int.zero); auto.
- decEq. decEq. apply extensionality; intros. unfold Pregmap.set.
- destruct (PregEq.eq x (ireg_of res)); auto. subst.
- unfold rs2. Simpl. Simpl.
- replace (preg_of res) with (IR (ireg_of res)).
- split. unfold rs3. Simpl. Simpl.
- destruct (eval_condition c rs ## (preg_of ## args) m); simpl; auto.
- unfold v. unfold rs2. Simpl. Simpl. rewrite B.
- destruct b; simpl; auto.
- intros. unfold rs3. repeat Simpl. unfold rs2. repeat Simpl.
- unfold preg_of; rewrite H2; auto.
+ eapply exec_straight_trans. eexact A. apply exec_straight_two with rs2 m.
+ auto.
+ simpl. unfold rs3. destruct (rs2 (crbit_for_cond cmp)); auto. destruct (Int.eq i Int.zero); auto.
+ auto. unfold rs3. destruct (rs2 (crbit_for_cond cmp)); auto. destruct (Int.eq i Int.zero); auto.
+ split. unfold rs3. Simpl.
+ replace (rs2 (crbit_for_cond cmp)) with (rs1 (crbit_for_cond cmp)).
+ destruct (eval_condition cmp rs##(preg_of##args) m) as [[]|]; simpl in *.
+ rewrite B. simpl. Simpl.
+ rewrite B. simpl. unfold rs2. Simpl.
+ auto.
+ destruct cmp; reflexivity.
+ intros. transitivity (rs2 r).
+ unfold rs3. destruct (rs2 (crbit_for_cond cmp)); Simpl. destruct (Int.eq i Int.zero); auto; Simpl.
+ unfold rs2. Simpl.
Qed.
Remark val_add_add_zero:
@@ -1276,43 +839,40 @@ Proof.
intros. destruct v1; destruct v2; simpl; auto; rewrite Int.add_zero; auto.
Qed.
-Lemma transl_load_store_correct:
- forall (mk_instr_imm: ireg -> int -> instruction)
+Lemma transl_memory_access_correct:
+ forall (P: regset -> Prop) (mk_instr_imm: ireg -> int -> instruction)
(mk_instr_gen: option (ireg -> shift_addr -> instruction))
(is_immed: int -> bool)
- addr args k ms sp rs m ms' m',
+ addr args k c (rs: regset) a m m',
+ transl_memory_access mk_instr_imm mk_instr_gen is_immed addr args k = OK c ->
+ eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
(forall (r1: ireg) (rs1: regset) n k,
- eval_addressing ge sp addr (map rs (map preg_of args)) = Some(Val.add rs1#r1 (Vint n)) ->
+ Val.add rs1#r1 (Vint n) = a ->
(forall (r: preg), r <> PC -> r <> IR14 -> rs1 r = rs r) ->
exists rs',
- exec_straight (mk_instr_imm r1 n :: k) rs1 m k rs' m' /\
- agree ms' sp rs') ->
+ exec_straight ge fn (mk_instr_imm r1 n :: k) rs1 m k rs' m' /\ P rs') ->
match mk_instr_gen with
| None => True
| Some mk =>
(forall (r1: ireg) (sa: shift_addr) (rs1: regset) k,
- eval_addressing ge sp addr (map rs (map preg_of args)) = Some(Val.add rs1#r1 (eval_shift_addr sa rs1)) ->
+ Val.add rs1#r1 (eval_shift_addr sa rs1) = a ->
(forall (r: preg), r <> PC -> r <> IR14 -> rs1 r = rs r) ->
exists rs',
- exec_straight (mk r1 sa :: k) rs1 m k rs' m' /\
- agree ms' sp rs')
+ exec_straight ge fn (mk r1 sa :: k) rs1 m k rs' m' /\ P rs')
end ->
- agree ms sp rs ->
- map mreg_type args = type_of_addressing addr ->
exists rs',
- exec_straight (transl_load_store mk_instr_imm mk_instr_gen is_immed addr args k) rs m
- k rs' m'
- /\ agree ms' sp rs'.
+ exec_straight ge fn c rs m k rs' m' /\ P rs'.
Proof.
- intros. destruct addr; simpl in H2; TypeInv; simpl.
+ intros until m'; intros TR EA MK1 MK2.
+ unfold transl_memory_access in TR; destruct addr; ArgsInv; simpl in EA; inv EA.
(* Aindexed *)
case (is_immed i).
(* Aindexed, small displacement *)
- apply H; auto.
+ apply MK1; auto.
(* Aindexed, large displacement *)
- destruct (addimm_correct IR14 (ireg_of m0) i (mk_instr_imm IR14 Int.zero :: k) rs m)
+ destruct (addimm_correct IR14 x i (mk_instr_imm IR14 Int.zero :: k) rs m)
as [rs' [A [B C]]].
- exploit (H IR14 rs' Int.zero); eauto.
+ exploit (MK1 IR14 rs' Int.zero); eauto.
rewrite B. rewrite Val.add_assoc. simpl Val.add. rewrite Int.add_zero. reflexivity.
intros [rs'' [D E]].
exists rs''; split.
@@ -1320,13 +880,12 @@ Proof.
(* Aindexed2 *)
destruct mk_instr_gen as [mk | ].
(* binary form available *)
- apply H0; auto.
+ apply MK2; auto.
(* binary form not available *)
- set (rs' := nextinstr (rs#IR14 <- (Val.add (rs (ireg_of m0)) (rs (ireg_of m1))))).
- exploit (H IR14 rs' Int.zero); eauto.
- unfold rs'. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
- decEq. apply val_add_add_zero.
- unfold rs'. intros. repeat Simpl.
+ set (rs' := nextinstr (rs#IR14 <- (Val.add (rs x) (rs x0)))).
+ exploit (MK1 IR14 rs' Int.zero); eauto.
+ unfold rs'. Simpl. symmetry. apply val_add_add_zero.
+ intros. unfold rs'. Simpl.
intros [rs'' [A B]].
exists rs''; split.
eapply exec_straight_step with (rs2 := rs'); eauto.
@@ -1334,189 +893,172 @@ Proof.
(* Aindexed2shift *)
destruct mk_instr_gen as [mk | ].
(* binary form available *)
- apply H0; auto. rewrite transl_shift_addr_correct. auto.
+ apply MK2; auto. rewrite transl_shift_addr_correct. auto.
(* binary form not available *)
- set (rs' := nextinstr (rs#IR14 <- (Val.add (rs (ireg_of m0)) (eval_shift s (rs (ireg_of m1)))))).
- exploit (H IR14 rs' Int.zero); eauto.
- unfold rs'. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
- decEq. apply val_add_add_zero.
- unfold rs'; intros; repeat Simpl.
+ set (rs' := nextinstr (rs#IR14 <- (Val.add (rs x) (eval_shift s (rs x0))))).
+ exploit (MK1 IR14 rs' Int.zero); eauto.
+ unfold rs'. Simpl. symmetry. apply val_add_add_zero.
+ intros; unfold rs'; Simpl.
intros [rs'' [A B]].
exists rs''; split.
eapply exec_straight_step with (rs2 := rs'); eauto.
simpl. rewrite transl_shift_correct. auto.
auto.
(* Ainstack *)
- destruct (is_immed i).
+ destruct (is_immed i); inv TR.
(* Ainstack, short displacement *)
- apply H; auto. rewrite (sp_val _ _ _ H1). auto.
+ apply MK1; auto.
(* Ainstack, large displacement *)
destruct (addimm_correct IR14 IR13 i (mk_instr_imm IR14 Int.zero :: k) rs m)
as [rs' [A [B C]]].
- exploit (H IR14 rs' Int.zero); eauto.
- rewrite (sp_val _ _ _ H1). rewrite B. rewrite Val.add_assoc. simpl Val.add. rewrite Int.add_zero. auto.
+ exploit (MK1 IR14 rs' Int.zero); eauto.
+ rewrite B. rewrite Val.add_assoc. f_equal. simpl. rewrite Int.add_zero; auto.
intros [rs'' [D E]].
exists rs''; split.
eapply exec_straight_trans. eexact A. eexact D. auto.
Qed.
Lemma transl_load_int_correct:
- forall (mk_instr: ireg -> ireg -> shift_addr -> instruction)
- (is_immed: int -> bool)
- (rd: mreg) addr args k ms sp rs m m' chunk a v,
- (forall (c: code) (r1 r2: ireg) (sa: shift_addr) (rs1: regset),
- exec_instr ge c (mk_instr r1 r2 sa) rs1 m' =
- exec_load chunk (Val.add rs1#r2 (eval_shift_addr sa rs1)) r1 rs1 m') ->
- agree ms sp rs ->
- map mreg_type args = type_of_addressing addr ->
- mreg_type rd = Tint ->
- eval_addressing ge sp addr (map ms args) = Some a ->
+ forall mk_instr is_immed dst addr args k c (rs: regset) a chunk m v,
+ transl_memory_access_int mk_instr is_immed dst addr args k = OK c ->
+ eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
Mem.loadv chunk m a = Some v ->
- Mem.extends m m' ->
+ (forall (r1 r2: ireg) (sa: shift_addr) (rs1: regset),
+ exec_instr ge fn (mk_instr r1 r2 sa) rs1 m =
+ exec_load chunk (Val.add rs1#r2 (eval_shift_addr sa rs1)) r1 rs1 m) ->
exists rs',
- exec_straight (transl_load_store_int mk_instr is_immed rd addr args k) rs m'
- k rs' m'
- /\ agree (Regmap.set rd v (undef_temps ms)) sp rs'.
+ exec_straight ge fn c rs m k rs' m
+ /\ rs'#(preg_of dst) = v
+ /\ forall r, nontemp_preg r = true -> r <> preg_of dst -> rs'#r = rs#r.
Proof.
- intros. unfold transl_load_store_int.
- exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto.
- unfold PregEq.t.
- intros [a' [A B]].
- exploit Mem.loadv_extends; eauto. intros [v' [C D]].
- apply transl_load_store_correct with ms; auto.
- intros.
- assert (Val.add (rs1 r1) (Vint n) = a') by congruence.
- exists (nextinstr (rs1#(ireg_of rd) <- v')); split.
- apply exec_straight_one. rewrite H. unfold exec_load.
- simpl. rewrite H8. rewrite C. auto. auto.
- apply agree_nextinstr. eapply agree_set_undef_mreg; eauto.
- unfold preg_of. rewrite H2. rewrite Pregmap.gss. auto.
- unfold preg_of. rewrite H2. intros. rewrite Pregmap.gso; auto. apply H7; auto with ppcgen.
- intros.
- assert (Val.add (rs1 r1) (eval_shift_addr sa rs1) = a') by congruence.
- exists (nextinstr (rs1#(ireg_of rd) <- v')); split.
- apply exec_straight_one. rewrite H. unfold exec_load.
- simpl. rewrite H8. rewrite C. auto. auto.
- apply agree_nextinstr. eapply agree_set_undef_mreg; eauto.
- unfold preg_of. rewrite H2. rewrite Pregmap.gss. auto.
- unfold preg_of. rewrite H2. intros. rewrite Pregmap.gso; auto. apply H7; auto with ppcgen.
+ intros. monadInv H. erewrite ireg_of_eq by eauto.
+ eapply transl_memory_access_correct; eauto.
+ intros; simpl. econstructor; split. apply exec_straight_one.
+ rewrite H2. unfold exec_load. simpl eval_shift_addr. rewrite H. rewrite H1. eauto. auto.
+ split. Simpl. intros; Simpl.
+ simpl; intros.
+ econstructor; split. apply exec_straight_one.
+ rewrite H2. unfold exec_load. rewrite H. rewrite H1. eauto. auto.
+ split. Simpl. intros; Simpl.
Qed.
Lemma transl_load_float_correct:
- forall (mk_instr: freg -> ireg -> int -> instruction)
- (is_immed: int -> bool)
- (rd: mreg) addr args k ms sp rs m m' chunk a v,
- (forall (c: code) (r1: freg) (r2: ireg) (n: int) (rs1: regset),
- exec_instr ge c (mk_instr r1 r2 n) rs1 m' =
- exec_load chunk (Val.add rs1#r2 (Vint n)) r1 rs1 m') ->
- agree ms sp rs ->
- map mreg_type args = type_of_addressing addr ->
- mreg_type rd = Tfloat ->
- eval_addressing ge sp addr (map ms args) = Some a ->
+ forall mk_instr is_immed dst addr args k c (rs: regset) a chunk m v,
+ transl_memory_access_float mk_instr is_immed dst addr args k = OK c ->
+ eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
Mem.loadv chunk m a = Some v ->
- Mem.extends m m' ->
+ (forall (r1: freg) (r2: ireg) (n: int) (rs1: regset),
+ exec_instr ge fn (mk_instr r1 r2 n) rs1 m =
+ exec_load chunk (Val.add rs1#r2 (Vint n)) r1 rs1 m) ->
exists rs',
- exec_straight (transl_load_store_float mk_instr is_immed rd addr args k) rs m'
- k rs' m'
- /\ agree (Regmap.set rd v (undef_temps ms)) sp rs'.
+ exec_straight ge fn c rs m k rs' m
+ /\ rs'#(preg_of dst) = v
+ /\ forall r, nontemp_preg r = true -> r <> preg_of dst -> rs'#r = rs#r.
Proof.
- intros. unfold transl_load_store_int.
- exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto.
- unfold PregEq.t.
- intros [a' [A B]].
- exploit Mem.loadv_extends; eauto. intros [v' [C D]].
- apply transl_load_store_correct with ms; auto.
- intros.
- assert (Val.add (rs1 r1) (Vint n) = a') by congruence.
- exists (nextinstr (rs1#(freg_of rd) <- v')); split.
- apply exec_straight_one. rewrite H. unfold exec_load.
- simpl. rewrite H8. rewrite C. auto. auto.
- apply agree_nextinstr. eapply agree_set_undef_mreg; eauto.
- unfold preg_of. rewrite H2. rewrite Pregmap.gss. auto.
- unfold preg_of. rewrite H2. intros. rewrite Pregmap.gso; auto. apply H7; auto with ppcgen.
+ intros. monadInv H. erewrite freg_of_eq by eauto.
+ eapply transl_memory_access_correct; eauto.
+ intros; simpl. econstructor; split. apply exec_straight_one.
+ rewrite H2. unfold exec_load. rewrite H. rewrite H1. eauto. auto.
+ split. Simpl. intros; Simpl.
+ simpl; auto.
Qed.
Lemma transl_store_int_correct:
- forall (mk_instr: ireg -> ireg -> shift_addr -> instruction)
- (is_immed: int -> bool)
- (rd: mreg) addr args k ms sp rs m1 chunk a m2 m1',
- (forall (c: code) (r1 r2: ireg) (sa: shift_addr) (rs1: regset),
- exec_instr ge c (mk_instr r1 r2 sa) rs1 m1' =
- exec_store chunk (Val.add rs1#r2 (eval_shift_addr sa rs1)) r1 rs1 m1') ->
- agree ms sp rs ->
- map mreg_type args = type_of_addressing addr ->
- mreg_type rd = Tint ->
- eval_addressing ge sp addr (map ms args) = Some a ->
- Mem.storev chunk m1 a (ms rd) = Some m2 ->
- Mem.extends m1 m1' ->
- exists m2',
- Mem.extends m2 m2' /\
- exists rs',
- exec_straight (transl_load_store_int mk_instr is_immed rd addr args k) rs m1'
- k rs' m2'
- /\ agree (undef_temps ms) sp rs'.
-Proof.
- intros. unfold transl_load_store_int.
- exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto.
- unfold PregEq.t.
- intros [a' [A B]].
- exploit preg_val; eauto. instantiate (1 := rd). intros C.
- exploit Mem.storev_extends; eauto. unfold preg_of; rewrite H2. intros [m2' [D E]].
- exists m2'; split; auto.
- apply transl_load_store_correct with ms; auto.
- intros.
- assert (Val.add (rs1 r1) (Vint n) = a') by congruence.
- exists (nextinstr rs1); split.
- apply exec_straight_one. rewrite H. simpl. rewrite H8.
- unfold exec_store. rewrite H7; auto with ppcgen. rewrite D. auto. auto.
- apply agree_nextinstr. apply agree_exten_temps with rs; auto with ppcgen.
- intros.
- assert (Val.add (rs1 r1) (eval_shift_addr sa rs1) = a') by congruence.
- exists (nextinstr rs1); split.
- apply exec_straight_one. rewrite H. simpl. rewrite H8.
- unfold exec_store. rewrite H7; auto with ppcgen. rewrite D. auto. auto.
- apply agree_nextinstr. apply agree_exten_temps with rs; auto with ppcgen.
+ forall mk_instr is_immed src addr args k c (rs: regset) a chunk m m',
+ transl_memory_access_int mk_instr is_immed src addr args k = OK c ->
+ eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
+ Mem.storev chunk m a rs#(preg_of src) = Some m' ->
+ (forall (r1 r2: ireg) (sa: shift_addr) (rs1: regset),
+ exec_instr ge fn (mk_instr r1 r2 sa) rs1 m =
+ exec_store chunk (Val.add rs1#r2 (eval_shift_addr sa rs1)) r1 rs1 m) ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m'
+ /\ forall r, nontemp_preg r = true -> rs'#r = rs#r.
+Proof.
+ intros. monadInv H. erewrite ireg_of_eq in * by eauto.
+ eapply transl_memory_access_correct; eauto.
+ intros; simpl. econstructor; split. apply exec_straight_one.
+ rewrite H2. unfold exec_store. simpl eval_shift_addr. rewrite H. rewrite H3; eauto with asmgen.
+ rewrite H1. eauto. auto.
+ intros; Simpl.
+ simpl; intros.
+ econstructor; split. apply exec_straight_one.
+ rewrite H2. unfold exec_store. rewrite H. rewrite H3; eauto with asmgen.
+ rewrite H1. eauto. auto.
+ intros; Simpl.
Qed.
Lemma transl_store_float_correct:
- forall (mk_instr: freg -> ireg -> int -> instruction)
- (is_immed: int -> bool)
- (rd: mreg) addr args k ms sp rs m1 chunk a m2 m1',
- (forall (c: code) (r1: freg) (r2: ireg) (n: int) (rs1: regset) m2',
- exec_store chunk (Val.add rs1#r2 (Vint n)) r1 rs1 m1' = OK (nextinstr rs1) m2' ->
- exists rs2,
- exec_instr ge c (mk_instr r1 r2 n) rs1 m1' = OK rs2 m2'
- /\ (forall (r: preg), r <> FR7 -> rs2 r = nextinstr rs1 r)) ->
- agree ms sp rs ->
- map mreg_type args = type_of_addressing addr ->
- mreg_type rd = Tfloat ->
- eval_addressing ge sp addr (map ms args) = Some a ->
- Mem.storev chunk m1 a (ms rd) = Some m2 ->
- Mem.extends m1 m1' ->
- exists m2',
- Mem.extends m2 m2' /\
- exists rs',
- exec_straight (transl_load_store_float mk_instr is_immed rd addr args k) rs m1'
- k rs' m2'
- /\ agree (undef_temps ms) sp rs'.
-Proof.
- intros. unfold transl_load_store_float.
- exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto.
- unfold PregEq.t.
- intros [a' [A B]].
- exploit preg_val; eauto. instantiate (1 := rd). intros C.
- exploit Mem.storev_extends; eauto. unfold preg_of; rewrite H2. intros [m2' [D E]].
- exists m2'; split; auto.
- apply transl_load_store_correct with ms; auto.
- intros.
- assert (Val.add (rs1 r1) (Vint n) = a') by congruence.
- exploit (H fn (freg_of rd) r1 n rs1 m2').
- unfold exec_store. rewrite H8. rewrite H7; auto with ppcgen. rewrite D. auto.
- intros [rs2 [P Q]].
- exists rs2; split. apply exec_straight_one. auto. rewrite Q; auto with ppcgen.
- apply agree_exten_temps with rs; auto.
- intros. rewrite Q; auto with ppcgen. Simpl. apply H7; auto with ppcgen.
-Qed.
+ forall mk_instr is_immed src addr args k c (rs: regset) a chunk m m',
+ transl_memory_access_float mk_instr is_immed src addr args k = OK c ->
+ eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
+ Mem.storev chunk m a rs#(preg_of src) = Some m' ->
+ (forall (r1: freg) (r2: ireg) (n: int) (rs1: regset),
+ exec_instr ge fn (mk_instr r1 r2 n) rs1 m =
+ exec_store chunk (Val.add rs1#r2 (Vint n)) r1 rs1 m) ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m'
+ /\ forall r, nontemp_preg r = true -> rs'#r = rs#r.
+Proof.
+ intros. monadInv H. erewrite freg_of_eq in * by eauto.
+ eapply transl_memory_access_correct; eauto.
+ intros; simpl. econstructor; split. apply exec_straight_one.
+ rewrite H2. unfold exec_store. rewrite H. rewrite H3; eauto with asmgen.
+ rewrite H1. eauto. auto.
+ intros; Simpl.
+ simpl; auto.
+Qed.
+
+Lemma transl_load_correct:
+ forall chunk addr args dst k c (rs: regset) a m v,
+ transl_load chunk addr args dst k = OK c ->
+ eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
+ Mem.loadv chunk m a = Some v ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ rs'#(preg_of dst) = v
+ /\ forall r, nontemp_preg r = true -> r <> preg_of dst -> rs'#r = rs#r.
+Proof.
+ intros. destruct chunk; simpl in H.
+ eapply transl_load_int_correct; eauto.
+ eapply transl_load_int_correct; eauto.
+ eapply transl_load_int_correct; eauto.
+ eapply transl_load_int_correct; eauto.
+ eapply transl_load_int_correct; eauto.
+ eapply transl_load_float_correct; eauto.
+ apply Mem.loadv_float64al32 in H1. eapply transl_load_float_correct; eauto.
+ eapply transl_load_float_correct; eauto.
+Qed.
+
+Lemma transl_store_correct:
+ forall chunk addr args src k c (rs: regset) a m m',
+ transl_store chunk addr args src k = OK c ->
+ eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
+ Mem.storev chunk m a rs#(preg_of src) = Some m' ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m'
+ /\ forall r, nontemp_preg r = true -> rs'#r = rs#r.
+Proof.
+ intros. destruct chunk; simpl in H.
+- assert (Mem.storev Mint8unsigned m a (rs (preg_of src)) = Some m').
+ rewrite <- H1. destruct a; simpl; auto. symmetry. apply Mem.store_signed_unsigned_8.
+ clear H1. eapply transl_store_int_correct; eauto.
+- eapply transl_store_int_correct; eauto.
+- assert (Mem.storev Mint16unsigned m a (rs (preg_of src)) = Some m').
+ rewrite <- H1. destruct a; simpl; auto. symmetry. apply Mem.store_signed_unsigned_16.
+ clear H1. eapply transl_store_int_correct; eauto.
+- eapply transl_store_int_correct; eauto.
+- eapply transl_store_int_correct; eauto.
+- unfold transl_memory_access_float in H. monadInv H. rewrite (freg_of_eq _ _ EQ) in *.
+ eapply transl_memory_access_correct; eauto.
+ intros. econstructor; split. apply exec_straight_one.
+ simpl. unfold exec_store. rewrite H. rewrite H2; eauto with asmgen.
+ rewrite H1. eauto. auto. intros. Simpl.
+ simpl; auto.
+- apply Mem.storev_float64al32 in H1. eapply transl_store_float_correct; eauto.
+- eapply transl_store_float_correct; eauto.
+Qed.
+
+End CONSTRUCTORS.
-End STRAIGHTLINE.
diff --git a/arm/Asmgenretaddr.v b/arm/Asmgenretaddr.v
deleted file mode 100644
index 2d3c72d..0000000
--- a/arm/Asmgenretaddr.v
+++ /dev/null
@@ -1,217 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Xavier Leroy, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-(** Predictor for return addresses in generated PPC code.
-
- The [return_address_offset] predicate defined here is used in the
- semantics for Mach (module [Machsem]) to determine the
- return addresses that are stored in activation records. *)
-
-Require Import Coqlib.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Op.
-Require Import Locations.
-Require Import Mach.
-Require Import Asm.
-Require Import Asmgen.
-
-(** The ``code tail'' of an instruction list [c] is the list of instructions
- starting at PC [pos]. *)
-
-Inductive code_tail: Z -> code -> code -> Prop :=
- | code_tail_0: forall c,
- code_tail 0 c c
- | code_tail_S: forall pos i c1 c2,
- code_tail pos c1 c2 ->
- code_tail (pos + 1) (i :: c1) c2.
-
-Lemma code_tail_pos:
- forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0.
-Proof.
- induction 1. omega. omega.
-Qed.
-
-(** Consider a Mach function [f] and a sequence [c] of Mach instructions
- representing the Mach code that remains to be executed after a
- function call returns. The predicate [return_address_offset f c ofs]
- holds if [ofs] is the integer offset of the PPC instruction
- following the call in the PPC code obtained by translating the
- code of [f]. Graphically:
-<<
- Mach function f |--------- Mcall ---------|
- Mach code c | |--------|
- | \ \
- | \ \
- | \ \
- PPC code | |--------|
- PPC function |--------------- Pbl ---------|
-
- <-------- ofs ------->
->>
-*)
-
-Inductive return_address_offset: Mach.function -> Mach.code -> int -> Prop :=
- | return_address_offset_intro:
- forall c f ofs,
- code_tail ofs (fn_code (transl_function f)) (transl_code f c) ->
- return_address_offset f c (Int.repr ofs).
-
-(** We now show that such an offset always exists if the Mach code [c]
- is a suffix of [f.(fn_code)]. This holds because the translation
- from Mach to PPC is compositional: each Mach instruction becomes
- zero, one or several PPC instructions, but the order of instructions
- is preserved. *)
-
-Lemma is_tail_code_tail:
- forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1.
-Proof.
- induction 1. exists 0; constructor.
- destruct IHis_tail as [ofs CT]. exists (ofs + 1); constructor; auto.
-Qed.
-
-Hint Resolve is_tail_refl: ppcretaddr.
-
-Ltac IsTail :=
- auto with ppcretaddr;
- match goal with
- | [ |- is_tail _ (_ :: _) ] => constructor; IsTail
- | [ |- is_tail _ (match ?x with true => _ | false => _ end) ] => destruct x; IsTail
- | [ |- is_tail _ (match ?x with left _ => _ | right _ => _ end) ] => destruct x; IsTail
- | [ |- is_tail _ (match ?x with nil => _ | _ :: _ => _ end) ] => destruct x; IsTail
- | [ |- is_tail _ (match ?x with Tint => _ | Tfloat => _ end) ] => destruct x; IsTail
- | [ |- is_tail _ (?f _ _ _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail
- | [ |- is_tail _ (?f _ _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail
- | [ |- is_tail _ (?f _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail
- | [ |- is_tail _ (?f _ _ _ ?k) ] => apply is_tail_trans with k; IsTail
- | [ |- is_tail _ (?f _ _ ?k) ] => apply is_tail_trans with k; IsTail
- | _ => idtac
- end.
-
-Lemma iterate_op_tail:
- forall op1 op2 l k, is_tail k (iterate_op op1 op2 l k).
-Proof.
- intros. unfold iterate_op.
- destruct l.
- auto with coqlib.
- constructor. revert l; induction l; simpl; auto with coqlib.
-Qed.
-Hint Resolve iterate_op_tail: ppcretaddr.
-
-Lemma loadimm_tail:
- forall r n k, is_tail k (loadimm r n k).
-Proof. unfold loadimm; intros; IsTail. Qed.
-Hint Resolve loadimm_tail: ppcretaddr.
-
-Lemma addimm_tail:
- forall r1 r2 n k, is_tail k (addimm r1 r2 n k).
-Proof. unfold addimm; intros; IsTail. Qed.
-Hint Resolve addimm_tail: ppcretaddr.
-
-Lemma andimm_tail:
- forall r1 r2 n k, is_tail k (andimm r1 r2 n k).
-Proof. unfold andimm; intros; IsTail. Qed.
-Hint Resolve andimm_tail: ppcretaddr.
-
-Lemma rsubimm_tail:
- forall r1 r2 n k, is_tail k (rsubimm r1 r2 n k).
-Proof. unfold rsubimm; intros; IsTail. Qed.
-Hint Resolve rsubimm_tail: ppcretaddr.
-
-Lemma orimm_tail:
- forall r1 r2 n k, is_tail k (orimm r1 r2 n k).
-Proof. unfold orimm; intros; IsTail. Qed.
-Hint Resolve orimm_tail: ppcretaddr.
-
-Lemma xorimm_tail:
- forall r1 r2 n k, is_tail k (xorimm r1 r2 n k).
-Proof. unfold xorimm; intros; IsTail. Qed.
-Hint Resolve xorimm_tail: ppcretaddr.
-
-Lemma transl_cond_tail:
- forall cond args k, is_tail k (transl_cond cond args k).
-Proof. unfold transl_cond; intros; destruct cond; IsTail. Qed.
-Hint Resolve transl_cond_tail: ppcretaddr.
-
-Lemma transl_op_tail:
- forall op args r k, is_tail k (transl_op op args r k).
-Proof. unfold transl_op; intros; destruct op; IsTail. Qed.
-Hint Resolve transl_op_tail: ppcretaddr.
-
-Lemma transl_load_store_tail:
- forall mk1 mk2 is_immed addr args k,
- is_tail k (transl_load_store mk1 mk2 is_immed addr args k).
-Proof. unfold transl_load_store; intros; destruct addr; IsTail.
- destruct mk2; IsTail. destruct mk2; IsTail. Qed.
-Hint Resolve transl_load_store_tail: ppcretaddr.
-
-Lemma transl_load_store_int_tail:
- forall mk is_immed rd addr args k,
- is_tail k (transl_load_store_int mk is_immed rd addr args k).
-Proof. unfold transl_load_store_int; intros; IsTail. Qed.
-Hint Resolve transl_load_store_int_tail: ppcretaddr.
-
-Lemma transl_load_store_float_tail:
- forall mk is_immed rd addr args k,
- is_tail k (transl_load_store_float mk is_immed rd addr args k).
-Proof. unfold transl_load_store_float; intros; IsTail. Qed.
-Hint Resolve transl_load_store_float_tail: ppcretaddr.
-
-Lemma loadind_int_tail:
- forall base ofs dst k, is_tail k (loadind_int base ofs dst k).
-Proof. unfold loadind_int; intros; IsTail. Qed.
-Hint Resolve loadind_int_tail: ppcretaddr.
-
-Lemma loadind_tail:
- forall base ofs ty dst k, is_tail k (loadind base ofs ty dst k).
-Proof. unfold loadind, loadind_float; intros; IsTail. Qed.
-Hint Resolve loadind_tail: ppcretaddr.
-
-Lemma storeind_int_tail:
- forall src base ofs k, is_tail k (storeind_int src base ofs k).
-Proof. unfold storeind_int; intros; IsTail. Qed.
-Hint Resolve storeind_int_tail: ppcretaddr.
-
-Lemma storeind_tail:
- forall src base ofs ty k, is_tail k (storeind src base ofs ty k).
-Proof. unfold storeind, storeind_float; intros; IsTail. Qed.
-Hint Resolve storeind_tail: ppcretaddr.
-
-Lemma transl_instr_tail:
- forall f i k, is_tail k (transl_instr f i k).
-Proof.
- unfold transl_instr; intros; destruct i; IsTail.
- destruct m; IsTail.
- destruct m; IsTail.
- destruct s0; IsTail.
- destruct s0; IsTail.
-Qed.
-Hint Resolve transl_instr_tail: ppcretaddr.
-
-Lemma transl_code_tail:
- forall f c1 c2, is_tail c1 c2 -> is_tail (transl_code f c1) (transl_code f c2).
-Proof.
- induction 1; simpl. constructor. eapply is_tail_trans; eauto with ppcretaddr.
-Qed.
-
-Lemma return_address_exists:
- forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) ->
- exists ra, return_address_offset f c ra.
-Proof.
- intros. assert (is_tail (transl_code f c) (fn_code (transl_function f))).
- unfold transl_function. simpl. IsTail. apply transl_code_tail; eauto with coqlib.
- destruct (is_tail_code_tail _ _ H0) as [ofs A].
- exists (Int.repr ofs). constructor. auto.
-Qed.
-
-
diff --git a/arm/PrintAsm.ml b/arm/PrintAsm.ml
index 278b6b1..f5b04b5 100644
--- a/arm/PrintAsm.ml
+++ b/arm/PrintAsm.ml
@@ -593,14 +593,14 @@ let print_instruction oc = function
fprintf oc " fsts %a, [%a, #%a]\n" freg_single FR6 ireg r2 coqint n; 2
(* Pseudo-instructions *)
| Pallocframe(sz, ofs) ->
- fprintf oc " mov r12, sp\n";
+ fprintf oc " mov r10, sp\n";
let ninstr = ref 0 in
List.iter
(fun n ->
fprintf oc " sub sp, sp, #%a\n" coqint n;
incr ninstr)
(Asmgen.decompose_int sz);
- fprintf oc " str r12, [sp, #%a]\n" coqint ofs;
+ fprintf oc " str r10, [sp, #%a]\n" coqint ofs;
2 + !ninstr
| Pfreeframe(sz, ofs) ->
if Asmgen.is_immed_arith sz
@@ -614,7 +614,8 @@ let print_instruction oc = function
fprintf oc " ldr %a, .L%d @ %a\n"
ireg r1 lbl print_symb_ofs (id, ofs); 1
| Pbtbl(r, tbl) ->
- fprintf oc " ldr pc, [pc, %a]\n" ireg r;
+ fprintf oc " mov r14, %a, lsl #2\n";
+ fprintf oc " ldr pc, [pc, r14]\n";
fprintf oc " mov r0, r0\n"; (* no-op *)
List.iter
(fun l -> fprintf oc " .word %a\n" print_label l)
diff --git a/backend/Asmgenproof0.v b/backend/Asmgenproof0.v
new file mode 100644
index 0000000..06b5407
--- /dev/null
+++ b/backend/Asmgenproof0.v
@@ -0,0 +1,844 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Correctness proof for Asm generation: machine-independent framework *)
+
+Require Import Coqlib.
+Require Intv.
+Require Import AST.
+Require Import Errors.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Events.
+Require Import Smallstep.
+Require Import Locations.
+Require Import Mach.
+Require Import Asm.
+Require Import Asmgen.
+Require Import Conventions.
+
+(** * Processor registers and register states *)
+
+Hint Extern 2 (_ <> _) => congruence: asmgen.
+
+Lemma ireg_of_eq:
+ forall r r', ireg_of r = OK r' -> preg_of r = IR r'.
+Proof.
+ unfold ireg_of; intros. destruct (preg_of r); inv H; auto.
+Qed.
+
+Lemma freg_of_eq:
+ forall r r', freg_of r = OK r' -> preg_of r = FR r'.
+Proof.
+ unfold freg_of; intros. destruct (preg_of r); inv H; auto.
+Qed.
+
+Lemma preg_of_injective:
+ forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2.
+Proof.
+ destruct r1; destruct r2; simpl; intros; reflexivity || discriminate.
+Qed.
+
+Lemma preg_of_data:
+ forall r, data_preg (preg_of r) = true.
+Proof.
+ intros. destruct r; reflexivity.
+Qed.
+Hint Resolve preg_of_data: asmgen.
+
+Lemma data_diff:
+ forall r r',
+ data_preg r = true -> data_preg r' = false -> r <> r'.
+Proof.
+ congruence.
+Qed.
+Hint Resolve data_diff: asmgen.
+
+Lemma preg_of_not_SP:
+ forall r, preg_of r <> SP.
+Proof.
+ intros. unfold preg_of; destruct r; simpl; congruence.
+Qed.
+
+Lemma preg_of_not_PC:
+ forall r, preg_of r <> PC.
+Proof.
+ intros. apply data_diff; auto with asmgen.
+Qed.
+
+Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen.
+
+Lemma nontemp_diff:
+ forall r r',
+ nontemp_preg r = true -> nontemp_preg r' = false -> r <> r'.
+Proof.
+ congruence.
+Qed.
+Hint Resolve nontemp_diff: asmgen.
+
+Lemma temporaries_temp_preg:
+ forall r, In r temporary_regs -> nontemp_preg (preg_of r) = false.
+Proof.
+ assert (List.forallb (fun r => negb (nontemp_preg (preg_of r))) temporary_regs = true) by reflexivity.
+ rewrite List.forallb_forall in H. intros. generalize (H r H0).
+ destruct (nontemp_preg (preg_of r)); simpl; congruence.
+Qed.
+
+Lemma nontemp_data_preg:
+ forall r, nontemp_preg r = true -> data_preg r = true.
+Proof.
+ destruct r; try (destruct i); try (destruct f); simpl; congruence.
+Qed.
+Hint Resolve nontemp_data_preg: asmgen.
+
+Lemma nextinstr_pc:
+ forall rs, (nextinstr rs)#PC = Val.add rs#PC Vone.
+Proof.
+ intros. apply Pregmap.gss.
+Qed.
+
+Lemma nextinstr_inv:
+ forall r rs, r <> PC -> (nextinstr rs)#r = rs#r.
+Proof.
+ intros. unfold nextinstr. apply Pregmap.gso. red; intro; subst. auto.
+Qed.
+
+Lemma nextinstr_inv1:
+ forall r rs, data_preg r = true -> (nextinstr rs)#r = rs#r.
+Proof.
+ intros. apply nextinstr_inv. red; intro; subst; discriminate.
+Qed.
+
+Lemma nextinstr_inv2:
+ forall r rs, nontemp_preg r = true -> (nextinstr rs)#r = rs#r.
+Proof.
+ intros. apply nextinstr_inv1; auto with asmgen.
+Qed.
+
+Lemma nextinstr_set_preg:
+ forall rs m v,
+ (nextinstr (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone.
+Proof.
+ intros. unfold nextinstr. rewrite Pregmap.gss.
+ rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_PC.
+Qed.
+
+(** * Agreement between Mach registers and processor registers *)
+
+Record agree (ms: Mach.regset) (sp: val) (rs: Asm.regset) : Prop := mkagree {
+ agree_sp: rs#SP = sp;
+ agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r))
+}.
+
+Lemma preg_val:
+ forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r).
+Proof.
+ intros. destruct H. auto.
+Qed.
+
+Lemma preg_vals:
+ forall ms sp rs, agree ms sp rs ->
+ forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)).
+Proof.
+ induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto.
+Qed.
+
+Lemma sp_val:
+ forall ms sp rs, agree ms sp rs -> sp = rs#SP.
+Proof.
+ intros. destruct H; auto.
+Qed.
+
+Lemma ireg_val:
+ forall ms sp rs r r',
+ agree ms sp rs ->
+ ireg_of r = OK r' ->
+ Val.lessdef (ms r) rs#r'.
+Proof.
+ intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto.
+Qed.
+
+Lemma freg_val:
+ forall ms sp rs r r',
+ agree ms sp rs ->
+ freg_of r = OK r' ->
+ Val.lessdef (ms r) (rs#r').
+Proof.
+ intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto.
+Qed.
+
+Lemma agree_exten:
+ forall ms sp rs rs',
+ agree ms sp rs ->
+ (forall r, data_preg r = true -> rs'#r = rs#r) ->
+ agree ms sp rs'.
+Proof.
+ intros. destruct H. split.
+ rewrite H0; auto. auto.
+ intros. rewrite H0; auto. apply preg_of_data.
+Qed.
+
+(** Preservation of register agreement under various assignments. *)
+
+Lemma agree_set_mreg:
+ forall ms sp rs r v rs',
+ agree ms sp rs ->
+ Val.lessdef v (rs'#(preg_of r)) ->
+ (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') ->
+ agree (Regmap.set r v ms) sp rs'.
+Proof.
+ intros. destruct H. split.
+ rewrite H1; auto. apply sym_not_equal. apply preg_of_not_SP.
+ auto.
+ intros. unfold Regmap.set. destruct (RegEq.eq r0 r). congruence.
+ rewrite H1. auto. apply preg_of_data.
+ red; intros; elim n. eapply preg_of_injective; eauto.
+Qed.
+
+Lemma agree_set_other:
+ forall ms sp rs r v,
+ agree ms sp rs ->
+ data_preg r = false ->
+ agree ms sp (rs#r <- v).
+Proof.
+ intros. apply agree_exten with rs. auto.
+ intros. apply Pregmap.gso. congruence.
+Qed.
+
+Lemma agree_nextinstr:
+ forall ms sp rs,
+ agree ms sp rs -> agree ms sp (nextinstr rs).
+Proof.
+ intros. unfold nextinstr. apply agree_set_other. auto. auto.
+Qed.
+
+Lemma agree_undef_regs:
+ forall ms sp rl rs,
+ agree ms sp rs ->
+ (forall r, In r rl -> data_preg r = false) ->
+ agree ms sp (undef_regs rl rs).
+Proof.
+ induction rl; simpl; intros. auto.
+ apply IHrl. apply agree_exten with rs; auto.
+ intros. apply Pregmap.gso. red; intros; subst.
+ assert (data_preg a = false) by auto. congruence.
+ intros. apply H0; auto.
+Qed.
+
+Lemma agree_exten_temps:
+ forall ms sp rs rs',
+ agree ms sp rs ->
+ (forall r, nontemp_preg r = true -> rs'#r = rs#r) ->
+ agree (undef_temps ms) sp rs'.
+Proof.
+ intros. destruct H. split.
+ rewrite H0; auto. auto.
+ intros. unfold undef_temps.
+ destruct (In_dec mreg_eq r temporary_regs).
+ rewrite Mach.undef_regs_same; auto.
+ rewrite Mach.undef_regs_other; auto. rewrite H0; auto.
+ simpl in n. destruct r; auto; intuition.
+Qed.
+
+Lemma agree_set_undef_mreg:
+ forall ms sp rs r v rs',
+ agree ms sp rs ->
+ Val.lessdef v (rs'#(preg_of r)) ->
+ (forall r', nontemp_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') ->
+ agree (Regmap.set r v (undef_temps ms)) sp rs'.
+Proof.
+ intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto.
+ eapply agree_exten_temps; eauto.
+ intros. unfold Pregmap.set. destruct (PregEq.eq r0 (preg_of r)).
+ congruence. auto.
+ intros. rewrite Pregmap.gso; auto.
+Qed.
+
+Lemma agree_change_sp:
+ forall ms sp rs sp',
+ agree ms sp rs -> sp' <> Vundef ->
+ agree ms sp' (rs#SP <- sp').
+Proof.
+ intros. inv H. split. apply Pregmap.gss. auto.
+ intros. rewrite Pregmap.gso; auto with asmgen.
+Qed.
+
+(** Connection between Mach and Asm calling conventions for external
+ functions. *)
+
+Lemma extcall_arg_match:
+ forall ms sp rs m m' l v,
+ agree ms sp rs ->
+ Mem.extends m m' ->
+ Mach.extcall_arg ms m sp l v ->
+ exists v', Asm.extcall_arg rs m' l v' /\ Val.lessdef v v'.
+Proof.
+ intros. inv H1.
+ exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto.
+ unfold load_stack in H2.
+ exploit Mem.loadv_extends; eauto. intros [v' [A B]].
+ rewrite (sp_val _ _ _ H) in A.
+ exists v'; split; auto.
+ destruct ty; econstructor.
+ reflexivity. assumption.
+ reflexivity. assumption.
+Qed.
+
+Lemma extcall_args_match:
+ forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' ->
+ forall ll vl,
+ list_forall2 (Mach.extcall_arg ms m sp) ll vl ->
+ exists vl', list_forall2 (Asm.extcall_arg rs m') ll vl' /\ Val.lessdef_list vl vl'.
+Proof.
+ induction 3; intros.
+ exists (@nil val); split. constructor. constructor.
+ exploit extcall_arg_match; eauto. intros [v1' [A B]].
+ destruct IHlist_forall2 as [vl' [C D]].
+ exists (v1' :: vl'); split; constructor; auto.
+Qed.
+
+Lemma extcall_arguments_match:
+ forall ms m m' sp rs sg args,
+ agree ms sp rs -> Mem.extends m m' ->
+ Mach.extcall_arguments ms m sp sg args ->
+ exists args', Asm.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'.
+Proof.
+ unfold Mach.extcall_arguments, Asm.extcall_arguments; intros.
+ eapply extcall_args_match; eauto.
+Qed.
+
+(** Translation of arguments to annotations. *)
+
+Lemma annot_arg_match:
+ forall ms sp rs m m' p v,
+ agree ms sp rs ->
+ Mem.extends m m' ->
+ Mach.annot_arg ms m sp p v ->
+ exists v', Asm.annot_arg rs m' (transl_annot_param p) v' /\ Val.lessdef v v'.
+Proof.
+ intros. inv H1; simpl.
+(* reg *)
+ exists (rs (preg_of r)); split. constructor. eapply preg_val; eauto.
+(* stack *)
+ exploit Mem.load_extends; eauto. intros [v' [A B]].
+ exists v'; split; auto.
+ inv H. econstructor; eauto.
+Qed.
+
+Lemma annot_arguments_match:
+ forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' ->
+ forall pl vl,
+ Mach.annot_arguments ms m sp pl vl ->
+ exists vl', Asm.annot_arguments rs m' (map transl_annot_param pl) vl'
+ /\ Val.lessdef_list vl vl'.
+Proof.
+ induction 3; intros.
+ exists (@nil val); split. constructor. constructor.
+ exploit annot_arg_match; eauto. intros [v1' [A B]].
+ destruct IHlist_forall2 as [vl' [C D]].
+ exists (v1' :: vl'); split; constructor; auto.
+Qed.
+
+(** * Correspondence between Mach code and Asm code *)
+
+Lemma find_instr_in:
+ forall c pos i,
+ find_instr pos c = Some i -> In i c.
+Proof.
+ induction c; simpl. intros; discriminate.
+ intros until i. case (zeq pos 0); intros.
+ left; congruence. right; eauto.
+Qed.
+
+(** The ``code tail'' of an instruction list [c] is the list of instructions
+ starting at PC [pos]. *)
+
+Inductive code_tail: Z -> code -> code -> Prop :=
+ | code_tail_0: forall c,
+ code_tail 0 c c
+ | code_tail_S: forall pos i c1 c2,
+ code_tail pos c1 c2 ->
+ code_tail (pos + 1) (i :: c1) c2.
+
+Lemma code_tail_pos:
+ forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0.
+Proof.
+ induction 1. omega. omega.
+Qed.
+
+Lemma find_instr_tail:
+ forall c1 i c2 pos,
+ code_tail pos c1 (i :: c2) ->
+ find_instr pos c1 = Some i.
+Proof.
+ induction c1; simpl; intros.
+ inv H.
+ destruct (zeq pos 0). subst pos.
+ inv H. auto. generalize (code_tail_pos _ _ _ H4). intro. omegaContradiction.
+ inv H. congruence. replace (pos0 + 1 - 1) with pos0 by omega.
+ eauto.
+Qed.
+
+Remark code_tail_bounds:
+ forall fn ofs i c,
+ code_tail ofs fn (i :: c) -> 0 <= ofs < list_length_z fn.
+Proof.
+ assert (forall ofs fn c, code_tail ofs fn c ->
+ forall i c', c = i :: c' -> 0 <= ofs < list_length_z fn).
+ induction 1; intros; simpl.
+ rewrite H. rewrite list_length_z_cons. generalize (list_length_z_pos c'). omega.
+ rewrite list_length_z_cons. generalize (IHcode_tail _ _ H0). omega.
+ eauto.
+Qed.
+
+Lemma code_tail_next:
+ forall fn ofs i c,
+ code_tail ofs fn (i :: c) ->
+ code_tail (ofs + 1) fn c.
+Proof.
+ assert (forall ofs fn c, code_tail ofs fn c ->
+ forall i c', c = i :: c' -> code_tail (ofs + 1) fn c').
+ induction 1; intros.
+ subst c. constructor. constructor.
+ constructor. eauto.
+ eauto.
+Qed.
+
+Lemma code_tail_next_int:
+ forall fn ofs i c,
+ list_length_z fn <= Int.max_unsigned ->
+ code_tail (Int.unsigned ofs) fn (i :: c) ->
+ code_tail (Int.unsigned (Int.add ofs Int.one)) fn c.
+Proof.
+ intros. rewrite Int.add_unsigned.
+ change (Int.unsigned Int.one) with 1.
+ rewrite Int.unsigned_repr. apply code_tail_next with i; auto.
+ generalize (code_tail_bounds _ _ _ _ H0). omega.
+Qed.
+
+(** [transl_code_at_pc pc f c ep tf tc] holds if the code pointer [pc] points
+ within the Asm code generated by translating Mach function [f],
+ and [tc] is the tail of the generated code at the position corresponding
+ to the code pointer [pc]. *)
+
+Inductive transl_code_at_pc (ge: Mach.genv):
+ val -> Mach.function -> Mach.code -> bool -> Asm.function -> Asm.code -> Prop :=
+ transl_code_at_pc_intro:
+ forall b ofs f c ep tf tc,
+ Genv.find_funct_ptr ge b = Some(Internal f) ->
+ transf_function f = Errors.OK tf ->
+ transl_code f c ep = OK tc ->
+ code_tail (Int.unsigned ofs) (fn_code tf) tc ->
+ transl_code_at_pc ge (Vptr b ofs) f c ep tf tc.
+
+(** * Execution of straight-line code *)
+
+Section STRAIGHTLINE.
+
+Variable ge: genv.
+Variable fn: function.
+
+(** Straight-line code is composed of processor instructions that execute
+ in sequence (no branches, no function calls and returns).
+ The following inductive predicate relates the machine states
+ before and after executing a straight-line sequence of instructions.
+ Instructions are taken from the first list instead of being fetched
+ from memory. *)
+
+Inductive exec_straight: code -> regset -> mem ->
+ code -> regset -> mem -> Prop :=
+ | exec_straight_one:
+ forall i1 c rs1 m1 rs2 m2,
+ exec_instr ge fn i1 rs1 m1 = Next rs2 m2 ->
+ rs2#PC = Val.add rs1#PC Vone ->
+ exec_straight (i1 :: c) rs1 m1 c rs2 m2
+ | exec_straight_step:
+ forall i c rs1 m1 rs2 m2 c' rs3 m3,
+ exec_instr ge fn i rs1 m1 = Next rs2 m2 ->
+ rs2#PC = Val.add rs1#PC Vone ->
+ exec_straight c rs2 m2 c' rs3 m3 ->
+ exec_straight (i :: c) rs1 m1 c' rs3 m3.
+
+Lemma exec_straight_trans:
+ forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3,
+ exec_straight c1 rs1 m1 c2 rs2 m2 ->
+ exec_straight c2 rs2 m2 c3 rs3 m3 ->
+ exec_straight c1 rs1 m1 c3 rs3 m3.
+Proof.
+ induction 1; intros.
+ apply exec_straight_step with rs2 m2; auto.
+ apply exec_straight_step with rs2 m2; auto.
+Qed.
+
+Lemma exec_straight_two:
+ forall i1 i2 c rs1 m1 rs2 m2 rs3 m3,
+ exec_instr ge fn i1 rs1 m1 = Next rs2 m2 ->
+ exec_instr ge fn i2 rs2 m2 = Next rs3 m3 ->
+ rs2#PC = Val.add rs1#PC Vone ->
+ rs3#PC = Val.add rs2#PC Vone ->
+ exec_straight (i1 :: i2 :: c) rs1 m1 c rs3 m3.
+Proof.
+ intros. apply exec_straight_step with rs2 m2; auto.
+ apply exec_straight_one; auto.
+Qed.
+
+Lemma exec_straight_three:
+ forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4,
+ exec_instr ge fn i1 rs1 m1 = Next rs2 m2 ->
+ exec_instr ge fn i2 rs2 m2 = Next rs3 m3 ->
+ exec_instr ge fn i3 rs3 m3 = Next rs4 m4 ->
+ rs2#PC = Val.add rs1#PC Vone ->
+ rs3#PC = Val.add rs2#PC Vone ->
+ rs4#PC = Val.add rs3#PC Vone ->
+ exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4.
+Proof.
+ intros. apply exec_straight_step with rs2 m2; auto.
+ eapply exec_straight_two; eauto.
+Qed.
+
+(** The following lemmas show that straight-line executions
+ (predicate [exec_straight]) correspond to correct Asm executions. *)
+
+Lemma exec_straight_steps_1:
+ forall c rs m c' rs' m',
+ exec_straight c rs m c' rs' m' ->
+ list_length_z (fn_code fn) <= Int.max_unsigned ->
+ forall b ofs,
+ rs#PC = Vptr b ofs ->
+ Genv.find_funct_ptr ge b = Some (Internal fn) ->
+ code_tail (Int.unsigned ofs) (fn_code fn) c ->
+ plus step ge (State rs m) E0 (State rs' m').
+Proof.
+ induction 1; intros.
+ apply plus_one.
+ econstructor; eauto.
+ eapply find_instr_tail. eauto.
+ eapply plus_left'.
+ econstructor; eauto.
+ eapply find_instr_tail. eauto.
+ 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:
+ forall c rs m c' rs' m',
+ exec_straight c rs m c' rs' m' ->
+ list_length_z (fn_code fn) <= Int.max_unsigned ->
+ forall b ofs,
+ rs#PC = Vptr b ofs ->
+ Genv.find_funct_ptr ge b = Some (Internal fn) ->
+ code_tail (Int.unsigned ofs) (fn_code fn) c ->
+ exists ofs',
+ rs'#PC = Vptr b ofs'
+ /\ code_tail (Int.unsigned ofs') (fn_code fn) c'.
+Proof.
+ induction 1; intros.
+ exists (Int.add ofs Int.one). split.
+ rewrite H0. rewrite H2. auto.
+ apply code_tail_next_int with i1; auto.
+ apply IHexec_straight with (Int.add ofs Int.one).
+ auto. rewrite H0. rewrite H3. reflexivity. auto.
+ apply code_tail_next_int with i; auto.
+Qed.
+
+End STRAIGHTLINE.
+
+(** * Stack invariants *)
+
+(** ** Stored return addresses *)
+
+(** [retaddr_stored_at m m' sp pos ra] holds if Asm memory [m']
+ contains value [ra] (a return address) at offset [pos] in block [sp]. *)
+
+Record retaddr_stored_at (m m': mem) (sp: block) (pos: Z) (ra: val) : Prop := {
+ rsa_noperm:
+ forall ofs k p, pos <= ofs < pos + 4 -> ~Mem.perm m sp ofs k p;
+ rsa_allperm:
+ forall ofs k p, pos <= ofs < pos + 4 -> Mem.perm m' sp ofs k p;
+ rsa_contains:
+ Mem.load Mint32 m' sp pos = Some ra
+}.
+
+Lemma retaddr_stored_at_invariant:
+ forall m m' sp pos ra m1 m1',
+ retaddr_stored_at m m' sp pos ra ->
+ (forall ofs p, pos <= ofs < pos + 4 -> Mem.perm m1 sp ofs Max p -> Mem.perm m sp ofs Max p) ->
+ (forall ofs k p, pos <= ofs < pos + 4 -> Mem.perm m' sp ofs k p -> Mem.perm m1' sp ofs k p) ->
+ (Mem.load Mint32 m' sp pos = Some ra -> Mem.load Mint32 m1' sp pos = Some ra) ->
+ retaddr_stored_at m1 m1' sp pos ra.
+Proof.
+ intros. inv H. constructor; intros.
+ red; intros. eelim rsa_noperm0. eauto. apply H0. auto. eapply Mem.perm_max; eauto.
+ eauto.
+ eauto.
+Qed.
+
+Lemma retaddr_stored_at_store:
+ forall chunk m m' b ofs v v' m1 m1' sp pos ra,
+ retaddr_stored_at m m' sp pos ra ->
+ Mem.store chunk m b ofs v = Some m1 ->
+ Mem.store chunk m' b ofs v' = Some m1' ->
+ retaddr_stored_at m1 m1' sp pos ra.
+Proof.
+ intros. eapply retaddr_stored_at_invariant; eauto; intros.
+- eapply Mem.perm_store_2; eauto.
+- eapply Mem.perm_store_1; eauto.
+- rewrite <- H2. eapply Mem.load_store_other; eauto.
+ destruct (eq_block sp b); auto. subst b.
+ right. exploit Mem.store_valid_access_3. eexact H0. intros [A B].
+ apply (Intv.range_disjoint' (pos, pos + size_chunk Mint32) (ofs, ofs + size_chunk chunk)).
+ red; intros; red; intros.
+ elim (rsa_noperm _ _ _ _ _ H x Cur Writable). assumption. apply A. assumption.
+ simpl; omega.
+ simpl; generalize (size_chunk_pos chunk); omega.
+Qed.
+
+Lemma retaddr_stored_at_storev:
+ forall chunk m m' a a' v v' m1 m1' sp pos ra,
+ retaddr_stored_at m m' sp pos ra ->
+ Mem.storev chunk m a v = Some m1 ->
+ Mem.storev chunk m' a' v' = Some m1' ->
+ Val.lessdef a a' ->
+ retaddr_stored_at m1 m1' sp pos ra.
+Proof.
+ intros. destruct a; simpl in H0; try discriminate. inv H2. simpl in H1.
+ eapply retaddr_stored_at_store; eauto.
+Qed.
+
+Lemma retaddr_stored_at_valid':
+ forall m m' sp pos ra,
+ retaddr_stored_at m m' sp pos ra ->
+ Mem.valid_block m' sp.
+Proof.
+ intros.
+ eapply Mem.valid_access_valid_block.
+ apply Mem.valid_access_implies with Readable; auto with mem.
+ eapply Mem.load_valid_access.
+ eapply rsa_contains; eauto.
+Qed.
+
+Lemma retaddr_stored_at_valid:
+ forall m m' sp pos ra,
+ retaddr_stored_at m m' sp pos ra ->
+ Mem.extends m m' ->
+ Mem.valid_block m sp.
+Proof.
+ intros.
+ erewrite Mem.valid_block_extends; eauto.
+ eapply retaddr_stored_at_valid'; eauto.
+Qed.
+
+Lemma retaddr_stored_at_extcall:
+ forall m1 m1' sp pos ra m2 m2',
+ retaddr_stored_at m1 m1' sp pos ra ->
+ (forall b ofs p, Mem.valid_block m1 b -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) ->
+ mem_unchanged_on (loc_out_of_bounds m1) m1' m2' ->
+ Mem.extends m1 m1' ->
+ retaddr_stored_at m2 m2' sp pos ra.
+Proof.
+ intros.
+ assert (B: forall ofs, pos <= ofs < pos + 4 -> loc_out_of_bounds m1 sp ofs).
+ intros; red; intros. eapply rsa_noperm; eauto.
+ eapply retaddr_stored_at_invariant; eauto.
+- intros. apply H0; auto. eapply retaddr_stored_at_valid; eauto.
+- intros. destruct H1. eauto.
+- intros. destruct H1. apply H4; auto.
+Qed.
+
+Lemma retaddr_stored_at_can_alloc:
+ forall m lo hi m1 sp pos m2 a v m3 m' m1' a' v' m2' ra,
+ Mem.alloc m lo hi = (m1, sp) ->
+ Mem.free m1 sp pos (pos + 4) = Some m2 ->
+ Mem.storev Mint32 m2 a v = Some m3 ->
+ Mem.alloc m' lo hi = (m1', sp) ->
+ Mem.storev Mint32 m1' a' v' = Some m2' ->
+ (4 | pos) ->
+ Mem.extends m3 m2' ->
+ Val.has_type ra Tint ->
+ exists m3',
+ Mem.store Mint32 m2' sp pos ra = Some m3'
+ /\ retaddr_stored_at m3 m3' sp pos ra
+ /\ Mem.extends m3 m3'.
+Proof.
+ intros. destruct a; simpl in H1; try discriminate. destruct a'; simpl in H3; try discriminate.
+ assert (POS: forall ofs, pos <= ofs < pos + 4 -> lo <= ofs < hi).
+ intros. eapply Mem.perm_alloc_3. eexact H. eapply Mem.free_range_perm; eauto.
+ assert (ST: { m3' | Mem.store Mint32 m2' sp pos ra = Some m3' }).
+ {
+ apply Mem.valid_access_store. split.
+ red; intros. eapply Mem.perm_store_1; eauto.
+ apply Mem.perm_implies with Freeable; auto with mem.
+ eapply Mem.perm_alloc_2; eauto.
+ assumption.
+ }
+ destruct ST as [m3' ST]. exists m3'; split; auto.
+ split. constructor.
+ intros; red; intros. eelim Mem.perm_free_2; eauto. eapply Mem.perm_store_2; eauto.
+ intros. eapply Mem.perm_store_1; eauto. eapply Mem.perm_store_1; eauto.
+ apply Mem.perm_implies with Freeable; auto with mem.
+ eapply Mem.perm_alloc_2; eauto.
+ replace ra with (Val.load_result Mint32 ra). eapply Mem.load_store_same; eauto.
+ destruct ra; reflexivity || contradiction.
+ eapply Mem.store_outside_extends; eauto.
+ intros. eelim Mem.perm_free_2; eauto. eapply Mem.perm_store_2; eauto.
+Qed.
+
+Lemma retaddr_stored_at_can_free:
+ forall m m' sp pos ra lo m1 hi m2,
+ retaddr_stored_at m m' sp pos ra ->
+ Mem.free m sp lo pos = Some m1 ->
+ Mem.free m1 sp (pos + 4) hi = Some m2 ->
+ Mem.extends m m' ->
+ exists m1', Mem.free m' sp lo hi = Some m1' /\ Mem.extends m2 m1'.
+Proof.
+ intros. inv H.
+ assert (F: { m1' | Mem.free m' sp lo hi = Some m1' }).
+ {
+ apply Mem.range_perm_free. red; intros.
+ assert (EITHER: lo <= ofs < pos \/ pos <= ofs < pos + 4 \/ pos + 4 <= ofs < hi) by omega.
+ destruct EITHER as [A | [A | A]].
+ eapply Mem.perm_extends; eauto. eapply Mem.free_range_perm; eauto.
+ auto.
+ eapply Mem.perm_extends; eauto.
+ eapply Mem.perm_free_3; eauto. eapply Mem.free_range_perm; eauto.
+ }
+ destruct F as [m1' F]. exists m1'; split; auto.
+ eapply Mem.free_right_extends; eauto.
+ eapply Mem.free_left_extends. eapply Mem.free_left_extends. eauto. eauto. eauto.
+ intros.
+ exploit Mem.perm_free_3. eexact H1. eauto. intros P1.
+ exploit Mem.perm_free_3. eexact H0. eauto. intros P0.
+ assert (EITHER: lo <= ofs < pos \/ pos <= ofs < pos + 4 \/ pos + 4 <= ofs < hi) by omega.
+ destruct EITHER as [A | [A | A]].
+ eelim Mem.perm_free_2. eexact H0. eexact A. eauto.
+ eelim rsa_noperm0; eauto.
+ eelim Mem.perm_free_2. eexact H1. eexact A. eauto.
+Qed.
+
+Lemma retaddr_stored_at_type:
+ forall m m' sp pos ra, retaddr_stored_at m m' sp pos ra -> Val.has_type ra Tint.
+Proof.
+ intros. change Tint with (type_of_chunk Mint32).
+ eapply Mem.load_type. eapply rsa_contains; eauto.
+Qed.
+
+(** Matching a Mach stack against an Asm memory state. *)
+
+Section MATCH_STACK.
+
+Variable ge: Mach.genv.
+
+Inductive match_stack:
+ list Mach.stackframe -> mem -> mem -> val -> block -> Prop :=
+ | match_stack_nil: forall m m' bound,
+ match_stack nil m m' Vzero bound
+ | match_stack_cons: forall f sp c s m m' ra tf tc ra' bound
+ (AT: transl_code_at_pc ge ra f c false tf tc)
+ (RSA: retaddr_stored_at m m' sp (Int.unsigned f.(fn_retaddr_ofs)) ra')
+ (BELOW: sp < bound),
+ match_stack s m m' ra' sp ->
+ match_stack (Stackframe f (Vptr sp Int.zero) c :: s) m m' ra bound.
+
+Lemma match_stack_invariant:
+ forall m2 m2' s m1 m1' ra bound,
+ match_stack s m1 m1' ra bound ->
+ (forall b ofs p, b < bound -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) ->
+ (forall b ofs k p, b < bound -> Mem.perm m1' b ofs k p -> Mem.perm m2' b ofs k p) ->
+ (forall b ofs v, b < bound -> Mem.load Mint32 m1' b ofs = Some v -> Mem.load Mint32 m2' b ofs = Some v) ->
+ match_stack s m2 m2' ra bound.
+Proof.
+ induction 1; intros; econstructor; eauto.
+ eapply retaddr_stored_at_invariant; eauto.
+ apply IHmatch_stack; intros.
+ eapply H0; eauto. omega.
+ eapply H1; eauto. omega.
+ eapply H2; eauto. omega.
+Qed.
+
+Lemma match_stack_change_bound:
+ forall s m m' ra bound1 bound2,
+ match_stack s m m' ra bound1 ->
+ bound1 <= bound2 ->
+ match_stack s m m' ra bound2.
+Proof.
+ intros. inv H; econstructor; eauto. omega.
+Qed.
+
+Lemma match_stack_storev:
+ forall chunk a v m1 a' v' m1' s m m' ra bound,
+ match_stack s m m' ra bound ->
+ Mem.storev chunk m a v = Some m1 ->
+ Mem.storev chunk m' a' v' = Some m1' ->
+ Val.lessdef a a' ->
+ match_stack s m1 m1' ra bound.
+Proof.
+ induction 1; intros; econstructor; eauto.
+ eapply retaddr_stored_at_storev; eauto.
+Qed.
+
+Lemma match_stack_extcall:
+ forall m2 m2' s m1 m1' ra bound,
+ match_stack s m1 m1' ra bound ->
+ (forall b ofs p, Mem.valid_block m1 b -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) ->
+ mem_unchanged_on (loc_out_of_bounds m1) m1' m2' ->
+ Mem.extends m1 m1' ->
+ match_stack s m2 m2' ra bound.
+Proof.
+ induction 1; intros; econstructor; eauto.
+ eapply retaddr_stored_at_extcall; eauto.
+Qed.
+
+Lemma match_stack_free_left:
+ forall s m m' ra bound b lo hi m1,
+ match_stack s m m' ra bound ->
+ Mem.free m b lo hi = Some m1 ->
+ match_stack s m1 m' ra bound.
+Proof.
+ intros. eapply match_stack_invariant; eauto.
+ intros. eapply Mem.perm_free_3; eauto.
+Qed.
+
+Lemma match_stack_free_right:
+ forall s m m' ra bound b lo hi m1',
+ match_stack s m m' ra bound ->
+ Mem.free m' b lo hi = Some m1' ->
+ bound <= b ->
+ match_stack s m m1' ra bound.
+Proof.
+ intros. eapply match_stack_invariant; eauto.
+ intros. eapply Mem.perm_free_1; eauto. left. unfold block; omega.
+ intros. rewrite <- H3. eapply Mem.load_free; eauto. left. unfold block; omega.
+Qed.
+
+Lemma parent_sp_def:
+ forall s m m' ra bound,
+ match_stack s m m' ra bound -> parent_sp s <> Vundef.
+Proof.
+ intros. inv H; simpl; congruence.
+Qed.
+
+Lemma lessdef_parent_sp:
+ forall s m m' ra bound v,
+ match_stack s m m' ra bound -> Val.lessdef (parent_sp s) v -> v = parent_sp s.
+Proof.
+ intros. inv H0; auto. exfalso. eelim parent_sp_def; eauto.
+Qed.
+
+End MATCH_STACK.
+
+
diff --git a/backend/Mach.v b/backend/Mach.v
index 56c0369..12c6c9d 100644
--- a/backend/Mach.v
+++ b/backend/Mach.v
@@ -21,10 +21,14 @@ Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Values.
+Require Import Memory.
Require Import Globalenvs.
+Require Import Events.
+Require Import Smallstep.
Require Import Op.
Require Import Locations.
Require Import Conventions.
+Require Stacklayout.
(** * Abstract syntax *)
@@ -89,13 +93,39 @@ Definition funsig (fd: fundef) :=
Definition genv := Genv.t fundef unit.
-(** * Elements of dynamic semantics *)
-
-(** The operational semantics is in module [Machsem]. *)
+(** * Operational semantics *)
+
+(** The semantics for Mach is close to that of [Linear]: they differ only
+ on the interpretation of stack slot accesses. In Mach, these
+ accesses are interpreted as memory accesses relative to the
+ stack pointer. More precisely:
+- [Mgetstack ofs ty r] is a memory load at offset [ofs * 4] relative
+ to the stack pointer.
+- [Msetstack r ofs ty] is a memory store at offset [ofs * 4] relative
+ to the stack pointer.
+- [Mgetparam ofs ty r] is a memory load at offset [ofs * 4]
+ relative to the pointer found at offset 0 from the stack pointer.
+ The semantics maintain a linked structure of activation records,
+ with the current record containing a pointer to the record of the
+ caller function at offset 0.
+
+In addition to this linking of activation records, the
+semantics also make provisions for storing a back link at offset
+[f.(fn_link_ofs)] from the stack pointer, and a return address at
+offset [f.(fn_retaddr_ofs)]. The latter stack location will be used
+by the Asm code generated by [Asmgen] to save the return address into
+the caller at the beginning of a function, then restore it and jump to
+it at the end of a function. *)
Definition chunk_of_type (ty: typ) :=
match ty with Tint => Mint32 | Tfloat => Mfloat64al32 end.
+Definition load_stack (m: mem) (sp: val) (ty: typ) (ofs: int) :=
+ Mem.loadv (chunk_of_type ty) m (Val.add sp (Vint ofs)).
+
+Definition store_stack (m: mem) (sp: val) (ty: typ) (ofs: int) (v: val) :=
+ Mem.storev (chunk_of_type ty) m (Val.add sp (Vint ofs)) v.
+
Module RegEq.
Definition t := mreg.
Definition eq := mreg_eq.
@@ -170,15 +200,210 @@ Proof.
destruct (is_label lbl a). inv H. auto with coqlib. eauto with coqlib.
Qed.
-Definition find_function_ptr
- (ge: genv) (ros: mreg + ident) (rs: regset) : option block :=
+Section RELSEM.
+
+Variable ge: genv.
+
+Definition find_function (ros: mreg + ident) (rs: regset) : option fundef :=
match ros with
- | inl r =>
- match rs r with
- | Vptr b ofs => if Int.eq ofs Int.zero then Some b else None
- | _ => None
- end
+ | inl r => Genv.find_funct ge (rs r)
| inr symb =>
- Genv.find_symbol ge symb
+ match Genv.find_symbol ge symb with
+ | None => None
+ | Some b => Genv.find_funct_ptr ge b
+ end
+ end.
+
+(** Extract the values of the arguments to an external call. *)
+
+Inductive extcall_arg: regset -> mem -> val -> loc -> val -> Prop :=
+ | extcall_arg_reg: forall rs m sp r,
+ extcall_arg rs m sp (R r) (rs r)
+ | extcall_arg_stack: forall rs m sp ofs ty v,
+ load_stack m sp ty (Int.repr (Stacklayout.fe_ofs_arg + 4 * ofs)) = Some v ->
+ extcall_arg rs m sp (S (Outgoing ofs ty)) v.
+
+Definition extcall_arguments
+ (rs: regset) (m: mem) (sp: val) (sg: signature) (args: list val) : Prop :=
+ list_forall2 (extcall_arg rs m sp) (loc_arguments sg) args.
+
+(** Extract the values of the arguments to an annotation. *)
+
+Inductive annot_arg: regset -> mem -> val -> annot_param -> val -> Prop :=
+ | annot_arg_reg: forall rs m sp r,
+ annot_arg rs m sp (APreg r) (rs r)
+ | annot_arg_stack: forall rs m stk base chunk ofs v,
+ Mem.load chunk m stk (Int.unsigned base + ofs) = Some v ->
+ annot_arg rs m (Vptr stk base) (APstack chunk ofs) v.
+
+Definition annot_arguments
+ (rs: regset) (m: mem) (sp: val) (params: list annot_param) (args: list val) : Prop :=
+ list_forall2 (annot_arg rs m sp) params args.
+
+(** Mach execution states. *)
+
+Inductive stackframe: Type :=
+ | Stackframe:
+ forall (f: function) (**r calling function *)
+ (sp: val) (**r stack pointer in calling function *)
+ (c: code), (**r program point in calling function *)
+ stackframe.
+
+Inductive state: Type :=
+ | State:
+ forall (stack: list stackframe) (**r call stack *)
+ (f: function) (**r current function *)
+ (sp: val) (**r stack pointer *)
+ (c: code) (**r current program point *)
+ (rs: regset) (**r register state *)
+ (m: mem), (**r memory state *)
+ state
+ | Callstate:
+ forall (stack: list stackframe) (**r call stack *)
+ (fd: fundef) (**r function to call *)
+ (rs: regset) (**r register state *)
+ (m: mem), (**r memory state *)
+ state
+ | Returnstate:
+ forall (stack: list stackframe) (**r call stack *)
+ (rs: regset) (**r register state *)
+ (m: mem), (**r memory state *)
+ state.
+
+Definition parent_sp (s: list stackframe) : val :=
+ match s with
+ | nil => Vptr Mem.nullptr Int.zero
+ | Stackframe f sp c :: s' => sp
end.
+Inductive step: state -> trace -> state -> Prop :=
+ | exec_Mlabel:
+ forall s f sp lbl c rs m,
+ step (State s f sp (Mlabel lbl :: c) rs m)
+ E0 (State s f sp c rs m)
+ | exec_Mgetstack:
+ forall s f sp ofs ty dst c rs m v,
+ load_stack m sp ty ofs = Some v ->
+ step (State s f sp (Mgetstack ofs ty dst :: c) rs m)
+ E0 (State s f sp c (rs#dst <- v) m)
+ | exec_Msetstack:
+ forall s f sp src ofs ty c rs m m',
+ store_stack m sp ty ofs (rs src) = Some m' ->
+ step (State s f sp (Msetstack src ofs ty :: c) rs m)
+ E0 (State s f sp c (undef_setstack rs) m')
+ | exec_Mgetparam:
+ forall s f sp ofs ty dst c rs m v,
+ load_stack m sp Tint f.(fn_link_ofs) = Some (parent_sp s) ->
+ load_stack m (parent_sp s) ty ofs = Some v ->
+ step (State s f sp (Mgetparam ofs ty dst :: c) rs m)
+ E0 (State s f sp c (rs # IT1 <- Vundef # dst <- v) m)
+ | exec_Mop:
+ forall s f sp op args res c rs m v,
+ eval_operation ge sp op rs##args m = Some v ->
+ step (State s f sp (Mop op args res :: c) rs m)
+ E0 (State s f sp c ((undef_op op rs)#res <- v) m)
+ | exec_Mload:
+ forall s 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 ->
+ step (State s f sp (Mload chunk addr args dst :: c) rs m)
+ E0 (State s f sp c ((undef_temps rs)#dst <- v) m)
+ | exec_Mstore:
+ forall s 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' ->
+ step (State s f sp (Mstore chunk addr args src :: c) rs m)
+ E0 (State s f sp c (undef_temps rs) m')
+ | exec_Mcall:
+ forall s f sp sig ros c rs m fd,
+ find_function ros rs = Some fd ->
+ step (State s f sp (Mcall sig ros :: c) rs m)
+ E0 (Callstate (Stackframe f sp c :: s)
+ fd rs m)
+ | exec_Mtailcall:
+ forall s f stk soff sig ros c rs m fd m' m'',
+ find_function ros rs = Some fd ->
+ load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
+ Mem.free m stk 0 (Int.unsigned f.(fn_retaddr_ofs)) = Some m' ->
+ Mem.free m' stk (Int.unsigned f.(fn_retaddr_ofs) + 4) f.(fn_stacksize) = Some m'' ->
+ step (State s f (Vptr stk soff) (Mtailcall sig ros :: c) rs m)
+ E0 (Callstate s fd rs m'')
+ | exec_Mbuiltin:
+ forall s f sp rs m ef args res b t v m',
+ external_call ef ge rs##args m t v m' ->
+ step (State s f sp (Mbuiltin ef args res :: b) rs m)
+ t (State s f sp b ((undef_temps rs)#res <- v) m')
+ | exec_Mannot:
+ forall s f sp rs m ef args b vargs t v m',
+ annot_arguments rs m sp args vargs ->
+ external_call ef ge vargs m t v m' ->
+ step (State s f sp (Mannot ef args :: b) rs m)
+ t (State s f sp b rs m')
+ | exec_Mgoto:
+ forall s f sp lbl c rs m c',
+ find_label lbl f.(fn_code) = Some c' ->
+ step (State s f sp (Mgoto lbl :: c) rs m)
+ E0 (State s f sp c' rs m)
+ | exec_Mcond_true:
+ forall s f sp cond args lbl c rs m c',
+ eval_condition cond rs##args m = Some true ->
+ find_label lbl f.(fn_code) = Some c' ->
+ step (State s f sp (Mcond cond args lbl :: c) rs m)
+ E0 (State s f sp c' (undef_temps rs) m)
+ | exec_Mcond_false:
+ forall s f sp cond args lbl c rs m,
+ eval_condition cond rs##args m = Some false ->
+ step (State s f sp (Mcond cond args lbl :: c) rs m)
+ E0 (State s f sp c (undef_temps rs) m)
+ | exec_Mjumptable:
+ forall s f sp arg tbl c rs m n lbl c',
+ rs arg = Vint n ->
+ list_nth_z tbl (Int.unsigned n) = Some lbl ->
+ find_label lbl f.(fn_code) = Some c' ->
+ step (State s f sp (Mjumptable arg tbl :: c) rs m)
+ E0 (State s f sp c' (undef_temps rs) m)
+ | exec_Mreturn:
+ forall s f stk soff c rs m m' m'',
+ load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
+ Mem.free m stk 0 (Int.unsigned f.(fn_retaddr_ofs)) = Some m' ->
+ Mem.free m' stk (Int.unsigned f.(fn_retaddr_ofs) + 4) f.(fn_stacksize) = Some m'' ->
+ step (State s f (Vptr stk soff) (Mreturn :: c) rs m)
+ E0 (Returnstate s rs m'')
+ | exec_function_internal:
+ forall s f rs m m1 m2 m3 stk,
+ Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) ->
+ Mem.free m1 stk (Int.unsigned f.(fn_retaddr_ofs)) (Int.unsigned f.(fn_retaddr_ofs) + 4) = Some m2 ->
+ let sp := Vptr stk Int.zero in
+ store_stack m2 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m3 ->
+ (4 | Int.unsigned f.(fn_retaddr_ofs)) ->
+ step (Callstate s (Internal f) rs m)
+ E0 (State s f sp f.(fn_code) (undef_temps rs) m3)
+ | exec_function_external:
+ forall s ef rs m t rs' args res m',
+ external_call ef ge args m t res m' ->
+ extcall_arguments rs m (parent_sp s) (ef_sig ef) args ->
+ rs' = (rs#(loc_result (ef_sig ef)) <- res) ->
+ step (Callstate s (External ef) rs m)
+ t (Returnstate s rs' m')
+ | exec_return:
+ forall s f sp c rs m,
+ step (Returnstate (Stackframe f sp c :: s) rs m)
+ E0 (State s f sp c rs m).
+
+End RELSEM.
+
+Inductive initial_state (p: program): state -> Prop :=
+ | initial_state_intro: forall b fd m0,
+ let ge := Genv.globalenv p in
+ Genv.init_mem p = Some m0 ->
+ Genv.find_symbol ge p.(prog_main) = Some b ->
+ Genv.find_funct_ptr ge b = Some fd ->
+ initial_state p (Callstate nil fd (Regmap.init Vundef) m0).
+
+Inductive final_state: state -> int -> Prop :=
+ | final_state_intro: forall rs m r,
+ rs (loc_result (mksignature nil (Some Tint))) = Vint r ->
+ final_state (Returnstate nil rs m) r.
+
+Definition semantics (p: program) :=
+ Semantics step (initial_state p) final_state (Genv.globalenv p).
diff --git a/backend/Machsem.v b/backend/Machsem.v
index 6d5f1cf..60762c0 100644
--- a/backend/Machsem.v
+++ b/backend/Machsem.v
@@ -25,7 +25,6 @@ Require Import Locations.
Require Import Conventions.
Require Import Mach.
Require Stacklayout.
-Require Asmgenretaddr.
(** The semantics for Mach is close to that of [Linear]: they differ only
on the interpretation of stack slot accesses. In Mach, these
@@ -91,16 +90,15 @@ Definition annot_arguments
Inductive stackframe: Type :=
| Stackframe:
- forall (f: block) (**r pointer to calling function *)
+ forall (f: function) (**r calling function *)
(sp: val) (**r stack pointer in calling function *)
- (retaddr: val) (**r Asm return address in calling function *)
(c: code), (**r program point in calling function *)
stackframe.
Inductive state: Type :=
| State:
forall (stack: list stackframe) (**r call stack *)
- (f: block) (**r pointer to current function *)
+ (f: function) (**r current function *)
(sp: val) (**r stack pointer *)
(c: code) (**r current program point *)
(rs: regset) (**r register state *)
@@ -108,7 +106,7 @@ Inductive state: Type :=
state
| Callstate:
forall (stack: list stackframe) (**r call stack *)
- (f: block) (**r pointer to function to call *)
+ (fd: fundef) (**r function to call *)
(rs: regset) (**r register state *)
(m: mem), (**r memory state *)
state
@@ -121,13 +119,7 @@ Inductive state: Type :=
Definition parent_sp (s: list stackframe) : val :=
match s with
| nil => Vptr Mem.nullptr Int.zero
- | Stackframe f sp ra c :: s' => sp
- end.
-
-Definition parent_ra (s: list stackframe) : val :=
- match s with
- | nil => Vzero
- | Stackframe f sp ra c :: s' => ra
+ | Stackframe f sp c :: s' => sp
end.
Section RELSEM.
@@ -150,12 +142,11 @@ Inductive step: state -> trace -> state -> Prop :=
step (State s f sp (Msetstack src ofs ty :: c) rs m)
E0 (State s f sp c (undef_setstack rs) m')
| exec_Mgetparam:
- forall s fb f sp ofs ty dst c rs m v,
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ forall s f sp ofs ty dst c rs m v,
load_stack m sp Tint f.(fn_link_ofs) = Some (parent_sp s) ->
load_stack m (parent_sp s) ty ofs = Some v ->
- step (State s fb sp (Mgetparam ofs ty dst :: c) rs m)
- E0 (State s fb sp c (rs # IT1 <- Vundef # dst <- v) m)
+ step (State s f sp (Mgetparam ofs ty dst :: c) rs m)
+ E0 (State s f sp c (rs # IT1 <- Vundef # dst <- v) m)
| exec_Mop:
forall s f sp op args res c rs m v,
eval_operation ge sp op rs##args m = Some v ->
@@ -174,22 +165,19 @@ Inductive step: state -> trace -> state -> Prop :=
step (State s f sp (Mstore chunk addr args src :: c) rs m)
E0 (State s f sp c (undef_temps rs) m')
| exec_Mcall:
- forall s fb sp sig ros c rs m f f' ra,
- find_function_ptr ge ros rs = Some f' ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Asmgenretaddr.return_address_offset f c ra ->
- step (State s fb sp (Mcall sig ros :: c) rs m)
- E0 (Callstate (Stackframe fb sp (Vptr fb ra) c :: s)
- f' rs m)
+ forall s f sp sig ros c rs m fd,
+ find_function ge ros rs = Some fd ->
+ step (State s f sp (Mcall sig ros :: c) rs m)
+ E0 (Callstate (Stackframe f sp c :: s)
+ fd rs m)
| exec_Mtailcall:
- forall s fb stk soff sig ros c rs m f f' m',
- find_function_ptr ge ros rs = Some f' ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ forall s f stk soff sig ros c rs m fd m' m'',
+ find_function ge ros rs = Some fd ->
load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
- load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
- Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
- step (State s fb (Vptr stk soff) (Mtailcall sig ros :: c) rs m)
- E0 (Callstate s f' rs m')
+ Mem.free m stk 0 (Int.unsigned f.(fn_retaddr_ofs)) = Some m' ->
+ Mem.free m' stk (Int.unsigned f.(fn_retaddr_ofs) + 4) f.(fn_stacksize) = Some m'' ->
+ step (State s f (Vptr stk soff) (Mtailcall sig ros :: c) rs m)
+ E0 (Callstate s fd rs m'')
| exec_Mbuiltin:
forall s f sp rs m ef args res b t v m',
external_call ef ge rs##args m t v m' ->
@@ -202,69 +190,65 @@ Inductive step: state -> trace -> state -> Prop :=
step (State s f sp (Mannot ef args :: b) rs m)
t (State s f sp b rs m')
| exec_Mgoto:
- forall s fb f sp lbl c rs m c',
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ forall s f sp lbl c rs m c',
find_label lbl f.(fn_code) = Some c' ->
- step (State s fb sp (Mgoto lbl :: c) rs m)
- E0 (State s fb sp c' rs m)
+ step (State s f sp (Mgoto lbl :: c) rs m)
+ E0 (State s f sp c' rs m)
| exec_Mcond_true:
- forall s fb f sp cond args lbl c rs m c',
+ forall s f sp cond args lbl c rs m c',
eval_condition cond rs##args m = Some true ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
find_label lbl f.(fn_code) = Some c' ->
- step (State s fb sp (Mcond cond args lbl :: c) rs m)
- E0 (State s fb sp c' (undef_temps rs) m)
+ step (State s f sp (Mcond cond args lbl :: c) rs m)
+ E0 (State s f sp c' (undef_temps rs) m)
| exec_Mcond_false:
forall s f sp cond args lbl c rs m,
eval_condition cond rs##args m = Some false ->
step (State s f sp (Mcond cond args lbl :: c) rs m)
E0 (State s f sp c (undef_temps rs) m)
| exec_Mjumptable:
- forall s fb f sp arg tbl c rs m n lbl c',
+ forall s f sp arg tbl c rs m n lbl c',
rs arg = Vint n ->
list_nth_z tbl (Int.unsigned n) = Some lbl ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
find_label lbl f.(fn_code) = Some c' ->
- step (State s fb sp (Mjumptable arg tbl :: c) rs m)
- E0 (State s fb sp c' (undef_temps rs) m)
+ step (State s f sp (Mjumptable arg tbl :: c) rs m)
+ E0 (State s f sp c' (undef_temps rs) m)
| exec_Mreturn:
- forall s fb stk soff c rs m f m',
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ forall s f stk soff c rs m m' m'',
load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
- load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
- Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
- step (State s fb (Vptr stk soff) (Mreturn :: c) rs m)
- E0 (Returnstate s rs m')
+ Mem.free m stk 0 (Int.unsigned f.(fn_retaddr_ofs)) = Some m' ->
+ Mem.free m' stk (Int.unsigned f.(fn_retaddr_ofs) + 4) f.(fn_stacksize) = Some m'' ->
+ step (State s f (Vptr stk soff) (Mreturn :: c) rs m)
+ E0 (Returnstate s rs m'')
| exec_function_internal:
- forall s fb rs m f m1 m2 m3 stk,
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ forall s f rs m m1 m2 m3 stk,
Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) ->
+ Mem.free m1 stk (Int.unsigned f.(fn_retaddr_ofs)) (Int.unsigned f.(fn_retaddr_ofs) + 4) = Some m2 ->
let sp := Vptr stk Int.zero in
- store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 ->
- store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 ->
- step (Callstate s fb rs m)
- E0 (State s fb sp f.(fn_code) (undef_temps rs) m3)
+ store_stack m2 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m3 ->
+ (4 | Int.unsigned f.(fn_retaddr_ofs)) ->
+ step (Callstate s (Internal f) rs m)
+ E0 (State s f sp f.(fn_code) (undef_temps rs) m3)
| exec_function_external:
- forall s fb rs m t rs' ef args res m',
- Genv.find_funct_ptr ge fb = Some (External ef) ->
+ forall s ef rs m t rs' args res m',
external_call ef ge args m t res m' ->
extcall_arguments rs m (parent_sp s) (ef_sig ef) args ->
rs' = (rs#(loc_result (ef_sig ef)) <- res) ->
- step (Callstate s fb rs m)
+ step (Callstate s (External ef) rs m)
t (Returnstate s rs' m')
| exec_return:
- forall s f sp ra c rs m,
- step (Returnstate (Stackframe f sp ra c :: s) rs m)
+ forall s f sp c rs m,
+ step (Returnstate (Stackframe f sp c :: s) rs m)
E0 (State s f sp c rs m).
End RELSEM.
Inductive initial_state (p: program): state -> Prop :=
- | initial_state_intro: forall fb m0,
+ | initial_state_intro: forall b fd m0,
let ge := Genv.globalenv p in
Genv.init_mem p = Some m0 ->
- Genv.find_symbol ge p.(prog_main) = Some fb ->
- initial_state p (Callstate nil fb (Regmap.init Vundef) m0).
+ Genv.find_symbol ge p.(prog_main) = Some b ->
+ Genv.find_funct_ptr ge b = Some fd ->
+ initial_state p (Callstate nil fd (Regmap.init Vundef) m0).
Inductive final_state: state -> int -> Prop :=
| final_state_intro: forall rs m r,
diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v
index b731487..cd01beb 100644
--- a/backend/Stackingproof.v
+++ b/backend/Stackingproof.v
@@ -29,7 +29,6 @@ Require LTL.
Require Import Linear.
Require Import Lineartyping.
Require Import Mach.
-Require Import Machsem.
Require Import Bounds.
Require Import Conventions.
Require Import Stacklayout.
@@ -422,23 +421,31 @@ Definition frame_perm_freeable (m: mem) (sp: block): Prop :=
forall ofs,
0 <= ofs < fe.(fe_size) ->
ofs < fe.(fe_stack_data) \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs ->
+ ofs < fe.(fe_ofs_retaddr) \/ fe.(fe_ofs_retaddr) + 4 <= ofs ->
Mem.perm m sp ofs Cur Freeable.
Lemma offset_of_index_perm:
forall m sp idx,
- index_valid idx ->
+ index_valid idx -> idx <> FI_retaddr ->
frame_perm_freeable m sp ->
Mem.range_perm m sp (offset_of_index fe idx) (offset_of_index fe idx + AST.typesize (type_of_index idx)) Cur Freeable.
Proof.
intros.
exploit offset_of_index_valid; eauto. intros [A B].
- exploit offset_of_index_disj_stack_data_2; eauto. intros.
- red; intros. apply H0. omega. omega.
+ exploit offset_of_index_disj.
+ instantiate (1 := FI_retaddr); exact I.
+ eexact H.
+ red. destruct idx; auto || congruence.
+ change (AST.typesize (type_of_index FI_retaddr)) with 4.
+ change (offset_of_index fe FI_retaddr) with fe.(fe_ofs_retaddr).
+ intros C.
+ exploit offset_of_index_disj_stack_data_2; eauto. intros D.
+ red; intros. apply H1. omega. omega. omega.
Qed.
Lemma store_index_succeeds:
forall m sp idx v,
- index_valid idx ->
+ index_valid idx -> idx <> FI_retaddr ->
frame_perm_freeable m sp ->
exists m',
Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m'.
@@ -520,7 +527,7 @@ Qed.
Lemma index_contains_inj_undef:
forall j m sp idx,
- index_valid idx ->
+ index_valid idx -> idx <> FI_retaddr ->
frame_perm_freeable m sp ->
index_contains_inj j m sp idx Vundef.
Proof.
@@ -550,7 +557,7 @@ Definition agree_regs (j: meminj) (ls: locset) (rs: regset) : Prop :=
Record agree_frame (j: meminj) (ls ls0: locset)
(m: mem) (sp: block)
(m': mem) (sp': block)
- (parent retaddr: val) : Prop :=
+ (parent: val) : Prop :=
mk_agree_frame {
(** Unused registers have the same value as in the caller *)
@@ -576,12 +583,9 @@ Record agree_frame (j: meminj) (ls ls0: locset)
In (S (Incoming ofs ty)) (loc_parameters f.(Linear.fn_sig)) ->
ls (S (Incoming ofs ty)) = ls0 (S (Outgoing ofs ty));
- (** The back link and return address slots of the Mach frame contain
- the [parent] and [retaddr] values, respectively. *)
+ (** The back link contains the [parent] value. *)
agree_link:
index_contains m' sp' FI_link parent;
- agree_retaddr:
- index_contains m' sp' FI_retaddr retaddr;
(** The areas of the frame reserved for saving used callee-save
registers always contain the values that those registers had
@@ -623,7 +627,7 @@ Record agree_frame (j: meminj) (ls ls0: locset)
}.
Hint Resolve agree_unused_reg agree_locals agree_outgoing agree_incoming
- agree_link agree_retaddr agree_saved_int agree_saved_float
+ agree_link agree_saved_int agree_saved_float
agree_valid_linear agree_valid_mach agree_perm
agree_wt_ls: stacking.
@@ -763,11 +767,11 @@ Qed.
(** Preservation under assignment of machine register. *)
Lemma agree_frame_set_reg:
- forall j ls ls0 m sp m' sp' parent ra r v,
- agree_frame j ls ls0 m sp m' sp' parent ra ->
+ forall j ls ls0 m sp m' sp' parent r v,
+ agree_frame j ls ls0 m sp m' sp' parent ->
mreg_within_bounds b r ->
Val.has_type v (Loc.type (R r)) ->
- agree_frame j (Locmap.set (R r) v ls) ls0 m sp m' sp' parent ra.
+ agree_frame j (Locmap.set (R r) v ls) ls0 m sp m' sp' parent.
Proof.
intros. inv H; constructor; auto; intros.
rewrite Locmap.gso. auto. red. intuition congruence.
@@ -794,10 +798,10 @@ Proof.
Qed.
Lemma agree_frame_undef_locs:
- forall j ls0 m sp m' sp' parent ra regs ls,
- agree_frame j ls ls0 m sp m' sp' parent ra ->
+ forall j ls0 m sp m' sp' parent regs ls,
+ agree_frame j ls ls0 m sp m' sp' parent ->
incl (List.map R regs) temporaries ->
- agree_frame j (Locmap.undef (List.map R regs) ls) ls0 m sp m' sp' parent ra.
+ agree_frame j (Locmap.undef (List.map R regs) ls) ls0 m sp m' sp' parent.
Proof.
induction regs; simpl; intros.
auto.
@@ -808,17 +812,17 @@ Proof.
Qed.
Lemma agree_frame_undef_temps:
- forall j ls ls0 m sp m' sp' parent ra,
- agree_frame j ls ls0 m sp m' sp' parent ra ->
- agree_frame j (LTL.undef_temps ls) ls0 m sp m' sp' parent ra.
+ forall j ls ls0 m sp m' sp' parent,
+ agree_frame j ls ls0 m sp m' sp' parent ->
+ agree_frame j (LTL.undef_temps ls) ls0 m sp m' sp' parent.
Proof.
intros. unfold temporaries. apply agree_frame_undef_locs; auto. apply incl_refl.
Qed.
Lemma agree_frame_undef_setstack:
- forall j ls ls0 m sp m' sp' parent ra,
- agree_frame j ls ls0 m sp m' sp' parent ra ->
- agree_frame j (Linear.undef_setstack ls) ls0 m sp m' sp' parent ra.
+ forall j ls ls0 m sp m' sp' parent,
+ agree_frame j ls ls0 m sp m' sp' parent ->
+ agree_frame j (Linear.undef_setstack ls) ls0 m sp m' sp' parent.
Proof.
intros. unfold Linear.undef_setstack, destroyed_at_move.
apply agree_frame_undef_locs; auto.
@@ -826,9 +830,9 @@ Proof.
Qed.
Lemma agree_frame_undef_op:
- forall j ls ls0 m sp m' sp' parent ra op,
- agree_frame j ls ls0 m sp m' sp' parent ra ->
- agree_frame j (Linear.undef_op op ls) ls0 m sp m' sp' parent ra.
+ forall j ls ls0 m sp m' sp' parent op,
+ agree_frame j ls ls0 m sp m' sp' parent ->
+ agree_frame j (Linear.undef_op op ls) ls0 m sp m' sp' parent.
Proof.
intros.
exploit agree_frame_undef_temps; eauto.
@@ -838,13 +842,13 @@ Qed.
(** Preservation by assignment to local slot *)
Lemma agree_frame_set_local:
- forall j ls ls0 m sp m' sp' parent retaddr ofs ty v v' m'',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
+ forall j ls ls0 m sp m' sp' parent ofs ty v v' m'',
+ agree_frame j ls ls0 m sp m' sp' parent ->
slot_within_bounds f b (Local ofs ty) ->
val_inject j v v' ->
Val.has_type v ty ->
Mem.store (chunk_of_type ty) m' sp' (offset_of_index fe (FI_local ofs ty)) v' = Some m'' ->
- agree_frame j (Locmap.set (S (Local ofs ty)) v ls) ls0 m sp m'' sp' parent retaddr.
+ agree_frame j (Locmap.set (S (Local ofs ty)) v ls) ls0 m sp m'' sp' parent.
Proof.
intros. inv H.
change (chunk_of_type ty) with (chunk_of_type (type_of_index (FI_local ofs ty))) in H3.
@@ -863,8 +867,6 @@ Proof.
rewrite Locmap.gso; auto. red; auto.
(* parent *)
eapply gso_index_contains; eauto. red; auto.
-(* retaddr *)
- eapply gso_index_contains; eauto. red; auto.
(* int callee save *)
eapply gso_index_contains_inj; eauto. simpl; auto.
(* float callee save *)
@@ -880,13 +882,13 @@ Qed.
(** Preservation by assignment to outgoing slot *)
Lemma agree_frame_set_outgoing:
- forall j ls ls0 m sp m' sp' parent retaddr ofs ty v v' m'',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
+ forall j ls ls0 m sp m' sp' parent ofs ty v v' m'',
+ agree_frame j ls ls0 m sp m' sp' parent ->
slot_within_bounds f b (Outgoing ofs ty) ->
val_inject j v v' ->
Val.has_type v ty ->
Mem.store (chunk_of_type ty) m' sp' (offset_of_index fe (FI_arg ofs ty)) v' = Some m'' ->
- agree_frame j (Locmap.set (S (Outgoing ofs ty)) v ls) ls0 m sp m'' sp' parent retaddr.
+ agree_frame j (Locmap.set (S (Outgoing ofs ty)) v ls) ls0 m sp m'' sp' parent.
Proof.
intros. inv H.
change (chunk_of_type ty) with (chunk_of_type (type_of_index (FI_arg ofs ty))) in H3.
@@ -899,7 +901,7 @@ Proof.
unfold Locmap.set. simpl. destruct (Loc.eq (S (Outgoing ofs ty)) (S (Outgoing ofs0 ty0))).
inv e. eapply gss_index_contains_inj; eauto.
case_eq (Loc.overlap_aux ty ofs ofs0 || Loc.overlap_aux ty0 ofs0 ofs); intros.
- apply index_contains_inj_undef. auto.
+ apply index_contains_inj_undef. auto. congruence.
red; intros. eapply Mem.perm_store_1; eauto.
eapply gso_index_contains_inj; eauto.
red. eapply Loc.overlap_aux_false_1; eauto.
@@ -907,8 +909,6 @@ Proof.
rewrite Locmap.gso; auto. red; auto.
(* parent *)
eapply gso_index_contains; eauto with stacking. red; auto.
-(* retaddr *)
- eapply gso_index_contains; eauto with stacking. red; auto.
(* int callee save *)
eapply gso_index_contains_inj; eauto with stacking. simpl; auto.
(* float callee save *)
@@ -924,8 +924,8 @@ Qed.
(** General invariance property with respect to memory changes. *)
Lemma agree_frame_invariant:
- forall j ls ls0 m sp m' sp' parent retaddr m1 m1',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
+ forall j ls ls0 m sp m' sp' parent m1 m1',
+ agree_frame j ls ls0 m sp m' sp' parent ->
(Mem.valid_block m sp -> Mem.valid_block m1 sp) ->
(forall ofs p, Mem.perm m1 sp ofs Max p -> Mem.perm m sp ofs Max p) ->
(Mem.valid_block m' sp' -> Mem.valid_block m1' sp') ->
@@ -937,7 +937,7 @@ Lemma agree_frame_invariant:
(forall ofs k p,
ofs < fe.(fe_stack_data) \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs ->
Mem.perm m' sp' ofs k p -> Mem.perm m1' sp' ofs k p) ->
- agree_frame j ls ls0 m1 sp m1' sp' parent retaddr.
+ agree_frame j ls ls0 m1 sp m1' sp' parent.
Proof.
intros.
assert (IC: forall idx v,
@@ -956,13 +956,13 @@ Qed.
(** A variant of the latter, for use with external calls *)
Lemma agree_frame_extcall_invariant:
- forall j ls ls0 m sp m' sp' parent retaddr m1 m1',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
+ forall j ls ls0 m sp m' sp' parent m1 m1',
+ agree_frame j ls ls0 m sp m' sp' parent ->
(Mem.valid_block m sp -> Mem.valid_block m1 sp) ->
(forall ofs p, Mem.perm m1 sp ofs Max p -> Mem.perm m sp ofs Max p) ->
(Mem.valid_block m' sp' -> Mem.valid_block m1' sp') ->
mem_unchanged_on (loc_out_of_reach j m) m' m1' ->
- agree_frame j ls ls0 m1 sp m1' sp' parent retaddr.
+ agree_frame j ls ls0 m1 sp m1' sp' parent.
Proof.
intros.
assert (REACH: forall ofs,
@@ -978,13 +978,13 @@ Qed.
(** Preservation by parallel stores in the Linear and Mach codes *)
Lemma agree_frame_parallel_stores:
- forall j ls ls0 m sp m' sp' parent retaddr chunk addr addr' v v' m1 m1',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
+ forall j ls ls0 m sp m' sp' parent chunk addr addr' v v' m1 m1',
+ agree_frame j ls ls0 m sp m' sp' parent ->
Mem.inject j m m' ->
val_inject j addr addr' ->
Mem.storev chunk m addr v = Some m1 ->
Mem.storev chunk m' addr' v' = Some m1' ->
- agree_frame j ls ls0 m1 sp m1' sp' parent retaddr.
+ agree_frame j ls ls0 m1 sp m1' sp' parent.
Proof.
Opaque Int.add.
intros until m1'. intros AG MINJ VINJ STORE1 STORE2.
@@ -1014,11 +1014,11 @@ Qed.
(** Preservation by increasing memory injections (allocations and external calls) *)
Lemma agree_frame_inject_incr:
- forall j ls ls0 m sp m' sp' parent retaddr m1 m1' j',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
+ forall j ls ls0 m sp m' sp' parent m1 m1' j',
+ agree_frame j ls ls0 m sp m' sp' parent ->
inject_incr j j' -> inject_separated j j' m1 m1' ->
Mem.valid_block m1' sp' ->
- agree_frame j' ls ls0 m sp m' sp' parent retaddr.
+ agree_frame j' ls ls0 m sp m' sp' parent.
Proof.
intros. inv H. constructor; auto; intros; eauto with stacking.
case_eq (j b0).
@@ -1054,11 +1054,11 @@ Proof.
Qed.
Lemma agree_frame_return:
- forall j ls ls0 m sp m' sp' parent retaddr ls',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
+ forall j ls ls0 m sp m' sp' parent ls',
+ agree_frame j ls ls0 m sp m' sp' parent ->
agree_callee_save ls' ls ->
wt_locset ls' ->
- agree_frame j ls' ls0 m sp m' sp' parent retaddr.
+ agree_frame j ls' ls0 m sp m' sp' parent.
Proof.
intros. red in H0. inv H; constructor; auto; intros.
rewrite H0; auto. apply mreg_not_within_bounds_callee_save; auto.
@@ -1070,10 +1070,10 @@ Qed.
(** Preservation at tailcalls (when [ls0] is changed but not [ls]). *)
Lemma agree_frame_tailcall:
- forall j ls ls0 m sp m' sp' parent retaddr ls0',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
+ forall j ls ls0 m sp m' sp' parent ls0',
+ agree_frame j ls ls0 m sp m' sp' parent ->
agree_callee_save ls0 ls0' ->
- agree_frame j ls ls0' m sp m' sp' parent retaddr.
+ agree_frame j ls ls0' m sp m' sp' parent.
Proof.
intros. red in H0. inv H; constructor; auto; intros.
rewrite <- H0; auto. apply mreg_not_within_bounds_callee_save; auto.
@@ -1082,7 +1082,6 @@ Proof.
rewrite <- H0; auto.
Qed.
-
(** Properties of [agree_callee_save]. *)
Lemma agree_callee_save_return_regs:
@@ -1123,7 +1122,6 @@ Variable mkindex: Z -> frame_index.
Variable ty: typ.
Variable j: meminj.
Variable cs: list stackframe.
-Variable fb: block.
Variable sp: block.
Variable csregs: list mreg.
Variable ls: locset.
@@ -1156,6 +1154,8 @@ Hypothesis mkindex_inj:
Hypothesis mkindex_diff:
forall r idx,
idx <> mkindex (number r) -> index_diff (mkindex (number r)) idx.
+Hypothesis mkindex_not_retaddr:
+ forall r, mkindex (number r) <> FI_retaddr.
Hypothesis csregs_typ:
forall r, In r csregs -> mreg_type r = ty.
@@ -1172,9 +1172,9 @@ Lemma save_callee_save_regs_correct:
agree_regs j ls rs ->
exists rs', exists m',
star step tge
- (State cs fb (Vptr sp Int.zero)
+ (State cs tf (Vptr sp Int.zero)
(save_callee_save_regs bound number mkindex ty fe l k) rs m)
- E0 (State cs fb (Vptr sp Int.zero) k rs' m')
+ E0 (State cs tf (Vptr sp Int.zero) k rs' m')
/\ (forall r,
In r l -> number r < bound fe ->
index_contains_inj j m' sp (mkindex (number r)) (ls (R r)))
@@ -1201,7 +1201,7 @@ Proof.
unfold save_callee_save_reg.
destruct (zlt (number a) (bound fe)).
(* a store takes place *)
- exploit store_index_succeeds. apply (mkindex_valid a); auto with coqlib.
+ exploit store_index_succeeds. apply (mkindex_valid a); auto with coqlib. auto.
eauto. instantiate (1 := rs a). intros [m1 ST].
exploit (IHl k (undef_setstack rs) m1). auto with coqlib. auto.
red; eauto with mem.
@@ -1244,13 +1244,13 @@ Qed.
End SAVE_CALLEE_SAVE.
Lemma save_callee_save_correct:
- forall j ls rs sp cs fb k m,
+ forall j ls rs sp cs k m,
agree_regs j (call_regs ls) rs -> wt_locset (call_regs ls) ->
frame_perm_freeable m sp ->
exists rs', exists m',
star step tge
- (State cs fb (Vptr sp Int.zero) (save_callee_save fe k) rs m)
- E0 (State cs fb (Vptr sp Int.zero) k rs' m')
+ (State cs tf (Vptr sp Int.zero) (save_callee_save fe k) rs m)
+ E0 (State cs tf (Vptr sp Int.zero) k rs' m')
/\ (forall r,
In r int_callee_save_regs -> index_int_callee_save r < b.(bound_int_callee_save) ->
index_contains_inj j m' sp (FI_saved_int (index_int_callee_save r)) (call_regs ls (R r)))
@@ -1275,12 +1275,13 @@ Transparent destroyed_at_move_regs.
fe_num_int_callee_save
index_int_callee_save
FI_saved_int Tint
- j cs fb sp int_callee_save_regs (call_regs ls)).
+ j cs sp int_callee_save_regs (call_regs ls)).
intros. apply index_int_callee_save_inj; auto.
intros. simpl. split. apply Zge_le. apply index_int_callee_save_pos; auto. assumption.
auto.
intros; congruence.
intros; simpl. destruct idx; auto. congruence.
+ intros; congruence.
intros. apply int_callee_save_type. auto.
auto.
auto.
@@ -1293,12 +1294,13 @@ Transparent destroyed_at_move_regs.
fe_num_float_callee_save
index_float_callee_save
FI_saved_float Tfloat
- j cs fb sp float_callee_save_regs (call_regs ls)).
+ j cs sp float_callee_save_regs (call_regs ls)).
intros. apply index_float_callee_save_inj; auto.
intros. simpl. split. apply Zge_le. apply index_float_callee_save_pos; auto. assumption.
simpl; auto.
intros; congruence.
intros; simpl. destruct idx; auto. congruence.
+ intros; congruence.
intros. apply float_callee_save_type. auto.
auto.
auto.
@@ -1369,28 +1371,28 @@ Qed.
saving of the used callee-save registers). *)
Lemma function_prologue_correct:
- forall j ls ls0 rs m1 m1' m2 sp parent ra cs fb k,
+ forall j ls ls0 rs m1 m1' m2 sp parent cs k,
agree_regs j ls rs ->
agree_callee_save ls ls0 ->
wt_locset ls ->
Mem.inject j m1 m1' ->
Mem.alloc m1 0 f.(Linear.fn_stacksize) = (m2, sp) ->
- Val.has_type parent Tint -> Val.has_type ra Tint ->
+ Val.has_type parent Tint ->
exists j', exists rs', exists m2', exists sp', exists m3', exists m4', exists m5',
Mem.alloc m1' 0 tf.(fn_stacksize) = (m2', sp')
- /\ store_stack m2' (Vptr sp' Int.zero) Tint tf.(fn_link_ofs) parent = Some m3'
- /\ store_stack m3' (Vptr sp' Int.zero) Tint tf.(fn_retaddr_ofs) ra = Some m4'
+ /\ Mem.free m2' sp' (Int.unsigned tf.(fn_retaddr_ofs)) (Int.unsigned tf.(fn_retaddr_ofs) + 4) = Some m3'
+ /\ store_stack m3' (Vptr sp' Int.zero) Tint tf.(fn_link_ofs) parent = Some m4'
/\ star step tge
- (State cs fb (Vptr sp' Int.zero) (save_callee_save fe k) (undef_temps rs) m4')
- E0 (State cs fb (Vptr sp' Int.zero) k rs' m5')
+ (State cs tf (Vptr sp' Int.zero) (save_callee_save fe k) (undef_temps rs) m4')
+ E0 (State cs tf (Vptr sp' Int.zero) k rs' m5')
/\ agree_regs j' (call_regs ls) rs'
- /\ agree_frame j' (call_regs ls) ls0 m2 sp m5' sp' parent ra
+ /\ agree_frame j' (call_regs ls) ls0 m2 sp m5' sp' parent
/\ inject_incr j j'
/\ inject_separated j j' m1 m1'
/\ Mem.inject j' m2 m5'
- /\ stores_in_frame sp' m2' m5'.
+ /\ stores_in_frame sp' m3' m5'.
Proof.
- intros until k; intros AGREGS AGCS WTREGS INJ1 ALLOC TYPAR TYRA.
+ intros until k; intros AGREGS AGCS WTREGS INJ1 ALLOC TYPAR.
rewrite unfold_transf_function.
unfold fn_stacksize, fn_link_ofs, fn_retaddr_ofs.
(* Allocation step *)
@@ -1415,14 +1417,37 @@ Proof.
assert (~Mem.valid_block m1' sp') by eauto with mem.
contradiction.
intros [j' [INJ2 [INCR [MAP1 MAP2]]]].
- assert (PERM: frame_perm_freeable m2' sp').
- red; intros. eapply Mem.perm_alloc_2; eauto.
+ (* separation *)
+ assert (SEP: forall b0 delta, j' b0 = Some(sp', delta) -> b0 = sp /\ delta = fe_stack_data fe).
+ intros. destruct (zeq b0 sp).
+ subst b0. rewrite MAP1 in H; inv H; auto.
+ rewrite MAP2 in H; auto.
+ assert (Mem.valid_block m1' sp'). eapply Mem.valid_block_inject_2; eauto.
+ assert (~Mem.valid_block m1' sp') by eauto with mem.
+ contradiction.
+ (* Freeing step *)
+ assert (OFSRA: Int.unsigned (Int.repr (fe_ofs_retaddr fe)) = fe_ofs_retaddr fe).
+ apply (offset_of_index_no_overflow FI_retaddr). exact I.
+ rewrite OFSRA.
+ assert (FREE: { m3' | Mem.free m2' sp' (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + 4) = Some m3'}).
+ apply Mem.range_perm_free.
+ exploit (offset_of_index_valid FI_retaddr). exact I.
+ unfold offset_of_index. simpl AST.typesize. intros [A B].
+ red; intros. eapply Mem.perm_alloc_2; eauto. omega.
+ destruct FREE as [m3' FREE].
+ assert (INJ3: Mem.inject j' m2 m3').
+ eapply Mem.free_right_inject; eauto.
+ intros. exploit SEP; eauto. intros [A B]. subst b1 delta.
+ exploit (offset_of_index_disj_stack_data_1 FI_retaddr). exact I.
+ unfold offset_of_index. simpl AST.typesize. intros.
+ exploit Mem.perm_alloc_3. eexact ALLOC. eauto. intros.
+ generalize bound_stack_data_stacksize; intros.
+ omega.
+ assert (PERM: frame_perm_freeable m3' sp').
+ red; intros. eapply Mem.perm_free_1; eauto. eapply Mem.perm_alloc_2; eauto.
(* Store of parent *)
- exploit (store_index_succeeds m2' sp' FI_link parent). red; auto. auto.
- intros [m3' STORE2].
- (* Store of retaddr *)
- exploit (store_index_succeeds m3' sp' FI_retaddr ra). red; auto. red; eauto with mem.
- intros [m4' STORE3].
+ exploit (store_index_succeeds m3' sp' FI_link parent). red; auto. congruence. auto.
+ intros [m4' STORE].
(* Saving callee-save registers *)
assert (PERM4: frame_perm_freeable m4' sp').
red; intros. eauto with mem.
@@ -1432,32 +1457,21 @@ Proof.
eexact PERM4.
intros [rs' [m5' [STEPS [ICS [FCS [OTHERS [STORES [PERM5 AGREGS']]]]]]]].
(* stores in frames *)
- assert (SIF: stores_in_frame sp' m2' m5').
+ assert (SIF: stores_in_frame sp' m3' m5').
econstructor; eauto.
rewrite size_type_chunk. apply offset_of_index_disj_stack_data_2; auto. red; auto.
- econstructor; eauto.
- rewrite size_type_chunk. apply offset_of_index_disj_stack_data_2; auto. red; auto.
- (* separation *)
- assert (SEP: forall b0 delta, j' b0 = Some(sp', delta) -> b0 = sp /\ delta = fe_stack_data fe).
- intros. destruct (zeq b0 sp).
- subst b0. rewrite MAP1 in H; inv H; auto.
- rewrite MAP2 in H; auto.
- assert (Mem.valid_block m1' sp'). eapply Mem.valid_block_inject_2; eauto.
- assert (~Mem.valid_block m1' sp') by eauto with mem.
- contradiction.
(* Conclusions *)
exists j'; exists rs'; exists m2'; exists sp'; exists m3'; exists m4'; exists m5'.
+ (* alloc *)
+ split. auto.
+ (* free *)
split. auto.
(* store parent *)
split. change Tint with (type_of_index FI_link).
change (fe_ofs_link fe) with (offset_of_index fe FI_link).
apply store_stack_succeeds; auto. red; auto.
- (* store retaddr *)
- split. change Tint with (type_of_index FI_retaddr).
- change (fe_ofs_retaddr fe) with (offset_of_index fe FI_retaddr).
- apply store_stack_succeeds; auto. red; auto.
(* saving of registers *)
- split. eexact STEPS.
+ split. rewrite <- unfold_transf_function. eexact STEPS.
(* agree_regs *)
split. auto.
(* agree frame *)
@@ -1467,18 +1481,13 @@ Proof.
elim H. apply temporary_within_bounds; auto.
apply AGCS. apply mreg_not_within_bounds_callee_save; auto.
(* locals *)
- simpl. apply index_contains_inj_undef; auto.
+ simpl. apply index_contains_inj_undef; auto. congruence.
(* outgoing *)
- simpl. apply index_contains_inj_undef; auto.
+ simpl. apply index_contains_inj_undef; auto. congruence.
(* incoming *)
unfold call_regs. apply AGCS. auto.
(* parent *)
apply OTHERS; auto. red; auto.
- eapply gso_index_contains; eauto. red; auto.
- eapply gss_index_contains; eauto. red; auto.
- red; auto.
- (* retaddr *)
- apply OTHERS; auto. red; auto.
eapply gss_index_contains; eauto. red; auto.
(* int callee save *)
rewrite <- AGCS. replace (ls (R r)) with (call_regs ls (R r)).
@@ -1499,7 +1508,7 @@ Proof.
(* valid sp *)
eauto with mem.
(* valid sp' *)
- eapply stores_in_frame_valid with (m := m2'); eauto with mem.
+ eapply stores_in_frame_valid with (m := m3'); eauto with mem.
(* bounds *)
exploit Mem.perm_alloc_inv. eexact ALLOC. eauto. rewrite zeq_true. auto.
(* perms *)
@@ -1531,7 +1540,6 @@ Variable ty: typ.
Variable csregs: list mreg.
Variable j: meminj.
Variable cs: list stackframe.
-Variable fb: block.
Variable sp: block.
Variable ls0: locset.
Variable m: mem.
@@ -1558,9 +1566,9 @@ Lemma restore_callee_save_regs_correct:
agree_unused ls0 rs ->
exists rs',
star step tge
- (State cs fb (Vptr sp Int.zero)
+ (State cs tf (Vptr sp Int.zero)
(restore_callee_save_regs bound number mkindex ty fe l k) rs m)
- E0 (State cs fb (Vptr sp Int.zero) k rs' m)
+ E0 (State cs tf (Vptr sp Int.zero) k rs' m)
/\ (forall r, In r l -> val_inject j (ls0 (R r)) (rs' r))
/\ (forall r, ~(In r l) -> rs' r = rs r)
/\ agree_unused ls0 rs'.
@@ -1605,13 +1613,13 @@ Qed.
End RESTORE_CALLEE_SAVE.
Lemma restore_callee_save_correct:
- forall j ls ls0 m sp m' sp' pa ra cs fb rs k,
- agree_frame j ls ls0 m sp m' sp' pa ra ->
+ forall j ls ls0 m sp m' sp' pa cs rs k,
+ agree_frame j ls ls0 m sp m' sp' pa ->
agree_unused j ls0 rs ->
exists rs',
star step tge
- (State cs fb (Vptr sp' Int.zero) (restore_callee_save fe k) rs m')
- E0 (State cs fb (Vptr sp' Int.zero) k rs' m')
+ (State cs tf (Vptr sp' Int.zero) (restore_callee_save fe k) rs m')
+ E0 (State cs tf (Vptr sp' Int.zero) k rs' m')
/\ (forall r,
In r int_callee_save_regs \/ In r float_callee_save_regs ->
val_inject j (ls0 (R r)) (rs' r))
@@ -1627,7 +1635,7 @@ Proof.
FI_saved_int
Tint
int_callee_save_regs
- j cs fb sp' ls0 m'); auto.
+ j cs sp' ls0 m'); auto.
intros. unfold mreg_within_bounds. rewrite (int_callee_save_type r H1). tauto.
eapply agree_saved_int; eauto.
apply incl_refl.
@@ -1640,7 +1648,7 @@ Proof.
FI_saved_float
Tfloat
float_callee_save_regs
- j cs fb sp' ls0 m'); auto.
+ j cs sp' ls0 m'); auto.
intros. unfold mreg_within_bounds. rewrite (float_callee_save_type r H1). tauto.
eapply agree_saved_float; eauto.
apply incl_refl.
@@ -1660,57 +1668,94 @@ Qed.
registers + reloading of the link and return address + freeing
of the frame). *)
+Remark mem_range_perm_free_twice:
+ forall m blk lo1 hi1 lo2 hi2,
+ (forall ofs, lo1 <= ofs < hi2 -> ofs < hi1 \/ lo2 <= ofs -> Mem.perm m blk ofs Cur Freeable) ->
+ lo1 <= hi1 /\ lo2 <= hi2 -> hi1 < lo2 ->
+ exists m', exists m'',
+ Mem.free m blk lo1 hi1 = Some m' /\ Mem.free m' blk lo2 hi2 = Some m''.
+Proof.
+ intros.
+ destruct (Mem.range_perm_free m blk lo1 hi1) as [m' FREE1].
+ red; intros. apply H. omega. omega.
+ destruct (Mem.range_perm_free m' blk lo2 hi2) as [m'' FREE2].
+ red; intros. eapply Mem.perm_free_1; eauto. right. omega.
+ apply H. omega. omega.
+ exists m'; exists m''; auto.
+Qed.
+
Lemma function_epilogue_correct:
- forall j ls ls0 m sp m' sp' pa ra cs fb rs k m1,
+ forall j ls ls0 m sp m' sp' pa cs rs k m1,
agree_regs j ls rs ->
- agree_frame j ls ls0 m sp m' sp' pa ra ->
+ agree_frame j ls ls0 m sp m' sp' pa ->
Mem.inject j m m' ->
Mem.free m sp 0 f.(Linear.fn_stacksize) = Some m1 ->
- exists rs1, exists m1',
+ exists rs1, exists m1', exists m2',
load_stack m' (Vptr sp' Int.zero) Tint tf.(fn_link_ofs) = Some pa
- /\ load_stack m' (Vptr sp' Int.zero) Tint tf.(fn_retaddr_ofs) = Some ra
- /\ Mem.free m' sp' 0 tf.(fn_stacksize) = Some m1'
+ /\ Mem.free m' sp' 0 (Int.unsigned tf.(fn_retaddr_ofs)) = Some m1'
+ /\ Mem.free m1' sp' (Int.unsigned tf.(fn_retaddr_ofs) + 4) tf.(fn_stacksize) = Some m2'
/\ star step tge
- (State cs fb (Vptr sp' Int.zero) (restore_callee_save fe k) rs m')
- E0 (State cs fb (Vptr sp' Int.zero) k rs1 m')
+ (State cs tf (Vptr sp' Int.zero) (restore_callee_save fe k) rs m')
+ E0 (State cs tf (Vptr sp' Int.zero) k rs1 m')
/\ agree_regs j (return_regs ls0 ls) rs1
/\ agree_callee_save (return_regs ls0 ls) ls0
/\ rs1 IT1 = rs IT1
- /\ Mem.inject j m1 m1'.
+ /\ Mem.inject j m1 m2'.
Proof.
intros.
+ assert (RETADDR: Int.unsigned tf.(fn_retaddr_ofs) = fe.(fe_ofs_retaddr)).
+ rewrite unfold_transf_function. unfold fn_retaddr_ofs.
+ apply (offset_of_index_no_overflow FI_retaddr). exact I.
+ rewrite RETADDR.
(* can free *)
- destruct (Mem.range_perm_free m' sp' 0 (fn_stacksize tf)) as [m1' FREE].
- rewrite unfold_transf_function; unfold fn_stacksize. red; intros.
+ destruct (mem_range_perm_free_twice m' sp'
+ 0 (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + 4) (fe_size fe))
+ as [m1' [m2' [FREE1 FREE2]]].
+ intros.
assert (EITHER: fe_stack_data fe <= ofs < fe_stack_data fe + Linear.fn_stacksize f
- \/ (ofs < fe_stack_data fe \/ fe_stack_data fe + Linear.fn_stacksize f <= ofs))
+ \/ (ofs < fe_stack_data fe \/ fe_stack_data fe + Linear.fn_stacksize f <= ofs))
by omega.
destruct EITHER.
replace ofs with ((ofs - fe_stack_data fe) + fe_stack_data fe) by omega.
eapply Mem.perm_inject with (f := j). eapply agree_inj; eauto. eauto.
eapply Mem.free_range_perm; eauto. omega.
- eapply agree_perm; eauto.
+ eapply agree_perm; eauto.
+ apply (offset_of_index_valid FI_retaddr). exact I.
+ omega.
(* inject after free *)
- assert (INJ1: Mem.inject j m1 m1').
- eapply Mem.free_inject with (l := (sp, 0, f.(Linear.fn_stacksize)) :: nil); eauto.
- simpl. rewrite H2. auto.
- intros. exploit agree_inj_unique; eauto. intros [P Q]; subst b1 delta.
- exists 0; exists (Linear.fn_stacksize f); split. auto with coqlib.
- eapply agree_bounds. eauto. eapply Mem.perm_max. eauto.
+ assert (UNMAPPED: forall b1 delta ofs k0 p,
+ j b1 = Some (sp', delta) ->
+ Mem.perm m1 b1 ofs k0 p ->
+ False).
+ {
+ intros.
+ exploit agree_inj_unique; eauto. intros [P Q]; subst b1 delta.
+ eelim Mem.perm_free_2. eexact H2. eapply agree_bounds; eauto.
+ eapply Mem.perm_free_3; eauto. apply Mem.perm_max with k0. eauto. eauto.
+ }
+ assert (INJ1: Mem.inject j m1 m2').
+ {
+ eapply Mem.free_right_inject.
+ eapply Mem.free_right_inject.
+ eapply Mem.free_left_inject. eauto. eauto.
+ eauto.
+ intros; eapply UNMAPPED; eauto.
+ eauto.
+ intros; eapply UNMAPPED; eauto.
+ }
(* can execute epilogue *)
exploit restore_callee_save_correct; eauto.
instantiate (1 := rs). red; intros.
- rewrite <- (agree_unused_reg _ _ _ _ _ _ _ _ _ H0). auto. auto.
+ rewrite <- (agree_unused_reg _ _ _ _ _ _ _ _ H0). auto. auto.
intros [rs1 [A [B C]]].
(* conclusions *)
- exists rs1; exists m1'.
+ exists rs1; exists m1'; exists m2'.
split. rewrite unfold_transf_function; unfold fn_link_ofs.
eapply index_contains_load_stack with (idx := FI_link); eauto with stacking.
- split. rewrite unfold_transf_function; unfold fn_retaddr_ofs.
- eapply index_contains_load_stack with (idx := FI_retaddr); eauto with stacking.
- split. auto.
+ split. exact FREE1.
+ split. rewrite unfold_transf_function; unfold fn_stacksize. exact FREE2.
split. eexact A.
- split. red;intros. unfold return_regs.
+ split. red; intros. unfold return_regs.
generalize (register_classification r) (int_callee_save_not_destroyed r) (float_callee_save_not_destroyed r); intros.
destruct (in_dec Loc.eq (R r) temporaries).
rewrite C; auto.
@@ -1742,14 +1787,12 @@ Inductive match_stacks (j: meminj) (m m': mem):
hi <= bound -> hi <= bound' -> match_globalenvs j hi ->
tailcall_possible sg ->
match_stacks j m m' nil nil sg bound bound'
- | match_stacks_cons: forall f sp ls c cs fb sp' ra c' cs' sg bound bound' trf
+ | match_stacks_cons: forall f sp ls c cs sp' c' cs' sg bound bound' tf
(TAIL: is_tail c (Linear.fn_code f))
(WTF: wt_function f)
- (FINDF: Genv.find_funct_ptr tge fb = Some (Internal trf))
- (TRF: transf_function f = OK trf)
+ (TRF: transf_function f = OK tf)
(TRC: transl_code (make_env (function_bounds f)) c = c')
- (TY_RA: Val.has_type ra Tint)
- (FRM: agree_frame f j ls (parent_locset cs) m sp m' sp' (parent_sp cs') (parent_ra cs'))
+ (FRM: agree_frame f j ls (parent_locset cs) m sp m' sp' (parent_sp cs'))
(ARGS: forall ofs ty,
In (S (Outgoing ofs ty)) (loc_arguments sg) ->
slot_within_bounds f (function_bounds f) (Outgoing ofs ty))
@@ -1758,7 +1801,7 @@ Inductive match_stacks (j: meminj) (m m': mem):
(BELOW': sp' < bound'),
match_stacks j m m'
(Linear.Stackframe f (Vptr sp Int.zero) ls c :: cs)
- (Stackframe fb (Vptr sp' Int.zero) ra c' :: cs')
+ (Stackframe tf (Vptr sp' Int.zero) c' :: cs')
sg bound bound'.
(** Invariance with respect to change of bounds. *)
@@ -1949,14 +1992,6 @@ Proof.
induction 1; simpl; auto.
Qed.
-Lemma match_stacks_type_retaddr:
- forall j m m' cs cs' sg bound bound',
- match_stacks j m m' cs cs' sg bound bound' ->
- Val.has_type (parent_ra cs') Tint.
-Proof.
- induction 1; simpl; auto.
-Qed.
-
(** * Syntactic properties of the translation *)
(** Preservation of code labels through the translation. *)
@@ -2157,9 +2192,8 @@ Lemma find_function_translated:
agree_regs j ls rs ->
match_stacks j m m' cs cs' sg bound bound' ->
Linear.find_function ge ros ls = Some f ->
- exists bf, exists tf,
- find_function_ptr tge ros rs = Some bf
- /\ Genv.find_funct_ptr tge bf = Some tf
+ exists tf,
+ find_function tge ros rs = Some tf
/\ transf_fundef f = OK tf.
Proof.
intros until f; intros AG MS FF.
@@ -2168,13 +2202,14 @@ Proof.
exploit Genv.find_funct_inv; eauto. intros [b EQ]. rewrite EQ in FF.
rewrite Genv.find_funct_find_funct_ptr in FF.
exploit function_ptr_translated; eauto. intros [tf [A B]].
- exists b; exists tf; split; auto. simpl.
+ exists tf; split; auto. simpl.
generalize (AG m0). rewrite EQ. intro INJ. inv INJ.
- inv MG. rewrite DOMAIN in H2. inv H2. simpl. auto. eapply FUNCTIONS; eauto.
- destruct (Genv.find_symbol ge i) as [b|] eqn:?; try discriminate.
+ rewrite Int.add_zero_l.
+ inv MG. rewrite DOMAIN in H2. inv H2. simpl. rewrite A. apply dec_eq_true.
+ eapply FUNCTIONS; eauto.
+ destruct (Genv.find_symbol ge i) as [b|] eqn:FS; try discriminate.
exploit function_ptr_translated; eauto. intros [tf [A B]].
- exists b; exists tf; split; auto. simpl.
- rewrite symbols_preserved. auto.
+ exists tf; split; auto. simpl. rewrite symbols_preserved. rewrite FS. auto.
Qed.
Hypothesis wt_prog: wt_program prog.
@@ -2262,9 +2297,9 @@ Variables m m': mem.
Variables ls ls0: locset.
Variable rs: regset.
Variables sp sp': block.
-Variables parent retaddr: val.
+Variables parent: val.
Hypothesis AGR: agree_regs j ls rs.
-Hypothesis AGF: agree_frame f j ls ls0 m sp m' sp' parent retaddr.
+Hypothesis AGF: agree_frame f j ls ls0 m sp m' sp' parent.
Lemma transl_annot_param_correct:
forall l,
@@ -2327,31 +2362,29 @@ End ANNOT_ARGUMENTS.
- Well-typedness of [f].
*)
-Inductive match_states: Linear.state -> Machsem.state -> Prop :=
+Inductive match_states: Linear.state -> Mach.state -> Prop :=
| match_states_intro:
- forall cs f sp c ls m cs' fb sp' rs m' j tf
+ forall cs f sp c ls m cs' sp' rs m' j tf
(MINJ: Mem.inject j m m')
(STACKS: match_stacks j m m' cs cs' f.(Linear.fn_sig) sp sp')
(TRANSL: transf_function f = OK tf)
- (FIND: Genv.find_funct_ptr tge fb = Some (Internal tf))
(WTF: wt_function f)
(AGREGS: agree_regs j ls rs)
- (AGFRAME: agree_frame f j ls (parent_locset cs) m sp m' sp' (parent_sp cs') (parent_ra cs'))
+ (AGFRAME: agree_frame f j ls (parent_locset cs) m sp m' sp' (parent_sp cs'))
(TAIL: is_tail c (Linear.fn_code f)),
match_states (Linear.State cs f (Vptr sp Int.zero) c ls m)
- (Machsem.State cs' fb (Vptr sp' Int.zero) (transl_code (make_env (function_bounds f)) c) rs m')
+ (Mach.State cs' tf (Vptr sp' Int.zero) (transl_code (make_env (function_bounds f)) c) rs m')
| match_states_call:
- forall cs f ls m cs' fb rs m' j tf
+ forall cs f ls m cs' rs m' j tf
(MINJ: Mem.inject j m m')
(STACKS: match_stacks j m m' cs cs' (Linear.funsig f) (Mem.nextblock m) (Mem.nextblock m'))
(TRANSL: transf_fundef f = OK tf)
- (FIND: Genv.find_funct_ptr tge fb = Some tf)
(WTF: wt_fundef f)
(WTLS: wt_locset ls)
(AGREGS: agree_regs j ls rs)
(AGLOCS: agree_callee_save ls (parent_locset cs)),
match_states (Linear.Callstate cs f ls m)
- (Machsem.Callstate cs' fb rs m')
+ (Mach.Callstate cs' tf rs m')
| match_states_return:
forall cs ls m cs' rs m' j sg
(MINJ: Mem.inject j m m')
@@ -2360,12 +2393,12 @@ Inductive match_states: Linear.state -> Machsem.state -> Prop :=
(AGREGS: agree_regs j ls rs)
(AGLOCS: agree_callee_save ls (parent_locset cs)),
match_states (Linear.Returnstate cs ls m)
- (Machsem.Returnstate cs' rs m').
+ (Mach.Returnstate cs' rs m').
Theorem transf_step_correct:
forall s1 t s2, Linear.step ge s1 t s2 ->
forall s1' (MS: match_states s1 s1'),
- exists s2', plus Machsem.step tge s1' t s2' /\ match_states s2 s2'.
+ exists s2', plus Mach.step tge s1' t s2' /\ match_states s2 s2'.
Proof.
assert (RED: forall f i c,
transl_code (make_env (function_bounds f)) (i :: c) =
@@ -2430,6 +2463,7 @@ Proof.
apply index_local_valid; auto.
red; auto.
apply index_arg_valid; auto.
+ assert (idx <> FI_retaddr) by (unfold idx; destruct sl; congruence).
exploit store_index_succeeds; eauto. eapply agree_perm; eauto.
instantiate (1 := rs0 r). intros [m1' STORE].
econstructor; split.
@@ -2440,12 +2474,12 @@ Proof.
econstructor; eauto with coqlib.
eapply Mem.store_outside_inject; eauto.
intros. exploit agree_inj_unique; eauto. intros [EQ1 EQ2]; subst b' delta.
- rewrite size_type_chunk in H5.
+ rewrite size_type_chunk in H6.
exploit offset_of_index_disj_stack_data_2; eauto.
exploit agree_bounds. eauto. apply Mem.perm_cur_max. eauto.
omega.
apply match_stacks_change_mach_mem with m'; auto.
- eauto with mem. eauto with mem. intros. rewrite <- H4; eapply Mem.load_store_other; eauto. left; unfold block; omega.
+ eauto with mem. eauto with mem. intros. rewrite <- H5; eapply Mem.load_store_other; eauto. left; unfold block; omega.
apply agree_regs_set_slot. apply agree_regs_undef_setstack; auto.
destruct sl.
eapply agree_frame_set_local. eapply agree_frame_undef_setstack; eauto. auto. auto.
@@ -2514,15 +2548,11 @@ Proof.
eapply agree_frame_parallel_stores; eauto.
(* Lcall *)
- exploit find_function_translated; eauto. intros [bf [tf' [A [B C]]]].
- exploit is_tail_transf_function; eauto. intros IST. simpl in IST.
- exploit Asmgenretaddr.return_address_exists. eexact IST.
- intros [ra D].
+ exploit find_function_translated; eauto. intros [tf' [A B]].
econstructor; split.
apply plus_one. econstructor; eauto.
econstructor; eauto.
econstructor; eauto with coqlib.
- simpl; auto.
intros; red. split.
generalize (loc_arguments_acceptable _ _ H0). simpl. omega.
apply Zle_trans with (size_arguments (Linear.funsig f')); auto.
@@ -2534,13 +2564,13 @@ Proof.
simpl; red; auto.
(* Ltailcall *)
- exploit find_function_translated; eauto. intros [bf [tf' [A [B C]]]].
+ exploit find_function_translated; eauto. intros [tf' [A B]].
exploit function_epilogue_correct; eauto.
- intros [rs1 [m1' [P [Q [R [S [T [U [V W]]]]]]]]].
+ intros [rs1 [m1' [m2' [P [Q [R [S [T [U [V W ]]]]]]]]]].
econstructor; split.
eapply plus_right. eexact S. econstructor; eauto.
- replace (find_function_ptr tge ros rs1)
- with (find_function_ptr tge ros rs0). eauto.
+ replace (find_function tge ros rs1)
+ with (find_function tge ros rs0). eauto.
destruct ros; simpl; auto. inv WTI. rewrite V; auto.
traceEq.
econstructor; eauto.
@@ -2549,11 +2579,15 @@ Proof.
apply match_stacks_change_linear_mem with m.
apply match_stacks_change_mach_mem with m'0.
auto.
- eauto with mem. intros. eapply Mem.perm_free_1; eauto. left; unfold block; omega.
- intros. rewrite <- H2. eapply Mem.load_free; eauto. left; unfold block; omega.
- eauto with mem. intros. eapply Mem.perm_free_3; eauto.
+ eauto with mem.
+ intros. eapply Mem.perm_free_1; eauto. left; unfold block; omega.
+ eapply Mem.perm_free_1; eauto. left; unfold block; omega.
+ intros. erewrite Mem.load_free. erewrite Mem.load_free; eauto.
+ left; unfold block; omega. eauto. left; unfold block; omega.
+ eauto with mem.
+ intros. eapply Mem.perm_free_3; eauto.
apply Zlt_le_weak. change (Mem.valid_block m' stk). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_linear; eauto.
- apply Zlt_le_weak. change (Mem.valid_block m1' sp'). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_mach; eauto.
+ apply Zlt_le_weak. change (Mem.valid_block m2' sp'). eapply Mem.valid_block_free_1; eauto. eapply Mem.valid_block_free_1; eauto. eapply agree_valid_mach; eauto.
eapply find_function_well_typed; eauto.
apply wt_return_regs; auto. eapply match_stacks_wt_locset; eauto. eapply agree_wt_ls; eauto.
@@ -2646,7 +2680,7 @@ Proof.
(* Lreturn *)
exploit function_epilogue_correct; eauto.
- intros [rs1 [m1' [P [Q [R [S [T [U [V W]]]]]]]]].
+ intros [rs1 [m1' [m2' [P [Q [R [S [T [U [V W]]]]]]]]]].
econstructor; split.
eapply plus_right. eexact S. econstructor; eauto.
traceEq.
@@ -2655,11 +2689,15 @@ Proof.
apply match_stacks_change_linear_mem with m.
apply match_stacks_change_mach_mem with m'0.
eauto.
- eauto with mem. intros. eapply Mem.perm_free_1; eauto. left; unfold block; omega.
- intros. rewrite <- H1. eapply Mem.load_free; eauto. left; unfold block; omega.
- eauto with mem. intros. eapply Mem.perm_free_3; eauto.
+ eauto with mem.
+ intros. eapply Mem.perm_free_1. eauto. left; unfold block; omega.
+ eapply Mem.perm_free_1; eauto. left; unfold block; omega.
+ intros. erewrite Mem.load_free. erewrite Mem.load_free; eauto.
+ left; unfold block; omega. eauto. left; unfold block; omega.
+ eauto with mem.
+ intros. eapply Mem.perm_free_3; eauto.
apply Zlt_le_weak. change (Mem.valid_block m' stk). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_linear; eauto.
- apply Zlt_le_weak. change (Mem.valid_block m1' sp'). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_mach; eauto.
+ apply Zlt_le_weak. change (Mem.valid_block m2' sp'). eapply Mem.valid_block_free_1; eauto. eapply Mem.valid_block_free_1; eauto. eapply agree_valid_mach; eauto.
apply wt_return_regs; auto. eapply match_stacks_wt_locset; eauto. eapply agree_wt_ls; eauto.
(* internal function *)
@@ -2669,11 +2707,14 @@ Proof.
inversion WTF as [|f' WTFN]. subst f'.
exploit function_prologue_correct; eauto.
eapply match_stacks_type_sp; eauto.
- eapply match_stacks_type_retaddr; eauto.
intros [j' [rs' [m2' [sp' [m3' [m4' [m5' [A [B [C [D [E [F [G [J [K L]]]]]]]]]]]]]]]].
econstructor; split.
- eapply plus_left. econstructor; eauto.
- rewrite (unfold_transf_function _ _ TRANSL). unfold fn_code. unfold transl_body.
+ eapply plus_left. econstructor; eauto.
+ rewrite (unfold_transf_function _ _ TRANSL). unfold fn_retaddr_ofs.
+ generalize (offset_of_index_no_overflow _ _ TRANSL FI_retaddr I).
+ unfold offset_of_index. intros EQ; rewrite EQ.
+ apply (offset_of_index_aligned f FI_retaddr).
+ rewrite (unfold_transf_function _ _ TRANSL) at 2. unfold fn_code. unfold transl_body.
eexact D. traceEq.
generalize (Mem.alloc_result _ _ _ _ _ H). intro SP_EQ.
generalize (Mem.alloc_result _ _ _ _ _ A). intro SP'_EQ.
@@ -2686,7 +2727,10 @@ Proof.
rewrite zeq_false. auto. omega.
intros. eapply stores_in_frame_valid; eauto with mem.
intros. eapply stores_in_frame_perm; eauto with mem.
- intros. rewrite <- H1. transitivity (Mem.load chunk m2' b ofs). eapply stores_in_frame_contents; eauto.
+ eapply Mem.perm_free_1; eauto. left; unfold block; omega. eauto with mem.
+ intros. rewrite <- H1.
+ transitivity (Mem.load chunk m3' b ofs). eapply stores_in_frame_contents; eauto.
+ transitivity (Mem.load chunk m2' b ofs). eapply Mem.load_free; eauto. left; unfold block; omega.
eapply Mem.load_alloc_unchanged; eauto. red. congruence.
auto with coqlib.
@@ -2724,7 +2768,7 @@ Qed.
Lemma transf_initial_states:
forall st1, Linear.initial_state prog st1 ->
- exists st2, Machsem.initial_state tprog st2 /\ match_states st1 st2.
+ exists st2, Mach.initial_state tprog st2 /\ match_states st1 st2.
Proof.
intros. inv H.
exploit function_ptr_translated; eauto. intros [tf [FIND TR]].
@@ -2733,6 +2777,7 @@ Proof.
eapply Genv.init_mem_transf_partial; eauto.
rewrite (transform_partial_program_main _ _ TRANSF).
rewrite symbols_preserved. eauto.
+ eexact FIND.
econstructor; eauto.
eapply Genv.initmem_inject; eauto.
apply match_stacks_empty with (Mem.nextblock m0). omega. omega.
@@ -2753,7 +2798,7 @@ Qed.
Lemma transf_final_states:
forall st1 st2 r,
- match_states st1 st2 -> Linear.final_state st1 r -> Machsem.final_state st2 r.
+ match_states st1 st2 -> Linear.final_state st1 r -> Mach.final_state st2 r.
Proof.
intros. inv H0. inv H. inv STACKS.
constructor.
@@ -2762,7 +2807,7 @@ Proof.
Qed.
Theorem transf_program_correct:
- forward_simulation (Linear.semantics prog) (Machsem.semantics tprog).
+ forward_simulation (Linear.semantics prog) (Mach.semantics tprog).
Proof.
eapply forward_simulation_plus.
eexact symbols_preserved.
diff --git a/backend/Stackingtyping.v b/backend/Stackingtyping.v
deleted file mode 100644
index 2324cd5..0000000
--- a/backend/Stackingtyping.v
+++ /dev/null
@@ -1,250 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Xavier Leroy, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-(** Type preservation for the [Stacking] pass. *)
-
-Require Import Coqlib.
-Require Import Errors.
-Require Import Integers.
-Require Import AST.
-Require Import Op.
-Require Import Locations.
-Require Import Conventions.
-Require Import Linear.
-Require Import Lineartyping.
-Require Import Mach.
-Require Import Machtyping.
-Require Import Bounds.
-Require Import Stacklayout.
-Require Import Stacking.
-Require Import Stackingproof.
-
-(** We show that the Mach code generated by the [Stacking] pass
- is well-typed if the original LTLin code is. *)
-
-Definition wt_instrs (k: Mach.code) : Prop :=
- forall i, In i k -> wt_instr i.
-
-Lemma wt_instrs_cons:
- forall i k,
- wt_instr i -> wt_instrs k -> wt_instrs (i :: k).
-Proof.
- unfold wt_instrs; intros. elim H1; intro.
- subst i0; auto. auto.
-Qed.
-
-Section TRANSL_FUNCTION.
-
-Variable f: Linear.function.
-Let fe := make_env (function_bounds f).
-Variable tf: Mach.function.
-Hypothesis TRANSF_F: transf_function f = OK tf.
-
-Lemma wt_fold_right:
- forall (A: Type) (f: A -> code -> code) (k: code) (l: list A),
- (forall x k', In x l -> wt_instrs k' -> wt_instrs (f x k')) ->
- wt_instrs k ->
- wt_instrs (List.fold_right f k l).
-Proof.
- induction l; intros; simpl.
- auto.
- apply H. apply in_eq. apply IHl.
- intros. apply H. auto with coqlib. auto.
- auto.
-Qed.
-
-Lemma wt_save_callee_save_int:
- forall k,
- wt_instrs k ->
- wt_instrs (save_callee_save_int fe k).
-Proof.
- intros. unfold save_callee_save_int, save_callee_save_regs.
- apply wt_fold_right; auto.
- intros. unfold save_callee_save_reg.
- case (zlt (index_int_callee_save x) (fe_num_int_callee_save fe)); intro.
- apply wt_instrs_cons; auto.
- apply wt_Msetstack. apply int_callee_save_type; auto.
- auto.
-Qed.
-
-Lemma wt_save_callee_save_float:
- forall k,
- wt_instrs k ->
- wt_instrs (save_callee_save_float fe k).
-Proof.
- intros. unfold save_callee_save_float, save_callee_save_regs.
- apply wt_fold_right; auto.
- intros. unfold save_callee_save_reg.
- case (zlt (index_float_callee_save x) (fe_num_float_callee_save fe)); intro.
- apply wt_instrs_cons; auto.
- apply wt_Msetstack. apply float_callee_save_type; auto.
- auto.
-Qed.
-
-Lemma wt_restore_callee_save_int:
- forall k,
- wt_instrs k ->
- wt_instrs (restore_callee_save_int fe k).
-Proof.
- intros. unfold restore_callee_save_int, restore_callee_save_regs.
- apply wt_fold_right; auto.
- intros. unfold restore_callee_save_reg.
- case (zlt (index_int_callee_save x) (fe_num_int_callee_save fe)); intro.
- apply wt_instrs_cons; auto.
- constructor. apply int_callee_save_type; auto.
- auto.
-Qed.
-
-Lemma wt_restore_callee_save_float:
- forall k,
- wt_instrs k ->
- wt_instrs (restore_callee_save_float fe k).
-Proof.
- intros. unfold restore_callee_save_float, restore_callee_save_regs.
- apply wt_fold_right; auto.
- intros. unfold restore_callee_save_reg.
- case (zlt (index_float_callee_save x) (fe_num_float_callee_save fe)); intro.
- apply wt_instrs_cons; auto.
- constructor. apply float_callee_save_type; auto.
- auto.
-Qed.
-
-Lemma wt_save_callee_save:
- forall k,
- wt_instrs k -> wt_instrs (save_callee_save fe k).
-Proof.
- intros. unfold save_callee_save.
- apply wt_save_callee_save_int. apply wt_save_callee_save_float. auto.
-Qed.
-
-Lemma wt_restore_callee_save:
- forall k,
- wt_instrs k -> wt_instrs (restore_callee_save fe k).
-Proof.
- intros. unfold restore_callee_save.
- apply wt_restore_callee_save_int. apply wt_restore_callee_save_float. auto.
-Qed.
-
-Lemma wt_transl_instr:
- forall instr k,
- In instr f.(Linear.fn_code) ->
- Lineartyping.wt_instr f instr ->
- wt_instrs k ->
- wt_instrs (transl_instr fe instr k).
-Proof.
- intros.
- generalize (instr_is_within_bounds f instr H H0); intro BND.
- destruct instr; unfold transl_instr; inv H0; simpl in BND.
- (* getstack *)
- destruct BND.
- destruct s; simpl in *; apply wt_instrs_cons; auto;
- constructor; auto.
- (* setstack *)
- destruct s.
- apply wt_instrs_cons; auto. apply wt_Msetstack. auto.
- auto.
- apply wt_instrs_cons; auto. apply wt_Msetstack. auto.
- (* op, move *)
- simpl. apply wt_instrs_cons. constructor; auto. auto.
- (* op, others *)
- apply wt_instrs_cons; auto.
- constructor.
- destruct o; simpl; congruence.
- rewrite H6. symmetry. apply type_shift_stack_operation.
- (* load *)
- apply wt_instrs_cons; auto.
- constructor; auto.
- rewrite H4. destruct a; reflexivity.
- (* store *)
- apply wt_instrs_cons; auto.
- constructor; auto.
- rewrite H4. destruct a; reflexivity.
- (* call *)
- apply wt_instrs_cons; auto.
- constructor; auto.
- (* tailcall *)
- apply wt_restore_callee_save. apply wt_instrs_cons; auto.
- constructor; auto.
- destruct s0; auto. rewrite H5; auto.
- (* builtin *)
- apply wt_instrs_cons; auto.
- constructor; auto.
- (* annot *)
- apply wt_instrs_cons; auto.
- constructor; auto.
- (* label *)
- apply wt_instrs_cons; auto.
- constructor.
- (* goto *)
- apply wt_instrs_cons; auto.
- constructor; auto.
- (* cond *)
- apply wt_instrs_cons; auto.
- constructor; auto.
- (* jumptable *)
- apply wt_instrs_cons; auto.
- constructor; auto.
- (* return *)
- apply wt_restore_callee_save. apply wt_instrs_cons. constructor. auto.
-Qed.
-
-End TRANSL_FUNCTION.
-
-Lemma wt_transf_function:
- forall f tf,
- transf_function f = OK tf ->
- Lineartyping.wt_function f ->
- wt_function tf.
-Proof.
- intros.
- exploit unfold_transf_function; eauto. intro EQ.
- set (b := function_bounds f) in *.
- set (fe := make_env b) in *.
- constructor.
- change (wt_instrs (fn_code tf)).
- rewrite EQ; simpl; unfold transl_body.
- unfold fe, b; apply wt_save_callee_save; auto.
- unfold transl_code. apply wt_fold_right.
- intros. eapply wt_transl_instr; eauto.
- red; intros. elim H1.
- rewrite EQ; unfold fn_stacksize.
- generalize (size_pos f).
- generalize (size_no_overflow _ _ H).
- unfold fe, b. omega.
-Qed.
-
-Lemma wt_transf_fundef:
- forall f tf,
- Lineartyping.wt_fundef f ->
- transf_fundef f = OK tf ->
- wt_fundef tf.
-Proof.
- intros f tf WT. inversion WT; subst.
- simpl; intros; inversion H. constructor.
- unfold transf_fundef, transf_partial_fundef.
- caseEq (transf_function f0); simpl; 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 = OK tp ->
- Lineartyping.wt_program p ->
- Machtyping.wt_program tp.
-Proof.
- intros; red; intros.
- generalize (transform_partial_program_function transf_fundef p i f H H1).
- intros [f0 [IN TRANSF]].
- apply wt_transf_fundef with f0; auto.
- eapply H0; eauto.
-Qed.
diff --git a/driver/Compiler.v b/driver/Compiler.v
index 9db7f42..c8fb8c5 100644
--- a/driver/Compiler.v
+++ b/driver/Compiler.v
@@ -31,7 +31,6 @@ Require LTL.
Require LTLin.
Require Linear.
Require Mach.
-Require Machsem.
Require Asm.
(** Translation passes. *)
Require Initializers.
@@ -59,7 +58,6 @@ Require RTLtyping.
Require LTLtyping.
Require LTLintyping.
Require Lineartyping.
-Require Machtyping.
(** Proofs of semantic preservation and typing preservation. *)
Require SimplExprproof.
Require SimplLocalsproof.
@@ -85,7 +83,6 @@ Require Reloadtyping.
Require RREproof.
Require RREtyping.
Require Stackingproof.
-Require Stackingtyping.
Require Asmgenproof.
(** Pretty-printers (defined in Caml). *)
@@ -239,8 +236,6 @@ Proof.
assert(TY3: Lineartyping.wt_program p9).
eapply RREtyping.program_typing_preserved.
eapply Reloadtyping.program_typing_preserved; eauto.
- assert(TY4: Machtyping.wt_program p10).
- eapply Stackingtyping.program_typing_preserved; eauto.
eapply compose_forward_simulation. apply Tailcallproof.transf_program_correct.
eapply compose_forward_simulation. apply Inliningproof.transf_program_correct. eassumption.
diff --git a/ia32/Asm.v b/ia32/Asm.v
index a78c8bf..87d9dc9 100644
--- a/ia32/Asm.v
+++ b/ia32/Asm.v
@@ -68,6 +68,10 @@ Coercion IR: ireg >-> preg.
Coercion FR: freg >-> preg.
Coercion CR: crbit >-> preg.
+(** Conventional names for stack pointer ([SP]) and return address ([RA]) *)
+
+Notation "'SP'" := ESP (only parsing).
+
(** ** Instruction set. *)
Definition label := positive.
@@ -197,6 +201,8 @@ with annot_param : Type :=
| APstack: memory_chunk -> Z -> annot_param.
Definition code := list instruction.
+Definition function := code.
+Definition fn_code (f: function) : code := f.
Definition fundef := AST.fundef code.
Definition program := AST.program fundef unit.
@@ -863,3 +869,30 @@ Ltac Equalities :=
(* final states *)
inv H; inv H0. congruence.
Qed.
+
+(** Classification functions for processor registers (used in Asmgenproof). *)
+
+Definition data_preg (r: preg) : bool :=
+ match r with
+ | PC => false
+ | IR _ => true
+ | FR _ => true
+ | ST0 => true
+ | CR _ => false
+ | RA => false
+ end.
+
+Definition nontemp_preg (r: preg) : bool :=
+ match r with
+ | PC => false
+ | IR ECX => false
+ | IR EDX => false
+ | IR _ => true
+ | FR XMM6 => false
+ | FR XMM7 => false
+ | FR _ => true
+ | ST0 => false
+ | CR _ => false
+ | RA => false
+ end.
+
diff --git a/ia32/Asmgen.v b/ia32/Asmgen.v
index 6b7cbf9..a7a629b 100644
--- a/ia32/Asmgen.v
+++ b/ia32/Asmgen.v
@@ -549,7 +549,7 @@ Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (edx_is_par
around, leading to incorrect executions. *)
Definition transf_function (f: Mach.function) : res Asm.code :=
- do c <- transl_code f f.(fn_code) true;
+ do c <- transl_code f f.(Mach.fn_code) true;
if zlt (list_length_z c) Int.max_unsigned
then OK (Pallocframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) :: c)
else Error (msg "code size exceeded").
diff --git a/ia32/Asmgenproof.v b/ia32/Asmgenproof.v
index d618d44..e43552e 100644
--- a/ia32/Asmgenproof.v
+++ b/ia32/Asmgenproof.v
@@ -25,12 +25,10 @@ Require Import Smallstep.
Require Import Op.
Require Import Locations.
Require Import Mach.
-Require Import Machsem.
-Require Import Machtyping.
Require Import Conventions.
Require Import Asm.
Require Import Asmgen.
-Require Import Asmgenretaddr.
+Require Import Asmgenproof0.
Require Import Asmgenproof1.
Section PRESERVATION.
@@ -77,65 +75,6 @@ Qed.
(** * Properties of control flow *)
-Lemma find_instr_in:
- forall c pos i,
- find_instr pos c = Some i -> In i c.
-Proof.
- induction c; simpl. intros; discriminate.
- intros until i. case (zeq pos 0); intros.
- left; congruence. right; eauto.
-Qed.
-
-Lemma find_instr_tail:
- forall c1 i c2 pos,
- code_tail pos c1 (i :: c2) ->
- find_instr pos c1 = Some i.
-Proof.
- induction c1; simpl; intros.
- inv H.
- destruct (zeq pos 0). subst pos.
- inv H. auto. generalize (code_tail_pos _ _ _ H4). intro. omegaContradiction.
- inv H. congruence. replace (pos0 + 1 - 1) with pos0 by omega.
- eauto.
-Qed.
-
-Remark code_tail_bounds:
- forall fn ofs i c,
- code_tail ofs fn (i :: c) -> 0 <= ofs < list_length_z fn.
-Proof.
- assert (forall ofs fn c, code_tail ofs fn c ->
- forall i c', c = i :: c' -> 0 <= ofs < list_length_z fn).
- induction 1; intros; simpl.
- rewrite H. rewrite list_length_z_cons. generalize (list_length_z_pos c'). omega.
- rewrite list_length_z_cons. generalize (IHcode_tail _ _ H0). omega.
- eauto.
-Qed.
-
-Lemma code_tail_next:
- forall fn ofs i c,
- code_tail ofs fn (i :: c) ->
- code_tail (ofs + 1) fn c.
-Proof.
- assert (forall ofs fn c, code_tail ofs fn c ->
- forall i c', c = i :: c' -> code_tail (ofs + 1) fn c').
- induction 1; intros.
- subst c. constructor. constructor.
- constructor. eauto.
- eauto.
-Qed.
-
-Lemma code_tail_next_int:
- forall fn ofs i c,
- list_length_z fn <= Int.max_unsigned ->
- code_tail (Int.unsigned ofs) fn (i :: c) ->
- code_tail (Int.unsigned (Int.add ofs Int.one)) fn c.
-Proof.
- intros. rewrite Int.add_unsigned.
- change (Int.unsigned Int.one) with 1.
- rewrite Int.unsigned_repr. apply code_tail_next with i; auto.
- generalize (code_tail_bounds _ _ _ _ H0). omega.
-Qed.
-
Lemma transf_function_no_overflow:
forall f tf,
transf_function f = OK tf -> list_length_z tf <= Int.max_unsigned.
@@ -144,73 +83,9 @@ Proof.
rewrite list_length_z_cons. omega.
Qed.
-(** [transl_code_at_pc pc fn c] holds if the code pointer [pc] points
- within the IA32 code generated by translating Mach function [fn],
- and [c] is the tail of the generated code at the position corresponding
- to the code pointer [pc]. *)
-
-Inductive transl_code_at_pc: val -> block -> Mach.function -> Mach.code -> bool ->
- Asm.code -> Asm.code -> Prop :=
- transl_code_at_pc_intro:
- forall b ofs f c ep tf tc,
- Genv.find_funct_ptr ge b = Some (Internal f) ->
- transf_function f = OK tf ->
- transl_code f c ep = OK tc ->
- code_tail (Int.unsigned ofs) tf tc ->
- transl_code_at_pc (Vptr b ofs) b f c ep tf tc.
-
-(** The following lemmas show that straight-line executions
- (predicate [exec_straight]) correspond to correct PPC executions
- (predicate [exec_steps]) under adequate [transl_code_at_pc] hypotheses. *)
-
-Lemma exec_straight_steps_1:
- forall fn c rs m c' rs' m',
- exec_straight tge fn c rs m c' rs' m' ->
- list_length_z fn <= Int.max_unsigned ->
- forall b ofs,
- rs#PC = Vptr b ofs ->
- Genv.find_funct_ptr tge b = Some (Internal fn) ->
- code_tail (Int.unsigned ofs) fn c ->
- plus step tge (State rs m) E0 (State rs' m').
-Proof.
- induction 1; intros.
- apply plus_one.
- econstructor; eauto.
- eapply find_instr_tail. eauto.
- eapply plus_left'.
- econstructor; eauto.
- eapply find_instr_tail. eauto.
- 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:
- forall fn c rs m c' rs' m',
- exec_straight tge fn c rs m c' rs' m' ->
- list_length_z fn <= Int.max_unsigned ->
- forall b ofs,
- rs#PC = Vptr b ofs ->
- Genv.find_funct_ptr tge b = Some (Internal fn) ->
- code_tail (Int.unsigned ofs) fn c ->
- exists ofs',
- rs'#PC = Vptr b ofs'
- /\ code_tail (Int.unsigned ofs') fn c'.
-Proof.
- induction 1; intros.
- exists (Int.add ofs Int.one). split.
- rewrite H0. rewrite H2. auto.
- apply code_tail_next_int with i1; auto.
- apply IHexec_straight with (Int.add ofs Int.one).
- auto. rewrite H0. rewrite H3. reflexivity. auto.
- apply code_tail_next_int with i; auto.
-Qed.
-
Lemma exec_straight_exec:
- forall fb f c ep tf tc c' rs m rs' m',
- transl_code_at_pc (rs PC) fb f c ep tf tc ->
+ forall f c ep tf tc c' rs m rs' m',
+ transl_code_at_pc ge (rs PC) f c ep tf tc ->
exec_straight tge tf tc rs m c' rs' m' ->
plus step tge (State rs m) E0 (State rs' m').
Proof.
@@ -221,11 +96,11 @@ Proof.
Qed.
Lemma exec_straight_at:
- forall fb f c ep tf tc c' ep' tc' rs m rs' m',
- transl_code_at_pc (rs PC) fb f c ep tf tc ->
+ forall f c ep tf tc c' ep' tc' rs m rs' m',
+ transl_code_at_pc ge (rs PC) f c ep tf tc ->
transl_code f c' ep' = OK tc' ->
exec_straight tge tf tc rs m tc' rs' m' ->
- transl_code_at_pc (rs' PC) fb f c' ep' tf tc'.
+ transl_code_at_pc ge (rs' PC) f c' ep' tf tc'.
Proof.
intros. inv H.
exploit exec_straight_steps_2; eauto.
@@ -235,36 +110,6 @@ Proof.
rewrite PC'. constructor; auto.
Qed.
-(** Correctness of the return addresses predicted by
- [Asmgen.return_address_offset]. *)
-
-Remark code_tail_no_bigger:
- forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat.
-Proof.
- induction 1; simpl; omega.
-Qed.
-
-Remark code_tail_unique:
- forall fn c pos pos',
- code_tail pos fn c -> code_tail pos' fn c -> pos = pos'.
-Proof.
- induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto.
- generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega.
- generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega.
- f_equal. eauto.
-Qed.
-
-Lemma return_address_offset_correct:
- forall b ofs fb f c tf tc ofs',
- transl_code_at_pc (Vptr b ofs) fb f c false tf tc ->
- return_address_offset f c ofs' ->
- ofs' = ofs.
-Proof.
- intros. inv H0. inv H.
- exploit code_tail_unique. eexact H12. eapply H1; eauto. intro.
- subst ofs0. apply Int.repr_unsigned.
-Qed.
-
(** The [find_label] function returns the code tail starting at the
given label. A connection with [code_tail] is then established. *)
@@ -446,7 +291,6 @@ Proof.
destruct c0; auto.
Qed.
-
Remark transl_op_label:
forall op args r k c,
transl_op op args r k = OK c ->
@@ -534,7 +378,7 @@ Qed.
Lemma transl_find_label:
forall f tf,
transf_function f = OK tf ->
- match Mach.find_label lbl f.(fn_code) with
+ match Mach.find_label lbl f.(Mach.fn_code) with
| None => find_label lbl tf = None
| Some c => exists tc, find_label lbl tf = Some tc /\ transl_code f c false = OK tc
end.
@@ -553,10 +397,10 @@ Lemma find_label_goto_label:
Genv.find_funct_ptr ge b = Some (Internal f) ->
transf_function f = OK tf ->
rs PC = Vptr b ofs ->
- Mach.find_label lbl f.(fn_code) = Some c' ->
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
exists tc', exists rs',
goto_label tf lbl rs m = Next rs' m
- /\ transl_code_at_pc (rs' PC) b f c' false tf tc'
+ /\ transl_code_at_pc ge (rs' PC) f c' false tf tc'
/\ forall r, r <> PC -> rs'#r = rs#r.
Proof.
intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2.
@@ -590,61 +434,51 @@ Qed.
- Mach register values and PPC register values agree.
*)
-Inductive match_stack: list Machsem.stackframe -> Prop :=
- | match_stack_nil:
- match_stack nil
- | match_stack_cons: forall fb sp ra c s f tf tc,
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- transl_code_at_pc ra fb f c false tf tc ->
- sp <> Vundef -> ra <> Vundef ->
- match_stack s ->
- match_stack (Stackframe fb sp ra c :: s).
-
-Inductive match_states: Machsem.state -> Asm.state -> Prop :=
+Inductive match_states: Mach.state -> Asm.state -> Prop :=
| match_states_intro:
- forall s fb sp c ep ms m m' rs f tf tc
- (STACKS: match_stack s)
- (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
+ forall s f sp c ep ms m m' rs tf tc ra
+ (STACKS: match_stack ge s m m' ra sp)
(MEXT: Mem.extends m m')
- (AT: transl_code_at_pc (rs PC) fb f c ep tf tc)
- (AG: agree ms sp rs)
+ (AT: transl_code_at_pc ge (rs PC) f c ep tf tc)
+ (AG: agree ms (Vptr sp Int.zero) rs)
+ (RSA: retaddr_stored_at m m' sp (Int.unsigned f.(fn_retaddr_ofs)) ra)
(DXP: ep = true -> rs#EDX = parent_sp s),
- match_states (Machsem.State s fb sp c ms m)
+ match_states (Mach.State s f (Vptr sp Int.zero) c ms m)
(Asm.State rs m')
| match_states_call:
- forall s fb ms m m' rs
- (STACKS: match_stack s)
+ forall s fd ms m m' rs fb
+ (STACKS: match_stack ge s m m' (rs RA) (Mem.nextblock m))
(MEXT: Mem.extends m m')
(AG: agree ms (parent_sp s) rs)
(ATPC: rs PC = Vptr fb Int.zero)
- (ATLR: rs RA = parent_ra s),
- match_states (Machsem.Callstate s fb ms m)
+ (FUNCT: Genv.find_funct_ptr ge fb = Some fd)
+ (WTRA: Val.has_type (rs RA) Tint),
+ match_states (Mach.Callstate s fd ms m)
(Asm.State rs m')
| match_states_return:
forall s ms m m' rs
- (STACKS: match_stack s)
+ (STACKS: match_stack ge s m m' (rs PC) (Mem.nextblock m))
(MEXT: Mem.extends m m')
- (AG: agree ms (parent_sp s) rs)
- (ATPC: rs PC = parent_ra s),
- match_states (Machsem.Returnstate s ms m)
+ (AG: agree ms (parent_sp s) rs),
+ match_states (Mach.Returnstate s ms m)
(Asm.State rs m').
Lemma exec_straight_steps:
- forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2,
- match_stack s ->
+ forall s f rs1 i c ep tf tc m1' m2 m2' sp ms2 ra,
+ match_stack ge s m2 m2' ra sp ->
Mem.extends m2 m2' ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- transl_code_at_pc (rs1 PC) fb f (i :: c) ep tf tc ->
- (forall k c, transl_instr f i ep k = OK c ->
+ retaddr_stored_at m2 m2' sp (Int.unsigned f.(fn_retaddr_ofs)) ra ->
+ transl_code_at_pc ge (rs1 PC) f (i :: c) ep tf tc ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
exists rs2,
exec_straight tge tf c rs1 m1' k rs2 m2'
- /\ agree ms2 sp rs2
+ /\ agree ms2 (Vptr sp Int.zero) rs2
/\ (edx_preserved ep i = true -> rs2#EDX = parent_sp s)) ->
exists st',
plus step tge (State rs1 m1') E0 st' /\
- match_states (Machsem.State s fb sp c ms2 m2) st'.
+ match_states (Mach.State s f (Vptr sp Int.zero) c ms2 m2) st'.
Proof.
- intros. inversion H2. subst. monadInv H7.
+ intros. inversion H2; subst. monadInv H7.
exploit H3; eauto. intros [rs2 [A [B C]]].
exists (State rs2 m2'); split.
eapply exec_straight_exec; eauto.
@@ -652,23 +486,23 @@ Proof.
Qed.
Lemma exec_straight_steps_goto:
- forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c',
- match_stack s ->
+ forall s f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c' ra,
+ match_stack ge s m2 m2' ra sp ->
Mem.extends m2 m2' ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mach.find_label lbl f.(fn_code) = Some c' ->
- transl_code_at_pc (rs1 PC) fb f (i :: c) ep tf tc ->
+ retaddr_stored_at m2 m2' sp (Int.unsigned f.(fn_retaddr_ofs)) ra ->
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
+ transl_code_at_pc ge (rs1 PC) f (i :: c) ep tf tc ->
edx_preserved ep i = false ->
- (forall k c, transl_instr f i ep k = OK c ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
exists jmp, exists k', exists rs2,
exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2'
- /\ agree ms2 sp rs2
+ /\ agree ms2 (Vptr sp Int.zero) rs2
/\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') ->
exists st',
plus step tge (State rs1 m1') E0 st' /\
- match_states (Machsem.State s fb sp c' ms2 m2) st'.
+ match_states (Mach.State s f (Vptr sp Int.zero) c' ms2 m2) st'.
Proof.
- intros. inversion H3. subst. monadInv H9.
+ intros. inversion H3; subst. monadInv H9.
exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]].
generalize (functions_transl _ _ _ H7 H8); intro FN.
generalize (transf_function_no_overflow _ _ H8); intro NOOV.
@@ -684,164 +518,99 @@ Proof.
rewrite C. eexact GOTO.
traceEq.
econstructor; eauto.
- apply agree_exten with rs2; auto with ppcgen.
+ apply agree_exten with rs2; auto with asmgen.
congruence.
Qed.
-Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef.
-Proof. induction 1; simpl. congruence. auto. Qed.
-
-Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef.
-Proof. induction 1; simpl. unfold Vzero. congruence. auto. Qed.
-
-Lemma lessdef_parent_sp:
- forall s v,
- match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s.
-Proof.
- intros. inv H0. auto. exploit parent_sp_def; eauto. tauto.
-Qed.
-
-Lemma lessdef_parent_ra:
- forall s v,
- match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s.
-Proof.
- intros. inv H0. auto. exploit parent_ra_def; eauto. tauto.
-Qed.
-
(** We need to show that, in the simulation diagram, we cannot
take infinitely many Mach transitions that correspond to zero
transitions on the PPC side. Actually, all Mach transitions
correspond to at least one Asm transition, except the
- transition from [Machsem.Returnstate] to [Machsem.State].
+ transition from [Mach.Returnstate] to [Mach.State].
So, the following integer measure will suffice to rule out
the unwanted behaviour. *)
-Definition measure (s: Machsem.state) : nat :=
+Definition measure (s: Mach.state) : nat :=
match s with
- | Machsem.State _ _ _ _ _ _ => 0%nat
- | Machsem.Callstate _ _ _ _ => 0%nat
- | Machsem.Returnstate _ _ _ => 1%nat
+ | Mach.State _ _ _ _ _ _ => 0%nat
+ | Mach.Callstate _ _ _ _ => 0%nat
+ | Mach.Returnstate _ _ _ => 1%nat
end.
-(** We show the simulation diagram by case analysis on the Mach transition
- on the left. Since the proof is large, we break it into one lemma
- per transition. *)
-
-Definition exec_instr_prop (s1: Machsem.state) (t: trace) (s2: Machsem.state) : Prop :=
- forall s1' (MS: match_states s1 s1'),
- (exists s2', plus step tge s1' t s2' /\ match_states s2 s2')
- \/ (measure s2 < measure s1 /\ t = E0 /\ match_states s2 s1')%nat.
-
+(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *)
-Lemma exec_Mlabel_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset)
- (m : mem),
- exec_instr_prop (Machsem.State s fb sp (Mlabel lbl :: c) ms m) E0
- (Machsem.State s fb sp c ms m).
+Theorem step_simulation:
+ forall S1 t S2, Mach.step ge S1 t S2 ->
+ forall S1' (MS: match_states S1 S1'),
+ (exists S2', plus step tge S1' t S2' /\ match_states S2 S2')
+ \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
Proof.
- intros; red; intros; inv MS.
+ induction 1; intros; inv MS.
+
+- (* Mlabel *)
left; eapply exec_straight_steps; eauto; intros.
- monadInv H. econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto.
split. apply agree_nextinstr; auto. simpl; congruence.
-Qed.
-Lemma exec_Mgetstack_prop:
- forall (s : list stackframe) (fb : block) (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 (Machsem.State s fb sp (Mgetstack ofs ty dst :: c) ms m) E0
- (Machsem.State s fb sp c (Regmap.set dst v ms) m).
-Proof.
- intros; red; intros; inv MS.
+- (* Mgetstack *)
unfold load_stack in H.
exploit Mem.loadv_extends; eauto. intros [v' [A B]].
rewrite (sp_val _ _ _ AG) in A.
- left; eapply exec_straight_steps; eauto. intros. simpl in H0.
+ left; eapply exec_straight_steps; eauto. intros. simpl in TR.
exploit loadind_correct; eauto. intros [rs' [P [Q R]]].
exists rs'; split. eauto.
split. eapply agree_set_mreg; eauto. congruence.
simpl; congruence.
-Qed.
-Lemma exec_Msetstack_prop:
- forall (s : list stackframe) (fb : block) (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 (Machsem.State s fb sp (Msetstack src ofs ty :: c) ms m) E0
- (Machsem.State s fb sp c (undef_setstack ms) m').
-Proof.
- intros; red; intros; inv MS.
+- (* Msetstack *)
unfold store_stack in H.
- assert (Val.lessdef (ms src) (rs (preg_of src))). eapply preg_val; eauto.
+ assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto.
exploit Mem.storev_extends; eauto. intros [m2' [A B]].
- rewrite (sp_val _ _ _ AG) in A.
- left; eapply exec_straight_steps; eauto. intros. simpl in H1.
+ left; eapply exec_straight_steps; eauto.
+ eapply match_stack_storev; eauto.
+ eapply retaddr_stored_at_storev; eauto.
+ rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR.
exploit storeind_correct; eauto. intros [rs' [P Q]].
exists rs'; split. eauto.
split. unfold undef_setstack. eapply agree_undef_move; eauto.
- simpl; intros. rewrite Q; auto with ppcgen.
-Qed.
+ simpl; intros. rewrite Q; auto with asmgen.
-Lemma exec_Mgetparam_prop:
- forall (s : list stackframe) (fb : block) (f: Mach.function) (sp : val)
- (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction)
- (ms : Mach.regset) (m : mem) (v : val),
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- load_stack m sp Tint f.(fn_link_ofs) = Some (parent_sp s) ->
- load_stack m (parent_sp s) ty ofs = Some v ->
- exec_instr_prop (Machsem.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0
- (Machsem.State s fb sp c (Regmap.set dst v (Regmap.set IT1 Vundef ms)) m).
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
+- (* Mgetparam *)
unfold load_stack in *.
- exploit Mem.loadv_extends. eauto. eexact H0. auto.
+ exploit Mem.loadv_extends. eauto. eexact H. auto.
intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A.
- assert (parent' = parent_sp s). inv B. auto. rewrite <- H3 in H1. simpl in H1. congruence.
- subst parent'.
- exploit Mem.loadv_extends. eauto. eexact H1. auto.
+ exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'.
+ exploit Mem.loadv_extends. eauto. eexact H0. auto.
intros [v' [C D]].
Opaque loadind.
left; eapply exec_straight_steps; eauto; intros.
assert (DIFF: negb (mreg_eq dst IT1) = true -> IR EDX <> preg_of dst).
- intros. change (IR EDX) with (preg_of IT1). red; intros.
- exploit preg_of_injective; eauto. intros. subst dst.
- unfold proj_sumbool in H3. rewrite dec_eq_true in H3. simpl in H3. congruence.
- destruct ep; simpl in H2.
+ intros. change (IR EDX) with (preg_of IT1). red; intros.
+ unfold proj_sumbool in H1. destruct (mreg_eq dst IT1); try discriminate.
+ elim n. eapply preg_of_injective; eauto.
+ destruct ep; simpl in TR.
(* EDX contains parent *)
- exploit loadind_correct. eexact H2.
- instantiate (2 := rs). rewrite DXP; eauto.
+ exploit loadind_correct. eexact TR.
+ instantiate (2 := rs0). rewrite DXP; eauto.
intros [rs1 [P [Q R]]].
exists rs1; split. eauto.
split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto.
simpl; intros. rewrite R; auto.
(* EDX does not contain parent *)
- monadInv H2.
+ monadInv TR.
exploit loadind_correct. eexact EQ0. eauto. intros [rs1 [P [Q R]]]. simpl in Q.
exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto.
intros [rs2 [S [T U]]].
exists rs2; split. eapply exec_straight_trans; eauto.
split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto.
- simpl; intros. rewrite U; auto.
-Qed.
+ simpl; intros. rewrite U; auto.
-Lemma exec_Mop_prop:
- forall (s : list stackframe) (fb : block) (sp : val) (op : operation)
- (args : list mreg) (res : mreg) (c : list Mach.instruction)
- (ms : mreg -> val) (m : mem) (v : val),
- eval_operation ge sp op ms ## args m = Some v ->
- exec_instr_prop (Machsem.State s fb sp (Mop op args res :: c) ms m) E0
- (Machsem.State s fb sp c (Regmap.set res v (undef_op op ms)) m).
-Proof.
- intros; red; intros; inv MS.
- assert (eval_operation tge sp op ms##args m = Some v).
+- (* Mop *)
+ assert (eval_operation tge (Vptr sp0 Int.zero) op rs##args m = Some v).
rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0.
intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.
- left; eapply exec_straight_steps; eauto; intros. simpl in H1.
+ left; eapply exec_straight_steps; eauto; intros. simpl in TR.
exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]].
assert (S: Val.lessdef v (rs2 (preg_of res))) by (eapply Val.lessdef_trans; eauto).
exists rs2; split. eauto.
@@ -850,209 +619,135 @@ Proof.
destruct op; try (eapply agree_set_undef_mreg; eauto).
eapply agree_set_undef_move_mreg; eauto.
simpl; congruence.
-Qed.
-Lemma exec_Mload_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (chunk : memory_chunk) (addr : addressing) (args : list mreg)
- (dst : mreg) (c : list Mach.instruction) (ms : mreg -> val)
- (m : mem) (a v : val),
- eval_addressing ge sp addr ms ## args = Some a ->
- Mem.loadv chunk m a = Some v ->
- exec_instr_prop (Machsem.State s fb sp (Mload chunk addr args dst :: c) ms m)
- E0 (Machsem.State s fb sp c (Regmap.set dst v (undef_temps ms)) m).
-Proof.
- intros; red; intros; inv MS.
- assert (eval_addressing tge sp addr ms##args = Some a).
+- (* Mload *)
+ assert (eval_addressing tge (Vptr sp0 Int.zero) addr rs##args = Some a).
rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
exploit Mem.loadv_extends; eauto. intros [v' [C D]].
- left; eapply exec_straight_steps; eauto; intros. simpl in H2.
+ left; eapply exec_straight_steps; eauto; intros. simpl in TR.
exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]].
exists rs2; split. eauto.
split. eapply agree_set_undef_mreg; eauto. congruence.
simpl; congruence.
-Qed.
-Lemma exec_Mstore_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (chunk : memory_chunk) (addr : addressing) (args : list mreg)
- (src : mreg) (c : list Mach.instruction) (ms : mreg -> val)
- (m m' : mem) (a : val),
- eval_addressing ge sp addr ms ## args = Some a ->
- Mem.storev chunk m a (ms src) = Some m' ->
- exec_instr_prop (Machsem.State s fb sp (Mstore chunk addr args src :: c) ms m) E0
- (Machsem.State s fb sp c (undef_temps ms) m').
-Proof.
- intros; red; intros; inv MS.
- assert (eval_addressing tge sp addr ms##args = Some a).
+- (* Mstore *)
+ assert (eval_addressing tge (Vptr sp0 Int.zero) addr rs##args = Some a).
rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
- assert (Val.lessdef (ms src) (rs (preg_of src))). eapply preg_val; eauto.
+ assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto.
exploit Mem.storev_extends; eauto. intros [m2' [C D]].
- left; eapply exec_straight_steps; eauto; intros. simpl in H3.
+ left; eapply exec_straight_steps; eauto.
+ eapply match_stack_storev; eauto.
+ eapply retaddr_stored_at_storev; eauto.
+ intros. simpl in TR.
exploit transl_store_correct; eauto. intros [rs2 [P Q]].
exists rs2; split. eauto.
split. eapply agree_exten_temps; eauto.
simpl; congruence.
-Qed.
-Lemma exec_Mcall_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (sig : signature) (ros : mreg + ident) (c : Mach.code)
- (ms : Mach.regset) (m : mem) (f : function) (f' : block)
- (ra : int),
- find_function_ptr ge ros ms = Some f' ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- return_address_offset f c ra ->
- exec_instr_prop (Machsem.State s fb sp (Mcall sig ros :: c) ms m) E0
- (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) f' ms m).
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
+- (* Mcall *)
inv AT.
assert (NOOV: list_length_z tf <= Int.max_unsigned).
eapply transf_function_no_overflow; eauto.
- destruct ros as [rf|fid]; simpl in H; monadInv H5.
- (* Indirect call *)
- assert (DEST: ms rf = Vptr f' Int.zero).
- destruct (ms rf); try discriminate.
- generalize (Int.eq_spec i Int.zero); destruct (Int.eq i Int.zero); congruence.
- clear H.
- generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1.
- assert (TCA: transl_code_at_pc (Vptr fb (Int.add ofs Int.one)) fb f c false tf x).
+ destruct ros as [rf|fid]; simpl in H; monadInv H3.
++ (* Indirect call *)
+ exploit Genv.find_funct_inv; eauto. intros [bf EQ2].
+ rewrite EQ2 in H; rewrite Genv.find_funct_find_funct_ptr in H.
+ assert (rs0 x0 = Vptr bf Int.zero).
+ exploit ireg_val; eauto. rewrite EQ2; intros LD; inv LD; auto.
+ generalize (code_tail_next_int _ _ _ _ NOOV H4). intro CT1.
+ assert (TCA: transl_code_at_pc ge (Vptr b (Int.add ofs Int.one)) f c false tf x).
econstructor; eauto.
- exploit return_address_offset_correct; eauto. intros; subst ra.
left; econstructor; split.
apply plus_one. eapply exec_step_internal. eauto.
eapply functions_transl; eauto. eapply find_instr_tail; eauto.
simpl. eauto.
- constructor; auto.
- econstructor; eauto. eapply agree_sp_def; eauto. congruence.
- simpl. eapply agree_exten; eauto. intros. repeat rewrite Pregmap.gso; auto with ppcgen.
- exploit ireg_val; eauto. rewrite DEST. intros LD. inv LD. auto.
- rewrite <- H2. auto.
- (* Direct call *)
- generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1.
- assert (TCA: transl_code_at_pc (Vptr fb (Int.add ofs Int.one)) fb f c false tf x).
+ econstructor; eauto.
+ econstructor; eauto.
+ rewrite <- H0. eexact TCA.
+ change (Mem.valid_block m sp0). eapply retaddr_stored_at_valid; eauto.
+ simpl. eapply agree_exten; eauto. intros. Simplifs.
+ rewrite <- H0. exact I.
++ (* Direct call *)
+ destruct (Genv.find_symbol ge fid) as [bf|] eqn:FS; try discriminate.
+ generalize (code_tail_next_int _ _ _ _ NOOV H4). intro CT1.
+ assert (TCA: transl_code_at_pc ge (Vptr b (Int.add ofs Int.one)) f c false tf x).
econstructor; eauto.
- exploit return_address_offset_correct; eauto. intros; subst ra.
left; econstructor; split.
apply plus_one. eapply exec_step_internal. eauto.
eapply functions_transl; eauto. eapply find_instr_tail; eauto.
- simpl. unfold symbol_offset. rewrite symbols_preserved. rewrite H. eauto.
- constructor; auto.
- econstructor; eauto. eapply agree_sp_def; eauto. congruence.
- simpl. eapply agree_exten; eauto. intros. repeat rewrite Pregmap.gso; auto with ppcgen.
- rewrite <- H2. auto.
-Qed.
-
-Lemma agree_change_sp:
- forall ms sp rs sp',
- agree ms sp rs -> sp' <> Vundef ->
- agree ms sp' (rs#ESP <- sp').
-Proof.
- intros. inv H. split. apply Pregmap.gss. auto.
- intros. rewrite Pregmap.gso; auto with ppcgen.
-Qed.
+ simpl. unfold symbol_offset. rewrite symbols_preserved. rewrite FS. eauto.
+ econstructor; eauto.
+ econstructor; eauto.
+ rewrite <- H0. eexact TCA.
+ change (Mem.valid_block m sp0). eapply retaddr_stored_at_valid; eauto.
+ simpl. eapply agree_exten; eauto. intros. Simplifs.
+ auto.
+ rewrite <- H0. exact I.
-Lemma exec_Mtailcall_prop:
- forall (s : list stackframe) (fb stk : block) (soff : int)
- (sig : signature) (ros : mreg + ident) (c : list Mach.instruction)
- (ms : Mach.regset) (m : mem) (f: Mach.function) (f' : block) m',
- find_function_ptr ge ros ms = Some f' ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
- load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
- Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
- exec_instr_prop
- (Machsem.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0
- (Callstate s f' ms m').
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
+- (* Mtailcall *)
inv AT.
assert (NOOV: list_length_z tf <= Int.max_unsigned).
eapply transf_function_no_overflow; eauto.
rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *.
- exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]].
+ exploit Mem.loadv_extends. eauto. eexact H0. auto. simpl. intros [parent' [A B]].
exploit lessdef_parent_sp; eauto. intros. subst parent'. clear B.
- exploit Mem.loadv_extends. eauto. eexact H2. auto. simpl. intros [ra' [C D]].
- exploit lessdef_parent_ra; eauto. intros. subst ra'. clear D.
- exploit Mem.free_parallel_extends; eauto. intros [m2' [E F]].
- destruct ros as [rf|fid]; simpl in H; monadInv H7.
- (* Indirect call *)
- assert (DEST: ms rf = Vptr f' Int.zero).
- destruct (ms rf); try discriminate.
- generalize (Int.eq_spec i Int.zero); destruct (Int.eq i Int.zero); congruence.
- clear H.
- generalize (code_tail_next_int _ _ _ _ NOOV H8). intro CT1.
+ assert (C: Mem.loadv Mint32 m'0 (Val.add (rs0 ESP) (Vint (fn_retaddr_ofs f))) = Some ra).
+Opaque Int.repr.
+ erewrite agree_sp; eauto. simpl. rewrite Int.add_zero_l.
+ eapply rsa_contains; eauto.
+ exploit retaddr_stored_at_can_free; eauto. intros [m2' [E F]].
+ assert (M: match_stack ge s m'' m2' ra (Mem.nextblock m'')).
+ apply match_stack_change_bound with stk.
+ eapply match_stack_free_left; eauto.
+ eapply match_stack_free_left; eauto.
+ eapply match_stack_free_right; eauto.
+ omega.
+ apply Z.lt_le_incl. change (Mem.valid_block m'' stk).
+ eapply Mem.valid_block_free_1; eauto. eapply Mem.valid_block_free_1; eauto.
+ eapply retaddr_stored_at_valid; eauto.
+ destruct ros as [rf|fid]; simpl in H; monadInv H6.
++ (* Indirect call *)
+ exploit Genv.find_funct_inv; eauto. intros [bf EQ2].
+ rewrite EQ2 in H; rewrite Genv.find_funct_find_funct_ptr in H.
+ assert (rs0 x0 = Vptr bf Int.zero).
+ exploit ireg_val; eauto. rewrite EQ2; intros LD; inv LD; auto.
+ generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1.
left; econstructor; split.
eapply plus_left. eapply exec_step_internal. eauto.
eapply functions_transl; eauto. eapply find_instr_tail; eauto.
simpl. rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto.
apply star_one. eapply exec_step_internal.
- transitivity (Val.add rs#PC Vone). auto. rewrite <- H4. simpl. eauto.
+ transitivity (Val.add rs0#PC Vone). auto. rewrite <- H3. simpl. eauto.
eapply functions_transl; eauto. eapply find_instr_tail; eauto.
simpl. eauto. traceEq.
- constructor; auto.
+ econstructor; eauto.
apply agree_set_other; auto. apply agree_nextinstr. apply agree_set_other; auto.
eapply agree_change_sp; eauto. eapply parent_sp_def; eauto.
- rewrite Pregmap.gss. rewrite nextinstr_inv; auto with ppcgen.
- repeat rewrite Pregmap.gso; auto with ppcgen.
- exploit ireg_val; eauto. rewrite DEST. intros LD. inv LD. auto.
- generalize (preg_of_not_ESP rf). rewrite (ireg_of_eq _ _ EQ1). congruence.
- (* Direct call *)
- generalize (code_tail_next_int _ _ _ _ NOOV H8). intro CT1.
+ Simplifs. rewrite Pregmap.gso; auto.
+ generalize (preg_of_not_SP rf). rewrite (ireg_of_eq _ _ EQ1). congruence.
+ change (Val.has_type ra Tint). eapply retaddr_stored_at_type; eauto.
++ (* Direct call *)
+ destruct (Genv.find_symbol ge fid) as [bf|] eqn:FS; try discriminate.
+ generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1.
left; econstructor; split.
eapply plus_left. eapply exec_step_internal. eauto.
eapply functions_transl; eauto. eapply find_instr_tail; eauto.
simpl. rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto.
apply star_one. eapply exec_step_internal.
- transitivity (Val.add rs#PC Vone). auto. rewrite <- H4. simpl. eauto.
+ transitivity (Val.add rs0#PC Vone). auto. rewrite <- H3. simpl. eauto.
eapply functions_transl; eauto. eapply find_instr_tail; eauto.
simpl. eauto. traceEq.
- constructor; auto.
+ econstructor; eauto.
apply agree_set_other; auto. apply agree_nextinstr. apply agree_set_other; auto.
eapply agree_change_sp; eauto. eapply parent_sp_def; eauto.
- rewrite Pregmap.gss. unfold symbol_offset. rewrite symbols_preserved. rewrite H. auto.
-Qed.
+ rewrite Pregmap.gss. unfold symbol_offset. rewrite symbols_preserved. rewrite FS. auto.
+ change (Val.has_type ra Tint). eapply retaddr_stored_at_type; eauto.
-Lemma exec_Mgoto_prop:
- forall (s : list stackframe) (fb : block) (f : function) (sp : val)
- (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset)
- (m : mem) (c' : Mach.code),
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mach.find_label lbl (fn_code f) = Some c' ->
- exec_instr_prop (Machsem.State s fb sp (Mgoto lbl :: c) ms m) E0
- (Machsem.State s fb sp c' ms m).
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- inv AT. monadInv H4.
- exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]].
- left; exists (State rs' m'); split.
- apply plus_one. econstructor; eauto.
- eapply functions_transl; eauto.
- eapply find_instr_tail; eauto.
- simpl; eauto.
- econstructor; eauto.
- eapply agree_exten; eauto with ppcgen.
- congruence.
-Qed.
-
-Lemma exec_Mbuiltin_prop:
- forall (s : list stackframe) (f : block) (sp : val)
- (ms : Mach.regset) (m : mem) (ef : external_function)
- (args : list mreg) (res : mreg) (b : list Mach.instruction)
- (t : trace) (v : val) (m' : mem),
- external_call ef ge ms ## args m t v m' ->
- exec_instr_prop (Machsem.State s f sp (Mbuiltin ef args res :: b) ms m) t
- (Machsem.State s f sp b (Regmap.set res v (undef_temps ms)) m').
-Proof.
- intros; red; intros; inv MS.
+- (* Mbuiltin *)
inv AT. monadInv H3.
exploit functions_transl; eauto. intro FN.
generalize (transf_function_no_overflow _ _ H2); intro NOOV.
@@ -1064,28 +759,21 @@ Proof.
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
econstructor; eauto.
+ eapply match_stack_extcall; eauto.
+ intros; eapply external_call_max_perm; eauto.
instantiate (2 := tf); instantiate (1 := x).
unfold nextinstr_nf, nextinstr. rewrite Pregmap.gss.
- simpl undef_regs. repeat rewrite Pregmap.gso; auto with ppcgen.
+ simpl undef_regs. repeat rewrite Pregmap.gso; auto with asmgen.
rewrite <- H0. simpl. econstructor; eauto.
eapply code_tail_next_int; eauto.
apply agree_nextinstr_nf. eapply agree_set_undef_mreg; eauto.
rewrite Pregmap.gss. auto.
- intros. repeat rewrite Pregmap.gso; auto with ppcgen.
+ intros. Simplifs.
+ eapply retaddr_stored_at_extcall; eauto.
+ intros; eapply external_call_max_perm; eauto.
congruence.
-Qed.
-Lemma exec_Mannot_prop:
- forall (s : list stackframe) (f : block) (sp : val)
- (ms : Mach.regset) (m : mem) (ef : external_function)
- (args : list Mach.annot_param) (b : list Mach.instruction)
- (vargs: list val) (t : trace) (v : val) (m' : mem),
- Machsem.annot_arguments ms m sp args vargs ->
- external_call ef ge vargs m t v m' ->
- exec_instr_prop (Machsem.State s f sp (Mannot ef args :: b) ms m) t
- (Machsem.State s f sp b ms m').
-Proof.
- intros; red; intros; inv MS.
+- (* Mannot *)
inv AT. monadInv H4.
exploit functions_transl; eauto. intro FN.
generalize (transf_function_no_overflow _ _ H3); intro NOOV.
@@ -1098,32 +786,35 @@ Proof.
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
eapply match_states_intro with (ep := false); eauto with coqlib.
+ eapply match_stack_extcall; eauto.
+ intros; eapply external_call_max_perm; eauto.
unfold nextinstr. rewrite Pregmap.gss.
rewrite <- H1; simpl. econstructor; eauto.
eapply code_tail_next_int; eauto.
apply agree_nextinstr. auto.
+ eapply retaddr_stored_at_extcall; eauto.
+ intros; eapply external_call_max_perm; eauto.
congruence.
-Qed.
-Lemma exec_Mcond_true_prop:
- forall (s : list stackframe) (fb : block) (f : function) (sp : val)
- (cond : condition) (args : list mreg) (lbl : Mach.label)
- (c : list Mach.instruction) (ms : mreg -> val) (m : mem)
- (c' : Mach.code),
- eval_condition cond ms ## args m = Some true ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mach.find_label lbl (fn_code f) = Some c' ->
- exec_instr_prop (Machsem.State s fb sp (Mcond cond args lbl :: c) ms m) E0
- (Machsem.State s fb sp c' (undef_temps ms) m).
-Proof.
- intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0.
+- (* Mgoto *)
+ inv AT. monadInv H3.
+ exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]].
+ left; exists (State rs' m'); split.
+ apply plus_one. econstructor; eauto.
+ eapply functions_transl; eauto.
+ eapply find_instr_tail; eauto.
+ simpl; eauto.
+ econstructor; eauto.
+ eapply agree_exten; eauto with asmgen.
+ congruence.
+
+- (* Mcond true *)
exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
left; eapply exec_straight_steps_goto; eauto.
- intros. simpl in H2.
- destruct (transl_cond_correct tge tf cond args _ _ rs m' H2)
+ intros. simpl in TR.
+ destruct (transl_cond_correct tge tf cond args _ _ rs0 m' TR)
as [rs' [A [B C]]].
- rewrite EC in B (* 8.4 *)
- || (unfold PregEq.t in B; rewrite EC in B) (* 8.3 *).
+ rewrite EC in B.
destruct (testcond_for_condition cond); simpl in *.
(* simple jcc *)
exists (Pjcc c1 lbl); exists k; exists rs'.
@@ -1131,47 +822,37 @@ Proof.
split. eapply agree_exten_temps; eauto.
simpl. rewrite B. auto.
(* jcc; jcc *)
- destruct (eval_testcond c1 rs') as [b1|] eqn:?;
- destruct (eval_testcond c2 rs') as [b2|] eqn:?; inv B.
+ destruct (eval_testcond c1 rs') as [b1|] eqn:TC1;
+ destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B.
destruct b1.
(* first jcc jumps *)
exists (Pjcc c1 lbl); exists (Pjcc c2 lbl :: k); exists rs'.
split. eexact A.
split. eapply agree_exten_temps; eauto.
- simpl. rewrite Heqo. auto.
+ simpl. rewrite TC1. auto.
(* second jcc jumps *)
exists (Pjcc c2 lbl); exists k; exists (nextinstr rs').
split. eapply exec_straight_trans. eexact A.
- eapply exec_straight_one. simpl. rewrite Heqo. auto. auto.
- split. eapply agree_exten_temps; eauto.
- intros. rewrite nextinstr_inv; auto with ppcgen.
- simpl. rewrite eval_testcond_nextinstr. rewrite Heqo0.
+ eapply exec_straight_one. simpl. rewrite TC1. auto. auto.
+ split. eapply agree_exten_temps; eauto.
+ intros; Simplifs.
+ simpl. rewrite eval_testcond_nextinstr. rewrite TC2.
destruct b2; auto || discriminate.
(* jcc2 *)
- destruct (eval_testcond c1 rs') as [b1|] eqn:?;
- destruct (eval_testcond c2 rs') as [b2|] eqn:?; inv B.
- destruct (andb_prop _ _ H4). subst.
+ destruct (eval_testcond c1 rs') as [b1|] eqn:TC1;
+ destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B.
+ destruct (andb_prop _ _ H2). subst.
exists (Pjcc2 c1 c2 lbl); exists k; exists rs'.
split. eexact A.
split. eapply agree_exten_temps; eauto.
- simpl. rewrite Heqo; rewrite Heqo0; auto.
-Qed.
+ simpl. rewrite TC1; rewrite TC2; auto.
-Lemma exec_Mcond_false_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (cond : condition) (args : list mreg) (lbl : Mach.label)
- (c : list Mach.instruction) (ms : mreg -> val) (m : mem),
- eval_condition cond ms ## args m = Some false ->
- exec_instr_prop (Machsem.State s fb sp (Mcond cond args lbl :: c) ms m) E0
- (Machsem.State s fb sp c (undef_temps ms) m).
-Proof.
- intros; red; intros; inv MS.
+- (* Mcond false *)
exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
- left; eapply exec_straight_steps; eauto. intros. simpl in H0.
- destruct (transl_cond_correct tge tf cond args _ _ rs m' H0)
+ left; eapply exec_straight_steps; eauto. intros. simpl in TR.
+ destruct (transl_cond_correct tge tf cond args _ _ rs0 m' TR)
as [rs' [A [B C]]].
- rewrite EC in B (* 8.4 *)
- || (unfold PregEq.t in B; rewrite EC in B) (* 8.3 *).
+ rewrite EC in B.
destruct (testcond_for_condition cond); simpl in *.
(* simple jcc *)
econstructor; split.
@@ -1180,149 +861,119 @@ Proof.
split. apply agree_nextinstr. eapply agree_exten_temps; eauto.
simpl; congruence.
(* jcc ; jcc *)
- destruct (eval_testcond c1 rs') as [b1|] eqn:?;
- destruct (eval_testcond c2 rs') as [b2|] eqn:?; inv B.
- destruct (orb_false_elim _ _ H2); subst.
+ destruct (eval_testcond c1 rs') as [b1|] eqn:TC1;
+ destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B.
+ destruct (orb_false_elim _ _ H1); subst.
econstructor; split.
eapply exec_straight_trans. eexact A.
- eapply exec_straight_two. simpl. rewrite Heqo. eauto. auto.
- simpl. rewrite eval_testcond_nextinstr. rewrite Heqo0. eauto. auto. auto.
+ eapply exec_straight_two. simpl. rewrite TC1. eauto. auto.
+ simpl. rewrite eval_testcond_nextinstr. rewrite TC2. eauto. auto. auto.
split. apply agree_nextinstr. apply agree_nextinstr. eapply agree_exten_temps; eauto.
simpl; congruence.
(* jcc2 *)
- destruct (eval_testcond c1 rs') as [b1|] eqn:?;
- destruct (eval_testcond c2 rs') as [b2|] eqn:?; inv B.
+ destruct (eval_testcond c1 rs') as [b1|] eqn:TC1;
+ destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B.
exists (nextinstr rs'); split.
eapply exec_straight_trans. eexact A.
apply exec_straight_one. simpl.
- rewrite Heqo; rewrite Heqo0.
+ rewrite TC1; rewrite TC2.
destruct b1. simpl in *. subst b2. auto. auto.
auto.
split. apply agree_nextinstr. eapply agree_exten_temps; eauto.
- rewrite H2; congruence.
-Qed.
+ rewrite H1; congruence.
-Lemma exec_Mjumptable_prop:
- forall (s : list stackframe) (fb : block) (f : function) (sp : val)
- (arg : mreg) (tbl : list Mach.label) (c : list Mach.instruction)
- (rs : mreg -> val) (m : mem) (n : int) (lbl : Mach.label)
- (c' : Mach.code),
- rs arg = Vint n ->
- list_nth_z tbl (Int.unsigned n) = Some lbl ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mach.find_label lbl (fn_code f) = Some c' ->
- exec_instr_prop
- (Machsem.State s fb sp (Mjumptable arg tbl :: c) rs m) E0
- (Machsem.State s fb sp c' (undef_temps rs) m).
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- inv AT. monadInv H6.
+- (* Mjumptable *)
+ inv AT. monadInv H5.
exploit functions_transl; eauto. intro FN.
- generalize (transf_function_no_overflow _ _ H5); intro NOOV.
+ generalize (transf_function_no_overflow _ _ H4); intro NOOV.
exploit find_label_goto_label. eauto. eauto. instantiate (2 := rs0#ECX <- Vundef #EDX <- Vundef).
- rewrite Pregmap.gso; auto with ppcgen. rewrite Pregmap.gso; auto with ppcgen. eauto. eauto.
+ repeat (rewrite Pregmap.gso by auto with asmgen). eauto. eauto.
intros [tc' [rs' [A [B C]]]].
exploit ireg_val; eauto. rewrite H. intros LD; inv LD.
left; econstructor; split.
apply plus_one. econstructor; eauto.
eapply find_instr_tail; eauto.
- simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eauto.
+ simpl. rewrite <- H8. unfold Mach.label in H0; unfold label; rewrite H0. eauto.
econstructor; eauto.
- eapply agree_exten_temps; eauto. intros. rewrite C; auto with ppcgen.
- repeat rewrite Pregmap.gso; auto with ppcgen.
+ eapply agree_exten_temps; eauto. intros. rewrite C; auto with asmgen. Simplifs.
congruence.
-Qed.
-Lemma exec_Mreturn_prop:
- forall (s : list stackframe) (fb stk : block) (soff : int)
- (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: Mach.function) m',
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
- load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
- Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
- exec_instr_prop (Machsem.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0
- (Returnstate s ms m').
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
+- (* Mreturn *)
inv AT.
assert (NOOV: list_length_z tf <= Int.max_unsigned).
eapply transf_function_no_overflow; eauto.
rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *.
- exploit Mem.loadv_extends. eauto. eexact H0. auto. simpl. intros [parent' [A B]].
+ exploit Mem.loadv_extends. eauto. eexact H. auto. simpl. intros [parent' [A B]].
exploit lessdef_parent_sp; eauto. intros. subst parent'. clear B.
- exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [ra' [C D]].
- exploit lessdef_parent_ra; eauto. intros. subst ra'. clear D.
- exploit Mem.free_parallel_extends; eauto. intros [m2' [E F]].
- monadInv H6.
+ assert (C: Mem.loadv Mint32 m'0 (Val.add (rs0 ESP) (Vint (fn_retaddr_ofs f))) = Some ra).
+Opaque Int.repr.
+ erewrite agree_sp; eauto. simpl. rewrite Int.add_zero_l.
+ eapply rsa_contains; eauto.
+ exploit retaddr_stored_at_can_free; eauto. intros [m2' [E F]].
+ assert (M: match_stack ge s m'' m2' ra (Mem.nextblock m'')).
+ apply match_stack_change_bound with stk.
+ eapply match_stack_free_left; eauto.
+ eapply match_stack_free_left; eauto.
+ eapply match_stack_free_right; eauto. omega.
+ apply Z.lt_le_incl. change (Mem.valid_block m'' stk).
+ eapply Mem.valid_block_free_1; eauto. eapply Mem.valid_block_free_1; eauto.
+ eapply retaddr_stored_at_valid; eauto.
+ monadInv H5.
exploit code_tail_next_int; eauto. intro CT1.
left; econstructor; split.
eapply plus_left. eapply exec_step_internal. eauto.
eapply functions_transl; eauto. eapply find_instr_tail; eauto.
simpl. rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto.
apply star_one. eapply exec_step_internal.
- transitivity (Val.add rs#PC Vone). auto. rewrite <- H3. simpl. eauto.
+ transitivity (Val.add rs0#PC Vone). auto. rewrite <- H2. simpl. eauto.
eapply functions_transl; eauto. eapply find_instr_tail; eauto.
simpl. eauto. traceEq.
constructor; auto.
apply agree_set_other; auto. apply agree_nextinstr. apply agree_set_other; auto.
eapply agree_change_sp; eauto. eapply parent_sp_def; eauto.
-Qed.
-Lemma exec_function_internal_prop:
- forall (s : list stackframe) (fb : block) (ms : Mach.regset)
- (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block),
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mem.alloc m 0 (fn_stacksize f) = (m1, stk) ->
- let sp := Vptr stk Int.zero in
- store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 ->
- store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 ->
- exec_instr_prop (Machsem.Callstate s fb ms m) E0
- (Machsem.State s fb sp (fn_code f) (undef_temps ms) m3).
-Proof.
- intros; red; intros; inv MS.
+- (* internal function *)
exploit functions_translated; eauto. intros [tf [A B]]. monadInv B.
generalize EQ; intros EQ'. monadInv EQ'.
destruct (zlt (list_length_z x0) Int.max_unsigned); inversion EQ1. clear EQ1.
unfold store_stack in *.
exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl.
intros [m1' [C D]].
- exploit Mem.storev_extends. eauto. eexact H1. eauto. eauto.
- intros [m2' [E F]].
- exploit Mem.storev_extends. eexact F. eauto. eauto. eauto.
- intros [m3' [P Q]].
+ assert (E: Mem.extends m2 m1') by (eapply Mem.free_left_extends; eauto).
+ exploit Mem.storev_extends. eexact E. eexact H1. eauto. eauto.
+ intros [m2' [F G]].
+ exploit retaddr_stored_at_can_alloc. eexact H. eauto. eauto. eauto. eauto.
+ auto. auto. auto. auto. eauto.
+ intros [m3' [P [Q R]]].
left; econstructor; split.
apply plus_one. econstructor; eauto.
- rewrite <- H4; simpl. eauto.
- simpl. rewrite C. simpl in E. rewrite (sp_val _ _ _ AG) in E. rewrite E.
- rewrite ATLR. simpl in P. rewrite P. eauto.
- econstructor; eauto.
- unfold nextinstr. rewrite Pregmap.gss. repeat rewrite Pregmap.gso; auto with ppcgen.
+ subst x; simpl. rewrite Int.unsigned_zero. simpl. eauto.
+ simpl. rewrite C. simpl in F. rewrite (sp_val _ _ _ AG) in F. rewrite F.
+ rewrite Int.add_zero_l. rewrite P. eauto.
+ econstructor; eauto.
+ assert (STK: stk = Mem.nextblock m) by (eapply Mem.alloc_result; eauto).
+ rewrite <- STK in STACKS. simpl in F. simpl in H1.
+ eapply match_stack_invariant; eauto.
+ intros. eapply Mem.perm_alloc_4; eauto. eapply Mem.perm_free_3; eauto.
+ eapply Mem.perm_store_2; eauto. unfold block; omega.
+ intros. eapply Mem.perm_store_1; eauto. eapply Mem.perm_store_1; eauto.
+ eapply Mem.perm_alloc_1; eauto.
+ intros. erewrite Mem.load_store_other. 2: eauto.
+ erewrite Mem.load_store_other. 2: eauto.
+ eapply Mem.load_alloc_other; eauto.
+ left; unfold block; omega.
+ left; unfold block; omega.
+ unfold nextinstr. rewrite Pregmap.gss. repeat rewrite Pregmap.gso; auto with asmgen.
rewrite ATPC. simpl. constructor; eauto.
- subst x. eapply code_tail_next_int. rewrite list_length_z_cons. omega.
+ subst x. unfold fn_code. eapply code_tail_next_int. rewrite list_length_z_cons. omega.
constructor.
apply agree_nextinstr. eapply agree_change_sp; eauto.
- apply agree_exten_temps with rs; eauto.
- intros. apply Pregmap.gso; auto with ppcgen.
+ apply agree_exten_temps with rs0; eauto.
+ intros; Simplifs.
congruence.
- intros. rewrite nextinstr_inv; auto with ppcgen.
- rewrite Pregmap.gso; auto with ppcgen.
- rewrite Pregmap.gss. eapply agree_sp; eauto.
-Qed.
+ intros. Simplifs. eapply agree_sp; eauto.
-Lemma exec_function_external_prop:
- forall (s : list stackframe) (fb : block) (ms : Mach.regset)
- (m : mem) (t0 : trace) (ms' : RegEq.t -> val)
- (ef : external_function) (args : list val) (res : val) (m': mem),
- Genv.find_funct_ptr ge fb = Some (External ef) ->
- external_call ef ge args m t0 res m' ->
- Machsem.extcall_arguments ms m (parent_sp s) (ef_sig ef) args ->
- ms' = Regmap.set (loc_result (ef_sig ef)) res ms ->
- exec_instr_prop (Machsem.Callstate s fb ms m)
- t0 (Machsem.Returnstate s ms' m').
-Proof.
- intros; red; intros; inv MS.
+- (* external function *)
exploit functions_translated; eauto.
intros [tf [A B]]. simpl in B. inv B.
exploit extcall_arguments_match; eauto.
@@ -1334,63 +985,38 @@ Proof.
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
econstructor; eauto.
+ rewrite Pregmap.gss. apply match_stack_change_bound with (Mem.nextblock m).
+ eapply match_stack_extcall; eauto.
+ intros. eapply external_call_max_perm; eauto.
+ eapply external_call_nextblock; eauto.
unfold loc_external_result.
eapply agree_set_mreg; eauto.
- rewrite Pregmap.gso; auto with ppcgen. rewrite Pregmap.gss. auto.
- intros. repeat rewrite Pregmap.gso; auto with ppcgen.
-Qed.
+ rewrite Pregmap.gso; auto with asmgen. rewrite Pregmap.gss. auto.
+ intros; Simplifs.
-Lemma exec_return_prop:
- forall (s : list stackframe) (fb : block) (sp ra : val)
- (c : Mach.code) (ms : Mach.regset) (m : mem),
- exec_instr_prop (Machsem.Returnstate (Stackframe fb sp ra c :: s) ms m) E0
- (Machsem.State s fb sp c ms m).
-Proof.
- intros; red; intros; inv MS. inv STACKS. simpl in *.
+- (* return *)
+ inv STACKS. simpl in *.
right. split. omega. split. auto.
- econstructor; eauto. rewrite ATPC; eauto.
- congruence.
+ econstructor; eauto. congruence.
Qed.
-Theorem transf_instr_correct:
- forall s1 t s2, Machsem.step ge s1 t s2 ->
- exec_instr_prop s1 t s2.
-Proof
- (Machsem.step_ind ge exec_instr_prop
- exec_Mlabel_prop
- exec_Mgetstack_prop
- exec_Msetstack_prop
- exec_Mgetparam_prop
- exec_Mop_prop
- exec_Mload_prop
- exec_Mstore_prop
- exec_Mcall_prop
- exec_Mtailcall_prop
- exec_Mbuiltin_prop
- exec_Mannot_prop
- exec_Mgoto_prop
- exec_Mcond_true_prop
- exec_Mcond_false_prop
- exec_Mjumptable_prop
- exec_Mreturn_prop
- exec_function_internal_prop
- exec_function_external_prop
- exec_return_prop).
-
Lemma transf_initial_states:
- forall st1, Machsem.initial_state prog st1 ->
+ forall st1, Mach.initial_state prog st1 ->
exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2.
Proof.
intros. inversion H. unfold ge0 in *.
+ exploit functions_translated; eauto. intros [tf [A B]].
econstructor; split.
econstructor.
eapply Genv.init_mem_transf_partial; eauto.
replace (symbol_offset (Genv.globalenv tprog) (prog_main tprog) Int.zero)
- with (Vptr fb Int.zero).
- econstructor; eauto. constructor. apply Mem.extends_refl.
- split. auto. unfold parent_sp; congruence.
- intros. repeat rewrite Pregmap.gso; auto with ppcgen.
- destruct r; simpl; congruence.
+ with (Vptr b Int.zero).
+ econstructor; eauto.
+ constructor.
+ apply Mem.extends_refl.
+ split. auto. intros. rewrite Regmap.gi. auto.
+ reflexivity.
+ exact I.
unfold symbol_offset.
rewrite (transform_partial_program_main _ _ TRANSF).
rewrite symbols_preserved. unfold ge; rewrite H1. auto.
@@ -1398,21 +1024,22 @@ Qed.
Lemma transf_final_states:
forall st1 st2 r,
- match_states st1 st2 -> Machsem.final_state st1 r -> Asm.final_state st2 r.
+ match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r.
Proof.
- intros. inv H0. inv H. constructor. auto.
+ intros. inv H0. inv H. inv STACKS. constructor.
+ auto.
compute in H1.
generalize (preg_val _ _ _ AX AG). rewrite H1. intros LD; inv LD. auto.
Qed.
Theorem transf_program_correct:
- forward_simulation (Machsem.semantics prog) (Asm.semantics tprog).
+ forward_simulation (Mach.semantics prog) (Asm.semantics tprog).
Proof.
eapply forward_simulation_star with (measure := measure).
eexact symbols_preserved.
eexact transf_initial_states.
eexact transf_final_states.
- exact transf_instr_correct.
+ exact step_simulation.
Qed.
End PRESERVATION.
diff --git a/ia32/Asmgenproof1.v b/ia32/Asmgenproof1.v
index b524539..75d59a4 100644
--- a/ia32/Asmgenproof1.v
+++ b/ia32/Asmgenproof1.v
@@ -23,233 +23,29 @@ Require Import Globalenvs.
Require Import Op.
Require Import Locations.
Require Import Mach.
-Require Import Machsem.
Require Import Machtyping.
Require Import Asm.
Require Import Asmgen.
+Require Import Asmgenproof0.
Require Import Conventions.
Open Local Scope error_monad_scope.
(** * Correspondence between Mach registers and IA32 registers *)
-Hint Extern 2 (_ <> _) => congruence: ppcgen.
-
-Lemma preg_of_injective:
- forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2.
-Proof.
- destruct r1; destruct r2; simpl; intros; reflexivity || discriminate.
-Qed.
-
-Lemma preg_of_not_ESP:
- forall r, preg_of r <> ESP.
-Proof.
- destruct r; simpl; congruence.
-Qed.
-
-Lemma preg_of_not_PC:
- forall r, preg_of r <> PC.
-Proof.
- destruct r; simpl; congruence.
-Qed.
-
-Hint Resolve preg_of_not_ESP preg_of_not_PC: ppcgen.
-
-Lemma ireg_of_eq:
- forall r r', ireg_of r = OK r' -> preg_of r = IR r'.
-Proof.
- unfold ireg_of; intros. destruct (preg_of r); inv H; auto.
-Qed.
-
-Lemma freg_of_eq:
- forall r r', freg_of r = OK r' -> preg_of r = FR r'.
-Proof.
- unfold freg_of; intros. destruct (preg_of r); inv H; auto.
-Qed.
-
-(** Agreement between Mach register sets and IA32 register sets. *)
-
-Record agree (ms: Mach.regset) (sp: val) (rs: Asm.regset) : Prop := mkagree {
- agree_sp: rs#ESP = sp;
- agree_sp_def: sp <> Vundef;
- agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r))
-}.
-
-Lemma preg_val:
- forall ms sp rs r,
- agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r).
-Proof.
- intros. destruct H. auto.
-Qed.
-
-Lemma preg_vals:
- forall ms sp rs, agree ms sp rs ->
- forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)).
-Proof.
- induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto.
-Qed.
-
-Lemma ireg_val:
- forall ms sp rs r r',
- agree ms sp rs ->
- ireg_of r = OK r' ->
- Val.lessdef (ms r) rs#r'.
-Proof.
- intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto.
-Qed.
-
-Lemma freg_val:
- forall ms sp rs r r',
- agree ms sp rs ->
- freg_of r = OK r' ->
- Val.lessdef (ms r) (rs#r').
-Proof.
- intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto.
-Qed.
-
-Lemma sp_val:
- forall ms sp rs,
- agree ms sp rs ->
- sp = rs#ESP.
-Proof.
- intros. destruct H; auto.
-Qed.
-
-Hint Resolve preg_val ireg_val freg_val sp_val: ppcgen.
-
-Definition important_preg (r: preg) : bool :=
- match r with
- | PC => false
- | IR _ => true
- | FR _ => true
- | ST0 => true
- | CR _ => false
- | RA => false
- end.
-
-Lemma preg_of_important:
- forall r, important_preg (preg_of r) = true.
-Proof.
- intros. destruct r; reflexivity.
-Qed.
-
-Lemma important_diff:
- forall r r',
- important_preg r = true -> important_preg r' = false -> r <> r'.
-Proof.
- congruence.
-Qed.
-Hint Resolve important_diff: ppcgen.
-
-Lemma agree_exten:
- forall ms sp rs rs',
- agree ms sp rs ->
- (forall r, important_preg r = true -> rs'#r = rs#r) ->
- agree ms sp rs'.
-Proof.
- intros. destruct H. split.
- rewrite H0; auto. auto.
- intros. rewrite H0; auto. apply preg_of_important.
-Qed.
-
-(** Preservation of register agreement under various assignments. *)
-
-Lemma agree_set_mreg:
- forall ms sp rs r v rs',
- agree ms sp rs ->
- Val.lessdef v (rs'#(preg_of r)) ->
- (forall r', important_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') ->
- agree (Regmap.set r v ms) sp rs'.
-Proof.
- intros. destruct H. split.
- rewrite H1; auto. apply sym_not_equal. apply preg_of_not_ESP.
- auto.
- intros. unfold Regmap.set. destruct (RegEq.eq r0 r). congruence.
- rewrite H1. auto. apply preg_of_important.
- red; intros; elim n. eapply preg_of_injective; eauto.
-Qed.
-
-Lemma agree_set_other:
- forall ms sp rs r v,
- agree ms sp rs ->
- important_preg r = false ->
- agree ms sp (rs#r <- v).
-Proof.
- intros. apply agree_exten with rs. auto.
- intros. apply Pregmap.gso. congruence.
-Qed.
-
-Lemma agree_nextinstr:
- forall ms sp rs,
- agree ms sp rs -> agree ms sp (nextinstr rs).
-Proof.
- intros. unfold nextinstr. apply agree_set_other. auto. auto.
-Qed.
-
-Lemma agree_undef_unimportant_regs:
- forall ms sp rl rs,
- agree ms sp rs ->
- (forall r, In r rl -> important_preg r = false) ->
- agree ms sp (undef_regs rl rs).
-Proof.
- induction rl; simpl; intros. auto.
- apply IHrl. apply agree_exten with rs; auto.
- intros. apply Pregmap.gso. red; intros; subst.
- assert (important_preg a = false) by auto. congruence.
- intros. apply H0; auto.
-Qed.
-
Lemma agree_nextinstr_nf:
forall ms sp rs,
agree ms sp rs -> agree ms sp (nextinstr_nf rs).
Proof.
intros. unfold nextinstr_nf. apply agree_nextinstr.
- apply agree_undef_unimportant_regs. auto.
- intro. simpl. ElimOrEq; auto.
-Qed.
-
-Definition nontemp_preg (r: preg) : bool :=
- match r with
- | PC => false
- | IR ECX => false
- | IR EDX => false
- | IR _ => true
- | FR XMM6 => false
- | FR XMM7 => false
- | FR _ => true
- | ST0 => false
- | CR _ => false
- | RA => false
- end.
-
-Lemma nontemp_diff:
- forall r r',
- nontemp_preg r = true -> nontemp_preg r' = false -> r <> r'.
-Proof.
- congruence.
-Qed.
-
-Hint Resolve nontemp_diff: ppcgen.
-
-Lemma agree_exten_temps:
- forall ms sp rs rs',
- agree ms sp rs ->
- (forall r, nontemp_preg r = true -> rs'#r = rs#r) ->
- agree (undef_temps ms) sp rs'.
-Proof.
- intros. destruct H. split.
- rewrite H0; auto. auto.
- intros. unfold undef_temps.
- destruct (In_dec mreg_eq r temporary_regs).
- rewrite Mach.undef_regs_same; auto.
- rewrite Mach.undef_regs_other; auto. rewrite H0; auto.
- simpl in n. destruct r; auto; intuition.
+ apply agree_undef_regs. auto.
+ intro. simpl. ElimOrEq; auto.
Qed.
Lemma agree_undef_move:
forall ms sp rs rs',
agree ms sp rs ->
- (forall r, important_preg r = true -> r <> ST0 -> rs'#r = rs#r) ->
+ (forall r, data_preg r = true -> r <> ST0 -> rs'#r = rs#r) ->
agree (undef_move ms) sp rs'.
Proof.
intros. destruct H. split.
@@ -258,30 +54,16 @@ Proof.
destruct (In_dec mreg_eq r destroyed_at_move_regs).
rewrite Mach.undef_regs_same; auto.
rewrite Mach.undef_regs_other; auto.
- assert (important_preg (preg_of r) = true /\ preg_of r <> ST0).
+ assert (data_preg (preg_of r) = true /\ preg_of r <> ST0).
simpl in n. destruct r; simpl; auto; intuition congruence.
destruct H. rewrite H0; auto.
Qed.
-Lemma agree_set_undef_mreg:
- forall ms sp rs r v rs',
- agree ms sp rs ->
- Val.lessdef v (rs'#(preg_of r)) ->
- (forall r', nontemp_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') ->
- agree (Regmap.set r v (undef_temps ms)) sp rs'.
-Proof.
- intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto.
- eapply agree_exten_temps; eauto.
- intros. unfold Pregmap.set. destruct (PregEq.eq r0 (preg_of r)).
- congruence. auto.
- intros. rewrite Pregmap.gso; auto.
-Qed.
-
Lemma agree_set_undef_move_mreg:
forall ms sp rs r v rs',
agree ms sp rs ->
Val.lessdef v (rs'#(preg_of r)) ->
- (forall r', important_preg r' = true /\ r' <> ST0 -> r' <> preg_of r -> rs'#r' = rs#r') ->
+ (forall r', data_preg r' = true /\ r' <> ST0 -> r' <> preg_of r -> rs'#r' = rs#r') ->
agree (Regmap.set r v (undef_move ms)) sp rs'.
Proof.
intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto.
@@ -293,30 +75,6 @@ Qed.
(** Useful properties of the PC register. *)
-Lemma nextinstr_inv:
- forall r rs,
- r <> PC ->
- (nextinstr rs)#r = rs#r.
-Proof.
- intros. unfold nextinstr. apply Pregmap.gso. red; intro; subst. auto.
-Qed.
-
-Lemma nextinstr_inv2:
- forall r rs,
- nontemp_preg r = true ->
- (nextinstr rs)#r = rs#r.
-Proof.
- intros. apply nextinstr_inv. red; intro; subst; discriminate.
-Qed.
-
-Lemma nextinstr_set_preg:
- forall rs m v,
- (nextinstr (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone.
-Proof.
- intros. unfold nextinstr. rewrite Pregmap.gss.
- rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_PC.
-Qed.
-
Lemma nextinstr_nf_inv:
forall r rs,
match r with PC => False | CR _ => False | _ => True end ->
@@ -333,18 +91,16 @@ Qed.
Lemma nextinstr_nf_inv1:
forall r rs,
- important_preg r = true -> (nextinstr_nf rs)#r = rs#r.
+ data_preg r = true -> (nextinstr_nf rs)#r = rs#r.
Proof.
- intros. apply nextinstr_nf_inv. unfold important_preg in H.
- destruct r; auto; congruence.
+ intros. apply nextinstr_nf_inv. destruct r; auto || discriminate.
Qed.
Lemma nextinstr_nf_inv2:
forall r rs,
nontemp_preg r = true -> (nextinstr_nf rs)#r = rs#r.
Proof.
- intros. apply nextinstr_nf_inv. unfold nontemp_preg in H.
- destruct r; auto; congruence.
+ intros. apply nextinstr_nf_inv1; auto with asmgen.
Qed.
Lemma nextinstr_nf_set_preg:
@@ -356,210 +112,70 @@ Proof.
apply nextinstr_set_preg.
Qed.
-(** Connection between Mach and Asm calling conventions for external
- functions. *)
-
-Lemma extcall_arg_match:
- forall ms sp rs m m' l v,
- agree ms sp rs ->
- Machsem.extcall_arg ms m sp l v ->
- Mem.extends m m' ->
- exists v', Asm.extcall_arg rs m' l v' /\ Val.lessdef v v'.
-Proof.
- intros. inv H0.
- exists (rs#(preg_of r)); split. constructor. eauto with ppcgen.
- unfold load_stack in H2.
- exploit Mem.loadv_extends; eauto. intros [v' [A B]].
- rewrite (sp_val _ _ _ H) in A.
- exists v'; split; auto. destruct ty; econstructor; eauto.
-Qed.
-
-Lemma extcall_args_match:
- forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' ->
- forall ll vl,
- list_forall2 (Machsem.extcall_arg ms m sp) ll vl ->
- exists vl', list_forall2 (Asm.extcall_arg rs m') ll vl' /\ Val.lessdef_list vl vl'.
-Proof.
- induction 3.
- exists (@nil val); split; constructor.
- exploit extcall_arg_match; eauto. intros [v1' [A B]].
- destruct IHlist_forall2 as [vl' [C D]].
- exists(v1' :: vl'); split. constructor; auto. constructor; auto.
-Qed.
-
-Lemma extcall_arguments_match:
- forall ms m sp rs sg args m',
- agree ms sp rs ->
- Machsem.extcall_arguments ms m sp sg args ->
- Mem.extends m m' ->
- exists args', Asm.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'.
-Proof.
- unfold Machsem.extcall_arguments, Asm.extcall_arguments; intros.
- eapply extcall_args_match; eauto.
-Qed.
-
-(** Translation of arguments to annotations. *)
+(** Useful simplification tactic *)
-Lemma annot_arg_match:
- forall ms sp rs m m' p v,
- agree ms sp rs ->
- Mem.extends m m' ->
- Machsem.annot_arg ms m sp p v ->
- exists v', Asm.annot_arg rs m' (transl_annot_param p) v' /\ Val.lessdef v v'.
-Proof.
- intros. inv H1; simpl.
-(* reg *)
- exists (rs (preg_of r)); split.
- unfold preg_of. destruct (mreg_type r); constructor.
- eapply preg_val; eauto.
-(* stack *)
- exploit Mem.load_extends; eauto. intros [v' [A B]].
- exists v'; split; auto.
- inv H. econstructor; eauto.
-Qed.
+Ltac Simplif :=
+ match goal with
+ | [ |- nextinstr_nf _ _ = _ ] =>
+ ((rewrite nextinstr_nf_inv by auto with asmgen)
+ || (rewrite nextinstr_nf_inv1 by auto with asmgen)); auto
+ | [ |- nextinstr _ _ = _ ] =>
+ ((rewrite nextinstr_inv by auto with asmgen)
+ || (rewrite nextinstr_inv1 by auto with asmgen)); auto
+ | [ |- Pregmap.get ?x (Pregmap.set ?x _ _) = _ ] =>
+ rewrite Pregmap.gss; auto
+ | [ |- Pregmap.set ?x _ _ ?x = _ ] =>
+ rewrite Pregmap.gss; auto
+ | [ |- Pregmap.get _ (Pregmap.set _ _ _) = _ ] =>
+ rewrite Pregmap.gso by (auto with asmgen); auto
+ | [ |- Pregmap.set _ _ _ _ = _ ] =>
+ rewrite Pregmap.gso by (auto with asmgen); auto
+ end.
-Lemma annot_arguments_match:
- forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' ->
- forall pl vl,
- Machsem.annot_arguments ms m sp pl vl ->
- exists vl', Asm.annot_arguments rs m' (map transl_annot_param pl) vl'
- /\ Val.lessdef_list vl vl'.
-Proof.
- induction 3; intros.
- exists (@nil val); split. constructor. constructor.
- exploit annot_arg_match; eauto. intros [v1' [A B]].
- destruct IHlist_forall2 as [vl' [C D]].
- exists (v1' :: vl'); split; constructor; auto.
-Qed.
+Ltac Simplifs := repeat Simplif.
-(** * Execution of straight-line code *)
+(** * Correctness of IA32 constructor functions *)
-Section STRAIGHTLINE.
+Section CONSTRUCTORS.
Variable ge: genv.
Variable fn: code.
-(** Straight-line code is composed of processor instructions that execute
- in sequence (no branches, no function calls and returns).
- The following inductive predicate relates the machine states
- before and after executing a straight-line sequence of instructions.
- Instructions are taken from the first list instead of being fetched
- from memory. *)
-
-Inductive exec_straight: code -> regset -> mem ->
- code -> regset -> mem -> Prop :=
- | exec_straight_one:
- forall i1 c rs1 m1 rs2 m2,
- exec_instr ge fn i1 rs1 m1 = Next rs2 m2 ->
- rs2#PC = Val.add rs1#PC Vone ->
- exec_straight (i1 :: c) rs1 m1 c rs2 m2
- | exec_straight_step:
- forall i c rs1 m1 rs2 m2 c' rs3 m3,
- exec_instr ge fn i rs1 m1 = Next rs2 m2 ->
- rs2#PC = Val.add rs1#PC Vone ->
- exec_straight c rs2 m2 c' rs3 m3 ->
- exec_straight (i :: c) rs1 m1 c' rs3 m3.
-
-Lemma exec_straight_trans:
- forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3,
- exec_straight c1 rs1 m1 c2 rs2 m2 ->
- exec_straight c2 rs2 m2 c3 rs3 m3 ->
- exec_straight c1 rs1 m1 c3 rs3 m3.
-Proof.
- induction 1; intros.
- apply exec_straight_step with rs2 m2; auto.
- apply exec_straight_step with rs2 m2; auto.
-Qed.
-
-Lemma exec_straight_two:
- forall i1 i2 c rs1 m1 rs2 m2 rs3 m3,
- exec_instr ge fn i1 rs1 m1 = Next rs2 m2 ->
- exec_instr ge fn i2 rs2 m2 = Next rs3 m3 ->
- rs2#PC = Val.add rs1#PC Vone ->
- rs3#PC = Val.add rs2#PC Vone ->
- exec_straight (i1 :: i2 :: c) rs1 m1 c rs3 m3.
-Proof.
- intros. apply exec_straight_step with rs2 m2; auto.
- apply exec_straight_one; auto.
-Qed.
-
-Lemma exec_straight_three:
- forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4,
- exec_instr ge fn i1 rs1 m1 = Next rs2 m2 ->
- exec_instr ge fn i2 rs2 m2 = Next rs3 m3 ->
- exec_instr ge fn i3 rs3 m3 = Next rs4 m4 ->
- rs2#PC = Val.add rs1#PC Vone ->
- rs3#PC = Val.add rs2#PC Vone ->
- rs4#PC = Val.add rs3#PC Vone ->
- exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4.
-Proof.
- intros. apply exec_straight_step with rs2 m2; auto.
- eapply exec_straight_two; eauto.
-Qed.
-
-(** * Correctness of IA32 constructor functions *)
-
(** Smart constructor for moves. *)
Lemma mk_mov_correct:
forall rd rs k c rs1 m,
mk_mov rd rs k = OK c ->
exists rs2,
- exec_straight c rs1 m k rs2 m
+ exec_straight ge fn c rs1 m k rs2 m
/\ rs2#rd = rs1#rs
- /\ forall r, important_preg r = true -> r <> ST0 -> r <> rd -> rs2#r = rs1#r.
+ /\ forall r, data_preg r = true -> r <> ST0 -> r <> rd -> rs2#r = rs1#r.
Proof.
unfold mk_mov; intros.
destruct rd; try (monadInv H); destruct rs; monadInv H.
(* mov *)
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
- split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
- intros. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gso. auto.
+ split. Simplifs. intros; Simplifs.
(* movd *)
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
- split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
- intros. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gso. auto.
+ split. Simplifs. intros; Simplifs.
(* getfp0 *)
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
- split. rewrite nextinstr_inv; auto with ppcgen.
- rewrite Pregmap.gso; auto with ppcgen.
- apply Pregmap.gss.
- intros. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gso; auto. rewrite Pregmap.gso; auto.
+ split. Simplifs. intros; Simplifs.
(* setfp0 *)
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
- split. auto.
- intros. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gso. auto.
+ split. Simplifs. intros; Simplifs.
Qed.
(** Smart constructor for shifts *)
-Ltac SRes :=
- match goal with
- | [ |- nextinstr _ _ = _ ] => rewrite nextinstr_inv; [auto | auto with ppcgen]
- | [ |- nextinstr_nf _ _ = _ ] => rewrite nextinstr_nf_inv; [auto | auto with ppcgen]
- | [ |- Pregmap.get ?x (Pregmap.set ?x _ _) = _ ] => rewrite Pregmap.gss; auto
- | [ |- Pregmap.set ?x _ _ ?x = _ ] => rewrite Pregmap.gss; auto
- | [ |- Pregmap.get _ (Pregmap.set _ _ _) = _ ] => rewrite Pregmap.gso; [auto | auto with ppcgen]
- | [ |- Pregmap.set _ _ _ _ = _ ] => rewrite Pregmap.gso; [auto | auto with ppcgen]
- end.
-
-Ltac SOther :=
- match goal with
- | [ |- nextinstr _ _ = _ ] => rewrite nextinstr_inv; [auto | auto with ppcgen]
- | [ |- nextinstr_nf _ _ = _ ] => rewrite nextinstr_nf_inv2; [auto | auto with ppcgen]
- | [ |- Pregmap.get ?x (Pregmap.set ?x _ _) = _ ] => rewrite Pregmap.gss; auto
- | [ |- Pregmap.set ?x _ _ ?x = _ ] => rewrite Pregmap.gss; auto
- | [ |- Pregmap.get _ (Pregmap.set _ _ _) = _ ] => rewrite Pregmap.gso; [auto | auto with ppcgen]
- | [ |- Pregmap.set _ _ _ _ = _ ] => rewrite Pregmap.gso; [auto | auto with ppcgen]
- end.
-
Lemma mk_shift_correct:
forall sinstr ssem r1 r2 k c rs1 m,
mk_shift sinstr r1 r2 k = OK c ->
(forall r c rs m,
exec_instr ge c (sinstr r) rs m = Next (nextinstr_nf (rs#r <- (ssem rs#r rs#ECX))) m) ->
exists rs2,
- exec_straight c rs1 m k rs2 m
+ exec_straight ge fn c rs1 m k rs2 m
/\ rs2#r1 = ssem rs1#r1 rs1#r2
/\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r.
Proof.
@@ -568,8 +184,7 @@ Proof.
(* fast case *)
monadInv H.
econstructor. split. apply exec_straight_one. apply H0. auto.
- split. repeat SRes.
- intros. repeat SOther.
+ split. Simplifs. intros; Simplifs.
(* xchg case *)
destruct (ireg_eq r1 ECX); monadInv H.
econstructor. split. eapply exec_straight_three.
@@ -577,15 +192,12 @@ Proof.
apply H0.
simpl; eauto.
auto. auto. auto.
- split. repeat SRes. repeat rewrite nextinstr_inv; auto with ppcgen.
- rewrite Pregmap.gss. decEq. rewrite Pregmap.gso; auto with ppcgen. apply Pregmap.gss.
- intros. destruct (preg_eq r r2). subst. repeat SRes. repeat SOther.
+ split. Simplifs. f_equal. Simplifs.
+ intros; Simplifs. destruct (preg_eq r r2). subst r. Simplifs. Simplifs.
(* general case *)
econstructor. split. eapply exec_straight_two. simpl; eauto. apply H0.
auto. auto.
- split. repeat SRes. repeat rewrite nextinstr_inv; auto with ppcgen.
- rewrite Pregmap.gss. decEq. rewrite Pregmap.gso; auto. congruence.
- intros. repeat SOther.
+ split. Simplifs. f_equal. Simplifs. intros. Simplifs.
Qed.
(** Parallel move 2 *)
@@ -594,7 +206,7 @@ Lemma mk_mov2_correct:
forall src1 dst1 src2 dst2 k rs m,
dst1 <> dst2 ->
exists rs',
- exec_straight (mk_mov2 src1 dst1 src2 dst2 k) rs m k rs' m
+ exec_straight ge fn (mk_mov2 src1 dst1 src2 dst2 k) rs m k rs' m
/\ rs'#dst1 = rs#src1
/\ rs'#dst2 = rs#src2
/\ forall r, r <> PC -> r <> dst1 -> r <> dst2 -> rs'#r = rs#r.
@@ -603,22 +215,22 @@ Proof.
(* single moves *)
destruct (ireg_eq src1 dst1). subst.
econstructor; split. apply exec_straight_one. simpl; eauto. auto.
- split. repeat SRes. split. repeat SRes. intros; repeat SOther.
+ intuition Simplifs.
destruct (ireg_eq src2 dst2). subst.
econstructor; split. apply exec_straight_one. simpl; eauto. auto.
- split. repeat SRes. split. repeat SRes. intros; repeat SOther.
+ intuition Simplifs.
(* xchg *)
destruct (ireg_eq src2 dst1). destruct (ireg_eq src1 dst2).
subst. econstructor; split. apply exec_straight_one. simpl; eauto. auto.
- split. repeat SRes. split. repeat SRes. intros; repeat SOther.
+ intuition Simplifs.
(* move 2; move 1 *)
subst. econstructor; split. eapply exec_straight_two.
simpl; eauto. simpl; eauto. auto. auto.
- split. repeat SRes. split. repeat SRes. intros; repeat SOther.
+ intuition Simplifs.
(* move 1; move 2*)
subst. econstructor; split. eapply exec_straight_two.
simpl; eauto. simpl; eauto. auto. auto.
- split. repeat SRes. split. repeat SRes. intros; repeat SOther.
+ intuition Simplifs.
Qed.
(** Smart constructor for division *)
@@ -636,7 +248,7 @@ Lemma mk_div_correct:
dsem rs1#r1 rs1#r2 = Some vq ->
msem rs1#r1 rs1#r2 = Some vr ->
exists rs2,
- exec_straight c rs1 m k rs2 m
+ exec_straight ge fn c rs1 m k rs2 m
/\ rs2#r1 = vq
/\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r.
Proof.
@@ -647,15 +259,13 @@ Proof.
rewrite H0.
change (nextinstr rs1 # ECX <- (rs1 EDX) EAX) with (rs1#EAX).
change ((nextinstr rs1 # ECX <- (rs1 EDX)) # EDX <- Vundef ECX) with (rs1#EDX).
- rewrite H1. rewrite H2. eauto. auto. auto.
- split. SRes.
- intros. repeat SOther.
+ rewrite H1. rewrite H2. eauto. auto. auto.
+ intuition Simplifs.
(* r1=EAX r2<>EDX *)
econstructor. split. eapply exec_straight_one. rewrite H0.
replace (rs1 # EDX <- Vundef r2) with (rs1 r2). rewrite H1; rewrite H2. eauto.
- symmetry. SOther. auto.
- split. SRes.
- intros. repeat SOther.
+ symmetry. Simplifs. auto.
+ intuition Simplifs.
(* r1 <> EAX *)
monadInv H.
set (rs2 := nextinstr (rs1#XMM7 <- (rs1#EAX))).
@@ -669,10 +279,10 @@ Proof.
rewrite H1; rewrite H2. eauto.
simpl; eauto. simpl; eauto.
auto. auto. auto.
- split. repeat SRes.
+ split. Simplifs.
intros. destruct (preg_eq r EAX). subst.
- repeat SRes. rewrite D; auto with ppcgen.
- repeat SOther. rewrite D; auto with ppcgen. unfold rs2; repeat SOther.
+ Simplifs. rewrite D; auto with asmgen.
+ Simplifs. rewrite D; auto with asmgen. unfold rs2; Simplifs.
Qed.
(** Smart constructor for modulus *)
@@ -690,7 +300,7 @@ Lemma mk_mod_correct:
dsem rs1#r1 rs1#r2 = Some vq ->
msem rs1#r1 rs1#r2 = Some vr ->
exists rs2,
- exec_straight c rs1 m k rs2 m
+ exec_straight ge fn c rs1 m k rs2 m
/\ rs2#r1 = vr
/\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r.
Proof.
@@ -705,16 +315,14 @@ Proof.
rewrite H1. rewrite H2. eauto.
simpl; eauto.
auto. auto. auto.
- split. SRes.
- intros. repeat SOther.
+ intuition Simplifs.
(* r1=EAX r2<>EDX *)
econstructor. split. eapply exec_straight_two. rewrite H0.
replace (rs1 # EDX <- Vundef r2) with (rs1 r2). rewrite H1; rewrite H2. eauto.
- symmetry. SOther.
+ symmetry. Simplifs.
simpl; eauto.
- auto. auto.
- split. SRes.
- intros. repeat SOther.
+ auto. auto.
+ intuition Simplifs.
(* r1 <> EAX *)
monadInv H.
set (rs2 := nextinstr (rs1#XMM7 <- (rs1#EAX))).
@@ -728,10 +336,10 @@ Proof.
rewrite H1; rewrite H2. eauto.
simpl; eauto. simpl; eauto.
auto. auto. auto.
- split. repeat SRes.
+ split. Simplifs.
intros. destruct (preg_eq r EAX). subst.
- repeat SRes. rewrite D; auto with ppcgen.
- repeat SOther. rewrite D; auto with ppcgen. unfold rs2; repeat SOther.
+ Simplifs. rewrite D; auto with asmgen.
+ Simplifs. rewrite D; auto with asmgen. unfold rs2; Simplifs.
Qed.
Remark divs_mods_exist:
@@ -765,7 +373,7 @@ Lemma mk_shrximm_correct:
mk_shrximm r1 n k = OK c ->
Val.shrx (rs1#r1) (Vint n) = Some v ->
exists rs2,
- exec_straight c rs1 m k rs2 m
+ exec_straight ge fn c rs1 m k rs2 m
/\ rs2#r1 = v
/\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r.
Proof.
@@ -781,25 +389,26 @@ Proof.
set (rs3 := nextinstr (rs2#tmp <- (Vint x'))).
set (rs4 := nextinstr (if Int.lt x Int.zero then rs3#r1 <- (Vint x') else rs3)).
set (rs5 := nextinstr_nf (rs4#r1 <- (Val.shr rs4#r1 (Vint n)))).
- assert (rs3#r1 = Vint x). unfold rs3. SRes. SRes.
- assert (rs3#tmp = Vint x'). unfold rs3. SRes. SRes.
+ assert (rs3#r1 = Vint x). unfold rs3. Simplifs.
+ assert (rs3#tmp = Vint x'). unfold rs3. Simplifs.
exists rs5. split.
apply exec_straight_step with rs2 m. simpl. rewrite A. simpl. rewrite Int.and_idem. auto. auto.
apply exec_straight_step with rs3 m. simpl.
change (rs2 r1) with (rs1 r1). rewrite A. simpl.
rewrite (Int.add_commut Int.zero tnm1). rewrite Int.add_zero. auto. auto.
apply exec_straight_step with rs4 m. simpl.
- change (rs3 SOF) with (rs2 SOF). unfold rs2. rewrite nextinstr_inv; auto with ppcgen.
- unfold compare_ints. rewrite Pregmap.gso; auto with ppcgen. rewrite Pregmap.gss.
+ change (rs3 SOF) with (rs2 SOF). unfold rs2. rewrite nextinstr_inv; auto with asmgen.
+ unfold compare_ints. rewrite Pregmap.gso; auto with asmgen. rewrite Pregmap.gss.
unfold Val.cmp. simpl. unfold rs4. destruct (Int.lt x Int.zero); simpl; auto. rewrite H0; auto.
unfold rs4. destruct (Int.lt x Int.zero); simpl; auto.
apply exec_straight_one. auto. auto.
- split. unfold rs5. SRes. SRes. unfold rs4. rewrite nextinstr_inv; auto with ppcgen.
- destruct (Int.lt x Int.zero). rewrite Pregmap.gss. rewrite A; auto. rewrite A; rewrite H; auto.
- intros. unfold rs5. repeat SOther. unfold rs4. SOther.
- transitivity (rs3#r). destruct (Int.lt x Int.zero). SOther. auto.
- unfold rs3. repeat SOther. unfold rs2. repeat SOther.
- unfold compare_ints. repeat SOther.
+ split. unfold rs5. Simplifs. unfold rs4. Simplifs.
+ f_equal. destruct (Int.lt x Int.zero).
+ Simplifs. rewrite A. auto. Simplifs. congruence.
+ intros. unfold rs5; Simplifs. unfold rs4; Simplifs.
+ transitivity (rs3#r).
+ destruct (Int.lt x Int.zero). Simplifs. auto.
+ unfold rs3; Simplifs. unfold rs2; Simplifs. unfold compare_ints; Simplifs.
Qed.
(** Smart constructor for integer conversions *)
@@ -810,18 +419,16 @@ Lemma mk_intconv_correct:
(forall c rd rs r m,
exec_instr ge c (mk rd rs) r m = Next (nextinstr (r#rd <- (sem r#rs))) m) ->
exists rs2,
- exec_straight c rs1 m k rs2 m
+ exec_straight ge fn c rs1 m k rs2 m
/\ rs2#rd = sem rs1#rs
/\ forall r, nontemp_preg r = true -> r <> rd -> rs2#r = rs1#r.
Proof.
unfold mk_intconv; intros. destruct (low_ireg rs); monadInv H.
econstructor. split. apply exec_straight_one. rewrite H0. eauto. auto.
- split. repeat SRes.
- intros. repeat SOther.
+ intuition Simplifs.
econstructor. split. eapply exec_straight_two.
- simpl. eauto. apply H0. auto. auto.
- split. repeat SRes.
- intros. repeat SOther.
+ simpl. eauto. apply H0. auto. auto.
+ intuition Simplifs.
Qed.
(** Smart constructor for small stores *)
@@ -845,15 +452,15 @@ Lemma mk_smallstore_correct:
(forall c r addr rs m,
exec_instr ge c (sto addr r) rs m = exec_store ge chunk m addr rs r) ->
exists rs2,
- exec_straight c rs1 m1 k rs2 m2
+ exec_straight ge fn c rs1 m1 k rs2 m2
/\ forall r, nontemp_preg r = true -> rs2#r = rs1#r.
Proof.
unfold mk_smallstore; intros.
remember (low_ireg r) as low. destruct low.
(* low reg *)
monadInv H. econstructor; split. apply exec_straight_one. rewrite H1.
- unfold exec_store. rewrite H0. eauto. auto.
- intros. SOther.
+ unfold exec_store. rewrite H0. eauto. auto.
+ intros; Simplifs.
(* high reg *)
remember (addressing_mentions addr ECX) as mentions. destruct mentions; monadInv H.
(* ECX is mentioned. *)
@@ -863,7 +470,7 @@ Proof.
econstructor; split.
apply exec_straight_three with rs2 m1 rs3 m1.
simpl. auto.
- simpl. replace (rs2 r) with (rs1 r). auto. symmetry. unfold rs2. repeat SRes.
+ simpl. replace (rs2 r) with (rs1 r). auto. symmetry. unfold rs2; Simplifs.
rewrite H1. unfold exec_store. simpl. rewrite Int.add_zero.
change (rs3 EDX) with (rs1 r).
change (rs3 ECX) with (eval_addrmode ge addr rs1).
@@ -873,7 +480,7 @@ Proof.
destruct (eval_addrmode ge addr rs1); simpl in H0; try discriminate.
simpl. rewrite Int.add_zero; auto.
auto. auto. auto.
- intros. repeat SOther. unfold rs3. repeat SOther. unfold rs2. repeat SOther.
+ intros. Simplifs. unfold rs3; Simplifs. unfold rs2; Simplifs.
(* ECX is not mentioned *)
set (rs2 := nextinstr (rs1#ECX <- (rs1 r))).
econstructor; split.
@@ -882,9 +489,9 @@ Proof.
rewrite H1. unfold exec_store.
rewrite (addressing_mentions_correct addr ECX rs2 rs1); auto.
change (rs2 ECX) with (rs1 r). rewrite H0. eauto.
- intros. unfold rs2. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gso; auto with ppcgen.
- auto. auto.
- intros. rewrite dec_eq_false. repeat SOther. unfold rs2. repeat SOther. congruence.
+ intros. unfold rs2; Simplifs.
+ auto. auto.
+ intros. rewrite dec_eq_false. Simplifs. unfold rs2; Simplifs. congruence.
Qed.
(** Accessing slots in the stack frame *)
@@ -894,9 +501,9 @@ Lemma loadind_correct:
loadind base ofs ty dst k = OK c ->
Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v ->
exists rs',
- exec_straight c rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ rs'#(preg_of dst) = v
- /\ forall r, important_preg r = true -> r <> preg_of dst -> rs'#r = rs#r.
+ /\ forall r, data_preg r = true -> r <> preg_of dst -> rs'#r = rs#r.
Proof.
unfold loadind; intros.
set (addr := Addrmode (Some base) None (inl (ident * int) ofs)) in *.
@@ -907,16 +514,14 @@ Proof.
monadInv H.
rewrite (ireg_of_eq _ _ EQ). econstructor.
split. apply exec_straight_one. simpl. unfold exec_load. rewrite H1. rewrite H0.
- eauto. auto.
- split. repeat SRes.
- intros. rewrite nextinstr_nf_inv1; auto. SOther.
+ eauto. auto.
+ intuition Simplifs.
(* float *)
exists (nextinstr_nf (rs#(preg_of dst) <- v)).
split. destruct (preg_of dst); inv H; apply exec_straight_one; simpl; auto.
unfold exec_load. rewrite H1; rewrite H0; auto.
- unfold exec_load. rewrite H1; rewrite H0; auto.
- split. rewrite nextinstr_nf_inv1. SRes. apply preg_of_important.
- intros. rewrite nextinstr_nf_inv1; auto. SOther.
+ unfold exec_load. rewrite H1; rewrite H0; auto.
+ intuition Simplifs.
Qed.
Lemma storeind_correct:
@@ -924,8 +529,8 @@ Lemma storeind_correct:
storeind src base ofs ty k = OK c ->
Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' ->
exists rs',
- exec_straight c rs m k rs' m'
- /\ forall r, important_preg r = true -> r <> ST0 -> rs'#r = rs#r.
+ exec_straight ge fn c rs m k rs' m'
+ /\ forall r, data_preg r = true -> r <> ST0 -> rs'#r = rs#r.
Proof.
unfold storeind; intros.
set (addr := Addrmode (Some base) None (inl (ident * int) ofs)) in *.
@@ -937,7 +542,7 @@ Proof.
rewrite (ireg_of_eq _ _ EQ) in H0. econstructor.
split. apply exec_straight_one. simpl. unfold exec_store. rewrite H1. rewrite H0.
eauto. auto.
- intros. apply nextinstr_nf_inv1; auto.
+ intros; Simplifs.
(* float *)
destruct (preg_of src); inv H.
econstructor; split. apply exec_straight_one.
@@ -945,7 +550,7 @@ Proof.
intros. apply nextinstr_nf_inv1; auto.
econstructor; split. apply exec_straight_one.
simpl. unfold exec_store. rewrite H1; rewrite H0. eauto. auto.
- intros. rewrite nextinstr_nf_inv1; auto. rewrite dec_eq_true. apply Pregmap.gso; auto.
+ intros. Simplifs. rewrite dec_eq_true. Simplifs.
Qed.
(** Translation of addressing modes *)
@@ -1010,7 +615,7 @@ Proof.
split. auto.
split. auto.
split. auto.
- intros. repeat SOther.
+ intros. Simplifs.
Qed.
Lemma int_signed_eq:
@@ -1139,7 +744,7 @@ Proof.
split. auto.
split. auto.
split. auto.
- intros. repeat SOther.
+ intros. Simplifs.
Qed.
Definition eval_extcond (xc: extcond) (rs: regset) : option bool :=
@@ -1158,112 +763,6 @@ Definition eval_extcond (xc: extcond) (rs: regset) : option bool :=
end
end.
-(*******
-
-Definition swap_floats {A: Type} (c: comparison) (n1 n2: A) : A :=
- match c with
- | Clt | Cle => n2
- | Ceq | Cne | Cgt | Cge => n1
- end.
-
-Lemma testcond_for_float_comparison_correct:
- forall c v1 v2 rs b,
- Val.cmpf_bool c v1 v2 = Some b ->
- eval_extcond (testcond_for_condition (Ccompf c))
- (nextinstr (compare_floats (swap_floats c v1 v2)
- (swap_floats c v2 v1) rs)) = Some b.
-Proof.
- intros. destruct v1; destruct v2; simpl in H; inv H.
- assert (SWP: forall f1 f2, Vfloat (swap_floats c f1 f2) = swap_floats c (Vfloat f1) (Vfloat f2)).
- destruct c; auto.
- generalize (compare_floats_spec rs (swap_floats c f f0) (swap_floats c f0 f)).
- repeat rewrite <- SWP.
- set (rs' := nextinstr (compare_floats (Vfloat (swap_floats c f f0))
- (Vfloat (swap_floats c f0 f)) rs)).
- intros [A [B [C D]]].
- unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C.
- destruct c; simpl.
-(* eq *)
- rewrite Float.cmp_ne_eq.
- destruct (Float.cmp Ceq f f0). auto.
- simpl. destruct (Float.cmp Clt f f0 || Float.cmp Cgt f f0); auto.
-(* ne *)
- rewrite Float.cmp_ne_eq.
- destruct (Float.cmp Ceq f f0). auto.
- simpl. destruct (Float.cmp Clt f f0 || Float.cmp Cgt f f0); auto.
-(* lt *)
- rewrite <- (Float.cmp_swap Cge f f0).
- rewrite <- (Float.cmp_swap Cne f f0).
- simpl.
- rewrite Float.cmp_ne_eq. rewrite Float.cmp_le_lt_eq.
- caseEq (Float.cmp Clt f f0); intros; simpl.
- caseEq (Float.cmp Ceq f f0); intros; simpl.
- elimtype False. eapply Float.cmp_lt_eq_false; eauto.
- auto.
- destruct (Float.cmp Ceq f f0); auto.
-(* le *)
- rewrite <- (Float.cmp_swap Cge f f0). simpl.
- destruct (Float.cmp Cle f f0); auto.
-(* gt *)
- rewrite Float.cmp_ne_eq. rewrite Float.cmp_ge_gt_eq.
- caseEq (Float.cmp Cgt f f0); intros; simpl.
- caseEq (Float.cmp Ceq f f0); intros; simpl.
- elimtype False. eapply Float.cmp_gt_eq_false; eauto.
- auto.
- destruct (Float.cmp Ceq f f0); auto.
-(* ge *)
- destruct (Float.cmp Cge f f0); auto.
-Qed.
-
-Lemma testcond_for_neg_float_comparison_correct:
- forall c n1 n2 rs,
- eval_extcond (testcond_for_condition (Cnotcompf c))
- (nextinstr (compare_floats (Vfloat (swap_floats c n1 n2))
- (Vfloat (swap_floats c n2 n1)) rs)) =
- Some(negb(Float.cmp c n1 n2)).
-Proof.
- intros.
- generalize (compare_floats_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)).
- set (rs' := nextinstr (compare_floats (Vfloat (swap_floats c n1 n2))
- (Vfloat (swap_floats c n2 n1)) rs)).
- intros [A [B [C D]]].
- unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C.
- destruct c; simpl.
-(* eq *)
- rewrite Float.cmp_ne_eq.
- caseEq (Float.cmp Ceq n1 n2); intros.
- auto.
- simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto.
-(* ne *)
- rewrite Float.cmp_ne_eq.
- caseEq (Float.cmp Ceq n1 n2); intros.
- auto.
- simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto.
-(* lt *)
- rewrite <- (Float.cmp_swap Cge n1 n2).
- rewrite <- (Float.cmp_swap Cne n1 n2).
- simpl.
- rewrite Float.cmp_ne_eq. rewrite Float.cmp_le_lt_eq.
- caseEq (Float.cmp Clt n1 n2); intros; simpl.
- caseEq (Float.cmp Ceq n1 n2); intros; simpl.
- elimtype False. eapply Float.cmp_lt_eq_false; eauto.
- auto.
- destruct (Float.cmp Ceq n1 n2); auto.
-(* le *)
- rewrite <- (Float.cmp_swap Cge n1 n2). simpl.
- destruct (Float.cmp Cle n1 n2); auto.
-(* gt *)
- rewrite Float.cmp_ne_eq. rewrite Float.cmp_ge_gt_eq.
- caseEq (Float.cmp Cgt n1 n2); intros; simpl.
- caseEq (Float.cmp Ceq n1 n2); intros; simpl.
- elimtype False. eapply Float.cmp_gt_eq_false; eauto.
- auto.
- destruct (Float.cmp Ceq n1 n2); auto.
-(* ge *)
- destruct (Float.cmp Cge n1 n2); auto.
-Qed.
-***************)
-
Definition swap_floats {A: Type} (c: comparison) (n1 n2: A) : A :=
match c with
| Clt | Cle => n2
@@ -1379,15 +878,15 @@ Remark compare_floats_inv:
Proof.
intros.
assert (DFL: undef_regs (CR ZF :: CR CF :: CR PF :: CR SOF :: nil) rs r = rs r).
- simpl. repeat SOther.
- unfold compare_floats; destruct vx; destruct vy; auto. repeat SOther.
+ simpl. Simplifs.
+ unfold compare_floats; destruct vx; destruct vy; auto. Simplifs.
Qed.
Lemma transl_cond_correct:
forall cond args k c rs m,
transl_cond cond args k = OK c ->
exists rs',
- exec_straight c rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ match eval_condition cond (map rs (map preg_of args)) m with
| None => True
| Some b => eval_extcond (testcond_for_condition cond) rs' = Some b
@@ -1401,88 +900,87 @@ Proof.
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
split. destruct (Val.cmp_bool c0 (rs x) (rs x0)) eqn:?; auto.
eapply testcond_for_signed_comparison_correct; eauto.
- intros. unfold compare_ints. repeat SOther.
+ intros. unfold compare_ints. Simplifs.
(* compu *)
simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1).
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto.
eapply testcond_for_unsigned_comparison_correct; eauto.
- intros. unfold compare_ints. repeat SOther.
+ intros. unfold compare_ints. Simplifs.
(* compimm *)
simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int.eq_dec i Int.zero).
econstructor; split. apply exec_straight_one. simpl; eauto. auto.
split. destruct (rs x); simpl; auto. subst. rewrite Int.and_idem.
eapply testcond_for_signed_comparison_correct; eauto.
- intros. unfold compare_ints. repeat SOther.
+ intros. unfold compare_ints. Simplifs.
econstructor; split. apply exec_straight_one. simpl; eauto. auto.
split. destruct (Val.cmp_bool c0 (rs x) (Vint i)) eqn:?; auto.
eapply testcond_for_signed_comparison_correct; eauto.
- intros. unfold compare_ints. repeat SOther.
+ intros. unfold compare_ints. Simplifs.
(* compuimm *)
simpl. rewrite (ireg_of_eq _ _ EQ).
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (Vint i)) eqn:?; auto.
eapply testcond_for_unsigned_comparison_correct; eauto.
- intros. unfold compare_ints. repeat SOther.
+ intros. unfold compare_ints. Simplifs.
(* compf *)
simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)).
split. apply exec_straight_one.
destruct c0; simpl; auto.
- unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with ppcgen.
+ unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with asmgen.
split. destruct (rs x); destruct (rs x0); simpl; auto.
repeat rewrite swap_floats_commut. apply testcond_for_float_comparison_correct.
- intros. SOther. apply compare_floats_inv; auto with ppcgen.
+ intros. Simplifs. apply compare_floats_inv; auto with asmgen.
(* notcompf *)
simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)).
split. apply exec_straight_one.
destruct c0; simpl; auto.
- unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with ppcgen.
+ unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with asmgen.
split. destruct (rs x); destruct (rs x0); simpl; auto.
repeat rewrite swap_floats_commut. apply testcond_for_neg_float_comparison_correct.
- intros. SOther. apply compare_floats_inv; auto with ppcgen.
+ intros. Simplifs. apply compare_floats_inv; auto with asmgen.
(* maskzero *)
simpl. rewrite (ireg_of_eq _ _ EQ).
econstructor. split. apply exec_straight_one. simpl; eauto. auto.
split. destruct (rs x); simpl; auto.
generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero m).
intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto.
- intros. unfold compare_ints. repeat SOther.
+ intros. unfold compare_ints. Simplifs.
(* masknotzero *)
simpl. rewrite (ireg_of_eq _ _ EQ).
econstructor. split. apply exec_straight_one. simpl; eauto. auto.
split. destruct (rs x); simpl; auto.
generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero m).
intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto.
- intros. unfold compare_ints. repeat SOther.
+ intros. unfold compare_ints. Simplifs.
Qed.
Remark eval_testcond_nextinstr:
forall c rs, eval_testcond c (nextinstr rs) = eval_testcond c rs.
Proof.
- intros. unfold eval_testcond. repeat rewrite nextinstr_inv; auto with ppcgen.
+ intros. unfold eval_testcond. repeat rewrite nextinstr_inv; auto with asmgen.
Qed.
Remark eval_testcond_set_ireg:
forall c rs r v, eval_testcond c (rs#(IR r) <- v) = eval_testcond c rs.
Proof.
- intros. unfold eval_testcond. repeat rewrite Pregmap.gso; auto with ppcgen.
+ intros. unfold eval_testcond. repeat rewrite Pregmap.gso; auto with asmgen.
Qed.
Lemma mk_setcc_correct:
forall cond rd k rs1 m,
exists rs2,
- exec_straight (mk_setcc cond rd k) rs1 m k rs2 m
+ exec_straight ge fn (mk_setcc cond rd k) rs1 m k rs2 m
/\ rs2#rd = Val.of_optbool(eval_extcond cond rs1)
/\ forall r, nontemp_preg r = true -> r <> rd -> rs2#r = rs1#r.
Proof.
intros. destruct cond; simpl in *.
(* base *)
econstructor; split.
- apply exec_straight_one. simpl; eauto. auto.
- split. SRes. SRes.
- intros; repeat SOther.
+ apply exec_straight_one. simpl; eauto. auto.
+ intuition Simplifs.
(* or *)
assert (Val.of_optbool
match eval_testcond c1 rs1 with
@@ -1506,16 +1004,15 @@ Proof.
simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto.
simpl; eauto.
auto. auto. auto.
- split. SRes.
- intros. repeat SOther.
+ intuition Simplifs.
econstructor; split.
eapply exec_straight_three.
simpl; eauto.
simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto.
simpl. eauto.
auto. auto. auto.
- split. repeat SRes. rewrite Val.or_commut. decEq; repeat SRes.
- intros. repeat SOther.
+ split. Simplifs. rewrite Val.or_commut. f_equal; Simplifs.
+ intros. Simplifs.
(* and *)
assert (Val.of_optbool
match eval_testcond c1 rs1 with
@@ -1539,16 +1036,15 @@ Proof.
simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto.
simpl; eauto.
auto. auto. auto.
- split. SRes.
- intros. repeat SOther.
+ intuition Simplifs.
econstructor; split.
eapply exec_straight_three.
simpl; eauto.
simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto.
simpl. eauto.
auto. auto. auto.
- split. repeat SRes. rewrite Val.and_commut. decEq; repeat SRes.
- intros. repeat SOther.
+ split. Simplifs. rewrite Val.and_commut. f_equal; Simplifs.
+ intros. Simplifs.
Qed.
(** Translation of arithmetic operations. *)
@@ -1567,33 +1063,32 @@ Ltac ArgsInv :=
Ltac TranslOp :=
econstructor; split;
[ apply exec_straight_one; [ simpl; eauto | auto ]
- | split; [ repeat SRes | intros; repeat SOther ]].
-
+ | split; [ Simplifs | intros; Simplifs ]].
Lemma transl_op_correct:
forall op args res k c (rs: regset) m v,
transl_op op args res k = OK c ->
eval_operation ge (rs#ESP) op (map rs (map preg_of args)) m = Some v ->
exists rs',
- exec_straight c rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ Val.lessdef v rs'#(preg_of res)
/\ forall r,
- match op with Omove => important_preg r = true /\ r <> ST0 | _ => nontemp_preg r = true end ->
+ match op with Omove => data_preg r = true /\ r <> ST0 | _ => nontemp_preg r = true end ->
r <> preg_of res -> rs' r = rs r.
Proof.
intros until v; intros TR EV.
assert (SAME:
(exists rs',
- exec_straight c rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ rs'#(preg_of res) = v
/\ forall r,
- match op with Omove => important_preg r = true /\ r <> ST0 | _ => nontemp_preg r = true end ->
+ match op with Omove => data_preg r = true /\ r <> ST0 | _ => nontemp_preg r = true end ->
r <> preg_of res -> rs' r = rs r) ->
exists rs',
- exec_straight c rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ Val.lessdef v rs'#(preg_of res)
/\ forall r,
- match op with Omove => important_preg r = true /\ r <> ST0 | _ => nontemp_preg r = true end ->
+ match op with Omove => data_preg r = true /\ r <> ST0 | _ => nontemp_preg r = true end ->
r <> preg_of res -> rs' r = rs r).
intros [rs' [A [B C]]]. subst v. exists rs'; auto.
@@ -1643,7 +1138,7 @@ Proof.
apply SAME. eapply mk_shift_correct; eauto.
(* lea *)
exploit transl_addressing_mode_correct; eauto. intros EA.
- TranslOp. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss; auto.
+ TranslOp. rewrite nextinstr_inv; auto with asmgen. rewrite Pregmap.gss; auto.
(* intoffloat *)
apply SAME. TranslOp. rewrite H0; auto.
(* floatofint *)
@@ -1667,7 +1162,7 @@ Lemma transl_load_correct:
eval_addressing ge (rs#ESP) addr (map rs (map preg_of args)) = Some a ->
Mem.loadv chunk m a = Some v ->
exists rs',
- exec_straight c rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ rs'#(preg_of dest) = v
/\ forall r, nontemp_preg r = true -> r <> preg_of dest -> rs'#r = rs#r.
Proof.
@@ -1679,15 +1174,15 @@ Proof.
unfold exec_load. rewrite EA'. rewrite H1. auto.
assert (rs2 PC = Val.add (rs PC) Vone).
transitivity (Val.add ((rs#(preg_of dest) <- v) PC) Vone).
- auto. decEq. apply Pregmap.gso; auto with ppcgen.
+ auto. decEq. apply Pregmap.gso; auto with asmgen.
exists rs2. split.
destruct chunk; ArgsInv; apply exec_straight_one; auto.
(* Mfloat64 -> Mfloat64al32 *)
rewrite <- H. simpl. unfold exec_load. rewrite H1.
destruct (eval_addrmode ge x rs); simpl in *; try discriminate.
erewrite Mem.load_float64al32; eauto.
- split. unfold rs2. rewrite nextinstr_nf_inv1. SRes. apply preg_of_important.
- intros. unfold rs2. repeat SOther.
+ split. unfold rs2. rewrite nextinstr_nf_inv1. Simplifs. apply preg_of_data.
+ intros. unfold rs2. Simplifs.
Qed.
Lemma transl_store_correct:
@@ -1696,7 +1191,7 @@ Lemma transl_store_correct:
eval_addressing ge (rs#ESP) addr (map rs (map preg_of args)) = Some a ->
Mem.storev chunk m a (rs (preg_of src)) = Some m' ->
exists rs',
- exec_straight c rs m k rs' m'
+ exec_straight ge fn c rs m k rs' m'
/\ forall r, nontemp_preg r = true -> rs'#r = rs#r.
Proof.
unfold transl_store; intros. monadInv H.
@@ -1717,28 +1212,29 @@ Proof.
rewrite H1. eauto.
destruct (eval_addrmode ge x rs); simpl; auto. rewrite Mem.store_signed_unsigned_16; auto.
auto.
- intros. SOther.
+ intros. Simplifs.
(* int16unsigned *)
econstructor; split.
apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
- intros. SOther.
+ intros. Simplifs.
(* int32 *)
econstructor; split.
apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
- intros. SOther.
+ intros. Simplifs.
(* float32 *)
econstructor; split.
apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
- intros. SOther.
+ intros. Simplifs.
(* float64 *)
econstructor; split.
apply exec_straight_one. simpl. unfold exec_store. erewrite Mem.storev_float64al32; eauto. auto.
- intros. SOther.
+ intros. Simplifs.
(* float64al32 *)
econstructor; split.
apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
- intros. SOther.
+ intros. Simplifs.
Qed.
-End STRAIGHTLINE.
+End CONSTRUCTORS.
+
diff --git a/ia32/Asmgenretaddr.v b/ia32/Asmgenretaddr.v
deleted file mode 100644
index 29d2ba0..0000000
--- a/ia32/Asmgenretaddr.v
+++ /dev/null
@@ -1,259 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Xavier Leroy, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-(** Predictor for return addresses in generated IA32 code.
-
- The [return_address_offset] predicate defined here is used in the
- semantics for Mach (module [Machsem]) to determine the
- return addresses that are stored in activation records. *)
-
-Require Import Coqlib.
-Require Import AST.
-Require Import Errors.
-Require Import Integers.
-Require Import Floats.
-Require Import Op.
-Require Import Locations.
-Require Import Mach.
-Require Import Asm.
-Require Import Asmgen.
-
-(** The ``code tail'' of an instruction list [c] is the list of instructions
- starting at PC [pos]. *)
-
-Inductive code_tail: Z -> code -> code -> Prop :=
- | code_tail_0: forall c,
- code_tail 0 c c
- | code_tail_S: forall pos i c1 c2,
- code_tail pos c1 c2 ->
- code_tail (pos + 1) (i :: c1) c2.
-
-Lemma code_tail_pos:
- forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0.
-Proof.
- induction 1. omega. omega.
-Qed.
-
-(** Consider a Mach function [f] and a sequence [c] of Mach instructions
- representing the Mach code that remains to be executed after a
- function call returns. The predicate [return_address_offset f c ofs]
- holds if [ofs] is the integer offset of the PPC instruction
- following the call in the Asm code obtained by translating the
- code of [f]. Graphically:
-<<
- Mach function f |--------- Mcall ---------|
- Mach code c | |--------|
- | \ \
- | \ \
- | \ \
- Asm code | |--------|
- Asm function |------------- Pcall ---------|
-
- <-------- ofs ------->
->>
-*)
-
-Inductive return_address_offset: Mach.function -> Mach.code -> int -> Prop :=
- | return_address_offset_intro:
- forall f c ofs,
- (forall tf tc,
- transf_function f = OK tf ->
- transl_code f c false = OK tc ->
- code_tail ofs tf tc) ->
- return_address_offset f c (Int.repr ofs).
-
-(** We now show that such an offset always exists if the Mach code [c]
- is a suffix of [f.(fn_code)]. This holds because the translation
- from Mach to PPC is compositional: each Mach instruction becomes
- zero, one or several PPC instructions, but the order of instructions
- is preserved. *)
-
-Lemma is_tail_code_tail:
- forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1.
-Proof.
- induction 1. exists 0; constructor.
- destruct IHis_tail as [ofs CT]. exists (ofs + 1); constructor; auto.
-Qed.
-
-Hint Resolve is_tail_refl: ppcretaddr.
-
-Ltac IsTail :=
- eauto with ppcretaddr;
- match goal with
- | [ |- is_tail _ (_ :: _) ] => constructor; IsTail
- | [ H: Error _ = OK _ |- _ ] => discriminate
- | [ H: OK _ = OK _ |- _ ] => inv H; IsTail
- | [ H: bind _ _ = OK _ |- _ ] => monadInv H; IsTail
- | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; IsTail
- | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; IsTail
- | _ => idtac
- end.
-
-Lemma mk_mov_tail:
- forall rd rs k c, mk_mov rd rs k = OK c -> is_tail k c.
-Proof.
- unfold mk_mov; intros. destruct rd; IsTail; destruct rs; IsTail.
-Qed.
-
-Lemma mk_shift_tail:
- forall si r1 r2 k c, mk_shift si r1 r2 k = OK c -> is_tail k c.
-Proof.
- unfold mk_shift; intros; IsTail.
-Qed.
-
-Lemma mk_mov2_tail:
- forall r1 r2 r3 r4 k, is_tail k (mk_mov2 r1 r2 r3 r4 k).
-Proof.
- unfold mk_mov2; intros.
- destruct (ireg_eq r1 r2). IsTail.
- destruct (ireg_eq r3 r4). IsTail.
- destruct (ireg_eq r3 r2); IsTail.
- destruct (ireg_eq r1 r4); IsTail.
-Qed.
-
-Lemma mk_div_tail:
- forall di r1 r2 k c, mk_div di r1 r2 k = OK c -> is_tail k c.
-Proof.
- unfold mk_div; intros; IsTail.
- eapply is_tail_trans. 2: eapply mk_mov2_tail. IsTail.
-Qed.
-
-Lemma mk_mod_tail:
- forall di r1 r2 k c, mk_mod di r1 r2 k = OK c -> is_tail k c.
-Proof.
- unfold mk_mod; intros; IsTail.
- eapply is_tail_trans. 2: eapply mk_mov2_tail. IsTail.
-Qed.
-
-Lemma mk_shrximm_tail:
- forall r n k c, mk_shrximm r n k = OK c -> is_tail k c.
-Proof.
- unfold mk_shrximm; intros; IsTail.
-Qed.
-
-Lemma mk_intconv_tail:
- forall mk rd rs k c, mk_intconv mk rd rs k = OK c -> is_tail k c.
-Proof.
- unfold mk_intconv; intros; IsTail.
-Qed.
-
-Lemma mk_smallstore_tail:
- forall sto addr rs k c, mk_smallstore sto addr rs k = OK c -> is_tail k c.
-Proof.
- unfold mk_smallstore; intros; IsTail.
-Qed.
-
-Lemma loadind_tail:
- forall base ofs ty dst k c, loadind base ofs ty dst k = OK c -> is_tail k c.
-Proof.
- unfold loadind; intros. destruct ty; IsTail. destruct (preg_of dst); IsTail.
-Qed.
-
-Lemma storeind_tail:
- forall src base ofs ty k c, storeind src base ofs ty k = OK c -> is_tail k c.
-Proof.
- unfold storeind; intros. destruct ty; IsTail. destruct (preg_of src); IsTail.
-Qed.
-
-Lemma mk_setcc_tail:
- forall cond rd k, is_tail k (mk_setcc cond rd k).
-Proof.
- unfold mk_setcc; intros. destruct cond.
- IsTail.
- destruct (ireg_eq rd EDX); IsTail.
- destruct (ireg_eq rd EDX); IsTail.
-Qed.
-
-Lemma mk_jcc_tail:
- forall cond lbl k, is_tail k (mk_jcc cond lbl k).
-Proof.
- unfold mk_jcc; intros. destruct cond; IsTail.
-Qed.
-
-Hint Resolve mk_mov_tail mk_shift_tail mk_div_tail mk_mod_tail mk_shrximm_tail
- mk_intconv_tail mk_smallstore_tail loadind_tail storeind_tail
- mk_setcc_tail mk_jcc_tail : ppcretaddr.
-
-Lemma transl_cond_tail:
- forall cond args k c, transl_cond cond args k = OK c -> is_tail k c.
-Proof.
- unfold transl_cond; intros. destruct cond; IsTail; destruct (Int.eq_dec i Int.zero); IsTail.
-Qed.
-
-Lemma transl_op_tail:
- forall op args res k c, transl_op op args res k = OK c -> is_tail k c.
-Proof.
- unfold transl_op; intros. destruct op; IsTail.
- eapply is_tail_trans. 2: eapply transl_cond_tail; eauto. IsTail.
-Qed.
-
-Lemma transl_load_tail:
- forall chunk addr args dest k c, transl_load chunk addr args dest k = OK c -> is_tail k c.
-Proof.
- unfold transl_load; intros. IsTail. destruct chunk; IsTail.
-Qed.
-
-Lemma transl_store_tail:
- forall chunk addr args src k c, transl_store chunk addr args src k = OK c -> is_tail k c.
-Proof.
- unfold transl_store; intros. IsTail. destruct chunk; IsTail.
-Qed.
-
-Lemma transl_instr_tail:
- forall f i ep k c, transl_instr f i ep k = OK c -> is_tail k c.
-Proof.
- unfold transl_instr; intros. destruct i; IsTail.
- eapply is_tail_trans; eapply loadind_tail; eauto.
- eapply transl_op_tail; eauto.
- eapply transl_load_tail; eauto.
- eapply transl_store_tail; eauto.
- destruct s0; IsTail.
- destruct s0; IsTail.
- eapply is_tail_trans. 2: eapply transl_cond_tail; eauto. IsTail.
-Qed.
-
-Lemma transl_code_tail:
- forall f c1 c2, is_tail c1 c2 ->
- forall tc2 ep2, transl_code f c2 ep2 = OK tc2 ->
- exists tc1, exists ep1, transl_code f c1 ep1 = OK tc1 /\ is_tail tc1 tc2.
-Proof.
- induction 1; simpl; intros.
- exists tc2; exists ep2; split; auto with coqlib.
- monadInv H0. exploit IHis_tail; eauto. intros [tc1 [ep1 [A B]]].
- exists tc1; exists ep1; split. auto.
- apply is_tail_trans with x. auto. eapply transl_instr_tail; eauto.
-Qed.
-
-Lemma return_address_exists:
- forall f sg ros c, is_tail (Mcall sg ros :: c) f.(fn_code) ->
- exists ra, return_address_offset f c ra.
-Proof.
- intros.
- caseEq (transf_function f). intros tf TF.
- assert (exists tc1, transl_code f (fn_code f) true = OK tc1 /\ is_tail tc1 tf).
- monadInv TF.
- destruct (zlt (list_length_z x) Int.max_unsigned); monadInv EQ0.
- econstructor; eauto with coqlib.
- destruct H0 as [tc2 [A B]].
- exploit transl_code_tail; eauto. intros [tc1 [ep [C D]]].
-Opaque transl_instr.
- monadInv C.
- assert (is_tail x tf).
- apply is_tail_trans with tc2; auto.
- apply is_tail_trans with tc1; auto.
- eapply transl_instr_tail; eauto.
- exploit is_tail_code_tail. eexact H0. intros [ofs C].
- exists (Int.repr ofs). constructor; intros. congruence.
- intros. exists (Int.repr 0). constructor; intros; congruence.
-Qed.
-
-
diff --git a/powerpc/Asm.v b/powerpc/Asm.v
index 5d815fd..27e801a 100644
--- a/powerpc/Asm.v
+++ b/powerpc/Asm.v
@@ -84,6 +84,11 @@ End PregEq.
Module Pregmap := EMap(PregEq).
+(** Conventional names for stack pointer ([SP]) and return address ([RA]) *)
+
+Notation "'SP'" := GPR1 (only parsing).
+Notation "'RA'" := LR (only parsing).
+
(** Symbolic constants. Immediate operands to an arithmetic instruction
or an indexed memory access can be either integer literals,
or the low or high 16 bits of a symbolic reference (the address
@@ -291,7 +296,9 @@ lbl: .long table[0], table[1], ...
*)
Definition code := list instruction.
-Definition fundef := AST.fundef code.
+Definition function := code.
+Definition fn_code (f: function) : code := f.
+Definition fundef := AST.fundef function.
Definition program := AST.program fundef unit.
(** * Operational semantics *)
@@ -309,6 +316,14 @@ Definition genv := Genv.t fundef unit.
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).
+(** Undefining some registers *)
+
+Fixpoint undef_regs (l: list preg) (rs: regset) : regset :=
+ match l with
+ | nil => rs
+ | r :: l' => undef_regs l' (rs#r <- Vundef)
+ end.
+
Section RELSEM.
(** Looking up instructions in a code sequence by position. *)
@@ -428,8 +443,8 @@ Definition const_high (c: constant) :=
or [Error] if the processor is stuck. *)
Inductive outcome: Type :=
- | OK: regset -> mem -> outcome
- | Error: outcome.
+ | Next: regset -> mem -> outcome
+ | Stuck: outcome.
(** Manipulations over the [PC] register: continuing with the next
instruction ([nextinstr]) or branching to a label ([goto_label]). *)
@@ -439,11 +454,11 @@ Definition nextinstr (rs: regset) :=
Definition goto_label (c: code) (lbl: label) (rs: regset) (m: mem) :=
match label_pos lbl 0 c with
- | None => Error
+ | None => Stuck
| Some pos =>
match rs#PC with
- | Vptr b ofs => OK (rs#PC <- (Vptr b (Int.repr pos))) m
- | _ => Error
+ | Vptr b ofs => Next (rs#PC <- (Vptr b (Int.repr pos))) m
+ | _ => Stuck
end
end.
@@ -453,29 +468,29 @@ Definition goto_label (c: code) (lbl: label) (rs: regset) (m: mem) :=
Definition load1 (chunk: memory_chunk) (rd: preg)
(cst: constant) (r1: ireg) (rs: regset) (m: mem) :=
match Mem.loadv chunk m (Val.add (gpr_or_zero rs r1) (const_low cst)) with
- | None => Error
- | Some v => OK (nextinstr (rs#rd <- v)) m
+ | None => Stuck
+ | Some v => Next (nextinstr (rs#rd <- v)) m
end.
Definition load2 (chunk: memory_chunk) (rd: preg) (r1 r2: ireg)
(rs: regset) (m: mem) :=
match Mem.loadv chunk m (Val.add rs#r1 rs#r2) with
- | None => Error
- | Some v => OK (nextinstr (rs#rd <- v)) m
+ | None => Stuck
+ | Some v => Next (nextinstr (rs#rd <- v)) m
end.
Definition store1 (chunk: memory_chunk) (r: preg)
(cst: constant) (r1: ireg) (rs: regset) (m: mem) :=
match Mem.storev chunk m (Val.add (gpr_or_zero rs r1) (const_low cst)) (rs#r) with
- | None => Error
- | Some m' => OK (nextinstr rs) m'
+ | None => Stuck
+ | Some m' => Next (nextinstr rs) m'
end.
Definition store2 (chunk: memory_chunk) (r: preg) (r1 r2: ireg)
(rs: regset) (m: mem) :=
match Mem.storev chunk m (Val.add rs#r1 rs#r2) (rs#r) with
- | None => Error
- | Some m' => OK (nextinstr rs) m'
+ | None => Stuck
+ | Some m' => Next (nextinstr rs) m'
end.
(** Operations over condition bits. *)
@@ -521,127 +536,124 @@ Definition compare_float (rs: regset) (v1 v2: val) :=
Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome :=
match i with
| Padd rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.add rs#r1 rs#r2))) m
+ Next (nextinstr (rs#rd <- (Val.add rs#r1 rs#r2))) m
| Padde rd r1 r2 =>
- OK (nextinstr (rs #rd <- (Val.add (Val.add rs#r1 rs#r2) rs#CARRY)
+ Next (nextinstr (rs #rd <- (Val.add (Val.add rs#r1 rs#r2) rs#CARRY)
#CARRY <- (Val.add_carry rs#r1 rs#r2 rs#CARRY))) m
| Paddi rd r1 cst =>
- OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_low cst)))) m
+ Next (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_low cst)))) m
| Paddic rd r1 cst =>
- OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_low cst))
+ Next (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_low cst))
#CARRY <- (Val.add_carry (gpr_or_zero rs r1) (const_low cst) Vzero))) m
| Paddis rd r1 cst =>
- OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_high cst)))) m
+ Next (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)
+ Next (nextinstr (rs#rd <- (Val.add rs#r1 rs#CARRY)
#CARRY <- (Val.add_carry rs#r1 Vzero rs#CARRY))) m
| Pallocframe sz ofs =>
let (m1, stk) := Mem.alloc m 0 sz in
let sp := Vptr stk Int.zero in
match Mem.storev Mint32 m1 (Val.add sp (Vint ofs)) rs#GPR1 with
- | None => Error
- | Some m2 => OK (nextinstr (rs#GPR1 <- sp #GPR0 <- Vundef)) m2
+ | None => Stuck
+ | Some m2 => Next (nextinstr (rs#GPR1 <- sp #GPR0 <- Vundef)) m2
end
| Pand_ rd r1 r2 =>
let v := Val.and rs#r1 rs#r2 in
- OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m
+ Next (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m
| Pandc rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.and rs#r1 (Val.notint rs#r2)))) m
+ Next (nextinstr (rs#rd <- (Val.and rs#r1 (Val.notint rs#r2)))) m
| Pandi_ rd r1 cst =>
let v := Val.and rs#r1 (const_low cst) in
- OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m
+ Next (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m
| Pandis_ rd r1 cst =>
let v := Val.and rs#r1 (const_high cst) in
- OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m
+ Next (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m
| Pb lbl =>
goto_label c lbl rs m
| Pbctr =>
- OK (rs#PC <- (rs#CTR)) m
+ Next (rs#PC <- (rs#CTR)) m
| Pbctrl =>
- OK (rs#LR <- (Val.add rs#PC Vone) #PC <- (rs#CTR)) m
+ Next (rs#LR <- (Val.add rs#PC Vone) #PC <- (rs#CTR)) m
| Pbf bit lbl =>
match rs#(reg_of_crbit bit) with
- | Vint n => if Int.eq n Int.zero then goto_label c lbl rs m else OK (nextinstr rs) m
- | _ => Error
+ | Vint n => if Int.eq n Int.zero then goto_label c lbl rs m else Next (nextinstr rs) m
+ | _ => Stuck
end
| Pbl ident =>
- OK (rs#LR <- (Val.add rs#PC Vone) #PC <- (symbol_offset ident Int.zero)) m
+ Next (rs#LR <- (Val.add rs#PC Vone) #PC <- (symbol_offset ident Int.zero)) m
| Pbs ident =>
- OK (rs#PC <- (symbol_offset ident Int.zero)) m
+ Next (rs#PC <- (symbol_offset ident Int.zero)) m
| Pblr =>
- OK (rs#PC <- (rs#LR)) m
+ Next (rs#PC <- (rs#LR)) m
| Pbt bit lbl =>
match rs#(reg_of_crbit bit) with
- | Vint n => if Int.eq n Int.zero then OK (nextinstr rs) m else goto_label c lbl rs m
- | _ => Error
+ | Vint n => if Int.eq n Int.zero then Next (nextinstr rs) m else goto_label c lbl rs m
+ | _ => Stuck
end
| Pbtbl r tbl =>
- match gpr_or_zero rs r with
+ match rs r with
| Vint n =>
- let pos := Int.unsigned n in
- if zeq (Zmod pos 4) 0 then
- match list_nth_z tbl (pos / 4) with
- | None => Error
- | Some lbl => goto_label c lbl (rs #GPR12 <- Vundef #CTR <- Vundef) m
- end
- else Error
- | _ => Error
+ match list_nth_z tbl (Int.unsigned n) with
+ | None => Stuck
+ | Some lbl => goto_label c lbl (rs #GPR12 <- Vundef #CTR <- Vundef) m
+ end
+ | _ => Stuck
end
| Pcmplw r1 r2 =>
- OK (nextinstr (compare_uint rs m rs#r1 rs#r2)) m
+ Next (nextinstr (compare_uint rs m rs#r1 rs#r2)) m
| Pcmplwi r1 cst =>
- OK (nextinstr (compare_uint rs m rs#r1 (const_low cst))) m
+ Next (nextinstr (compare_uint rs m rs#r1 (const_low cst))) m
| Pcmpw r1 r2 =>
- OK (nextinstr (compare_sint rs rs#r1 rs#r2)) m
+ Next (nextinstr (compare_sint rs rs#r1 rs#r2)) m
| Pcmpwi r1 cst =>
- OK (nextinstr (compare_sint rs rs#r1 (const_low cst))) m
+ Next (nextinstr (compare_sint rs rs#r1 (const_low cst))) m
| Pcror bd b1 b2 =>
- OK (nextinstr (rs#(reg_of_crbit bd) <- (Val.or rs#(reg_of_crbit b1) rs#(reg_of_crbit b2)))) m
+ Next (nextinstr (rs#(reg_of_crbit bd) <- (Val.or rs#(reg_of_crbit b1) rs#(reg_of_crbit b2)))) m
| Pdivw rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.maketotal (Val.divs rs#r1 rs#r2)))) m
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.divs rs#r1 rs#r2)))) m
| Pdivwu rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.maketotal (Val.divu rs#r1 rs#r2)))) m
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.divu rs#r1 rs#r2)))) m
| Peqv rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.notint (Val.xor rs#r1 rs#r2)))) m
+ Next (nextinstr (rs#rd <- (Val.notint (Val.xor rs#r1 rs#r2)))) m
| Pextsb rd r1 =>
- OK (nextinstr (rs#rd <- (Val.sign_ext 8 rs#r1))) m
+ Next (nextinstr (rs#rd <- (Val.sign_ext 8 rs#r1))) m
| Pextsh rd r1 =>
- OK (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m
+ Next (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m
| Pfreeframe sz ofs =>
match Mem.loadv Mint32 m (Val.add rs#GPR1 (Vint ofs)) with
- | None => Error
+ | None => Stuck
| Some v =>
match rs#GPR1 with
| Vptr stk ofs =>
match Mem.free m stk 0 sz with
- | None => Error
- | Some m' => OK (nextinstr (rs#GPR1 <- v)) m'
+ | None => Stuck
+ | Some m' => Next (nextinstr (rs#GPR1 <- v)) m'
end
- | _ => Error
+ | _ => Stuck
end
end
| Pfabs rd r1 =>
- OK (nextinstr (rs#rd <- (Val.absf rs#r1))) m
+ Next (nextinstr (rs#rd <- (Val.absf rs#r1))) m
| Pfadd rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.addf rs#r1 rs#r2))) m
+ Next (nextinstr (rs#rd <- (Val.addf rs#r1 rs#r2))) m
| Pfcmpu r1 r2 =>
- OK (nextinstr (compare_float rs rs#r1 rs#r2)) m
+ Next (nextinstr (compare_float rs rs#r1 rs#r2)) m
| Pfcti rd r1 =>
- OK (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.maketotal (Val.intoffloat rs#r1)))) m
+ Next (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.maketotal (Val.intoffloat rs#r1)))) m
| Pfdiv rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.divf rs#r1 rs#r2))) m
+ Next (nextinstr (rs#rd <- (Val.divf rs#r1 rs#r2))) m
| Pfmake rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.floatofwords rs#r1 rs#r2))) m
+ Next (nextinstr (rs#rd <- (Val.floatofwords rs#r1 rs#r2))) m
| Pfmr rd r1 =>
- OK (nextinstr (rs#rd <- (rs#r1))) m
+ Next (nextinstr (rs#rd <- (rs#r1))) m
| Pfmul rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.mulf rs#r1 rs#r2))) m
+ Next (nextinstr (rs#rd <- (Val.mulf rs#r1 rs#r2))) m
| Pfneg rd r1 =>
- OK (nextinstr (rs#rd <- (Val.negf rs#r1))) m
+ Next (nextinstr (rs#rd <- (Val.negf rs#r1))) m
| Pfrsp rd r1 =>
- OK (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m
+ Next (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m
| Pfsub rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.subf rs#r1 rs#r2))) m
+ Next (nextinstr (rs#rd <- (Val.subf rs#r1 rs#r2))) m
| Plbz rd cst r1 =>
load1 Mint8unsigned rd cst r1 rs m
| Plbzx rd r1 r2 =>
@@ -663,50 +675,50 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
| Plhzx rd r1 r2 =>
load2 Mint16unsigned rd r1 r2 rs m
| Plfi rd f =>
- OK (nextinstr (rs #GPR12 <- Vundef #rd <- (Vfloat f))) m
+ Next (nextinstr (rs #GPR12 <- Vundef #rd <- (Vfloat f))) m
| Plwz rd cst r1 =>
load1 Mint32 rd cst r1 rs m
| Plwzx rd r1 r2 =>
load2 Mint32 rd r1 r2 rs m
| Pmfcrbit rd bit =>
- OK (nextinstr (rs#rd <- (rs#(reg_of_crbit bit)))) m
+ Next (nextinstr (rs#rd <- (rs#(reg_of_crbit bit)))) m
| Pmflr rd =>
- OK (nextinstr (rs#rd <- (rs#LR))) m
+ Next (nextinstr (rs#rd <- (rs#LR))) m
| Pmr rd r1 =>
- OK (nextinstr (rs#rd <- (rs#r1))) m
+ Next (nextinstr (rs#rd <- (rs#r1))) m
| Pmtctr r1 =>
- OK (nextinstr (rs#CTR <- (rs#r1))) m
+ Next (nextinstr (rs#CTR <- (rs#r1))) m
| Pmtlr r1 =>
- OK (nextinstr (rs#LR <- (rs#r1))) m
+ Next (nextinstr (rs#LR <- (rs#r1))) m
| Pmulli rd r1 cst =>
- OK (nextinstr (rs#rd <- (Val.mul rs#r1 (const_low cst)))) m
+ Next (nextinstr (rs#rd <- (Val.mul rs#r1 (const_low cst)))) m
| Pmullw rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.mul rs#r1 rs#r2))) m
+ Next (nextinstr (rs#rd <- (Val.mul rs#r1 rs#r2))) m
| Pnand rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.notint (Val.and rs#r1 rs#r2)))) m
+ Next (nextinstr (rs#rd <- (Val.notint (Val.and rs#r1 rs#r2)))) m
| Pnor rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.notint (Val.or rs#r1 rs#r2)))) m
+ Next (nextinstr (rs#rd <- (Val.notint (Val.or rs#r1 rs#r2)))) m
| Por rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.or rs#r1 rs#r2))) m
+ Next (nextinstr (rs#rd <- (Val.or rs#r1 rs#r2))) m
| Porc rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.or rs#r1 (Val.notint rs#r2)))) m
+ Next (nextinstr (rs#rd <- (Val.or rs#r1 (Val.notint rs#r2)))) m
| Pori rd r1 cst =>
- OK (nextinstr (rs#rd <- (Val.or rs#r1 (const_low cst)))) m
+ Next (nextinstr (rs#rd <- (Val.or rs#r1 (const_low cst)))) m
| Poris rd r1 cst =>
- OK (nextinstr (rs#rd <- (Val.or rs#r1 (const_high cst)))) m
+ Next (nextinstr (rs#rd <- (Val.or rs#r1 (const_high cst)))) m
| Prlwinm rd r1 amount mask =>
- OK (nextinstr (rs#rd <- (Val.rolm rs#r1 amount mask))) m
+ Next (nextinstr (rs#rd <- (Val.rolm rs#r1 amount mask))) m
| Prlwimi rd r1 amount mask =>
- OK (nextinstr (rs#rd <- (Val.or (Val.and rs#rd (Vint (Int.not mask)))
+ Next (nextinstr (rs#rd <- (Val.or (Val.and rs#rd (Vint (Int.not mask)))
(Val.rolm rs#r1 amount mask)))) m
| Pslw rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.shl rs#r1 rs#r2))) m
+ Next (nextinstr (rs#rd <- (Val.shl rs#r1 rs#r2))) m
| Psraw rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.shr rs#r1 rs#r2) #CARRY <- (Val.shr_carry rs#r1 rs#r2))) m
+ Next (nextinstr (rs#rd <- (Val.shr rs#r1 rs#r2) #CARRY <- (Val.shr_carry rs#r1 rs#r2))) m
| Psrawi rd r1 n =>
- OK (nextinstr (rs#rd <- (Val.shr rs#r1 (Vint n)) #CARRY <- (Val.shr_carry rs#r1 (Vint n)))) m
+ Next (nextinstr (rs#rd <- (Val.shr rs#r1 (Vint n)) #CARRY <- (Val.shr_carry rs#r1 (Vint n)))) m
| Psrw rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.shru rs#r1 rs#r2))) m
+ Next (nextinstr (rs#rd <- (Val.shru rs#r1 rs#r2))) m
| Pstb rd cst r1 =>
store1 Mint8unsigned rd cst r1 rs m
| Pstbx rd r1 r2 =>
@@ -717,13 +729,13 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
store2 Mfloat64al32 rd r1 r2 rs m
| Pstfs rd cst r1 =>
match store1 Mfloat32 rd cst r1 rs m with
- | OK rs' m' => OK (rs'#FPR13 <- Vundef) m'
- | Error => Error
+ | Next rs' m' => Next (rs'#FPR13 <- Vundef) m'
+ | Stuck => Stuck
end
| Pstfsx rd r1 r2 =>
match store2 Mfloat32 rd r1 r2 rs m with
- | OK rs' m' => OK (rs'#FPR13 <- Vundef) m'
- | Error => Error
+ | Next rs' m' => Next (rs'#FPR13 <- Vundef) m'
+ | Stuck => Stuck
end
| Psth rd cst r1 =>
store1 Mint16unsigned rd cst r1 rs m
@@ -734,41 +746,34 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
| Pstwx rd r1 r2 =>
store2 Mint32 rd r1 r2 rs m
| Psubfc rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.sub rs#r2 rs#r1)
+ Next (nextinstr (rs#rd <- (Val.sub rs#r2 rs#r1)
#CARRY <- (Val.add_carry rs#r2 (Val.notint rs#r1) Vone))) m
| Psubfe rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.add (Val.add rs#r2 (Val.notint rs#r1)) rs#CARRY)
+ Next (nextinstr (rs#rd <- (Val.add (Val.add rs#r2 (Val.notint rs#r1)) rs#CARRY)
#CARRY <- (Val.add_carry rs#r2 (Val.notint rs#r1) rs#CARRY))) m
| Psubfic rd r1 cst =>
- OK (nextinstr (rs#rd <- (Val.sub (const_low cst) rs#r1)
+ Next (nextinstr (rs#rd <- (Val.sub (const_low cst) rs#r1)
#CARRY <- (Val.add_carry (const_low cst) (Val.notint rs#r1) Vone))) m
| Pxor rd r1 r2 =>
- OK (nextinstr (rs#rd <- (Val.xor rs#r1 rs#r2))) m
+ Next (nextinstr (rs#rd <- (Val.xor rs#r1 rs#r2))) m
| Pxori rd r1 cst =>
- OK (nextinstr (rs#rd <- (Val.xor rs#r1 (const_low cst)))) m
+ Next (nextinstr (rs#rd <- (Val.xor rs#r1 (const_low cst)))) m
| Pxoris rd r1 cst =>
- OK (nextinstr (rs#rd <- (Val.xor rs#r1 (const_high cst)))) m
+ Next (nextinstr (rs#rd <- (Val.xor rs#r1 (const_high cst)))) m
| Plabel lbl =>
- OK (nextinstr rs) m
+ Next (nextinstr rs) m
| Pbuiltin ef args res =>
- Error (**r treated specially below *)
+ Stuck (**r treated specially below *)
| Pannot ef args =>
- Error (**r treated specially below *)
+ Stuck (**r treated specially below *)
end.
(** Translation of the LTL/Linear/Mach view of machine registers
- to the PPC view. PPC has two different types for registers
- (integer and float) while LTL et al have only one. The
- [ireg_of] and [freg_of] are therefore partial in principle.
- To keep things simpler, we make them return nonsensical
- results when applied to a LTL register of the wrong type.
- The proof in [Asmgenproof] will show that this never happens.
-
- Note that no LTL register maps to [GPR0].
+ to the PPC view. Note that no LTL register maps to [GPR0].
This register is reserved as a temporary to be used
by the generated PPC code. *)
-Definition ireg_of (r: mreg) : ireg :=
+Definition preg_of (r: mreg) : preg :=
match r with
| R3 => GPR3 | R4 => GPR4 | R5 => GPR5 | R6 => GPR6
| R7 => GPR7 | R8 => GPR8 | R9 => GPR9 | R10 => GPR10
@@ -778,11 +783,6 @@ Definition ireg_of (r: mreg) : ireg :=
| R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28
| R29 => GPR29 | R30 => GPR30 | R31 => GPR31
| IT1 => GPR11 | IT2 => GPR12
- | _ => GPR12 (* should not happen *)
- end.
-
-Definition freg_of (r: mreg) : freg :=
- match r with
| F1 => FPR1 | F2 => FPR2 | F3 => FPR3 | F4 => FPR4
| F5 => FPR5 | F6 => FPR6 | F7 => FPR7 | F8 => FPR8
| F9 => FPR9 | F10 => FPR10 | F11 => FPR11
@@ -792,13 +792,6 @@ Definition freg_of (r: mreg) : freg :=
| F24 => FPR24 | F25 => FPR25 | F26 => FPR26 | F27 => FPR27
| F28 => FPR28 | F29 => FPR29 | F30 => FPR30 | F31 => FPR31
| FT1 => FPR0 | FT2 => FPR12 | FT3 => FPR13
- | _ => FPR0 (* should not happen *)
- end.
-
-Definition preg_of (r: mreg) :=
- match mreg_type r with
- | Tint => IR (ireg_of r)
- | Tfloat => FR (freg_of r)
end.
(** Extract the values of the arguments of an external call.
@@ -849,7 +842,7 @@ Inductive step: state -> trace -> state -> Prop :=
rs PC = Vptr b ofs ->
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_instr c i rs m = Next rs' m' ->
step (State rs m) E0 (State rs' m')
| exec_step_builtin:
forall b ofs c ef args res rs m t v m',
@@ -968,3 +961,25 @@ Ltac Equalities :=
(* final states *)
inv H; inv H0. congruence.
Qed.
+
+(** Classification functions for processor registers (used in Asmgenproof). *)
+
+Definition data_preg (r: preg) : bool :=
+ match r with
+ | IR GPR0 => false
+ | PC => false | LR => false | CTR => false
+ | CR0_0 => false | CR0_1 => false | CR0_2 => false | CR0_3 => false
+ | CARRY => false
+ | _ => true
+ end.
+
+Definition nontemp_preg (r: preg) : bool :=
+ match r with
+ | IR GPR0 => false | IR GPR11 => false | IR GPR12 => false
+ | FR FPR0 => false | FR FPR12 => false | FR FPR13 => false
+ | PC => false | LR => false | CTR => false
+ | CR0_0 => false | CR0_1 => false | CR0_2 => false | CR0_3 => false
+ | CARRY => false
+ | _ => true
+ end.
+
diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v
index 8ef249d..0035dff 100644
--- a/powerpc/Asmgen.v
+++ b/powerpc/Asmgen.v
@@ -22,6 +22,23 @@ Require Import Locations.
Require Import Mach.
Require Import Asm.
+Open Local Scope string_scope.
+Open Local Scope error_monad_scope.
+
+(** The code generation functions take advantage of several
+ characteristics of the [Mach] code generated by earlier passes of the
+ compiler, mostly that argument and result registers are of the correct
+ types. These properties are true by construction, but it's easier to
+ recheck them during code generation and fail if they do not hold. *)
+
+(** Extracting integer or float registers. *)
+
+Definition ireg_of (r: mreg) : res ireg :=
+ match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end.
+
+Definition freg_of (r: mreg) : res freg :=
+ match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end.
+
(** Decomposition of integer constants. As noted in file [Asm],
immediate arguments to PowerPC instructions must fit into 16 bits,
and are interpreted after zero extension, sign extension, or
@@ -106,30 +123,36 @@ Definition rolm (r1 r2: ireg) (amount mask: int) (k: code) :=
(** Accessing slots in the stack frame. *)
Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) :=
- if Int.eq (high_s ofs) Int.zero then
- match ty with
- | Tint => Plwz (ireg_of dst) (Cint ofs) base :: k
- | Tfloat => Plfd (freg_of dst) (Cint ofs) base :: k
- end
- else
- loadimm GPR0 ofs
- (match ty with
- | Tint => Plwzx (ireg_of dst) base GPR0 :: k
- | Tfloat => Plfdx (freg_of dst) base GPR0 :: k
- end).
+ match ty with
+ | Tint =>
+ do r <- ireg_of dst;
+ OK (if Int.eq (high_s ofs) Int.zero then
+ Plwz r (Cint ofs) base :: k
+ else
+ loadimm GPR0 ofs (Plwzx r base GPR0 :: k))
+ | Tfloat =>
+ do r <- freg_of dst;
+ OK (if Int.eq (high_s ofs) Int.zero then
+ Plfd r (Cint ofs) base :: k
+ else
+ loadimm GPR0 ofs (Plfdx r base GPR0 :: k))
+ end.
Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) :=
- if Int.eq (high_s ofs) Int.zero then
- match ty with
- | Tint => Pstw (ireg_of src) (Cint ofs) base :: k
- | Tfloat => Pstfd (freg_of src) (Cint ofs) base :: k
- end
- else
- loadimm GPR0 ofs
- (match ty with
- | Tint => Pstwx (ireg_of src) base GPR0 :: k
- | Tfloat => Pstfdx (freg_of src) base GPR0 :: k
- end).
+ match ty with
+ | Tint =>
+ do r <- ireg_of src;
+ OK (if Int.eq (high_s ofs) Int.zero then
+ Pstw r (Cint ofs) base :: k
+ else
+ loadimm GPR0 ofs (Pstwx r base GPR0 :: k))
+ | Tfloat =>
+ do r <- freg_of src;
+ OK (if Int.eq (high_s ofs) Int.zero then
+ Pstfd r (Cint ofs) base :: k
+ else
+ loadimm GPR0 ofs (Pstfdx r base GPR0 :: k))
+ end.
(** Constructor for a floating-point comparison. The PowerPC has
a single [fcmpu] instruction to compare floats, which sets
@@ -156,29 +179,31 @@ Definition transl_cond
(cond: condition) (args: list mreg) (k: code) :=
match cond, args with
| Ccomp c, a1 :: a2 :: nil =>
- Pcmpw (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpw r1 r2 :: k)
| Ccompu c, a1 :: a2 :: nil =>
- Pcmplw (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmplw r1 r2 :: k)
| Ccompimm c n, a1 :: nil =>
+ do r1 <- ireg_of a1;
if Int.eq (high_s n) Int.zero then
- Pcmpwi (ireg_of a1) (Cint n) :: k
+ OK (Pcmpwi r1 (Cint n) :: k)
else
- loadimm GPR0 n (Pcmpw (ireg_of a1) GPR0 :: k)
+ OK (loadimm GPR0 n (Pcmpw r1 GPR0 :: k))
| Ccompuimm c n, a1 :: nil =>
+ do r1 <- ireg_of a1;
if Int.eq (high_u n) Int.zero then
- Pcmplwi (ireg_of a1) (Cint n) :: k
+ OK (Pcmplwi r1 (Cint n) :: k)
else
- loadimm GPR0 n (Pcmplw (ireg_of a1) GPR0 :: k)
+ OK (loadimm GPR0 n (Pcmplw r1 GPR0 :: k))
| Ccompf cmp, a1 :: a2 :: nil =>
- floatcomp cmp (freg_of a1) (freg_of a2) k
+ do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp cmp r1 r2 k)
| Cnotcompf cmp, a1 :: a2 :: nil =>
- floatcomp cmp (freg_of a1) (freg_of a2) k
+ do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp cmp r1 r2 k)
| Cmaskzero n, a1 :: nil =>
- andimm_base GPR0 (ireg_of a1) n k
+ do r1 <- ireg_of a1; OK (andimm_base GPR0 r1 n k)
| Cmasknotzero n, a1 :: nil =>
- andimm_base GPR0 (ireg_of a1) n k
+ do r1 <- ireg_of a1; OK (andimm_base GPR0 r1 n k)
| _, _ =>
- k (**r never happens for well-typed code *)
+ Error(msg "Asmgen.transl_cond")
end.
(* CRbit_0 = Less
@@ -264,180 +289,267 @@ Definition classify_condition (c: condition) (args: list mreg): condition_class
Definition transl_cond_op
(cond: condition) (args: list mreg) (r: mreg) (k: code) :=
+ do r' <- ireg_of r;
match classify_condition cond args with
| condition_eq0 _ a _ =>
- Psubfic GPR0 (ireg_of a) (Cint Int.zero) ::
- Padde (ireg_of r) GPR0 (ireg_of a) :: k
+ do a' <- ireg_of a;
+ OK (Psubfic GPR0 a' (Cint Int.zero) ::
+ Padde r' GPR0 a' :: k)
| condition_ne0 _ a _ =>
- Paddic GPR0 (ireg_of a) (Cint Int.mone) ::
- Psubfe (ireg_of r) GPR0 (ireg_of a) :: k
+ do a' <- ireg_of a;
+ OK (Paddic GPR0 a' (Cint Int.mone) ::
+ Psubfe r' GPR0 a' :: k)
| condition_ge0 _ a _ =>
- Prlwinm (ireg_of r) (ireg_of a) Int.one Int.one ::
- Pxori (ireg_of r) (ireg_of r) (Cint Int.one) :: k
+ do a' <- ireg_of a;
+ OK (Prlwinm r' a' Int.one Int.one ::
+ Pxori r' r' (Cint Int.one) :: k)
| condition_lt0 _ a _ =>
- Prlwinm (ireg_of r) (ireg_of a) Int.one Int.one :: k
+ do a' <- ireg_of a;
+ OK (Prlwinm r' a' Int.one Int.one :: k)
| condition_default _ _ =>
let p := crbit_for_cond cond in
transl_cond cond args
- (Pmfcrbit (ireg_of r) (fst p) ::
+ (Pmfcrbit r' (fst p) ::
if snd p
then k
- else Pxori (ireg_of r) (ireg_of r) (Cint Int.one) :: k)
+ else Pxori r' r' (Cint Int.one) :: k)
end.
(** Translation of the arithmetic operation [r <- op(args)].
The corresponding instructions are prepended to [k]. *)
Definition transl_op
- (op: operation) (args: list mreg) (r: mreg) (k: code) :=
+ (op: operation) (args: list mreg) (res: mreg) (k: code) :=
match op, args with
| Omove, a1 :: nil =>
- match mreg_type a1 with
- | Tint => Pmr (ireg_of r) (ireg_of a1) :: k
- | Tfloat => Pfmr (freg_of r) (freg_of a1) :: k
+ match preg_of res, preg_of a1 with
+ | IR r, IR a => OK (Pmr r a :: k)
+ | FR r, FR a => OK (Pfmr r a :: k)
+ | _ , _ => Error(msg "Asmgen.Omove")
end
| Ointconst n, nil =>
- loadimm (ireg_of r) n k
+ do r <- ireg_of res; OK (loadimm r n k)
| Ofloatconst f, nil =>
- Plfi (freg_of r) f :: k
+ do r <- freg_of res; OK (Plfi r f :: k)
| Oaddrsymbol s ofs, nil =>
- if symbol_is_small_data s ofs then
- Paddi (ireg_of r) GPR0 (Csymbol_sda s ofs) :: k
- else
- Paddis GPR12 GPR0 (Csymbol_high s ofs) ::
- Paddi (ireg_of r) GPR12 (Csymbol_low s ofs) :: k
+ do r <- ireg_of res;
+ OK (if symbol_is_small_data s ofs then
+ Paddi r GPR0 (Csymbol_sda s ofs) :: k
+ else
+ Paddis GPR12 GPR0 (Csymbol_high s ofs) ::
+ Paddi r GPR12 (Csymbol_low s ofs) :: k)
| Oaddrstack n, nil =>
- addimm (ireg_of r) GPR1 n k
+ do r <- ireg_of res; OK (addimm r GPR1 n k)
| Ocast8signed, a1 :: nil =>
- Pextsb (ireg_of r) (ireg_of a1) :: k
+ do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pextsb r r1 :: k)
| Ocast16signed, a1 :: nil =>
- Pextsh (ireg_of r) (ireg_of a1) :: k
+ do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pextsh r r1 :: k)
| Oadd, a1 :: a2 :: nil =>
- Padd (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Padd r r1 r2 :: k)
| Oaddimm n, a1 :: nil =>
- addimm (ireg_of r) (ireg_of a1) n k
+ do r1 <- ireg_of a1; do r <- ireg_of res; OK (addimm r r1 n k)
| Osub, a1 :: a2 :: nil =>
- Psubfc (ireg_of r) (ireg_of a2) (ireg_of a1) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Psubfc r r2 r1 :: k)
| Osubimm n, a1 :: nil =>
- if Int.eq (high_s n) Int.zero then
- Psubfic (ireg_of r) (ireg_of a1) (Cint n) :: k
- else
- loadimm GPR0 n (Psubfc (ireg_of r) (ireg_of a1) GPR0 :: k)
+ do r1 <- ireg_of a1; do r <- ireg_of res;
+ OK (if Int.eq (high_s n) Int.zero then
+ Psubfic r r1 (Cint n) :: k
+ else
+ loadimm GPR0 n (Psubfc r r1 GPR0 :: k))
| Omul, a1 :: a2 :: nil =>
- Pmullw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Pmullw r r1 r2 :: k)
| Omulimm n, a1 :: nil =>
- if Int.eq (high_s n) Int.zero then
- Pmulli (ireg_of r) (ireg_of a1) (Cint n) :: k
- else
- loadimm GPR0 n (Pmullw (ireg_of r) (ireg_of a1) GPR0 :: k)
+ do r1 <- ireg_of a1; do r <- ireg_of res;
+ OK (if Int.eq (high_s n) Int.zero then
+ Pmulli r r1 (Cint n) :: k
+ else
+ loadimm GPR0 n (Pmullw r r1 GPR0 :: k))
| Odiv, a1 :: a2 :: nil =>
- Pdivw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Pdivw r r1 r2 :: k)
| Odivu, a1 :: a2 :: nil =>
- Pdivwu (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Pdivwu r r1 r2 :: k)
| Oand, a1 :: a2 :: nil =>
- Pand_ (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Pand_ r r1 r2 :: k)
| Oandimm n, a1 :: nil =>
- andimm (ireg_of r) (ireg_of a1) n k
+ do r1 <- ireg_of a1; do r <- ireg_of res;
+ OK (andimm r r1 n k)
| Oor, a1 :: a2 :: nil =>
- Por (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Por r r1 r2 :: k)
| Oorimm n, a1 :: nil =>
- orimm (ireg_of r) (ireg_of a1) n k
+ do r1 <- ireg_of a1; do r <- ireg_of res;
+ OK (orimm r r1 n k)
| Oxor, a1 :: a2 :: nil =>
- Pxor (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Pxor r r1 r2 :: k)
| Oxorimm n, a1 :: nil =>
- xorimm (ireg_of r) (ireg_of a1) n k
+ do r1 <- ireg_of a1; do r <- ireg_of res;
+ OK (xorimm r r1 n k)
| Onot, a1 :: nil =>
- Pnor (ireg_of r) (ireg_of a1) (ireg_of a1) :: k
+ do r1 <- ireg_of a1; do r <- ireg_of res;
+ OK (Pnor r r1 r1 :: k)
| Onand, a1 :: a2 :: nil =>
- Pnand (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Pnand r r1 r2 :: k)
| Onor, a1 :: a2 :: nil =>
- Pnor (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Pnor r r1 r2 :: k)
| Onxor, a1 :: a2 :: nil =>
- Peqv (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Peqv r r1 r2 :: k)
| Oandc, a1 :: a2 :: nil =>
- Pandc (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Pandc r r1 r2 :: k)
| Oorc, a1 :: a2 :: nil =>
- Porc (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Porc r r1 r2 :: k)
| Oshl, a1 :: a2 :: nil =>
- Pslw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Pslw r r1 r2 :: k)
| Oshr, a1 :: a2 :: nil =>
- Psraw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Psraw r r1 r2 :: k)
| Oshrimm n, a1 :: nil =>
- Psrawi (ireg_of r) (ireg_of a1) n :: k
+ do r1 <- ireg_of a1; do r <- ireg_of res;
+ OK (Psrawi r r1 n :: k)
| Oshrximm n, a1 :: nil =>
- Psrawi (ireg_of r) (ireg_of a1) n ::
- Paddze (ireg_of r) (ireg_of r) :: k
+ do r1 <- ireg_of a1; do r <- ireg_of res;
+ OK (Psrawi r r1 n :: Paddze r r :: k)
| Oshru, a1 :: a2 :: nil =>
- Psrw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Psrw r r1 r2 :: k)
| Orolm amount mask, a1 :: nil =>
- rolm (ireg_of r) (ireg_of a1) amount mask k
+ do r1 <- ireg_of a1; do r <- ireg_of res;
+ OK (rolm r r1 amount mask k)
| Oroli amount mask, a1 :: a2 :: nil =>
- if mreg_eq a1 r then (**r should always be true *)
- Prlwimi (ireg_of r) (ireg_of a2) amount mask :: k
- else
- Pmr GPR0 (ireg_of a1) ::
- Prlwimi GPR0 (ireg_of a2) amount mask ::
- Pmr (ireg_of r) GPR0 :: k
+ do x <- assertion (mreg_eq a1 res);
+ do r2 <- ireg_of a2; do r <- ireg_of res;
+ OK (Prlwimi r r2 amount mask :: k)
| Onegf, a1 :: nil =>
- Pfneg (freg_of r) (freg_of a1) :: k
+ do r1 <- freg_of a1; do r <- freg_of res;
+ OK (Pfneg r r1 :: k)
| Oabsf, a1 :: nil =>
- Pfabs (freg_of r) (freg_of a1) :: k
+ do r1 <- freg_of a1; do r <- freg_of res;
+ OK (Pfabs r r1 :: k)
| Oaddf, a1 :: a2 :: nil =>
- Pfadd (freg_of r) (freg_of a1) (freg_of a2) :: k
+ do r1 <- freg_of a1; do r2 <- freg_of a2; do r <- freg_of res;
+ OK (Pfadd r r1 r2 :: k)
| Osubf, a1 :: a2 :: nil =>
- Pfsub (freg_of r) (freg_of a1) (freg_of a2) :: k
+ do r1 <- freg_of a1; do r2 <- freg_of a2; do r <- freg_of res;
+ OK (Pfsub r r1 r2 :: k)
| Omulf, a1 :: a2 :: nil =>
- Pfmul (freg_of r) (freg_of a1) (freg_of a2) :: k
+ do r1 <- freg_of a1; do r2 <- freg_of a2; do r <- freg_of res;
+ OK (Pfmul r r1 r2 :: k)
| Odivf, a1 :: a2 :: nil =>
- Pfdiv (freg_of r) (freg_of a1) (freg_of a2) :: k
+ do r1 <- freg_of a1; do r2 <- freg_of a2; do r <- freg_of res;
+ OK (Pfdiv r r1 r2 :: k)
| Osingleoffloat, a1 :: nil =>
- Pfrsp (freg_of r) (freg_of a1) :: k
+ do r1 <- freg_of a1; do r <- freg_of res;
+ OK (Pfrsp r r1 :: k)
| Ointoffloat, a1 :: nil =>
- Pfcti (ireg_of r) (freg_of a1) :: k
+ do r1 <- freg_of a1; do r <- ireg_of res;
+ OK (Pfcti r r1 :: k)
| Ofloatofwords, a1 :: a2 :: nil =>
- Pfmake (freg_of r) (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- freg_of res;
+ OK (Pfmake r r1 r2 :: k)
| Ocmp cmp, _ =>
- transl_cond_op cmp args r k
+ transl_cond_op cmp args res k
| _, _ =>
- k (**r never happens for well-typed code *)
+ Error(msg "Asmgen.transl_op")
end.
-(** Common code to translate [Mload] and [Mstore] instructions. *)
+(** Translation of memory accesses: loads, and stores. *)
Definition int_temp_for (r: mreg) :=
if mreg_eq r IT2 then GPR11 else GPR12.
-Definition transl_load_store
+Definition transl_memory_access
(mk1: constant -> ireg -> instruction)
(mk2: ireg -> ireg -> instruction)
(addr: addressing) (args: list mreg)
(temp: ireg) (k: code) :=
match addr, args with
| Aindexed ofs, a1 :: nil =>
- if Int.eq (high_s ofs) Int.zero then
- mk1 (Cint ofs) (ireg_of a1) :: k
- else
- Paddis temp (ireg_of a1) (Cint (high_s ofs)) ::
- mk1 (Cint (low_s ofs)) temp :: k
+ do r1 <- ireg_of a1;
+ OK (if Int.eq (high_s ofs) Int.zero then
+ mk1 (Cint ofs) r1 :: k
+ else
+ Paddis temp r1 (Cint (high_s ofs)) ::
+ mk1 (Cint (low_s ofs)) temp :: k)
| Aindexed2, a1 :: a2 :: nil =>
- mk2 (ireg_of a1) (ireg_of a2) :: k
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (mk2 r1 r2 :: k)
| Aglobal symb ofs, nil =>
- if symbol_is_small_data symb ofs then
- mk1 (Csymbol_sda symb ofs) GPR0 :: k
- else
- Paddis temp GPR0 (Csymbol_high symb ofs) ::
- mk1 (Csymbol_low symb ofs) temp :: k
+ OK (if symbol_is_small_data symb ofs then
+ mk1 (Csymbol_sda symb ofs) GPR0 :: k
+ else
+ Paddis temp GPR0 (Csymbol_high symb ofs) ::
+ mk1 (Csymbol_low symb ofs) temp :: k)
| Abased symb ofs, a1 :: nil =>
- Paddis temp (ireg_of a1) (Csymbol_high symb ofs) ::
- mk1 (Csymbol_low symb ofs) temp :: k
+ do r1 <- ireg_of a1;
+ OK (Paddis temp r1 (Csymbol_high symb ofs) ::
+ mk1 (Csymbol_low symb ofs) temp :: k)
| Ainstack ofs, nil =>
- if Int.eq (high_s ofs) Int.zero then
- mk1 (Cint ofs) GPR1 :: k
- else
- Paddis temp GPR1 (Cint (high_s ofs)) ::
- mk1 (Cint (low_s ofs)) temp :: k
+ OK (if Int.eq (high_s ofs) Int.zero then
+ mk1 (Cint ofs) GPR1 :: k
+ else
+ Paddis temp GPR1 (Cint (high_s ofs)) ::
+ mk1 (Cint (low_s ofs)) temp :: k)
| _, _ =>
- (* should not happen *) k
+ Error(msg "Asmgen.transl_memory_access")
+ end.
+
+Definition transl_load (chunk: memory_chunk) (addr: addressing)
+ (args: list mreg) (dst: mreg) (k: code) :=
+ match chunk with
+ | Mint8signed =>
+ do r <- ireg_of dst;
+ transl_memory_access (Plbz r) (Plbzx r) addr args GPR12 (Pextsb r r :: k)
+ | Mint8unsigned =>
+ do r <- ireg_of dst;
+ transl_memory_access (Plbz r) (Plbzx r) addr args GPR12 k
+ | Mint16signed =>
+ do r <- ireg_of dst;
+ transl_memory_access (Plha r) (Plhax r) addr args GPR12 k
+ | Mint16unsigned =>
+ do r <- ireg_of dst;
+ transl_memory_access (Plhz r) (Plhzx r) addr args GPR12 k
+ | Mint32 =>
+ do r <- ireg_of dst;
+ transl_memory_access (Plwz r) (Plwzx r) addr args GPR12 k
+ | Mfloat32 =>
+ do r <- freg_of dst;
+ transl_memory_access (Plfs r) (Plfsx r) addr args GPR12 k
+ | Mfloat64 | Mfloat64al32 =>
+ do r <- freg_of dst;
+ transl_memory_access (Plfd r) (Plfdx r) addr args GPR12 k
+ end.
+
+Definition transl_store (chunk: memory_chunk) (addr: addressing)
+ (args: list mreg) (src: mreg) (k: code) :=
+ let temp := int_temp_for src in
+ match chunk with
+ | Mint8signed | Mint8unsigned =>
+ do r <- ireg_of src;
+ transl_memory_access (Pstb r) (Pstbx r) addr args temp k
+ | Mint16signed | Mint16unsigned =>
+ do r <- ireg_of src;
+ transl_memory_access (Psth r) (Psthx r) addr args temp k
+ | Mint32 =>
+ do r <- ireg_of src;
+ transl_memory_access (Pstw r) (Pstwx r) addr args temp k
+ | Mfloat32 =>
+ do r <- freg_of src;
+ transl_memory_access (Pstfs r) (Pstfsx r) addr args temp k
+ | Mfloat64 | Mfloat64al32 =>
+ do r <- freg_of src;
+ transl_memory_access (Pstfd r) (Pstfdx r) addr args temp k
end.
(** Translation of arguments to annotations *)
@@ -450,105 +562,80 @@ Definition transl_annot_param (p: Mach.annot_param) : Asm.annot_param :=
(** Translation of a Mach instruction. *)
-Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) :=
+Definition transl_instr (f: Mach.function) (i: Mach.instruction)
+ (r11_is_parent: bool) (k: code) :=
match i with
| Mgetstack ofs ty dst =>
loadind GPR1 ofs ty dst k
| Msetstack src ofs ty =>
storeind src GPR1 ofs ty k
| Mgetparam ofs ty dst =>
- Plwz GPR11 (Cint f.(fn_link_ofs)) GPR1 :: loadind GPR11 ofs ty dst k
+ if r11_is_parent then
+ loadind GPR11 ofs ty dst k
+ else
+ (do k1 <- loadind GPR11 ofs ty dst k;
+ loadind GPR1 f.(fn_link_ofs) Tint IT1 k1)
| Mop op args res =>
transl_op op args res k
| Mload chunk addr args dst =>
- match chunk with
- | Mint8signed =>
- transl_load_store
- (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) addr args GPR12
- (Pextsb (ireg_of dst) (ireg_of dst) :: k)
- | Mint8unsigned =>
- transl_load_store
- (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) addr args GPR12 k
- | Mint16signed =>
- transl_load_store
- (Plha (ireg_of dst)) (Plhax (ireg_of dst)) addr args GPR12 k
- | Mint16unsigned =>
- transl_load_store
- (Plhz (ireg_of dst)) (Plhzx (ireg_of dst)) addr args GPR12 k
- | Mint32 =>
- transl_load_store
- (Plwz (ireg_of dst)) (Plwzx (ireg_of dst)) addr args GPR12 k
- | Mfloat32 =>
- transl_load_store
- (Plfs (freg_of dst)) (Plfsx (freg_of dst)) addr args GPR12 k
- | Mfloat64 | Mfloat64al32 =>
- transl_load_store
- (Plfd (freg_of dst)) (Plfdx (freg_of dst)) addr args GPR12 k
- end
+ transl_load chunk addr args dst k
| Mstore chunk addr args src =>
- let temp := int_temp_for src in
- match chunk with
- | Mint8signed =>
- transl_load_store
- (Pstb (ireg_of src)) (Pstbx (ireg_of src)) addr args temp k
- | Mint8unsigned =>
- transl_load_store
- (Pstb (ireg_of src)) (Pstbx (ireg_of src)) addr args temp k
- | Mint16signed =>
- transl_load_store
- (Psth (ireg_of src)) (Psthx (ireg_of src)) addr args temp k
- | Mint16unsigned =>
- transl_load_store
- (Psth (ireg_of src)) (Psthx (ireg_of src)) addr args temp k
- | Mint32 =>
- transl_load_store
- (Pstw (ireg_of src)) (Pstwx (ireg_of src)) addr args temp k
- | Mfloat32 =>
- transl_load_store
- (Pstfs (freg_of src)) (Pstfsx (freg_of src)) addr args temp k
- | Mfloat64 | Mfloat64al32 =>
- transl_load_store
- (Pstfd (freg_of src)) (Pstfdx (freg_of src)) addr args temp k
- end
+ transl_store chunk addr args src k
| Mcall sig (inl r) =>
- Pmtctr (ireg_of r) :: Pbctrl :: k
+ do r1 <- ireg_of r; OK (Pmtctr r1 :: Pbctrl :: k)
| Mcall sig (inr symb) =>
- Pbl symb :: k
+ OK (Pbl symb :: k)
| Mtailcall sig (inl r) =>
- Pmtctr (ireg_of r) ::
- Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 ::
- Pmtlr GPR0 ::
- Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::
- Pbctr :: k
+ do r1 <- ireg_of r;
+ OK (Pmtctr r1 ::
+ Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 ::
+ Pmtlr GPR0 ::
+ Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::
+ Pbctr :: k)
| Mtailcall sig (inr symb) =>
- Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 ::
- Pmtlr GPR0 ::
- Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::
- Pbs symb :: k
+ OK (Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 ::
+ Pmtlr GPR0 ::
+ Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::
+ Pbs symb :: k)
| Mbuiltin ef args res =>
- Pbuiltin ef (map preg_of args) (preg_of res) :: k
+ OK (Pbuiltin ef (map preg_of args) (preg_of res) :: k)
| Mannot ef args =>
- Pannot ef (map transl_annot_param args) :: k
+ OK (Pannot ef (map transl_annot_param args) :: k)
| Mlabel lbl =>
- Plabel lbl :: k
+ OK (Plabel lbl :: k)
| Mgoto lbl =>
- Pb lbl :: k
+ OK (Pb lbl :: k)
| Mcond cond args lbl =>
let p := crbit_for_cond cond in
transl_cond cond args
(if (snd p) then Pbt (fst p) lbl :: k else Pbf (fst p) lbl :: k)
| Mjumptable arg tbl =>
- Prlwinm GPR12 (ireg_of arg) (Int.repr 2) (Int.repr (-4)) ::
- Pbtbl GPR12 tbl :: k
+ do r <- ireg_of arg;
+ OK (Pbtbl r tbl :: k)
| Mreturn =>
- Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 ::
- Pmtlr GPR0 ::
- Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::
- Pblr :: k
+ OK (Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 ::
+ Pmtlr GPR0 ::
+ Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::
+ Pblr :: k)
+ end.
+
+(** Translation of a code sequence *)
+
+Definition r11_is_parent (before: bool) (i: Mach.instruction) : bool :=
+ match i with
+ | Msetstack src ofs ty => before
+ | Mgetparam ofs ty dst => negb (mreg_eq dst IT1)
+ | Mop Omove args res => before && negb (mreg_eq res IT1)
+ | _ => false
end.
-Definition transl_code (f: Mach.function) (il: list Mach.instruction) :=
- List.fold_right (transl_instr f) nil il.
+Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (r11p: bool) :=
+ match il with
+ | nil => OK nil
+ | i1 :: il' =>
+ do k <- transl_code f il' (r11_is_parent r11p i1);
+ transl_instr f i1 r11p k
+ end.
(** Translation of a whole function. Note that we must check
that the generated code contains less than [2^32] instructions,
@@ -556,18 +643,16 @@ Definition transl_code (f: Mach.function) (il: list Mach.instruction) :=
around, leading to incorrect executions. *)
Definition transl_function (f: Mach.function) :=
- Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::
- Pmflr GPR0 ::
- Pstw GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 ::
- transl_code f f.(fn_code).
-
-Open Local Scope string_scope.
+ do c <- transl_code f f.(Mach.fn_code) false;
+ OK (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::
+ Pmflr GPR0 ::
+ Pstw GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 :: c).
Definition transf_function (f: Mach.function) : res Asm.code :=
- let c := transl_function f in
+ do c <- transl_function f;
if zlt Int.max_unsigned (list_length_z c)
- then Errors.Error (msg "code size exceeded")
- else Errors.OK c.
+ then Error (msg "code size exceeded")
+ else OK c.
Definition transf_fundef (f: Mach.fundef) : res Asm.fundef :=
transf_partial_fundef transf_function f.
diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v
index de9decb..6c95744 100644
--- a/powerpc/Asmgenproof.v
+++ b/powerpc/Asmgenproof.v
@@ -27,11 +27,9 @@ Require Import Op.
Require Import Locations.
Require Import Conventions.
Require Import Mach.
-Require Import Machsem.
-Require Import Machtyping.
Require Import Asm.
Require Import Asmgen.
-Require Import Asmgenretaddr.
+Require Import Asmgenproof0.
Require Import Asmgenproof1.
Section PRESERVATION.
@@ -67,210 +65,53 @@ Proof
(Genv.find_funct_ptr_transf_partial transf_fundef _ TRANSF).
Lemma functions_transl:
- forall f b,
+ forall f b tf,
Genv.find_funct_ptr ge b = Some (Internal f) ->
- Genv.find_funct_ptr tge b = Some (Internal (transl_function f)).
+ transf_function f = OK tf ->
+ Genv.find_funct_ptr tge b = Some (Internal tf).
Proof.
intros.
- 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 (list_length_z (transl_function f))); simpl; intro.
- congruence. intro. inv B0. auto.
-Qed.
-
-Lemma functions_transl_no_overflow:
- forall b f,
- Genv.find_funct_ptr ge b = Some (Internal f) ->
- list_length_z (transl_function f) <= Int.max_unsigned.
-Proof.
- intros.
- destruct (functions_translated _ _ H) as [tf [A B]].
- generalize B. unfold transf_fundef, transf_partial_fundef, transf_function.
- case (zlt Int.max_unsigned (list_length_z (transl_function f))); simpl; intro.
- congruence. intro; omega.
+ destruct (functions_translated _ _ H) as [tf' [A B]].
+ rewrite A. monadInv B. f_equal. congruence.
Qed.
(** * Properties of control flow *)
-Lemma find_instr_in:
- forall c pos i,
- find_instr pos c = Some i -> In i c.
-Proof.
- induction c; simpl. intros; discriminate.
- intros until i. case (zeq pos 0); intros.
- left; congruence. right; eauto.
-Qed.
-
-Lemma find_instr_tail:
- forall c1 i c2 pos,
- code_tail pos c1 (i :: c2) ->
- find_instr pos c1 = Some i.
-Proof.
- induction c1; simpl; intros.
- inv H.
- destruct (zeq pos 0). subst pos.
- inv H. auto. generalize (code_tail_pos _ _ _ H4). intro. omegaContradiction.
- inv H. congruence. replace (pos0 + 1 - 1) with pos0 by omega.
- eauto.
-Qed.
-
-Remark code_tail_bounds:
- forall fn ofs i c,
- code_tail ofs fn (i :: c) -> 0 <= ofs < list_length_z fn.
+Lemma transf_function_no_overflow:
+ forall f tf,
+ transf_function f = OK tf -> list_length_z tf <= Int.max_unsigned.
Proof.
- assert (forall ofs fn c, code_tail ofs fn c ->
- forall i c', c = i :: c' -> 0 <= ofs < list_length_z fn).
- induction 1; intros; simpl.
- rewrite H. rewrite list_length_z_cons. generalize (list_length_z_pos c'). omega.
- rewrite list_length_z_cons. generalize (IHcode_tail _ _ H0). omega.
- eauto.
-Qed.
-
-Lemma code_tail_next:
- forall fn ofs i c,
- code_tail ofs fn (i :: c) ->
- code_tail (ofs + 1) fn c.
-Proof.
- assert (forall ofs fn c, code_tail ofs fn c ->
- forall i c', c = i :: c' -> code_tail (ofs + 1) fn c').
- induction 1; intros.
- subst c. constructor. constructor.
- constructor. eauto.
- eauto.
-Qed.
-
-Lemma code_tail_next_int:
- forall fn ofs i c,
- list_length_z fn <= Int.max_unsigned ->
- code_tail (Int.unsigned ofs) fn (i :: c) ->
- code_tail (Int.unsigned (Int.add ofs Int.one)) fn c.
-Proof.
- intros. rewrite Int.add_unsigned.
- change (Int.unsigned Int.one) with 1.
- rewrite Int.unsigned_repr. apply code_tail_next with i; auto.
- generalize (code_tail_bounds _ _ _ _ H0). omega.
-Qed.
-
-(** [transl_code_at_pc pc fn c] holds if the code pointer [pc] points
- within the PPC code generated by translating Mach function [fn],
- and [c] is the tail of the generated code at the position corresponding
- to the code pointer [pc]. *)
-
-Inductive transl_code_at_pc: val -> block -> Mach.function -> Mach.code -> Prop :=
- transl_code_at_pc_intro:
- forall b ofs f c,
- Genv.find_funct_ptr ge b = Some (Internal f) ->
- code_tail (Int.unsigned ofs) (transl_function f) (transl_code f c) ->
- transl_code_at_pc (Vptr b ofs) b f c.
-
-(** The following lemmas show that straight-line executions
- (predicate [exec_straight]) correspond to correct PPC executions
- (predicate [exec_steps]) under adequate [transl_code_at_pc] hypotheses. *)
-
-Lemma exec_straight_steps_1:
- forall fn c rs m c' rs' m',
- exec_straight tge fn c rs m c' rs' m' ->
- list_length_z fn <= Int.max_unsigned ->
- forall b ofs,
- rs#PC = Vptr b ofs ->
- Genv.find_funct_ptr tge b = Some (Internal fn) ->
- code_tail (Int.unsigned ofs) fn c ->
- plus step tge (State rs m) E0 (State rs' m').
-Proof.
- induction 1; intros.
- apply plus_one.
- econstructor; eauto.
- eapply find_instr_tail. eauto.
- eapply plus_left'.
- econstructor; eauto.
- eapply find_instr_tail. eauto.
- 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:
- forall fn c rs m c' rs' m',
- exec_straight tge fn c rs m c' rs' m' ->
- list_length_z fn <= Int.max_unsigned ->
- forall b ofs,
- rs#PC = Vptr b ofs ->
- Genv.find_funct_ptr tge b = Some (Internal fn) ->
- code_tail (Int.unsigned ofs) fn c ->
- exists ofs',
- rs'#PC = Vptr b ofs'
- /\ code_tail (Int.unsigned ofs') fn c'.
-Proof.
- induction 1; intros.
- exists (Int.add ofs Int.one). split.
- rewrite H0. rewrite H2. auto.
- apply code_tail_next_int with i1; auto.
- apply IHexec_straight with (Int.add ofs Int.one).
- auto. rewrite H0. rewrite H3. reflexivity. auto.
- apply code_tail_next_int with i; auto.
+ intros. monadInv H. destruct (zlt Int.max_unsigned (list_length_z x)); inv EQ0.
+ omega.
Qed.
Lemma exec_straight_exec:
- forall fb f c c' rs m rs' m',
- transl_code_at_pc (rs PC) fb f c ->
- exec_straight tge (transl_function f)
- (transl_code f c) rs m c' rs' m' ->
+ forall f c ep tf tc c' rs m rs' m',
+ transl_code_at_pc ge (rs PC) f c ep tf tc ->
+ exec_straight tge tf tc rs m c' rs' m' ->
plus step tge (State rs m) E0 (State rs' m').
Proof.
- intros. inversion H. subst.
+ intros. inv H.
eapply exec_straight_steps_1; eauto.
- eapply functions_transl_no_overflow; eauto.
- eapply functions_transl; eauto.
+ eapply transf_function_no_overflow; eauto.
+ eapply functions_transl; eauto.
Qed.
Lemma exec_straight_at:
- forall fb f c c' rs m rs' m',
- transl_code_at_pc (rs PC) fb f c ->
- exec_straight tge (transl_function f)
- (transl_code f c) rs m (transl_code f c') rs' m' ->
- transl_code_at_pc (rs' PC) fb f c'.
+ forall f c ep tf tc c' ep' tc' rs m rs' m',
+ transl_code_at_pc ge (rs PC) f c ep tf tc ->
+ transl_code f c' ep' = OK tc' ->
+ exec_straight tge tf tc rs m tc' rs' m' ->
+ transl_code_at_pc ge (rs' PC) f c' ep' tf tc'.
Proof.
- intros. inversion H. subst.
- generalize (functions_transl_no_overflow _ _ H2). intro.
- generalize (functions_transl _ _ H2). intro.
- generalize (exec_straight_steps_2 _ _ _ _ _ _ _
- H0 H4 _ _ (sym_equal H1) H5 H3).
+ intros. inv H.
+ exploit exec_straight_steps_2; eauto.
+ eapply transf_function_no_overflow; eauto.
+ eapply functions_transl; eauto.
intros [ofs' [PC' CT']].
rewrite PC'. constructor; auto.
Qed.
-(** Correctness of the return addresses predicted by
- [PPCgen.return_address_offset]. *)
-
-Remark code_tail_no_bigger:
- forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat.
-Proof.
- induction 1; simpl; omega.
-Qed.
-
-Remark code_tail_unique:
- forall fn c pos pos',
- code_tail pos fn c -> code_tail pos' fn c -> pos = pos'.
-Proof.
- induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto.
- generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega.
- generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega.
- f_equal. eauto.
-Qed.
-
-Lemma return_address_offset_correct:
- forall b ofs fb f c ofs',
- transl_code_at_pc (Vptr b ofs) fb f c ->
- return_address_offset f c ofs' ->
- ofs' = ofs.
-Proof.
- intros. inv H0. inv H.
- generalize (code_tail_unique _ _ _ _ H1 H7). intro. rewrite H.
- apply Int.repr_unsigned.
-Qed.
-
(** The [find_label] function returns the code tail starting at the
given label. A connection with [code_tail] is then established. *)
@@ -391,119 +232,137 @@ Qed.
Hint Rewrite rolm_label: labels.
Remark loadind_label:
- forall base ofs ty dst k, find_label lbl (loadind base ofs ty dst k) = find_label lbl k.
+ forall base ofs ty dst k c,
+ loadind base ofs ty dst k = OK c ->
+ find_label lbl c = find_label lbl k.
Proof.
- intros; unfold loadind.
- destruct (Int.eq (high_s ofs) Int.zero); destruct ty; autorewrite with labels; auto.
+ unfold loadind; intros.
+ destruct ty; destruct (Int.eq (high_s ofs) Int.zero); monadInv H;
+ autorewrite with labels; auto.
Qed.
-Hint Rewrite loadind_label: labels.
Remark storeind_label:
- forall base ofs ty src k, find_label lbl (storeind base src ofs ty k) = find_label lbl k.
+ forall base ofs ty src k c,
+ storeind base src ofs ty k = OK c ->
+ find_label lbl c = find_label lbl k.
Proof.
- intros; unfold storeind.
- destruct (Int.eq (high_s ofs) Int.zero); destruct ty; autorewrite with labels; auto.
+ unfold storeind; intros.
+ destruct ty; destruct (Int.eq (high_s ofs) Int.zero); monadInv H;
+ autorewrite with labels; auto.
Qed.
-Hint Rewrite storeind_label: labels.
Remark floatcomp_label:
forall cmp r1 r2 k, find_label lbl (floatcomp cmp r1 r2 k) = find_label lbl k.
Proof.
intros; unfold floatcomp. destruct cmp; reflexivity.
Qed.
+Hint Rewrite floatcomp_label: labels.
Remark transl_cond_label:
- forall cond args k, find_label lbl (transl_cond cond args k) = find_label lbl k.
+ forall cond args k c,
+ transl_cond cond args k = OK c -> find_label lbl c = find_label lbl k.
Proof.
- intros; unfold transl_cond.
- destruct cond; (destruct args;
- [try reflexivity | destruct args;
- [try reflexivity | destruct args; try reflexivity]]).
- case (Int.eq (high_s i) Int.zero). reflexivity.
- autorewrite with labels; reflexivity.
- case (Int.eq (high_u i) Int.zero). reflexivity.
- autorewrite with labels; reflexivity.
- apply floatcomp_label. apply floatcomp_label.
- apply andimm_base_label. apply andimm_base_label.
+ unfold transl_cond; intros; destruct cond;
+ (destruct args;
+ [try discriminate | destruct args;
+ [try discriminate | destruct args; try discriminate]]);
+ monadInv H; autorewrite with labels; auto.
+ destruct (Int.eq (high_s i) Int.zero); inv EQ0; autorewrite with labels; auto.
+ destruct (Int.eq (high_u i) Int.zero); inv EQ0; autorewrite with labels; auto.
Qed.
-Hint Rewrite transl_cond_label: labels.
Remark transl_cond_op_label:
- forall c args r k,
- find_label lbl (transl_cond_op c args r k) = find_label lbl k.
+ forall cond args r k c,
+ transl_cond_op cond args r k = OK c -> find_label lbl c = find_label lbl k.
Proof.
- intros c args.
- unfold transl_cond_op. destruct (classify_condition c args); intros; auto.
- autorewrite with labels. destruct (snd (crbit_for_cond c)); auto.
+ unfold transl_cond_op; intros; destruct (classify_condition cond args);
+ monadInv H; auto.
+ erewrite transl_cond_label. 2: eauto.
+ destruct (snd (crbit_for_cond c0)); auto.
Qed.
-Hint Rewrite transl_cond_op_label: labels.
Remark transl_op_label:
- forall op args r k, find_label lbl (transl_op op args r k) = find_label lbl k.
+ forall op args r k c,
+ transl_op op args r k = OK c -> find_label lbl c = find_label lbl k.
Proof.
- intros; unfold transl_op;
- destruct op; destruct args; try (destruct args); try (destruct args); try (destruct args);
- try reflexivity; autorewrite with labels; try reflexivity.
- case (mreg_type m); reflexivity.
- case (symbol_is_small_data i i0); reflexivity.
- case (Int.eq (high_s i) Int.zero); autorewrite with labels; reflexivity.
- case (Int.eq (high_s i) Int.zero); autorewrite with labels; reflexivity.
- destruct (mreg_eq m r); reflexivity.
+ unfold transl_op; intros; destruct op; try (eapply transl_cond_op_label; eauto; fail);
+ (destruct args;
+ [try discriminate | destruct args;
+ [try discriminate | destruct args; try discriminate]]);
+ try (monadInv H); autorewrite with labels; auto.
+ destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; auto.
+ destruct (symbol_is_small_data i i0); auto.
+ destruct (Int.eq (high_s i) Int.zero); autorewrite with labels; auto.
+ destruct (Int.eq (high_s i) Int.zero); autorewrite with labels; auto.
Qed.
-Hint Rewrite transl_op_label: labels.
-Remark transl_load_store_label:
+Remark transl_memory_access_label:
forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction)
- addr args temp k,
+ addr args temp k c,
+ transl_memory_access mk1 mk2 addr args temp k = OK c ->
(forall c r, is_label lbl (mk1 c r) = false) ->
(forall r1 r2, is_label lbl (mk2 r1 r2) = false) ->
- find_label lbl (transl_load_store mk1 mk2 addr args temp k) = find_label lbl k.
-Proof.
- intros; unfold transl_load_store.
- destruct addr; destruct args; try (destruct args); try (destruct args);
- try reflexivity.
- destruct (Int.eq (high_s i) Int.zero); simpl; rewrite H; auto.
+ find_label lbl c = find_label lbl k.
+Proof.
+ unfold transl_memory_access; intros; destruct addr;
+ (destruct args;
+ [try discriminate | destruct args;
+ [try discriminate | destruct args; try discriminate]]);
+ monadInv H; autorewrite with labels; auto.
+ destruct (Int.eq (high_s i) Int.zero); simpl; rewrite H0; auto.
+ simpl; rewrite H1; auto.
+ destruct (symbol_is_small_data i i0); simpl; rewrite H0; auto.
simpl; rewrite H0; auto.
- destruct (symbol_is_small_data i i0); simpl; rewrite H; auto.
- simpl; rewrite H; auto.
- destruct (Int.eq (high_s i) Int.zero); simpl; rewrite H; auto.
+ destruct (Int.eq (high_s i) Int.zero); simpl; rewrite H0; auto.
Qed.
-Hint Rewrite transl_load_store_label: labels.
Lemma transl_instr_label:
- forall f i k,
- find_label lbl (transl_instr f i k) =
- if Mach.is_label lbl i then Some k else find_label lbl k.
-Proof.
- intros. generalize (Mach.is_label_correct lbl i).
- case (Mach.is_label lbl i); intro.
- subst i. simpl. rewrite peq_true. auto.
- destruct i; simpl; autorewrite with labels; try reflexivity.
- destruct m; rewrite transl_load_store_label; intros; reflexivity.
- destruct m; rewrite transl_load_store_label; intros; reflexivity.
- destruct s0; reflexivity.
- destruct s0; reflexivity.
- rewrite peq_false. auto. congruence.
- case (snd (crbit_for_cond c)); reflexivity.
+ forall f i ep k c,
+ transl_instr f i ep k = OK c ->
+ find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k.
+Proof.
+ unfold transl_instr, Mach.is_label; intros; destruct i; try (monadInv H);
+ autorewrite with labels; auto.
+ eapply loadind_label; eauto.
+ eapply storeind_label; eauto.
+ destruct ep. eapply loadind_label; eauto.
+ monadInv H. transitivity (find_label lbl x); eapply loadind_label; eauto.
+ eapply transl_op_label; eauto.
+ destruct m; monadInv H; rewrite (transl_memory_access_label _ _ _ _ _ _ _ EQ0); auto.
+ destruct m; monadInv H; rewrite (transl_memory_access_label _ _ _ _ _ _ _ EQ0); auto.
+ destruct s0; monadInv H; auto.
+ destruct s0; monadInv H; auto.
+ erewrite transl_cond_label. 2: eauto. destruct (snd (crbit_for_cond c0)); auto.
Qed.
Lemma transl_code_label:
- forall f c,
- find_label lbl (transl_code f c) =
- option_map (transl_code f) (Mach.find_label lbl c).
+ forall f c ep tc,
+ transl_code f c ep = OK tc ->
+ match Mach.find_label lbl c with
+ | None => find_label lbl tc = None
+ | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc'
+ end.
Proof.
induction c; simpl; intros.
- auto. rewrite transl_instr_label.
- case (Mach.is_label lbl a). reflexivity.
- auto.
+ inv H. auto.
+ monadInv H. rewrite (transl_instr_label _ _ _ _ _ EQ0).
+ generalize (Mach.is_label_correct lbl a).
+ destruct (Mach.is_label lbl a); intros.
+ subst a. simpl in EQ. exists x; auto.
+ eapply IHc; eauto.
Qed.
Lemma transl_find_label:
- forall f,
- find_label lbl (transl_function f) =
- option_map (transl_code f) (Mach.find_label lbl f.(fn_code)).
+ forall f tf,
+ transf_function f = OK tf ->
+ match Mach.find_label lbl f.(Mach.fn_code) with
+ | None => find_label lbl tf = None
+ | Some c => exists tc, find_label lbl tf = Some tc /\ transl_code f c false = OK tc
+ end.
Proof.
- intros. unfold transl_function. simpl. apply transl_code_label.
+ intros. monadInv H. destruct (zlt Int.max_unsigned (list_length_z x)); inv EQ0.
+ monadInv EQ. simpl.
+ eapply transl_code_label; eauto.
Qed.
End TRANSL_LABEL.
@@ -512,28 +371,26 @@ End TRANSL_LABEL.
transition in the generated PPC code. *)
Lemma find_label_goto_label:
- forall f lbl rs m c' b ofs,
+ forall f tf lbl rs m c' b ofs,
Genv.find_funct_ptr ge b = Some (Internal f) ->
+ transf_function f = OK tf ->
rs PC = Vptr b ofs ->
- Mach.find_label lbl f.(fn_code) = Some c' ->
- exists rs',
- goto_label (transl_function f) lbl rs m = OK rs' m
- /\ transl_code_at_pc (rs' PC) b f c'
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
+ exists tc', exists rs',
+ goto_label tf lbl rs m = Next rs' m
+ /\ transl_code_at_pc ge (rs' PC) f c' false tf tc'
/\ forall r, r <> PC -> rs'#r = rs#r.
Proof.
- intros.
- generalize (transl_find_label lbl f).
- rewrite H1; simpl. intro.
- generalize (label_pos_code_tail lbl (transl_function f) 0
- (transl_code f c') H2).
- intros [pos' [A [B C]]].
- exists (rs#PC <- (Vptr b (Int.repr pos'))).
- split. unfold goto_label. rewrite A. rewrite H0. auto.
+ intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2.
+ intros [tc [A B]].
+ exploit label_pos_code_tail; eauto. instantiate (1 := 0).
+ intros [pos' [P [Q R]]].
+ exists tc; exists (rs#PC <- (Vptr b (Int.repr pos'))).
+ split. unfold goto_label. rewrite P. rewrite H1. auto.
split. rewrite Pregmap.gss. constructor; auto.
- rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in B.
- auto. omega.
- generalize (functions_transl_no_overflow _ _ H).
- omega.
+ rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in Q.
+ auto. omega.
+ generalize (transf_function_no_overflow _ _ H0). omega.
intros. apply Pregmap.gso; auto.
Qed.
@@ -555,108 +412,92 @@ Qed.
- Mach register values and PPC register values agree.
*)
-Inductive match_stack: list Machsem.stackframe -> Prop :=
- | match_stack_nil:
- match_stack nil
- | match_stack_cons: forall fb sp ra c s f,
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- wt_function f ->
- incl c f.(fn_code) ->
- transl_code_at_pc ra fb f c ->
- sp <> Vundef ->
- ra <> Vundef ->
- match_stack s ->
- match_stack (Stackframe fb sp ra c :: s).
-
-Inductive match_states: Machsem.state -> Asm.state -> Prop :=
+Inductive match_states: Mach.state -> Asm.state -> Prop :=
| match_states_intro:
- forall s fb sp c ms m rs m' f
- (STACKS: match_stack s)
- (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
- (WTF: wt_function f)
- (INCL: incl c f.(fn_code))
- (AT: transl_code_at_pc (rs PC) fb f c)
- (AG: agree ms sp rs)
- (MEXT: Mem.extends m m'),
- match_states (Machsem.State s fb sp c ms m)
+ forall s f sp c ep ms m m' rs tf tc ra
+ (STACKS: match_stack ge s m m' ra sp)
+ (MEXT: Mem.extends m m')
+ (AT: transl_code_at_pc ge (rs PC) f c ep tf tc)
+ (AG: agree ms (Vptr sp Int.zero) rs)
+ (RSA: retaddr_stored_at m m' sp (Int.unsigned f.(fn_retaddr_ofs)) ra)
+ (DXP: ep = true -> rs#GPR11 = parent_sp s),
+ match_states (Mach.State s f (Vptr sp Int.zero) c ms m)
(Asm.State rs m')
| match_states_call:
- forall s fb ms m rs m'
- (STACKS: match_stack s)
- (AG: agree ms (parent_sp s) rs)
+ forall s fd ms m m' rs fb
+ (STACKS: match_stack ge s m m' (rs LR) (Mem.nextblock m))
(MEXT: Mem.extends m m')
+ (AG: agree ms (parent_sp s) rs)
(ATPC: rs PC = Vptr fb Int.zero)
- (ATLR: rs LR = parent_ra s),
- match_states (Machsem.Callstate s fb ms m)
+ (FUNCT: Genv.find_funct_ptr ge fb = Some fd)
+ (WTRA: Val.has_type (rs LR) Tint),
+ match_states (Mach.Callstate s fd ms m)
(Asm.State rs m')
| match_states_return:
- forall s ms m rs m'
- (STACKS: match_stack s)
- (AG: agree ms (parent_sp s) rs)
+ forall s ms m m' rs
+ (STACKS: match_stack ge s m m' (rs PC) (Mem.nextblock m))
(MEXT: Mem.extends m m')
- (ATPC: rs PC = parent_ra s),
- match_states (Machsem.Returnstate s ms m)
+ (AG: agree ms (parent_sp s) rs),
+ match_states (Mach.Returnstate s ms m)
(Asm.State rs m').
Lemma exec_straight_steps:
- forall s fb sp m1' f c1 rs1 c2 m2 m2' ms2,
- match_stack s ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- wt_function f ->
- incl c2 f.(fn_code) ->
- transl_code_at_pc (rs1 PC) fb f c1 ->
- (exists rs2,
- exec_straight tge (transl_function f) (transl_code f c1) rs1 m1' (transl_code f c2) rs2 m2'
- /\ agree ms2 sp rs2) ->
+ forall s f rs1 i c ep tf tc m1' m2 m2' sp ms2 ra,
+ match_stack ge s m2 m2' ra sp ->
Mem.extends m2 m2' ->
+ retaddr_stored_at m2 m2' sp (Int.unsigned f.(fn_retaddr_ofs)) ra ->
+ transl_code_at_pc ge (rs1 PC) f (i :: c) ep tf tc ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
+ exists rs2,
+ exec_straight tge tf c rs1 m1' k rs2 m2'
+ /\ agree ms2 (Vptr sp Int.zero) rs2
+ /\ (r11_is_parent ep i = true -> rs2#GPR11 = parent_sp s)) ->
exists st',
plus step tge (State rs1 m1') E0 st' /\
- match_states (Machsem.State s fb sp c2 ms2 m2) st'.
+ match_states (Mach.State s f (Vptr sp Int.zero) c ms2 m2) st'.
Proof.
- intros. destruct H4 as [rs2 [A B]].
+ intros. inversion H2; subst. monadInv H7.
+ exploit H3; eauto. intros [rs2 [A [B C]]].
exists (State rs2 m2'); split.
- eapply exec_straight_exec; eauto.
+ eapply exec_straight_exec; eauto.
econstructor; eauto. eapply exec_straight_at; eauto.
Qed.
-Lemma exec_straight_steps_bis:
- forall s fb sp m1' f c1 rs1 c2 m2 ms2,
- match_stack s ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- wt_function f ->
- incl c2 f.(fn_code) ->
- transl_code_at_pc (rs1 PC) fb f c1 ->
- (exists m2',
- Mem.extends m2 m2'
- /\ exists rs2,
- exec_straight tge (transl_function f) (transl_code f c1) rs1 m1' (transl_code f c2) rs2 m2'
- /\ agree ms2 sp rs2) ->
+Lemma exec_straight_steps_goto:
+ forall s f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c' ra,
+ match_stack ge s m2 m2' ra sp ->
+ Mem.extends m2 m2' ->
+ retaddr_stored_at m2 m2' sp (Int.unsigned f.(fn_retaddr_ofs)) ra ->
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
+ transl_code_at_pc ge (rs1 PC) f (i :: c) ep tf tc ->
+ r11_is_parent ep i = false ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
+ exists jmp, exists k', exists rs2,
+ exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2'
+ /\ agree ms2 (Vptr sp Int.zero) rs2
+ /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') ->
exists st',
plus step tge (State rs1 m1') E0 st' /\
- match_states (Machsem.State s fb sp c2 ms2 m2) st'.
+ match_states (Mach.State s f (Vptr sp Int.zero) c' ms2 m2) st'.
Proof.
- intros. destruct H4 as [m2' [A B]].
- eapply exec_straight_steps; eauto.
-Qed.
-
-Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef.
-Proof. induction 1; simpl. congruence. auto. Qed.
-
-Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef.
-Proof. induction 1; simpl. unfold Vzero. congruence. auto. Qed.
-
-Lemma lessdef_parent_sp:
- forall s v,
- match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s.
-Proof.
- intros. inv H0. auto. exploit parent_sp_def; eauto. tauto.
-Qed.
-
-Lemma lessdef_parent_ra:
- forall s v,
- match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s.
-Proof.
- intros. inv H0. auto. exploit parent_ra_def; eauto. tauto.
+ intros. inversion H3; subst. monadInv H9.
+ exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]].
+ generalize (functions_transl _ _ _ H7 H8); intro FN.
+ generalize (transf_function_no_overflow _ _ H8); intro NOOV.
+ exploit exec_straight_steps_2; eauto.
+ intros [ofs' [PC2 CT2]].
+ exploit find_label_goto_label; eauto.
+ intros [tc' [rs3 [GOTO [AT' OTH]]]].
+ exists (State rs3 m2'); split.
+ eapply plus_right'.
+ eapply exec_straight_steps_1; eauto.
+ econstructor; eauto.
+ eapply find_instr_tail. eauto.
+ rewrite C. eexact GOTO.
+ traceEq.
+ econstructor; eauto.
+ apply agree_exten with rs2; auto with asmgen.
+ congruence.
Qed.
(** We need to show that, in the simulation diagram, we cannot
@@ -667,448 +508,285 @@ Qed.
So, the following integer measure will suffice to rule out
the unwanted behaviour. *)
-Definition measure (s: Machsem.state) : nat :=
+Definition measure (s: Mach.state) : nat :=
match s with
- | Machsem.State _ _ _ _ _ _ => 0%nat
- | Machsem.Callstate _ _ _ _ => 0%nat
- | Machsem.Returnstate _ _ _ => 1%nat
+ | Mach.State _ _ _ _ _ _ => 0%nat
+ | Mach.Callstate _ _ _ _ => 0%nat
+ | Mach.Returnstate _ _ _ => 1%nat
end.
-(** We show the simulation diagram by case analysis on the Mach transition
- on the left. Since the proof is large, we break it into one lemma
- per transition. *)
-
-Definition exec_instr_prop (s1: Machsem.state) (t: trace) (s2: Machsem.state) : Prop :=
- forall s1' (MS: match_states s1 s1'),
- (exists s2', plus step tge s1' t s2' /\ match_states s2 s2')
- \/ (measure s2 < measure s1 /\ t = E0 /\ match_states s2 s1')%nat.
-
-
-Lemma exec_Mlabel_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset)
- (m : mem),
- exec_instr_prop (Machsem.State s fb sp (Mlabel lbl :: c) ms m) E0
- (Machsem.State s fb sp c ms m).
+Remark preg_of_not_GPR11: forall r, negb (mreg_eq r IT1) = true -> IR GPR11 <> preg_of r.
Proof.
- intros; red; intros; inv MS.
- left; eapply exec_straight_steps; eauto with coqlib.
- exists (nextinstr rs); split.
- simpl. apply exec_straight_one. reflexivity. reflexivity.
- apply agree_nextinstr; auto.
+ intros. change (IR GPR11) with (preg_of IT1). red; intros.
+ exploit preg_of_injective; eauto. intros; subst r; discriminate.
Qed.
-Lemma exec_Mgetstack_prop:
- forall (s : list stackframe) (fb : block) (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 (Machsem.State s fb sp (Mgetstack ofs ty dst :: c) ms m) E0
- (Machsem.State s fb sp c (Regmap.set dst v ms) m).
-Proof.
- intros; red; intros; inv MS.
- unfold load_stack in H.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inversion WTI.
- exploit Mem.loadv_extends; eauto. intros [v' [A B]].
- rewrite (sp_val _ _ _ AG) in A.
- exploit (loadind_correct tge (transl_function f) GPR1 ofs ty dst (transl_code f c) rs m' v').
- auto. auto. congruence.
- intros [rs2 [EX [RES OTH]]].
- left; eapply exec_straight_steps; eauto with coqlib.
- simpl. exists rs2; split. auto.
- apply agree_set_mreg with rs; auto with ppcgen. congruence.
-Qed.
+(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *)
-Lemma exec_Msetstack_prop:
- forall (s : list stackframe) (fb : block) (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 (Machsem.State s fb sp (Msetstack src ofs ty :: c) ms m) E0
- (Machsem.State s fb sp c ms m').
+Theorem step_simulation:
+ forall S1 t S2, Mach.step ge S1 t S2 ->
+ forall S1' (MS: match_states S1 S1'),
+ (exists S2', plus step tge S1' t S2' /\ match_states S2 S2')
+ \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
Proof.
- intros; red; intros; inv MS.
- unfold store_stack in H.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
- generalize (preg_val ms sp rs src AG). intro.
- exploit Mem.storev_extends; eauto.
- intros [m2' [A B]].
+ induction 1; intros; inv MS.
+
+- (* Mlabel *)
+ left; eapply exec_straight_steps; eauto; intros.
+ monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ split. apply agree_nextinstr; auto. simpl; congruence.
+
+- (* Mgetstack *)
+ unfold load_stack in H.
+ exploit Mem.loadv_extends; eauto. intros [v' [A B]].
rewrite (sp_val _ _ _ AG) in A.
- exploit (storeind_correct tge (transl_function f) GPR1 ofs (mreg_type src)
- src (transl_code f c) rs).
- eauto. auto. congruence.
- intros [rs2 [EX OTH]].
- left; eapply exec_straight_steps; eauto with coqlib.
- exists rs2; split; auto.
- apply agree_exten with rs; auto with ppcgen.
-Qed.
+ left; eapply exec_straight_steps; eauto. intros. simpl in TR.
+ exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]].
+ exists rs'; split. eauto.
+ split. eapply agree_set_mreg; eauto with asmgen. congruence.
+ simpl; congruence.
-Lemma exec_Mgetparam_prop:
- forall (s : list stackframe) (fb : block) (f: Mach.function) (sp : val)
- (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction)
- (ms : Mach.regset) (m : mem) (v : val),
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- load_stack m sp Tint f.(fn_link_ofs) = Some (parent_sp s) ->
- load_stack m (parent_sp s) ty ofs = Some v ->
- exec_instr_prop (Machsem.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0
- (Machsem.State s fb sp c (Regmap.set dst v (Regmap.set IT1 Vundef ms)) m).
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
- unfold load_stack in *. simpl in H0.
+- (* Msetstack *)
+ unfold store_stack in H.
+ assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto.
+ exploit Mem.storev_extends; eauto. intros [m2' [A B]].
+ left; eapply exec_straight_steps; eauto.
+ eapply match_stack_storev; eauto.
+ eapply retaddr_stored_at_storev; eauto.
+ rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR.
+ exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]].
+ exists rs'; split. eauto.
+ split. change (undef_setstack rs) with rs. apply agree_exten with rs0; auto with asmgen.
+ simpl; intros. rewrite Q; auto with asmgen.
+
+- (* Mgetparam *)
+ unfold load_stack in *.
+ exploit Mem.loadv_extends. eauto. eexact H. auto.
+ intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'.
exploit Mem.loadv_extends. eauto. eexact H0. auto.
- intros [parent' [A B]].
- exploit Mem.loadv_extends. eauto. eexact H1.
- instantiate (1 := (Val.add parent' (Vint ofs))).
- inv B. auto. simpl; auto.
intros [v' [C D]].
- left; eapply exec_straight_steps; eauto with coqlib. simpl.
- set (rs1 := nextinstr (rs#GPR11 <- parent')).
- exploit (loadind_correct tge (transl_function f) GPR11 ofs (mreg_type dst) dst (transl_code f c) rs1 m' v').
- unfold rs1. rewrite nextinstr_inv; auto with ppcgen. auto. congruence.
- intros [rs2 [U [V W]]].
- exists rs2; split.
- apply exec_straight_step with rs1 m'.
- simpl. unfold load1. simpl. rewrite gpr_or_zero_not_zero.
- rewrite <- (sp_val _ _ _ AG). rewrite A. auto. congruence. auto.
- auto.
- apply agree_set_mreg with rs1; auto with ppcgen.
- unfold rs1. change (IR GPR11) with (preg_of IT1).
- apply agree_nextinstr. apply agree_set_mreg with rs; auto with ppcgen.
- intros. apply Pregmap.gso; auto with ppcgen.
- congruence.
-Qed.
-
-Lemma exec_Mop_prop:
- forall (s : list stackframe) (fb : block) (sp : val) (op : operation)
- (args : list mreg) (res : mreg) (c : list Mach.instruction)
- (ms : mreg -> val) (m : mem) (v : val),
- eval_operation ge sp op ms ## args m = Some v ->
- exec_instr_prop (Machsem.State s fb sp (Mop op args res :: c) ms m) E0
- (Machsem.State s fb sp c (Regmap.set res v (undef_op op ms)) m).
-Proof.
- intros; red; intros; inv MS.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI.
- left; eapply exec_straight_steps; eauto with coqlib.
- simpl. eapply transl_op_correct; eauto.
- rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
-Qed.
-
-Remark loadv_8_signed_unsigned:
- forall m a v,
- Mem.loadv Mint8signed m a = Some v ->
- exists v', Mem.loadv Mint8unsigned m a = Some v' /\ v = Val.sign_ext 8 v'.
-Proof.
- unfold Mem.loadv; intros. destruct a; try congruence.
- generalize (Mem.load_int8_signed_unsigned m b (Int.unsigned i)).
- rewrite H. destruct (Mem.load Mint8unsigned m b (Int.unsigned i)).
- simpl; intros. exists v0; split; congruence.
+Opaque loadind.
+ left; eapply exec_straight_steps; eauto; intros.
+ destruct ep; simpl in TR.
+(* GPR11 contains parent *)
+ exploit loadind_correct. eexact TR.
+ instantiate (2 := rs0). rewrite DXP; eauto. congruence.
+ intros [rs1 [P [Q R]]].
+ exists rs1; split. eauto.
+ split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen.
+ simpl; intros. rewrite R; auto with asmgen.
+ apply preg_of_not_GPR11; auto.
+(* GPR11 does not contain parent *)
+ monadInv TR.
+ exploit loadind_correct. eexact EQ0. eauto. congruence. intros [rs1 [P [Q R]]]. simpl in Q.
+ exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. congruence.
+ intros [rs2 [S [T U]]].
+ exists rs2; split. eapply exec_straight_trans; eauto.
+ split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto.
+ instantiate (1 := rs1#GPR11 <- (rs2#GPR11)). intros.
+ rewrite Pregmap.gso; auto with asmgen.
+ congruence. intros. unfold Pregmap.set. destruct (PregEq.eq r' GPR11). congruence. auto with asmgen.
+ simpl; intros. rewrite U; auto with asmgen.
+ apply preg_of_not_GPR11; auto.
+
+- (* Mop *)
+ assert (eval_operation tge (Vptr sp0 Int.zero) op rs##args m = Some v).
+ rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
+ exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0.
+ intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ left; eapply exec_straight_steps; eauto; intros. simpl in TR.
+ exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]].
+ exists rs2; split. eauto. split. auto.
+ simpl. destruct op; try congruence. destruct ep; simpl; try congruence. intros.
+ rewrite R; auto. apply preg_of_not_GPR11; auto.
+
+- (* Mload *)
+ assert (eval_addressing tge (Vptr sp0 Int.zero) addr rs##args = Some a).
+ rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit Mem.loadv_extends; eauto. intros [v' [C D]].
+ left; eapply exec_straight_steps; eauto; intros. simpl in TR.
+ exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]].
+ exists rs2; split. eauto.
+ split. eapply agree_set_undef_mreg; eauto. congruence.
+ intros; auto with asmgen.
simpl; congruence.
-Qed.
-Lemma exec_Mload_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (chunk : memory_chunk) (addr : addressing) (args : list mreg)
- (dst : mreg) (c : list Mach.instruction) (ms : mreg -> val)
- (m : mem) (a v : val),
- eval_addressing ge sp addr ms ## args = Some a ->
- Mem.loadv chunk m a = Some v ->
- exec_instr_prop (Machsem.State s fb sp (Mload chunk addr args dst :: c) ms m)
- E0 (Machsem.State s fb sp c (Regmap.set dst v (undef_temps ms)) m).
-Proof.
- intros; red; intros; inv MS.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI; inversion WTI.
- assert (eval_addressing tge sp addr ms##args = Some a).
+- (* Mstore *)
+ assert (eval_addressing tge (Vptr sp0 Int.zero) addr rs##args = Some a).
rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
- left; eapply exec_straight_steps; eauto with coqlib;
- destruct chunk; simpl; simpl in H6;
- (* all cases but Mint8signed and Mfloat64 *)
- try (eapply transl_load_correct; eauto;
- intros; simpl; unfold preg_of; rewrite H6; auto; fail).
- (* Mint8signed *)
- exploit loadv_8_signed_unsigned; eauto. intros [v' [LOAD EQ]].
- assert (X1: forall (cst : constant) (r1 : ireg) (rs1 : regset),
- exec_instr tge (transl_function f) (Plbz (ireg_of dst) cst r1) rs1 m' =
- load1 tge Mint8unsigned (preg_of dst) cst r1 rs1 m').
- intros. unfold preg_of; rewrite H6. reflexivity.
- assert (X2: forall (r1 r2 : ireg) (rs1 : regset),
- exec_instr tge (transl_function f) (Plbzx (ireg_of dst) r1 r2) rs1 m' =
- load2 Mint8unsigned (preg_of dst) r1 r2 rs1 m').
- intros. unfold preg_of; rewrite H6. reflexivity.
- exploit transl_load_correct; eauto.
- intros [rs2 [EX1 AG1]].
- econstructor; split.
- eapply exec_straight_trans. eexact EX1.
- apply exec_straight_one. simpl. eauto. auto.
- apply agree_nextinstr.
- eapply agree_set_twice_mireg; eauto.
- rewrite EQ. apply Val.sign_ext_lessdef.
- generalize (ireg_val _ _ _ dst AG1 H6). rewrite Regmap.gss. auto.
- (* Mfloat64 *)
- exploit Mem.loadv_float64al32; eauto. intros. clear H0.
- eapply transl_load_correct; eauto;
- intros; simpl; unfold preg_of; rewrite H6; auto.
-Qed.
-
-Lemma storev_8_signed_unsigned:
- forall m a v,
- Mem.storev Mint8signed m a v = Mem.storev Mint8unsigned m a v.
-Proof.
- intros. unfold Mem.storev. destruct a; auto.
- apply Mem.store_signed_unsigned_8.
-Qed.
-
-Lemma storev_16_signed_unsigned:
- forall m a v,
- Mem.storev Mint16signed m a v = Mem.storev Mint16unsigned m a v.
-Proof.
- intros. unfold Mem.storev. destruct a; auto.
- apply Mem.store_signed_unsigned_16.
-Qed.
-
-Lemma exec_Mstore_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (chunk : memory_chunk) (addr : addressing) (args : list mreg)
- (src : mreg) (c : list Mach.instruction) (ms : mreg -> val)
- (m m' : mem) (a : val),
- eval_addressing ge sp addr ms ## args = Some a ->
- Mem.storev chunk m a (ms src) = Some m' ->
- exec_instr_prop (Machsem.State s fb sp (Mstore chunk addr args src :: c) ms m) E0
- (Machsem.State s fb sp c (undef_temps ms) m').
-Proof.
- intros; red; intros; inv MS.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI; inv WTI.
- rewrite <- (eval_addressing_preserved _ _ symbols_preserved) in H.
- left; eapply exec_straight_steps_bis; eauto with coqlib.
- destruct chunk; simpl; simpl in H6;
- try (generalize (Mem.storev_float64al32 _ _ _ _ H0); intros);
- try (rewrite storev_8_signed_unsigned in H0);
- try (rewrite storev_16_signed_unsigned in H0);
- simpl; eapply transl_store_correct; eauto;
- (unfold preg_of; rewrite H6; intros; econstructor; eauto).
- split. simpl. rewrite H1. eauto. intros; apply Pregmap.gso; auto.
- split. simpl. rewrite H1. eauto. intros; apply Pregmap.gso; auto.
-Qed.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto.
+ exploit Mem.storev_extends; eauto. intros [m2' [C D]].
+ left; eapply exec_straight_steps; eauto.
+ eapply match_stack_storev; eauto.
+ eapply retaddr_stored_at_storev; eauto.
+ intros. simpl in TR. exploit transl_store_correct; eauto. intros [rs2 [P Q]].
+ exists rs2; split. eauto.
+ split. eapply agree_exten_temps; eauto. intros; auto with asmgen.
+ simpl; congruence.
-Lemma exec_Mcall_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (sig : signature) (ros : mreg + ident) (c : Mach.code)
- (ms : Mach.regset) (m : mem) (f : function) (f' : block)
- (ra : int),
- find_function_ptr ge ros ms = Some f' ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- return_address_offset f c ra ->
- exec_instr_prop (Machsem.State s fb sp (Mcall sig ros :: c) ms m) E0
- (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) f' ms m).
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inversion WTI.
+- (* Mcall *)
inv AT.
- assert (NOOV: list_length_z (transl_function f) <= Int.max_unsigned).
- eapply functions_transl_no_overflow; eauto.
- destruct ros; simpl in H; simpl transl_code in H7.
- (* Indirect call *)
- generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1.
+ assert (NOOV: list_length_z tf <= Int.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ destruct ros as [rf|fid]; simpl in H; monadInv H3.
++ (* Indirect call *)
+ exploit Genv.find_funct_inv; eauto. intros [bf EQ2].
+ rewrite EQ2 in H; rewrite Genv.find_funct_find_funct_ptr in H.
+ assert (rs0 x0 = Vptr bf Int.zero).
+ exploit ireg_val; eauto. rewrite EQ2; intros LD; inv LD; auto.
+ generalize (code_tail_next_int _ _ _ _ NOOV H4). intro CT1.
generalize (code_tail_next_int _ _ _ _ NOOV CT1). intro CT2.
- assert (P1: ms m0 = Vptr f' Int.zero).
- destruct (ms m0); try congruence.
- generalize H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence.
- assert (P2: rs (ireg_of m0) = Vptr f' Int.zero).
- generalize (ireg_val _ _ _ m0 AG H3).
- rewrite P1. intro. inv H2. auto.
- set (rs2 := nextinstr (rs#CTR <- (Vptr f' Int.zero))).
- set (rs3 := rs2 #LR <- (Val.add rs2#PC Vone) #PC <- (Vptr f' Int.zero)).
- assert (ATPC: rs3 PC = Vptr f' Int.zero). reflexivity.
- exploit return_address_offset_correct; eauto. constructor; eauto.
- intro RA_EQ.
- assert (ATLR: rs3 LR = Vptr fb ra).
- rewrite RA_EQ.
- change (rs3 LR) with (Val.add (Val.add (rs PC) Vone) Vone).
- rewrite <- H5. reflexivity.
- assert (AG3: agree ms sp rs3).
- unfold rs3, rs2; auto 8 with ppcgen.
- left; exists (State rs3 m'); split.
- apply plus_left with E0 (State rs2 m') E0.
- econstructor. eauto. apply functions_transl. eexact H0.
- eapply find_instr_tail. eauto.
- simpl. rewrite P2. auto.
- apply star_one. econstructor.
- change (rs2 PC) with (Val.add (rs PC) Vone). rewrite <- H5.
- simpl. auto.
- apply functions_transl. eexact H0.
- eapply find_instr_tail. eauto.
- simpl. reflexivity.
+ assert (TCA: transl_code_at_pc ge (Vptr b (Int.add (Int.add ofs Int.one) Int.one)) f c false tf x).
+ econstructor; eauto.
+ left; econstructor; split.
+ eapply plus_left. eapply exec_step_internal. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. eauto.
+ apply star_one. eapply exec_step_internal. Simpl. rewrite <- H0; simpl; eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. eauto.
traceEq.
+ econstructor; eauto.
econstructor; eauto.
- econstructor; eauto with coqlib.
- rewrite RA_EQ. econstructor; eauto.
- eapply agree_sp_def; eauto. congruence.
-
- (* Direct call *)
- generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1.
- set (rs2 := rs #LR <- (Val.add rs#PC Vone) #PC <- (symbol_offset tge i Int.zero)).
- assert (ATPC: rs2 PC = Vptr f' Int.zero).
- change (rs2 PC) with (symbol_offset tge i Int.zero).
- unfold symbol_offset. rewrite symbols_preserved. rewrite H. auto.
- exploit return_address_offset_correct; eauto. constructor; eauto.
- intro RA_EQ.
- assert (ATLR: rs2 LR = Vptr fb ra).
- rewrite RA_EQ.
- change (rs2 LR) with (Val.add (rs PC) Vone).
- rewrite <- H5. reflexivity.
- assert (AG2: agree ms sp rs2).
- unfold rs2; auto 8 with ppcgen.
- left; exists (State rs2 m'); split.
- apply plus_one. econstructor.
- eauto.
- apply functions_transl. eexact H0.
- eapply find_instr_tail. eauto.
- simpl. reflexivity.
- econstructor; eauto with coqlib.
- econstructor; eauto with coqlib.
- rewrite RA_EQ. econstructor; eauto.
- eapply agree_sp_def; eauto. congruence.
-Qed.
-
-Lemma exec_Mtailcall_prop:
- forall (s : list stackframe) (fb stk : block) (soff : int)
- (sig : signature) (ros : mreg + ident) (c : list Mach.instruction)
- (ms : Mach.regset) (m : mem) (f: Mach.function) (f' : block) m',
- find_function_ptr ge ros ms = Some f' ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
- load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
- Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
- exec_instr_prop
- (Machsem.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0
- (Callstate s f' ms m').
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inversion WTI.
- inversion AT. subst b f0 c0.
- assert (NOOV: list_length_z (transl_function f) <= Int.max_unsigned).
- eapply functions_transl_no_overflow; eauto.
- exploit Mem.free_parallel_extends; eauto.
- intros [m2' [FREE' EXT']].
- unfold load_stack in *. simpl in H1; simpl in H2.
- exploit Mem.load_extends. eexact MEXT. eexact H1.
- intros [parent' [LOAD1 LD1]].
- rewrite (lessdef_parent_sp s parent' STACKS LD1) in LOAD1.
- exploit Mem.load_extends. eexact MEXT. eexact H2.
- intros [ra' [LOAD2 LD2]].
- rewrite (lessdef_parent_ra s ra' STACKS LD2) in LOAD2.
- destruct ros; simpl in H; simpl in H9.
- (* Indirect call *)
- assert (P1: ms m0 = Vptr f' Int.zero).
- destruct (ms m0); try congruence.
- generalize H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence.
- assert (P2: rs (ireg_of m0) = Vptr f' Int.zero).
- generalize (ireg_val _ _ _ m0 AG H7).
- rewrite P1. intro. inv H11. auto.
- set (rs2 := nextinstr (rs#CTR <- (Vptr f' Int.zero))).
- set (rs3 := nextinstr (rs2#GPR0 <- (parent_ra s))).
- set (rs4 := nextinstr (rs3#LR <- (parent_ra s))).
+ Simpl. rewrite <- H0; eexact TCA.
+ change (Mem.valid_block m sp0). eapply retaddr_stored_at_valid; eauto.
+ simpl. eapply agree_exten; eauto. intros. Simpl.
+ Simpl. rewrite <- H0. exact I.
++ (* Direct call *)
+ destruct (Genv.find_symbol ge fid) as [bf|] eqn:FS; try discriminate.
+ generalize (code_tail_next_int _ _ _ _ NOOV H4). intro CT1.
+ assert (TCA: transl_code_at_pc ge (Vptr b (Int.add ofs Int.one)) f c false tf x).
+ econstructor; eauto.
+ left; econstructor; split.
+ apply plus_one. eapply exec_step_internal. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. unfold symbol_offset. rewrite symbols_preserved. rewrite FS. eauto.
+ econstructor; eauto.
+ econstructor; eauto.
+ rewrite <- H0. eexact TCA.
+ change (Mem.valid_block m sp0). eapply retaddr_stored_at_valid; eauto.
+ simpl. eapply agree_exten; eauto. intros. Simpl.
+ auto.
+ rewrite <- H0. exact I.
+
+- (* Mtailcall *)
+ inversion AT; subst.
+ assert (NOOV: list_length_z tf <= Int.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *.
+ exploit Mem.loadv_extends. eauto. eexact H0. auto. simpl. intros [parent' [A B]].
+ exploit lessdef_parent_sp; eauto. intros. subst parent'. clear B.
+ assert (C: Mem.loadv Mint32 m'0 (Val.add (rs0 GPR1) (Vint (fn_retaddr_ofs f))) = Some ra).
+Opaque Int.repr.
+ erewrite agree_sp; eauto. simpl. rewrite Int.add_zero_l.
+ eapply rsa_contains; eauto.
+ exploit retaddr_stored_at_can_free; eauto. intros [m2' [E F]].
+ assert (M: match_stack ge s m'' m2' ra (Mem.nextblock m'')).
+ apply match_stack_change_bound with stk.
+ eapply match_stack_free_left; eauto.
+ eapply match_stack_free_left; eauto.
+ eapply match_stack_free_right; eauto.
+ omega.
+ apply Z.lt_le_incl. change (Mem.valid_block m'' stk).
+ eapply Mem.valid_block_free_1; eauto. eapply Mem.valid_block_free_1; eauto.
+ eapply retaddr_stored_at_valid; eauto.
+ destruct ros as [rf|fid]; simpl in H; monadInv H6.
++ (* Indirect call *)
+ exploit Genv.find_funct_inv; eauto. intros [bf EQ2].
+ rewrite EQ2 in H; rewrite Genv.find_funct_find_funct_ptr in H.
+ assert (rs0 x0 = Vptr bf Int.zero).
+ exploit ireg_val; eauto. rewrite EQ2; intros LD; inv LD; auto.
+ set (rs2 := nextinstr (rs0#CTR <- (Vptr bf Int.zero))).
+ set (rs3 := nextinstr (rs2#GPR0 <- ra)).
+ set (rs4 := nextinstr (rs3#LR <- ra)).
set (rs5 := nextinstr (rs4#GPR1 <- (parent_sp s))).
set (rs6 := rs5#PC <- (rs5 CTR)).
- assert (exec_straight tge (transl_function f)
- (transl_code f (Mtailcall sig (inl ident m0) :: c)) rs m'0
- (Pbctr :: transl_code f c) rs5 m2').
- simpl. apply exec_straight_step with rs2 m'0.
- simpl. rewrite P2. auto. auto.
+ assert (exec_straight tge tf
+ (Pmtctr x0 :: Plwz GPR0 (Cint (fn_retaddr_ofs f)) GPR1 :: Pmtlr GPR0
+ :: Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: Pbctr :: x)
+ rs0 m'0
+ (Pbctr :: x) rs5 m2').
+ apply exec_straight_step with rs2 m'0.
+ simpl. rewrite H6. auto. auto.
apply exec_straight_step with rs3 m'0.
simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low.
- change (rs2 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG).
- simpl. rewrite LOAD2. auto. congruence. auto.
+ change (rs2 GPR1) with (rs0 GPR1). rewrite C. auto. congruence. auto.
apply exec_straight_step with rs4 m'0.
simpl. reflexivity. reflexivity.
apply exec_straight_one.
- simpl. change (rs4 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG).
- simpl. rewrite LOAD1. rewrite FREE'. reflexivity. reflexivity.
+ simpl. change (rs4 GPR1) with (rs0 GPR1). rewrite A. rewrite <- (sp_val _ _ _ AG).
+ rewrite E. reflexivity. reflexivity.
left; exists (State rs6 m2'); split.
(* execution *)
eapply plus_right'. eapply exec_straight_exec; eauto.
econstructor.
- change (rs5 PC) with (Val.add (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone) Vone).
- rewrite <- H8; simpl. eauto.
+ change (rs5 PC) with (Val.add (Val.add (Val.add (Val.add (rs0 PC) Vone) Vone) Vone) Vone).
+ rewrite <- H3; simpl. eauto.
eapply functions_transl; eauto.
eapply find_instr_tail.
repeat (eapply code_tail_next_int; auto). eauto.
simpl. reflexivity. traceEq.
(* match states *)
econstructor; eauto.
- assert (AG4: agree ms (Vptr stk soff) rs4).
- unfold rs4, rs3, rs2; auto 10 with ppcgen.
- assert (AG5: agree ms (parent_sp s) rs5).
- unfold rs5. apply agree_nextinstr.
- split. reflexivity. apply parent_sp_def; auto.
- intros. inv AG4. rewrite Pregmap.gso; auto with ppcgen.
- unfold rs6; auto with ppcgen.
- (* direct call *)
- set (rs2 := nextinstr (rs#GPR0 <- (parent_ra s))).
- set (rs3 := nextinstr (rs2#LR <- (parent_ra s))).
+Hint Resolve agree_nextinstr agree_set_other: asmgen.
+ assert (AG4: agree rs (Vptr stk Int.zero) rs4).
+ unfold rs4, rs3, rs2; auto 10 with asmgen.
+ assert (AG5: agree rs (parent_sp s) rs5).
+ unfold rs5. apply agree_nextinstr. eapply agree_change_sp. eauto.
+ eapply parent_sp_def; eauto.
+ unfold rs6, rs5; auto 10 with asmgen.
+ reflexivity.
+ change (rs6 LR) with ra. eapply retaddr_stored_at_type; eauto.
++ (* Direct call *)
+ destruct (Genv.find_symbol ge fid) as [bf|] eqn:FS; try discriminate.
+ set (rs2 := nextinstr (rs0#GPR0 <- ra)).
+ set (rs3 := nextinstr (rs2#LR <- ra)).
set (rs4 := nextinstr (rs3#GPR1 <- (parent_sp s))).
- set (rs5 := rs4#PC <- (Vptr f' Int.zero)).
- assert (exec_straight tge (transl_function f)
- (transl_code f (Mtailcall sig (inr mreg i) :: c)) rs m'0
- (Pbs i :: transl_code f c) rs4 m2').
- simpl. apply exec_straight_step with rs2 m'0.
+ set (rs5 := rs4#PC <- (Vptr bf Int.zero)).
+ assert (exec_straight tge tf
+ (Plwz GPR0 (Cint (fn_retaddr_ofs f)) GPR1 :: Pmtlr GPR0
+ :: Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: Pbs fid :: x)
+ rs0 m'0
+ (Pbs fid :: x) rs4 m2').
+ apply exec_straight_step with rs2 m'0.
simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low.
- rewrite <- (sp_val _ _ _ AG).
- simpl. rewrite LOAD2. auto. discriminate. auto.
+ rewrite C. auto. congruence. auto.
apply exec_straight_step with rs3 m'0.
simpl. reflexivity. reflexivity.
apply exec_straight_one.
- simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG).
- simpl. rewrite LOAD1. rewrite FREE'. reflexivity. reflexivity.
+ simpl. change (rs3 GPR1) with (rs0 GPR1). rewrite A. rewrite <- (sp_val _ _ _ AG).
+ rewrite E. reflexivity. reflexivity.
left; exists (State rs5 m2'); split.
(* execution *)
eapply plus_right'. eapply exec_straight_exec; eauto.
econstructor.
- change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone).
- rewrite <- H8; simpl. eauto.
+ change (rs4 PC) with (Val.add (Val.add (Val.add (rs0 PC) Vone) Vone) Vone).
+ rewrite <- H3; simpl. eauto.
eapply functions_transl; eauto.
eapply find_instr_tail.
repeat (eapply code_tail_next_int; auto). eauto.
- simpl. unfold symbol_offset. rewrite symbols_preserved. rewrite H.
- reflexivity. traceEq.
+ simpl. unfold symbol_offset. rewrite symbols_preserved. rewrite FS. auto. traceEq.
(* match states *)
econstructor; eauto.
- assert (AG3: agree ms (Vptr stk soff) rs3).
- unfold rs3, rs2; auto 10 with ppcgen.
- assert (AG4: agree ms (parent_sp s) rs4).
- unfold rs4. apply agree_nextinstr.
- split. reflexivity.
- apply parent_sp_def; auto.
- intros. inv AG3. rewrite Pregmap.gso; auto with ppcgen.
- unfold rs5; auto with ppcgen.
-Qed.
+Hint Resolve agree_nextinstr agree_set_other: asmgen.
+ assert (AG3: agree rs (Vptr stk Int.zero) rs3).
+ unfold rs3, rs2; auto 10 with asmgen.
+ assert (AG4: agree rs (parent_sp s) rs4).
+ unfold rs4. apply agree_nextinstr. eapply agree_change_sp. eauto.
+ eapply parent_sp_def; eauto.
+ unfold rs5; auto 10 with asmgen.
+ reflexivity.
+ change (rs5 LR) with ra. eapply retaddr_stored_at_type; eauto.
-Lemma exec_Mbuiltin_prop:
- forall (s : list stackframe) (f : block) (sp : val)
- (ms : Mach.regset) (m : mem) (ef : external_function)
- (args : list mreg) (res : mreg) (b : list Mach.instruction)
- (t : trace) (v : val) (m' : mem),
- external_call ef ge ms ## args m t v m' ->
- exec_instr_prop (Machsem.State s f sp (Mbuiltin ef args res :: b) ms m) t
- (Machsem.State s f sp b (Regmap.set res v (undef_temps ms)) m').
-Proof.
- intros; red; intros; inv MS.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
- inv AT. simpl in H3.
- generalize (functions_transl _ _ FIND); intro FN.
- generalize (functions_transl_no_overflow _ _ FIND); intro NOOV.
+- (* Mbuiltin *)
+ inv AT. monadInv H3.
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H2); intro NOOV.
exploit external_call_mem_extends; eauto. eapply preg_vals; eauto.
intros [vres' [m2' [A [B [C D]]]]].
left. econstructor; split. apply plus_one.
@@ -1116,30 +794,23 @@ Proof.
eapply find_instr_tail; eauto.
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
- econstructor; eauto with coqlib.
- unfold nextinstr. rewrite Pregmap.gss. repeat rewrite Pregmap.gso; auto with ppcgen.
- rewrite <- H0. simpl. constructor; auto.
- eapply code_tail_next_int; eauto.
- apply sym_not_equal. auto with ppcgen.
- apply agree_nextinstr. apply agree_set_mreg_undef_temps with rs; auto.
- rewrite Pregmap.gss. auto.
- intros. repeat rewrite Pregmap.gso; auto with ppcgen.
-Qed.
+ econstructor; eauto.
+ eapply match_stack_extcall; eauto.
+ intros; eapply external_call_max_perm; eauto.
+ instantiate (2 := tf); instantiate (1 := x).
+ Simpl. rewrite <- H0. simpl. econstructor; eauto.
+ eapply code_tail_next_int; eauto.
+ apply agree_nextinstr. eapply agree_set_undef_mreg; eauto.
+ rewrite Pregmap.gss. auto.
+ intros. Simpl.
+ eapply retaddr_stored_at_extcall; eauto.
+ intros; eapply external_call_max_perm; eauto.
+ congruence.
-Lemma exec_Mannot_prop:
- forall (s : list stackframe) (f : block) (sp : val)
- (ms : Mach.regset) (m : mem) (ef : external_function)
- (args : list Mach.annot_param) (b : list Mach.instruction)
- (vargs: list val) (t : trace) (v : val) (m' : mem),
- Machsem.annot_arguments ms m sp args vargs ->
- external_call ef ge vargs m t v m' ->
- exec_instr_prop (Machsem.State s f sp (Mannot ef args :: b) ms m) t
- (Machsem.State s f sp b ms m').
-Proof.
- intros; red; intros; inv MS.
- inv AT. simpl in H3.
- generalize (functions_transl _ _ FIND); intro FN.
- generalize (functions_transl_no_overflow _ _ FIND); intro NOOV.
+- (* Mannot *)
+ inv AT. monadInv H4.
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H3); intro NOOV.
exploit annot_arguments_match; eauto. intros [vargs' [P Q]].
exploit external_call_mem_extends; eauto.
intros [vres' [m2' [A [B [C D]]]]].
@@ -1148,373 +819,238 @@ Proof.
eapply find_instr_tail; eauto. eauto.
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
- econstructor; eauto with coqlib.
+ eapply match_states_intro with (ep := false); eauto with coqlib.
+ eapply match_stack_extcall; eauto.
+ intros; eapply external_call_max_perm; eauto.
unfold nextinstr. rewrite Pregmap.gss.
- rewrite <- H1; simpl. econstructor; auto.
+ rewrite <- H1; simpl. econstructor; eauto.
eapply code_tail_next_int; eauto.
apply agree_nextinstr. auto.
-Qed.
+ eapply retaddr_stored_at_extcall; eauto.
+ intros; eapply external_call_max_perm; eauto.
+ congruence.
-Lemma exec_Mgoto_prop:
- forall (s : list stackframe) (fb : block) (f : function) (sp : val)
- (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset)
- (m : mem) (c' : Mach.code),
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mach.find_label lbl (fn_code f) = Some c' ->
- exec_instr_prop (Machsem.State s fb sp (Mgoto lbl :: c) ms m) E0
- (Machsem.State s fb sp c' ms m).
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- inv AT. simpl in H3.
- generalize (find_label_goto_label f lbl rs m' _ _ _ FIND (sym_equal H1) H0).
- intros [rs2 [GOTO [AT2 INV]]].
- left; exists (State rs2 m'); split.
+- (* Mgoto *)
+ inv AT. monadInv H3.
+ exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]].
+ left; exists (State rs' m'); split.
apply plus_one. econstructor; eauto.
- apply functions_transl; eauto.
+ eapply functions_transl; eauto.
eapply find_instr_tail; eauto.
- simpl; auto.
- econstructor; eauto.
- eapply Mach.find_label_incl; eauto.
- apply agree_exten with rs; auto with ppcgen.
-Qed.
-
-Lemma exec_Mcond_true_prop:
- forall (s : list stackframe) (fb : block) (f : function) (sp : val)
- (cond : condition) (args : list mreg) (lbl : Mach.label)
- (c : list Mach.instruction) (ms : mreg -> val) (m : mem)
- (c' : Mach.code),
- eval_condition cond ms ## args m = Some true ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mach.find_label lbl (fn_code f) = Some c' ->
- exec_instr_prop (Machsem.State s fb sp (Mcond cond args lbl :: c) ms m) E0
- (Machsem.State s fb sp c' (undef_temps ms) m).
-Proof.
- intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
- pose (k1 :=
- if snd (crbit_for_cond cond)
- then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c
- else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c).
- exploit transl_cond_correct; eauto.
- simpl. intros [rs2 [EX [RES AG2]]].
- inv AT. simpl in H5.
- generalize (functions_transl _ _ H4); intro FN.
- generalize (functions_transl_no_overflow _ _ H4); intro NOOV.
- exploit exec_straight_steps_2; eauto.
- intros [ofs' [PC2 CT2]].
- generalize (find_label_goto_label f lbl rs2 m' _ _ _ FIND PC2 H1).
- intros [rs3 [GOTO [AT3 INV3]]].
- left; exists (State rs3 m'); split.
- eapply plus_right'.
- eapply exec_straight_steps_1; eauto.
- caseEq (snd (crbit_for_cond cond)); intro ISSET; rewrite ISSET in RES.
- econstructor; eauto.
- eapply find_instr_tail. unfold k1 in CT2; rewrite ISSET in CT2. eauto.
- simpl. rewrite RES. simpl. auto.
+ simpl; eauto.
econstructor; eauto.
- eapply find_instr_tail. unfold k1 in CT2; rewrite ISSET in CT2. eauto.
- simpl. rewrite RES. simpl. auto.
- traceEq.
- econstructor; eauto.
- eapply Mach.find_label_incl; eauto.
- apply agree_undef_temps with rs2; auto with ppcgen.
-Qed.
-
-Lemma exec_Mcond_false_prop:
- forall (s : list stackframe) (fb : block) (sp : val)
- (cond : condition) (args : list mreg) (lbl : Mach.label)
- (c : list Mach.instruction) (ms : mreg -> val) (m : mem),
- eval_condition cond ms ## args m = Some false ->
- exec_instr_prop (Machsem.State s fb sp (Mcond cond args lbl :: c) ms m) E0
- (Machsem.State s fb sp c (undef_temps ms) m).
-Proof.
- intros; red; intros; inv MS.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inversion WTI.
- exploit transl_cond_correct; eauto.
- simpl. intros [rs2 [EX [RES AG2]]].
- left; eapply exec_straight_steps; eauto with coqlib.
- exists (nextinstr rs2); split.
- simpl. eapply exec_straight_trans. eexact EX.
- caseEq (snd (crbit_for_cond cond)); intro ISSET; rewrite ISSET in RES.
- apply exec_straight_one. simpl. rewrite RES. reflexivity.
- reflexivity.
- apply exec_straight_one. simpl. rewrite RES. reflexivity.
- reflexivity.
- apply agree_nextinstr. apply agree_undef_temps with rs2; auto.
-Qed.
+ eapply agree_exten; eauto with asmgen.
+ congruence.
-Lemma exec_Mjumptable_prop:
- forall (s : list stackframe) (fb : block) (f : function) (sp : val)
- (arg : mreg) (tbl : list Mach.label) (c : list Mach.instruction)
- (rs : mreg -> val) (m : mem) (n : int) (lbl : Mach.label)
- (c' : Mach.code),
- rs arg = Vint n ->
- list_nth_z tbl (Int.unsigned n) = Some lbl ->
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mach.find_label lbl (fn_code f) = Some c' ->
- exec_instr_prop
- (Machsem.State s fb sp (Mjumptable arg tbl :: c) rs m) E0
- (Machsem.State s fb sp c' (undef_temps rs) m).
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inv WTI.
- exploit list_nth_z_range; eauto. intro RANGE.
- assert (SHIFT: Int.unsigned (Int.rolm n (Int.repr 2) (Int.repr (-4))) = Int.unsigned n * 4).
- replace (Int.repr (-4)) with (Int.shl Int.mone (Int.repr 2)).
- rewrite <- Int.shl_rolm. rewrite Int.shl_mul.
- unfold Int.mul. apply Int.unsigned_repr. omega.
- compute. reflexivity.
- apply Int.mkint_eq. compute. reflexivity.
- inv AT. simpl in H7.
- set (k1 := Pbtbl GPR12 tbl :: transl_code f c).
- set (rs1 := nextinstr (rs0 # GPR12 <- (Vint (Int.rolm n (Int.repr 2) (Int.repr (-4)))))).
- generalize (functions_transl _ _ H4); intro FN.
- generalize (functions_transl_no_overflow _ _ H4); intro NOOV.
- assert (exec_straight tge (transl_function f)
- (Prlwinm GPR12 (ireg_of arg) (Int.repr 2) (Int.repr (-4)) :: k1) rs0 m'
- k1 rs1 m').
- apply exec_straight_one.
- simpl. generalize (ireg_val _ _ _ arg AG H5). rewrite H. intro. inv H8.
- reflexivity. reflexivity.
- exploit exec_straight_steps_2; eauto.
- intros [ofs' [PC1 CT1]].
- set (rs2 := rs1 # GPR12 <- Vundef # CTR <- Vundef).
- assert (PC2: rs2 PC = Vptr fb ofs'). rewrite <- PC1. reflexivity.
- generalize (find_label_goto_label f lbl rs2 m' _ _ _ FIND PC2 H2).
- intros [rs3 [GOTO [AT3 INV3]]].
- left; exists (State rs3 m'); split.
- eapply plus_right'.
- eapply exec_straight_steps_1; eauto.
- econstructor; eauto.
- eapply find_instr_tail. unfold k1 in CT1. eauto.
- unfold exec_instr. rewrite gpr_or_zero_not_zero; auto with ppcgen.
- change (rs1 GPR12) with (Vint (Int.rolm n (Int.repr 2) (Int.repr (-4)))).
- lazy iota beta. rewrite SHIFT. rewrite Z_mod_mult. rewrite zeq_true.
- rewrite Z_div_mult.
- change label with Mach.label; rewrite H0. exact GOTO. omega. traceEq.
+- (* Mcond true *)
+ exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
+ left; eapply exec_straight_steps_goto; eauto.
+ intros. simpl in TR.
+ destruct (transl_cond_correct_1 tge tf cond args _ rs0 m' _ TR) as [rs' [A [B C]]].
+ rewrite EC in B.
+ destruct (snd (crbit_for_cond cond)).
+ (* Pbt, taken *)
+ econstructor; econstructor; econstructor; split. eexact A.
+ split. eapply agree_exten_temps; eauto with asmgen.
+ simpl. rewrite B. reflexivity.
+ (* Pbf, taken *)
+ econstructor; econstructor; econstructor; split. eexact A.
+ split. eapply agree_exten_temps; eauto with asmgen.
+ simpl. rewrite B. reflexivity.
+
+- (* Mcond false *)
+ exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
+ left; eapply exec_straight_steps; eauto. intros. simpl in TR.
+ destruct (transl_cond_correct_1 tge tf cond args _ rs0 m' _ TR) as [rs' [A [B C]]].
+ rewrite EC in B.
+ econstructor; split.
+ eapply exec_straight_trans. eexact A.
+ destruct (snd (crbit_for_cond cond)).
+ apply exec_straight_one. simpl. rewrite B. reflexivity. auto.
+ apply exec_straight_one. simpl. rewrite B. reflexivity. auto.
+ split. eapply agree_exten_temps; eauto with asmgen.
+ intros; Simpl.
+ simpl. congruence.
+
+- (* Mjumptable *)
+ inv AT. monadInv H5.
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H4); intro NOOV.
+ exploit find_label_goto_label. eauto. eauto.
+ instantiate (2 := rs0#GPR12 <- Vundef #CTR <- Vundef).
+ Simpl. eauto.
+ eauto.
+ intros [tc' [rs' [A [B C]]]].
+ exploit ireg_val; eauto. rewrite H. intros LD; inv LD.
+ left; econstructor; split.
+ apply plus_one. econstructor; eauto.
+ eapply find_instr_tail; eauto.
+ simpl. rewrite <- H8. unfold Mach.label in H0; unfold label; rewrite H0. eexact A.
econstructor; eauto.
- eapply Mach.find_label_incl; eauto.
- apply agree_undef_temps with rs0; auto.
- intros. rewrite INV3; auto with ppcgen.
- unfold rs2. repeat rewrite Pregmap.gso; auto with ppcgen.
- unfold rs1. rewrite nextinstr_inv; auto with ppcgen.
- apply Pregmap.gso; auto with ppcgen.
-Qed.
+ eapply agree_exten_temps; eauto. intros. rewrite C; auto with asmgen. Simpl.
+ congruence.
-Lemma exec_Mreturn_prop:
- forall (s : list stackframe) (fb stk : block) (soff : int)
- (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: Mach.function) m',
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
- load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
- Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
- exec_instr_prop (Machsem.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0
- (Returnstate s ms m').
-Proof.
- intros; red; intros; inv MS.
- assert (f0 = f) by congruence. subst f0.
- exploit Mem.free_parallel_extends; eauto.
- intros [m2' [FREE' EXT']].
- unfold load_stack in *. simpl in H0; simpl in H1.
- exploit Mem.load_extends. eexact MEXT. eexact H0.
- intros [parent' [LOAD1 LD1]].
- rewrite (lessdef_parent_sp s parent' STACKS LD1) in LOAD1.
- exploit Mem.load_extends. eexact MEXT. eexact H1.
- intros [ra' [LOAD2 LD2]].
- rewrite (lessdef_parent_ra s ra' STACKS LD2) in LOAD2.
- set (rs2 := nextinstr (rs#GPR0 <- (parent_ra s))).
- set (rs3 := nextinstr (rs2#LR <- (parent_ra s))).
+- (* Mreturn *)
+ inversion AT; subst.
+ assert (NOOV: list_length_z tf <= Int.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *.
+ exploit Mem.loadv_extends. eauto. eexact H. auto. simpl. intros [parent' [A B]].
+ exploit lessdef_parent_sp; eauto. intros. subst parent'. clear B.
+ assert (C: Mem.loadv Mint32 m'0 (Val.add (rs0 GPR1) (Vint (fn_retaddr_ofs f))) = Some ra).
+Opaque Int.repr.
+ erewrite agree_sp; eauto. simpl. rewrite Int.add_zero_l.
+ eapply rsa_contains; eauto.
+ exploit retaddr_stored_at_can_free; eauto. intros [m2' [E F]].
+ assert (M: match_stack ge s m'' m2' ra (Mem.nextblock m'')).
+ apply match_stack_change_bound with stk.
+ eapply match_stack_free_left; eauto.
+ eapply match_stack_free_left; eauto.
+ eapply match_stack_free_right; eauto. omega.
+ apply Z.lt_le_incl. change (Mem.valid_block m'' stk).
+ eapply Mem.valid_block_free_1; eauto. eapply Mem.valid_block_free_1; eauto.
+ eapply retaddr_stored_at_valid; eauto.
+ monadInv H5.
+ set (rs2 := nextinstr (rs0#GPR0 <- ra)).
+ set (rs3 := nextinstr (rs2#LR <- ra)).
set (rs4 := nextinstr (rs3#GPR1 <- (parent_sp s))).
- set (rs5 := rs4#PC <- (parent_ra s)).
- assert (exec_straight tge (transl_function f)
- (transl_code f (Mreturn :: c)) rs m'0
- (Pblr :: transl_code f c) rs4 m2').
+ set (rs5 := rs4#PC <- ra).
+ assert (exec_straight tge tf
+ (Plwz GPR0 (Cint (fn_retaddr_ofs f)) GPR1
+ :: Pmtlr GPR0
+ :: Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: Pblr :: x) rs0 m'0
+ (Pblr :: x) rs4 m2').
simpl. apply exec_straight_three with rs2 m'0 rs3 m'0.
- simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low.
- rewrite <- (sp_val _ _ _ AG). simpl. rewrite LOAD2.
- reflexivity. discriminate.
- unfold rs3. reflexivity.
- simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG).
- simpl. rewrite LOAD1. rewrite FREE'. reflexivity.
- reflexivity. reflexivity. reflexivity.
+ simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. rewrite C. auto. congruence.
+ simpl. auto.
+ simpl. change (rs3 GPR1) with (rs0 GPR1). rewrite A.
+ rewrite <- (sp_val _ _ _ AG). rewrite E. auto.
+ auto. auto. auto.
left; exists (State rs5 m2'); split.
(* execution *)
apply plus_right' with E0 (State rs4 m2') E0.
eapply exec_straight_exec; eauto.
- inv AT. econstructor.
- change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone).
- rewrite <- H4. simpl. eauto.
- apply functions_transl; eauto.
- generalize (functions_transl_no_overflow _ _ H5); intro NOOV.
- simpl in H6. eapply find_instr_tail.
+ econstructor.
+ change (rs4 PC) with (Val.add (Val.add (Val.add (rs0 PC) Vone) Vone) Vone).
+ rewrite <- H2. simpl. eauto.
+ eapply functions_transl; eauto.
+ eapply find_instr_tail.
eapply code_tail_next_int; auto.
eapply code_tail_next_int; auto.
eapply code_tail_next_int; eauto.
reflexivity. traceEq.
(* match states *)
econstructor; eauto.
- assert (AG3: agree ms (Vptr stk soff) rs3).
- unfold rs3, rs2; auto 10 with ppcgen.
- assert (AG4: agree ms (parent_sp s) rs4).
- split. reflexivity. apply parent_sp_def; auto. intros. unfold rs4.
- rewrite nextinstr_inv. rewrite Pregmap.gso.
- elim AG3; auto. auto with ppcgen. auto with ppcgen.
- unfold rs5; auto with ppcgen.
-Qed.
-
-Hypothesis wt_prog: wt_program prog.
-
-Lemma exec_function_internal_prop:
- forall (s : list stackframe) (fb : block) (ms : Mach.regset)
- (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block),
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- Mem.alloc m 0 (fn_stacksize f) = (m1, stk) ->
- let sp := Vptr stk Int.zero in
- store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 ->
- store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 ->
- exec_instr_prop (Machsem.Callstate s fb ms m) E0
- (Machsem.State s fb sp (fn_code f) (undef_temps ms) m3).
-Proof.
- intros; red; intros; inv MS.
- assert (WTF: wt_function f).
- generalize (Genv.find_funct_ptr_prop wt_fundef _ _ wt_prog H); intro TY.
- inversion TY; auto.
- exploit functions_transl; eauto. intro TFIND.
- generalize (functions_transl_no_overflow _ _ H); intro NOOV.
- unfold store_stack in *; simpl in *.
- exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl.
- intros [m1' [ALLOC' MEXT1]].
- exploit Mem.store_within_extends. eexact MEXT1. eexact H1. auto.
- intros [m2' [STORE2 MEXT2]].
- exploit Mem.store_within_extends. eexact MEXT2. eexact H2. auto.
- intros [m3' [STORE3 MEXT3]].
- set (rs2 := nextinstr (rs#GPR1 <- sp #GPR0 <- Vundef)).
- set (rs3 := nextinstr (rs2#GPR0 <- (parent_ra s))).
- set (rs4 := nextinstr rs3).
+ assert (AG3: agree rs (Vptr stk Int.zero) rs3).
+ unfold rs3, rs2; auto 10 with asmgen.
+ assert (AG4: agree rs (parent_sp s) rs4).
+ unfold rs4. apply agree_nextinstr. eapply agree_change_sp; eauto.
+ eapply parent_sp_def; eauto.
+ unfold rs5; auto with asmgen.
+
+- (* internal function *)
+ exploit functions_translated; eauto. intros [tf [A B]]. monadInv B.
+ generalize EQ; intros EQ'. monadInv EQ'.
+ destruct (zlt Int.max_unsigned (list_length_z x0)); inversion EQ1. clear EQ1.
+ unfold store_stack in *.
+ exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl.
+ intros [m1' [C D]].
+ assert (E: Mem.extends m2 m1') by (eapply Mem.free_left_extends; eauto).
+ exploit Mem.storev_extends. eexact E. eexact H1. eauto. eauto.
+ intros [m2' [F G]].
+ exploit retaddr_stored_at_can_alloc. eexact H. eauto. eauto. eauto. eauto.
+ auto. auto. auto. auto. eauto.
+ intros [m3' [P [Q R]]].
(* Execution of function prologue *)
+ monadInv EQ0.
+ set (rs2 := nextinstr (rs0#GPR1 <- sp #GPR0 <- Vundef)).
+ set (rs3 := nextinstr (rs2#GPR0 <- (rs0#LR))).
+ set (rs4 := nextinstr rs3).
assert (EXEC_PROLOGUE:
- exec_straight tge (transl_function f)
- (transl_function f) rs m'
- (transl_code f (fn_code f)) rs4 m3').
- unfold transl_function at 2.
+ exec_straight tge x
+ x rs0 m'
+ x1 rs4 m3').
+ rewrite <- H5 at 2.
apply exec_straight_three with rs2 m2' rs3 m2'.
- unfold exec_instr. rewrite ALLOC'. fold sp.
- rewrite <- (sp_val _ _ _ AG). unfold sp; simpl; rewrite STORE2. reflexivity.
- simpl. change (rs2 LR) with (rs LR). rewrite ATLR. reflexivity.
+ unfold exec_instr. rewrite C. fold sp.
+ rewrite <- (sp_val _ _ _ AG). unfold chunk_of_type in F. rewrite F. auto.
+ simpl. auto.
simpl. unfold store1. rewrite gpr_or_zero_not_zero.
- unfold const_low. change (rs3 GPR1) with sp. change (rs3 GPR0) with (parent_ra s).
- simpl. rewrite STORE3. reflexivity.
- discriminate. reflexivity. reflexivity. reflexivity.
- (* Agreement at end of prologue *)
- assert (AT4: transl_code_at_pc rs4#PC fb f f.(fn_code)).
- change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone).
- rewrite ATPC. simpl. constructor. auto.
- eapply code_tail_next_int; auto.
- eapply code_tail_next_int; auto.
- eapply code_tail_next_int; auto.
- change (Int.unsigned Int.zero) with 0.
- unfold transl_function. constructor.
- assert (AG2: agree ms sp rs2).
- split. reflexivity. unfold sp. congruence.
- intros. unfold rs2. rewrite nextinstr_inv.
- repeat (rewrite Pregmap.gso). inv AG; auto.
- auto with ppcgen. auto with ppcgen. auto with ppcgen.
- assert (AG4: agree ms sp rs4).
- unfold rs4, rs3; auto with ppcgen.
+ change (rs3 GPR1) with sp. change (rs3 GPR0) with (rs0 LR). simpl.
+ rewrite Int.add_zero_l. rewrite P. auto. congruence.
+ auto. auto. auto.
left; exists (State rs4 m3'); split.
- (* execution *)
- eapply exec_straight_steps_1; eauto.
- change (Int.unsigned Int.zero) with 0. constructor.
- (* match states *)
- econstructor; eauto with coqlib. apply agree_undef_temps with rs4; auto.
-Qed.
+ eapply exec_straight_steps_1; eauto. unfold fn_code; omega. constructor.
+ econstructor; eauto.
+ assert (STK: stk = Mem.nextblock m) by (eapply Mem.alloc_result; eauto).
+ rewrite <- STK in STACKS. simpl in F. simpl in H1.
+ eapply match_stack_invariant; eauto.
+ intros. eapply Mem.perm_alloc_4; eauto. eapply Mem.perm_free_3; eauto.
+ eapply Mem.perm_store_2; eauto. unfold block; omega.
+ intros. eapply Mem.perm_store_1; eauto. eapply Mem.perm_store_1; eauto.
+ eapply Mem.perm_alloc_1; eauto.
+ intros. erewrite Mem.load_store_other. 2: eauto.
+ erewrite Mem.load_store_other. 2: eauto.
+ eapply Mem.load_alloc_other; eauto.
+ left; unfold block; omega.
+ left; unfold block; omega.
+ change (rs4 PC) with (Val.add (Val.add (Val.add (rs0 PC) Vone) Vone) Vone).
+ rewrite ATPC. simpl. constructor; eauto.
+ subst x. unfold fn_code. eapply code_tail_next_int. omega.
+ eapply code_tail_next_int. omega.
+ eapply code_tail_next_int. omega.
+ constructor.
+ unfold rs4, rs3, rs2.
+ apply agree_nextinstr. apply agree_set_other; auto. apply agree_set_other; auto.
+ apply agree_nextinstr. apply agree_set_other; auto.
+ eapply agree_change_sp; eauto. apply agree_exten_temps with rs0; eauto.
+ unfold sp; congruence.
+ congruence.
-Lemma exec_function_external_prop:
- forall (s : list stackframe) (fb : block) (ms : Mach.regset)
- (m : mem) (t0 : trace) (ms' : RegEq.t -> val)
- (ef : external_function) (args : list val) (res : val) (m': mem),
- Genv.find_funct_ptr ge fb = Some (External ef) ->
- external_call ef ge args m t0 res m' ->
- Machsem.extcall_arguments ms m (parent_sp s) (ef_sig ef) args ->
- ms' = Regmap.set (loc_result (ef_sig ef)) res ms ->
- exec_instr_prop (Machsem.Callstate s fb ms m)
- t0 (Machsem.Returnstate s ms' m').
-Proof.
- intros; red; intros; inv MS.
+- (* external function *)
exploit functions_translated; eauto.
- intros [tf [A B]]. simpl in B. inv B.
+ intros [tf [A B]]. simpl in B. inv B.
exploit extcall_arguments_match; eauto.
intros [args' [C D]].
- exploit external_call_mem_extends; eauto.
+ exploit external_call_mem_extends; eauto.
intros [res' [m2' [P [Q [R S]]]]].
- left; exists (State (rs#(loc_external_result (ef_sig ef)) <- res' #PC <- (rs LR))
- m2'); split.
+ left; econstructor; split.
apply plus_one. eapply exec_step_external; eauto.
- eapply external_call_symbols_preserved; eauto.
+ eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
econstructor; eauto.
- unfold loc_external_result.
- apply agree_set_other; auto with ppcgen.
- apply agree_set_mreg with rs; auto.
- rewrite Pregmap.gss; auto.
- intros; apply Pregmap.gso; auto.
-Qed.
-
-Lemma exec_return_prop:
- forall (s : list stackframe) (fb : block) (sp ra : val)
- (c : Mach.code) (ms : Mach.regset) (m : mem),
- exec_instr_prop (Machsem.Returnstate (Stackframe fb sp ra c :: s) ms m) E0
- (Machsem.State s fb sp c ms m).
-Proof.
- intros; red; intros; inv MS. inv STACKS. simpl in *.
+ rewrite Pregmap.gss. apply match_stack_change_bound with (Mem.nextblock m).
+ eapply match_stack_extcall; eauto.
+ intros. eapply external_call_max_perm; eauto.
+ eapply external_call_nextblock; eauto.
+ unfold loc_external_result.
+ eapply agree_set_mreg; eauto.
+ rewrite Pregmap.gso; auto with asmgen. rewrite Pregmap.gss. auto.
+ intros; Simpl.
+
+- (* return *)
+ inv STACKS. simpl in *.
right. split. omega. split. auto.
- econstructor; eauto. rewrite ATPC; auto.
+ econstructor; eauto. congruence.
Qed.
-Theorem transf_instr_correct:
- forall s1 t s2, Machsem.step ge s1 t s2 ->
- exec_instr_prop s1 t s2.
-Proof
- (Machsem.step_ind ge exec_instr_prop
- exec_Mlabel_prop
- exec_Mgetstack_prop
- exec_Msetstack_prop
- exec_Mgetparam_prop
- exec_Mop_prop
- exec_Mload_prop
- exec_Mstore_prop
- exec_Mcall_prop
- exec_Mtailcall_prop
- exec_Mbuiltin_prop
- exec_Mannot_prop
- exec_Mgoto_prop
- exec_Mcond_true_prop
- exec_Mcond_false_prop
- exec_Mjumptable_prop
- exec_Mreturn_prop
- exec_function_internal_prop
- exec_function_external_prop
- exec_return_prop).
-
Lemma transf_initial_states:
- forall st1, Machsem.initial_state prog st1 ->
+ forall st1, Mach.initial_state prog st1 ->
exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2.
Proof.
intros. inversion H. unfold ge0 in *.
+ exploit functions_translated; eauto. intros [tf [A B]].
econstructor; split.
econstructor.
eapply Genv.init_mem_transf_partial; eauto.
replace (symbol_offset (Genv.globalenv tprog) (prog_main tprog) Int.zero)
- with (Vptr fb Int.zero).
- econstructor; eauto. constructor.
- split. auto. simpl. congruence.
- intros. repeat rewrite Pregmap.gso; auto with ppcgen.
+ with (Vptr b Int.zero).
+ econstructor; eauto.
+ constructor.
apply Mem.extends_refl.
+ split. auto. intros. rewrite Regmap.gi. auto.
+ reflexivity.
+ exact I.
unfold symbol_offset.
rewrite (transform_partial_program_main _ _ TRANSF).
rewrite symbols_preserved. unfold ge; rewrite H1. auto.
@@ -1522,21 +1058,22 @@ Qed.
Lemma transf_final_states:
forall st1 st2 r,
- match_states st1 st2 -> Machsem.final_state st1 r -> Asm.final_state st2 r.
+ match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r.
Proof.
- intros. inv H0. inv H. constructor. auto.
- compute in H1.
- exploit (ireg_val _ _ _ R3 AG). auto. rewrite H1; intro. inv H. auto.
+ intros. inv H0. inv H. inv STACKS. constructor.
+ auto.
+ compute in H1.
+ generalize (preg_val _ _ _ R3 AG). rewrite H1. intros LD; inv LD. auto.
Qed.
Theorem transf_program_correct:
- forward_simulation (Machsem.semantics prog) (Asm.semantics tprog).
+ forward_simulation (Mach.semantics prog) (Asm.semantics tprog).
Proof.
eapply forward_simulation_star with (measure := measure).
eexact symbols_preserved.
eexact transf_initial_states.
eexact transf_final_states.
- exact transf_instr_correct.
+ exact step_simulation.
Qed.
End PRESERVATION.
diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v
index 56cb224..1e16a0d 100644
--- a/powerpc/Asmgenproof1.v
+++ b/powerpc/Asmgenproof1.v
@@ -13,6 +13,7 @@
(** Correctness proof for PPC generation: auxiliary results. *)
Require Import Coqlib.
+Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
@@ -23,11 +24,10 @@ Require Import Globalenvs.
Require Import Op.
Require Import Locations.
Require Import Mach.
-Require Import Machsem.
-Require Import Machtyping.
Require Import Asm.
Require Import Asmgen.
Require Import Conventions.
+Require Import Asmgenproof0.
(** * Properties of low half/high half decomposition *)
@@ -103,308 +103,7 @@ Proof.
rewrite Int.sub_idem. apply Int.add_zero.
Qed.
-(** * Correspondence between Mach registers and PPC registers *)
-
-Hint Extern 2 (_ <> _) => discriminate: ppcgen.
-
-(** Mapping from Mach registers to PPC registers. *)
-
-Lemma preg_of_injective:
- forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2.
-Proof.
- destruct r1; destruct r2; simpl; intros; reflexivity || discriminate.
-Qed.
-
-(** Characterization of PPC registers that correspond to Mach registers. *)
-
-Definition is_data_reg (r: preg) : bool :=
- match r with
- | IR GPR0 => false
- | PC => false | LR => false | CTR => false
- | CR0_0 => false | CR0_1 => false | CR0_2 => false | CR0_3 => false
- | CARRY => false
- | _ => true
- end.
-
-Lemma ireg_of_is_data_reg:
- forall (r: mreg), is_data_reg (ireg_of r) = true.
-Proof.
- destruct r; reflexivity.
-Qed.
-
-Lemma freg_of_is_data_reg:
- forall (r: mreg), is_data_reg (ireg_of r) = true.
-Proof.
- destruct r; reflexivity.
-Qed.
-
-Lemma preg_of_is_data_reg:
- forall (r: mreg), is_data_reg (preg_of r) = true.
-Proof.
- destruct r; reflexivity.
-Qed.
-
-Lemma data_reg_diff:
- forall r r', is_data_reg r = true -> is_data_reg r' = false -> r <> r'.
-Proof.
- intros. congruence.
-Qed.
-
-Lemma ireg_diff:
- forall r r', r <> r' -> IR r <> IR r'.
-Proof.
- intros. congruence.
-Qed.
-
-Lemma diff_ireg:
- forall r r', IR r <> IR r' -> r <> r'.
-Proof.
- intros. congruence.
-Qed.
-
-Hint Resolve ireg_of_is_data_reg freg_of_is_data_reg preg_of_is_data_reg
- data_reg_diff ireg_diff diff_ireg: ppcgen.
-
-Definition is_nontemp_reg (r: preg) : bool :=
- match r with
- | IR GPR0 => false | IR GPR11 => false | IR GPR12 => false
- | FR FPR0 => false | FR FPR12 => false | FR FPR13 => false
- | PC => false | LR => false | CTR => false
- | CR0_0 => false | CR0_1 => false | CR0_2 => false | CR0_3 => false
- | CARRY => false
- | _ => true
- end.
-
-Remark is_nontemp_is_data:
- forall r, is_nontemp_reg r = true -> is_data_reg r = true.
-Proof.
- destruct r; simpl; try congruence. destruct i; congruence.
-Qed.
-
-Lemma nontemp_reg_diff:
- forall r r', is_nontemp_reg r = true -> is_nontemp_reg r' = false -> r <> r'.
-Proof.
- intros. congruence.
-Qed.
-
-Hint Resolve is_nontemp_is_data nontemp_reg_diff: ppcgen.
-
-Lemma ireg_of_not_GPR1:
- forall r, ireg_of r <> GPR1.
-Proof.
- intro. case r; discriminate.
-Qed.
-
-Lemma preg_of_not_GPR1:
- forall r, preg_of r <> GPR1.
-Proof.
- intro. case r; discriminate.
-Qed.
-Hint Resolve ireg_of_not_GPR1 preg_of_not_GPR1: ppcgen.
-
-Lemma int_temp_for_diff:
- forall r, IR(int_temp_for r) <> preg_of r.
-Proof.
- intros. unfold int_temp_for. destruct (mreg_eq r IT2).
- subst r. compute. congruence.
- change (IR GPR12) with (preg_of IT2). red; intros; elim n.
- apply preg_of_injective; auto.
-Qed.
-
-(** Agreement between Mach register sets and PPC register sets. *)
-
-Record agree (ms: Mach.regset) (sp: val) (rs: Asm.regset) : Prop := mkagree {
- agree_sp: rs#GPR1 = sp;
- agree_sp_def: sp <> Vundef;
- agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r))
-}.
-
-Lemma preg_val:
- forall ms sp rs r,
- agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r).
-Proof.
- intros. eapply agree_mregs; eauto.
-Qed.
-
-Lemma preg_vals:
- forall ms sp rs rl,
- agree ms sp rs -> Val.lessdef_list (List.map ms rl) (List.map rs (List.map preg_of rl)).
-Proof.
- induction rl; intros; simpl.
- constructor.
- constructor. eapply preg_val; eauto. eauto.
-Qed.
-
-Lemma ireg_val:
- forall ms sp rs r,
- agree ms sp rs ->
- mreg_type r = Tint ->
- Val.lessdef (ms r) rs#(ireg_of r).
-Proof.
- intros. replace (IR (ireg_of r)) with (preg_of r). eapply preg_val; eauto.
- unfold preg_of. rewrite H0. auto.
-Qed.
-
-Lemma freg_val:
- forall ms sp rs r,
- agree ms sp rs ->
- mreg_type r = Tfloat ->
- Val.lessdef (ms r) rs#(freg_of r).
-Proof.
- intros. replace (FR (freg_of r)) with (preg_of r). eapply preg_val; eauto.
- unfold preg_of. rewrite H0. auto.
-Qed.
-
-Lemma sp_val:
- forall ms sp rs,
- agree ms sp rs ->
- sp = rs#GPR1.
-Proof.
- intros. elim H; auto.
-Qed.
-
-Lemma agree_exten:
- forall ms sp rs rs',
- agree ms sp rs ->
- (forall r, is_data_reg r = true -> rs'#r = rs#r) ->
- agree ms sp rs'.
-Proof.
- intros. inv H. constructor; auto.
- intros. rewrite H0; auto with ppcgen.
-Qed.
-
-(** Preservation of register agreement under various assignments. *)
-
-Lemma agree_set_mreg:
- forall ms sp rs r v rs',
- agree ms sp rs ->
- Val.lessdef v (rs'#(preg_of r)) ->
- (forall r', is_data_reg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') ->
- agree (Regmap.set r v ms) sp rs'.
-Proof.
- intros. inv H. constructor; auto with ppcgen.
- intros. unfold Regmap.set. destruct (RegEq.eq r0 r).
- subst r0. auto.
- rewrite H1; auto with ppcgen. red; intros; elim n; apply preg_of_injective; auto.
-Qed.
-Hint Resolve agree_set_mreg: ppcgen.
-
-Lemma agree_set_mireg:
- forall ms sp rs r v (rs': regset),
- agree ms sp rs ->
- Val.lessdef v (rs'#(ireg_of r)) ->
- mreg_type r = Tint ->
- (forall r', is_data_reg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') ->
- agree (Regmap.set r v ms) sp rs'.
-Proof.
- intros. eapply agree_set_mreg; eauto. unfold preg_of; rewrite H1; auto.
-Qed.
-Hint Resolve agree_set_mireg: ppcgen.
-
-Lemma agree_set_mfreg:
- forall ms sp rs r v (rs': regset),
- agree ms sp rs ->
- Val.lessdef v (rs'#(freg_of r)) ->
- mreg_type r = Tfloat ->
- (forall r', is_data_reg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') ->
- agree (Regmap.set r v ms) sp rs'.
-Proof.
- intros. eapply agree_set_mreg; eauto. unfold preg_of; rewrite H1; auto.
-Qed.
-
-Lemma agree_set_other:
- forall ms sp rs r v,
- agree ms sp rs ->
- is_data_reg r = false ->
- agree ms sp (rs#r <- v).
-Proof.
- intros. apply agree_exten with rs.
- auto. intros. apply Pregmap.gso. congruence.
-Qed.
-Hint Resolve agree_set_other: ppcgen.
-
-Lemma agree_nextinstr:
- forall ms sp rs,
- agree ms sp rs -> agree ms sp (nextinstr rs).
-Proof.
- intros. unfold nextinstr. apply agree_set_other. auto. auto.
-Qed.
-Hint Resolve agree_nextinstr: ppcgen.
-
-Lemma agree_undef_regs:
- forall rl ms sp rs rs',
- agree ms sp rs ->
- (forall r, is_data_reg r = true -> ~In r (List.map preg_of rl) -> rs'#r = rs#r) ->
- agree (undef_regs rl ms) sp rs'.
-Proof.
- induction rl; simpl; intros.
- apply agree_exten with rs; auto.
- apply IHrl with (rs#(preg_of a) <- (rs'#(preg_of a))).
- apply agree_set_mreg with rs; auto with ppcgen.
- intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of a)).
- congruence. auto.
- intros. unfold Pregmap.set. destruct (PregEq.eq r (preg_of a)).
- congruence. apply H0; auto. intuition congruence.
-Qed.
-
-Lemma agree_undef_temps:
- forall ms sp rs rs',
- agree ms sp rs ->
- (forall r, is_nontemp_reg r = true -> rs'#r = rs#r) ->
- agree (undef_temps ms) sp rs'.
-Proof.
- unfold undef_temps. intros. apply agree_undef_regs with rs; auto.
- simpl. unfold preg_of; simpl. intros. intuition.
- apply H0. destruct r; simpl in *; auto.
- destruct i; intuition. destruct f; intuition.
-Qed.
-Hint Resolve agree_undef_temps: ppcgen.
-
-Lemma agree_set_mreg_undef_temps:
- forall ms sp rs r v rs',
- agree ms sp rs ->
- Val.lessdef v (rs'#(preg_of r)) ->
- (forall r', is_nontemp_reg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') ->
- agree (Regmap.set r v (undef_temps ms)) sp rs'.
-Proof.
- intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))).
- apply agree_undef_temps with rs; auto.
- intros. unfold Pregmap.set. destruct (PregEq.eq r0 (preg_of r)).
- congruence. apply H1; auto.
- auto.
- intros. rewrite Pregmap.gso; auto.
-Qed.
-
-Lemma agree_set_twice_mireg:
- forall ms sp rs r v v1 v',
- agree (Regmap.set r v1 ms) sp rs ->
- mreg_type r = Tint ->
- Val.lessdef v v' ->
- agree (Regmap.set r v ms) sp (rs#(ireg_of r) <- v').
-Proof.
- intros. inv H.
- split. rewrite Pregmap.gso. auto.
- generalize (ireg_of_not_GPR1 r); congruence.
- auto.
- intros. generalize (agree_mregs0 r0).
- case (mreg_eq r0 r); intro.
- subst r0. repeat rewrite Regmap.gss. unfold preg_of; rewrite H0.
- rewrite Pregmap.gss. auto.
- repeat rewrite Regmap.gso; auto.
- rewrite Pregmap.gso. auto.
- replace (IR (ireg_of r)) with (preg_of r).
- red; intros. elim n. apply preg_of_injective; auto.
- unfold preg_of. rewrite H0. auto.
-Qed.
-
-(** Useful properties of the PC and GPR0 registers. *)
-
-Lemma nextinstr_inv:
- forall r rs, r <> PC -> (nextinstr rs)#r = rs#r.
-Proof.
- intros. unfold nextinstr. apply Pregmap.gso. auto.
-Qed.
-Hint Resolve nextinstr_inv: ppcgen.
+(** Useful properties of the GPR0 registers. *)
Lemma gpr_or_zero_not_zero:
forall rs r, r <> GPR0 -> gpr_or_zero rs r = rs#r.
@@ -416,154 +115,40 @@ Lemma gpr_or_zero_zero:
Proof.
intros. reflexivity.
Qed.
-Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: ppcgen.
-
-(** Connection between Mach and Asm calling conventions for external
- functions. *)
+Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: asmgen.
-Lemma extcall_arg_match:
- forall ms sp rs m m' l v,
- agree ms sp rs ->
- Mem.extends m m' ->
- Machsem.extcall_arg ms m sp l v ->
- exists v', Asm.extcall_arg rs m' l v' /\ Val.lessdef v v'.
+Lemma ireg_of_not_GPR0:
+ forall m r, ireg_of m = OK r -> IR r <> IR GPR0.
Proof.
- intros. inv H1.
- exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto.
- unfold load_stack in H2.
- exploit Mem.loadv_extends; eauto. intros [v' [A B]].
- rewrite (sp_val _ _ _ H) in A.
- exists v'; split; auto.
- destruct ty; econstructor.
- reflexivity. assumption.
- reflexivity. assumption.
+ intros. erewrite <- ireg_of_eq; eauto with asmgen.
Qed.
+Hint Resolve ireg_of_not_GPR0: asmgen.
-Lemma extcall_args_match:
- forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' ->
- forall ll vl,
- list_forall2 (Machsem.extcall_arg ms m sp) ll vl ->
- exists vl', list_forall2 (Asm.extcall_arg rs m') ll vl' /\ Val.lessdef_list vl vl'.
+Lemma ireg_of_not_GPR0':
+ forall m r, ireg_of m = OK r -> r <> GPR0.
Proof.
- induction 3; intros.
- exists (@nil val); split. constructor. constructor.
- exploit extcall_arg_match; eauto. intros [v1' [A B]].
- destruct IHlist_forall2 as [vl' [C D]].
- exists (v1' :: vl'); split; constructor; auto.
+ intros. generalize (ireg_of_not_GPR0 _ _ H). congruence.
Qed.
+Hint Resolve ireg_of_not_GPR0': asmgen.
-Lemma extcall_arguments_match:
- forall ms m m' sp rs sg args,
- agree ms sp rs -> Mem.extends m m' ->
- Machsem.extcall_arguments ms m sp sg args ->
- exists args', Asm.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'.
-Proof.
- unfold Machsem.extcall_arguments, Asm.extcall_arguments; intros.
- eapply extcall_args_match; eauto.
-Qed.
+(** Useful simplification tactic *)
-(** Translation of arguments to annotations. *)
+Ltac Simplif :=
+ ((rewrite nextinstr_inv by eauto with asmgen)
+ || (rewrite nextinstr_inv1 by eauto with asmgen)
+ || (rewrite Pregmap.gss)
+ || (rewrite nextinstr_pc)
+ || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen.
-Lemma annot_arg_match:
- forall ms sp rs m m' p v,
- agree ms sp rs ->
- Mem.extends m m' ->
- Machsem.annot_arg ms m sp p v ->
- exists v', Asm.annot_arg rs m' (transl_annot_param p) v' /\ Val.lessdef v v'.
-Proof.
- intros. inv H1; simpl.
-(* reg *)
- exists (rs (preg_of r)); split. constructor. eapply preg_val; eauto.
-(* stack *)
- exploit Mem.load_extends; eauto. intros [v' [A B]].
- exists v'; split; auto.
- inv H. econstructor; eauto.
-Qed.
+Ltac Simpl := repeat Simplif.
-Lemma annot_arguments_match:
- forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' ->
- forall pl vl,
- Machsem.annot_arguments ms m sp pl vl ->
- exists vl', Asm.annot_arguments rs m' (map transl_annot_param pl) vl'
- /\ Val.lessdef_list vl vl'.
-Proof.
- induction 3; intros.
- exists (@nil val); split. constructor. constructor.
- exploit annot_arg_match; eauto. intros [v1' [A B]].
- destruct IHlist_forall2 as [vl' [C D]].
- exists (v1' :: vl'); split; constructor; auto.
-Qed.
-
-(** * Execution of straight-line code *)
+(** * Correctness of PowerPC constructor functions *)
-Section STRAIGHTLINE.
+Section CONSTRUCTORS.
Variable ge: genv.
Variable fn: code.
-(** Straight-line code is composed of PPC instructions that execute
- in sequence (no branches, no function calls and returns).
- The following inductive predicate relates the machine states
- before and after executing a straight-line sequence of instructions.
- Instructions are taken from the first list instead of being fetched
- from memory. *)
-
-Inductive exec_straight: code -> regset -> mem ->
- code -> regset -> mem -> Prop :=
- | exec_straight_one:
- forall i1 c rs1 m1 rs2 m2,
- exec_instr ge fn i1 rs1 m1 = OK rs2 m2 ->
- rs2#PC = Val.add rs1#PC Vone ->
- exec_straight (i1 :: c) rs1 m1 c rs2 m2
- | exec_straight_step:
- forall i c rs1 m1 rs2 m2 c' rs3 m3,
- exec_instr ge fn i rs1 m1 = OK rs2 m2 ->
- rs2#PC = Val.add rs1#PC Vone ->
- exec_straight c rs2 m2 c' rs3 m3 ->
- exec_straight (i :: c) rs1 m1 c' rs3 m3.
-
-Lemma exec_straight_trans:
- forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3,
- exec_straight c1 rs1 m1 c2 rs2 m2 ->
- exec_straight c2 rs2 m2 c3 rs3 m3 ->
- exec_straight c1 rs1 m1 c3 rs3 m3.
-Proof.
- induction 1; intros.
- apply exec_straight_step with rs2 m2; auto.
- apply exec_straight_step with rs2 m2; auto.
-Qed.
-
-Lemma exec_straight_two:
- forall i1 i2 c rs1 m1 rs2 m2 rs3 m3,
- exec_instr ge fn i1 rs1 m1 = OK rs2 m2 ->
- exec_instr ge fn i2 rs2 m2 = OK rs3 m3 ->
- rs2#PC = Val.add rs1#PC Vone ->
- rs3#PC = Val.add rs2#PC Vone ->
- exec_straight (i1 :: i2 :: c) rs1 m1 c rs3 m3.
-Proof.
- intros. apply exec_straight_step with rs2 m2; auto.
- apply exec_straight_one; auto.
-Qed.
-
-Lemma exec_straight_three:
- forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4,
- exec_instr ge fn i1 rs1 m1 = OK rs2 m2 ->
- exec_instr ge fn i2 rs2 m2 = OK rs3 m3 ->
- exec_instr ge fn i3 rs3 m3 = OK rs4 m4 ->
- rs2#PC = Val.add rs1#PC Vone ->
- rs3#PC = Val.add rs2#PC Vone ->
- rs4#PC = Val.add rs3#PC Vone ->
- exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4.
-Proof.
- intros. apply exec_straight_step with rs2 m2; auto.
- eapply exec_straight_two; eauto.
-Qed.
-
-(** * Correctness of PowerPC constructor functions *)
-
-Ltac SIMP :=
- (rewrite nextinstr_inv || rewrite Pregmap.gss || rewrite Pregmap.gso); auto with ppcgen.
-
(** Properties of comparisons. *)
Lemma compare_float_spec:
@@ -578,7 +163,7 @@ Proof.
split. reflexivity.
split. reflexivity.
split. reflexivity.
- intros. unfold compare_float. repeat SIMP.
+ intros. unfold compare_float. Simpl.
Qed.
Lemma compare_sint_spec:
@@ -593,7 +178,7 @@ Proof.
split. reflexivity.
split. reflexivity.
split. reflexivity.
- intros. unfold compare_sint. repeat SIMP.
+ intros. unfold compare_sint. Simpl.
Qed.
Lemma compare_uint_spec:
@@ -608,7 +193,7 @@ Proof.
split. reflexivity.
split. reflexivity.
split. reflexivity.
- intros. unfold compare_uint. repeat SIMP.
+ intros. unfold compare_uint. Simpl.
Qed.
(** Loading a constant. *)
@@ -616,35 +201,25 @@ Qed.
Lemma loadimm_correct:
forall r n k rs m,
exists rs',
- exec_straight (loadimm r n k) rs m k rs' m
+ exec_straight ge fn (loadimm r n k) rs m k rs' m
/\ rs'#r = Vint n
/\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'.
Proof.
intros. unfold loadimm.
case (Int.eq (high_s n) Int.zero).
(* addi *)
- exists (nextinstr (rs#r <- (Vint n))).
- split. apply exec_straight_one.
- simpl. rewrite Int.add_zero_l. auto.
- reflexivity.
- split. repeat SIMP. intros; repeat SIMP.
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ rewrite Int.add_zero_l. intuition Simpl.
(* addis *)
generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro.
- exists (nextinstr (rs#r <- (Vint n))).
- split. apply exec_straight_one.
- simpl. rewrite Int.add_commut.
- rewrite <- H. rewrite low_high_s. reflexivity.
- reflexivity.
- split. repeat SIMP. intros; repeat SIMP.
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ rewrite <- H. rewrite Int.add_commut. rewrite low_high_s.
+ intuition Simpl.
(* addis + ori *)
- pose (rs1 := nextinstr (rs#r <- (Vint (Int.shl (high_u n) (Int.repr 16))))).
- exists (nextinstr (rs1#r <- (Vint n))).
- split. eapply exec_straight_two.
- simpl. rewrite Int.add_zero_l. reflexivity.
- simpl. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
- unfold Val.or. rewrite low_high_u. reflexivity.
- reflexivity. reflexivity.
- unfold rs1. split. repeat SIMP. intros; repeat SIMP.
+ econstructor; split. eapply exec_straight_two.
+ simpl; eauto. simpl; eauto. auto. auto.
+ split. Simpl. rewrite Int.add_zero_l. unfold Val.or. rewrite low_high_u. auto.
+ intros; Simpl.
Qed.
(** Add integer immediate. *)
@@ -654,37 +229,31 @@ Lemma addimm_correct:
r1 <> GPR0 ->
r2 <> GPR0 ->
exists rs',
- exec_straight (addimm r1 r2 n k) rs m k rs' m
+ exec_straight ge fn (addimm r1 r2 n k) rs m k rs' m
/\ rs'#r1 = Val.add rs#r2 (Vint n)
/\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
intros. unfold addimm.
(* addi *)
case (Int.eq (high_s n) Int.zero).
- exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))).
- split. apply exec_straight_one.
- simpl. rewrite gpr_or_zero_not_zero; auto.
- reflexivity.
- split. repeat SIMP. intros. repeat SIMP.
+ econstructor; split. apply exec_straight_one.
+ simpl. rewrite gpr_or_zero_not_zero; eauto.
+ reflexivity.
+ intuition Simpl.
(* addis *)
generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro.
- exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))).
- split. apply exec_straight_one.
- simpl. rewrite gpr_or_zero_not_zero; auto.
- generalize (low_high_s n). rewrite H1. rewrite Int.add_zero. intro.
- rewrite H2. auto.
- reflexivity.
- split. repeat SIMP. intros; repeat SIMP.
+ econstructor; split. apply exec_straight_one.
+ simpl. rewrite gpr_or_zero_not_zero; auto. auto.
+ split. Simpl.
+ generalize (low_high_s n). rewrite H1. rewrite Int.add_zero. congruence.
+ intros; Simpl.
(* addis + addi *)
- pose (rs1 := nextinstr (rs#r1 <- (Val.add rs#r2 (Vint (Int.shl (high_s n) (Int.repr 16)))))).
- exists (nextinstr (rs1#r1 <- (Val.add rs#r2 (Vint n)))).
- split. apply exec_straight_two with rs1 m.
- simpl. rewrite gpr_or_zero_not_zero; auto.
- simpl. rewrite gpr_or_zero_not_zero; auto.
- unfold rs1 at 1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
- rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
- reflexivity. reflexivity.
- unfold rs1; split. repeat SIMP. intros; repeat SIMP.
+ econstructor; split. eapply exec_straight_two.
+ simpl. rewrite gpr_or_zero_not_zero; eauto.
+ simpl. rewrite gpr_or_zero_not_zero; eauto.
+ auto. auto.
+ split. Simpl. rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
+ intros; Simpl.
Qed.
(** And integer immediate. *)
@@ -694,10 +263,10 @@ Lemma andimm_base_correct:
r2 <> GPR0 ->
let v := Val.and rs#r2 (Vint n) in
exists rs',
- exec_straight (andimm_base r1 r2 n k) rs m k rs' m
+ exec_straight ge fn (andimm_base r1 r2 n k) rs m k rs' m
/\ rs'#r1 = v
/\ rs'#CR0_2 = Val.cmp Ceq v Vzero
- /\ forall r', is_data_reg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
+ /\ forall r', data_preg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
Proof.
intros. unfold andimm_base.
case (Int.eq (high_u n) Int.zero).
@@ -706,9 +275,9 @@ Proof.
generalize (compare_sint_spec (rs#r1 <- v) v Vzero).
intros [A [B [C D]]].
split. apply exec_straight_one. reflexivity. reflexivity.
- split. rewrite D; auto with ppcgen. SIMP.
+ split. rewrite D; auto with asmgen. Simpl.
split. auto.
- intros. rewrite D; auto with ppcgen. SIMP.
+ intros. rewrite D; auto with asmgen. Simpl.
(* andis *)
generalize (Int.eq_spec (low_u n) Int.zero);
case (Int.eq (low_u n) Int.zero); intro.
@@ -718,9 +287,9 @@ Proof.
split. apply exec_straight_one. simpl.
generalize (low_high_u n). rewrite H0. rewrite Int.or_zero.
intro. rewrite H1. reflexivity. reflexivity.
- split. rewrite D; auto with ppcgen. SIMP.
+ split. rewrite D; auto with asmgen. Simpl.
split. auto.
- intros. rewrite D; auto with ppcgen. SIMP.
+ intros. rewrite D; auto with asmgen. Simpl.
(* loadimm + and *)
generalize (loadimm_correct GPR0 n (Pand_ r1 r2 GPR0 :: k) rs m).
intros [rs1 [EX1 [RES1 OTHER1]]].
@@ -731,25 +300,24 @@ Proof.
apply exec_straight_one. simpl. rewrite RES1.
rewrite (OTHER1 r2). reflexivity. congruence. congruence.
reflexivity.
- split. rewrite D; auto with ppcgen. SIMP.
+ split. rewrite D; auto with asmgen. Simpl.
split. auto.
- intros. rewrite D; auto with ppcgen. SIMP.
+ intros. rewrite D; auto with asmgen. Simpl.
Qed.
Lemma andimm_correct:
forall r1 r2 n k (rs : regset) m,
r2 <> GPR0 ->
exists rs',
- exec_straight (andimm r1 r2 n k) rs m k rs' m
+ exec_straight ge fn (andimm r1 r2 n k) rs m k rs' m
/\ rs'#r1 = Val.and rs#r2 (Vint n)
- /\ forall r', is_data_reg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
+ /\ forall r', data_preg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
Proof.
intros. unfold andimm. destruct (is_rlw_mask n).
(* turned into rlw *)
- exists (nextinstr (rs#r1 <- (Val.and rs#r2 (Vint n)))).
- split. apply exec_straight_one. simpl. rewrite Val.rolm_zero. auto. reflexivity.
- split. SIMP. apply Pregmap.gss.
- intros. SIMP. apply Pregmap.gso; auto with ppcgen.
+ econstructor; split. eapply exec_straight_one.
+ simpl. rewrite Val.rolm_zero. eauto. auto.
+ intuition Simpl.
(* andimm_base *)
destruct (andimm_base_correct r1 r2 n k rs m) as [rs' [A [B [C D]]]]; auto.
exists rs'; auto.
@@ -761,7 +329,7 @@ Lemma orimm_correct:
forall r1 (r2: ireg) n k (rs : regset) m,
let v := Val.or rs#r2 (Vint n) in
exists rs',
- exec_straight (orimm r1 r2 n k) rs m k rs' m
+ exec_straight ge fn (orimm r1 r2 n k) rs m k rs' m
/\ rs'#r1 = v
/\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
@@ -770,8 +338,7 @@ Proof.
(* ori *)
exists (nextinstr (rs#r1 <- v)).
split. apply exec_straight_one. reflexivity. reflexivity.
- split. repeat SIMP.
- intros. repeat SIMP.
+ intuition Simpl.
(* oris *)
generalize (Int.eq_spec (low_u n) Int.zero);
case (Int.eq (low_u n) Int.zero); intro.
@@ -779,12 +346,11 @@ Proof.
split. apply exec_straight_one. simpl.
generalize (low_high_u n). rewrite H. rewrite Int.or_zero.
intro. rewrite H0. reflexivity. reflexivity.
- split. repeat SIMP.
- intros. repeat SIMP.
+ intuition Simpl.
(* oris + ori *)
econstructor; split. eapply exec_straight_two; simpl; reflexivity.
- split. repeat rewrite nextinstr_inv; auto with ppcgen. repeat rewrite Pregmap.gss. rewrite Val.or_assoc. simpl. rewrite low_high_u. reflexivity.
- intros. repeat SIMP.
+ intuition Simpl.
+ rewrite Val.or_assoc. simpl. rewrite low_high_u. reflexivity.
Qed.
(** Xor integer immediate. *)
@@ -793,7 +359,7 @@ Lemma xorimm_correct:
forall r1 (r2: ireg) n k (rs : regset) m,
let v := Val.xor rs#r2 (Vint n) in
exists rs',
- exec_straight (xorimm r1 r2 n k) rs m k rs' m
+ exec_straight ge fn (xorimm r1 r2 n k) rs m k rs' m
/\ rs'#r1 = v
/\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
@@ -802,20 +368,19 @@ Proof.
(* xori *)
exists (nextinstr (rs#r1 <- v)).
split. apply exec_straight_one. reflexivity. reflexivity.
- split. repeat SIMP. intros. repeat SIMP.
+ intuition Simpl.
(* xoris *)
generalize (Int.eq_spec (low_u n) Int.zero);
case (Int.eq (low_u n) Int.zero); intro.
exists (nextinstr (rs#r1 <- v)).
split. apply exec_straight_one. simpl.
- generalize (low_high_u_xor n). rewrite H. rewrite Int.xor_zero.
+ generalize (low_high_u n). rewrite H. rewrite Int.or_zero.
intro. rewrite H0. reflexivity. reflexivity.
- split. repeat SIMP. intros. repeat SIMP.
+ intuition Simpl.
(* xoris + xori *)
econstructor; split. eapply exec_straight_two; simpl; reflexivity.
- split. repeat rewrite nextinstr_inv; auto with ppcgen. repeat rewrite Pregmap.gss.
+ intuition Simpl.
rewrite Val.xor_assoc. simpl. rewrite low_high_u_xor. reflexivity.
- intros. repeat SIMP.
Qed.
(** Rotate and mask. *)
@@ -824,95 +389,108 @@ Lemma rolm_correct:
forall r1 r2 amount mask k (rs : regset) m,
r1 <> GPR0 ->
exists rs',
- exec_straight (rolm r1 r2 amount mask k) rs m k rs' m
+ exec_straight ge fn (rolm r1 r2 amount mask k) rs m k rs' m
/\ rs'#r1 = Val.rolm rs#r2 amount mask
- /\ forall r', is_data_reg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
+ /\ forall r', data_preg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
Proof.
intros. unfold rolm. destruct (is_rlw_mask mask).
(* rlwinm *)
- exists (nextinstr (rs#r1 <- (Val.rolm rs#r2 amount mask))).
- split. apply exec_straight_one; auto.
- split. SIMP. apply Pregmap.gss.
- intros. SIMP. apply Pregmap.gso; auto.
+ econstructor; split. eapply exec_straight_one; simpl; eauto.
+ intuition Simpl.
(* rlwinm ; andimm *)
set (rs1 := nextinstr (rs#r1 <- (Val.rolm rs#r2 amount Int.mone))).
destruct (andimm_base_correct r1 r1 mask k rs1 m) as [rs' [A [B [C D]]]]; auto.
exists rs'.
split. eapply exec_straight_step; eauto. auto. auto.
- split. rewrite B. unfold rs1. SIMP. rewrite Pregmap.gss.
- destruct (rs r2); simpl; auto. unfold Int.rolm. rewrite Int.and_assoc.
+ split. rewrite B. unfold rs1. rewrite nextinstr_inv; auto with asmgen.
+ rewrite Pregmap.gss. destruct (rs r2); simpl; auto.
+ unfold Int.rolm. rewrite Int.and_assoc.
decEq; decEq; decEq. rewrite Int.and_commut. apply Int.and_mone.
- intros. rewrite D; auto. unfold rs1; SIMP. apply Pregmap.gso; auto.
+ intros. rewrite D; auto. unfold rs1; Simpl.
Qed.
(** Indexed memory loads. *)
Lemma loadind_correct:
- forall (base: ireg) ofs ty dst k (rs: regset) m v,
+ forall (base: ireg) ofs ty dst k (rs: regset) m v c,
+ loadind base ofs ty dst k = OK c ->
Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v ->
- mreg_type dst = ty ->
base <> GPR0 ->
exists rs',
- exec_straight (loadind base ofs ty dst k) rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ rs'#(preg_of dst) = v
/\ forall r, r <> PC -> r <> preg_of dst -> r <> GPR0 -> rs'#r = rs#r.
Proof.
- intros. unfold loadind. destruct (Int.eq (high_s ofs) Int.zero).
-(* one load *)
- exists (nextinstr (rs#(preg_of dst) <- v)); split.
- unfold preg_of. rewrite H0.
- destruct ty; apply exec_straight_one; auto with ppcgen; simpl.
- unfold load1. rewrite gpr_or_zero_not_zero; auto.
- simpl in *. rewrite H. auto.
- unfold load1. rewrite gpr_or_zero_not_zero; auto.
- simpl in *. rewrite H. auto.
- split. repeat SIMP. intros. repeat SIMP.
-(* loadimm + one load *)
+Opaque Int.eq.
+ unfold loadind; intros. destruct ty; monadInv H; simpl in H0.
+(* integer *)
+ rewrite (ireg_of_eq _ _ EQ).
+ destruct (Int.eq (high_s ofs) Int.zero).
+ (* one load *)
+ econstructor; split. apply exec_straight_one. simpl.
+ unfold load1. rewrite gpr_or_zero_not_zero; auto. simpl. rewrite H0. eauto. auto.
+ intuition Simpl.
+ (* loadimm + load *)
+ exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
+ exists (nextinstr (rs'#x <- v)); split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one; auto.
+ simpl. unfold load2. rewrite C; auto with asmgen. rewrite B. rewrite H0. auto.
+ intuition Simpl.
+(* float *)
+ rewrite (freg_of_eq _ _ EQ).
+ destruct (Int.eq (high_s ofs) Int.zero).
+ (* one load *)
+ econstructor; split. apply exec_straight_one. simpl.
+ unfold load1. rewrite gpr_or_zero_not_zero; auto. simpl. rewrite H0. eauto. auto.
+ intuition Simpl.
+ (* loadimm + load *)
exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
- exists (nextinstr (rs'#(preg_of dst) <- v)); split.
- eapply exec_straight_trans. eexact A.
- unfold preg_of. rewrite H0.
- destruct ty; apply exec_straight_one; auto with ppcgen; simpl.
- unfold load2. rewrite B. rewrite C; auto with ppcgen. simpl in H. rewrite H. auto.
- unfold load2. rewrite B. rewrite C; auto with ppcgen. simpl in H. rewrite H. auto.
- split. repeat SIMP.
- intros. repeat SIMP.
+ exists (nextinstr (rs'#x <- v)); split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one; auto.
+ simpl. unfold load2. rewrite C; auto with asmgen. rewrite B. rewrite H0. auto.
+ intuition Simpl.
Qed.
(** Indexed memory stores. *)
Lemma storeind_correct:
- forall (base: ireg) ofs ty src k (rs: regset) m m',
+ forall (base: ireg) ofs ty src k (rs: regset) m m' c,
+ storeind src base ofs ty k = OK c ->
Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' ->
- mreg_type src = ty ->
base <> GPR0 ->
exists rs',
- exec_straight (storeind src base ofs ty k) rs m k rs' m'
+ exec_straight ge fn c rs m k rs' m'
/\ forall r, r <> PC -> r <> GPR0 -> rs'#r = rs#r.
Proof.
- intros. unfold storeind. destruct (Int.eq (high_s ofs) Int.zero).
-(* one store *)
- exists (nextinstr rs); split.
- destruct ty; apply exec_straight_one; auto with ppcgen; simpl.
- unfold store1. rewrite gpr_or_zero_not_zero; auto.
- simpl in *. unfold preg_of in H; rewrite H0 in H. rewrite H. auto.
- unfold store1. rewrite gpr_or_zero_not_zero; auto.
- simpl in *. unfold preg_of in H; rewrite H0 in H. rewrite H. auto.
- intros. apply nextinstr_inv; auto.
-(* loadimm + one store *)
+ unfold storeind; intros.
+ assert (preg_of src <> GPR0) by auto with asmgen.
+ destruct ty; monadInv H; simpl in H0.
+(* integer *)
+ rewrite (ireg_of_eq _ _ EQ) in *.
+ destruct (Int.eq (high_s ofs) Int.zero).
+ (* one store *)
+ econstructor; split. apply exec_straight_one. simpl.
+ unfold store1. rewrite gpr_or_zero_not_zero; auto. simpl. rewrite H0. eauto. auto.
+ intros; Simpl.
+ (* loadimm + store *)
+ exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
+ exists (nextinstr rs'); split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one; auto.
+ simpl. unfold store2. rewrite B. rewrite ! C; auto with asmgen. rewrite H0. auto.
+ intuition Simpl.
+(* float *)
+ rewrite (freg_of_eq _ _ EQ) in *.
+ destruct (Int.eq (high_s ofs) Int.zero).
+ (* one store *)
+ econstructor; split. apply exec_straight_one. simpl.
+ unfold store1. rewrite gpr_or_zero_not_zero; auto. simpl. rewrite H0. eauto. auto.
+ intuition Simpl.
+ (* loadimm + store *)
exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
- assert (rs' base = rs base). apply C; auto with ppcgen.
- assert (rs' (preg_of src) = rs (preg_of src)). apply C; auto with ppcgen.
- exists (nextinstr rs').
- split. eapply exec_straight_trans. eexact A.
- destruct ty; apply exec_straight_one; auto with ppcgen; simpl.
- unfold store2. replace (IR (ireg_of src)) with (preg_of src).
- rewrite H2; rewrite H3. rewrite B. simpl in H. rewrite H. auto.
- unfold preg_of; rewrite H0; auto.
- unfold store2. replace (FR (freg_of src)) with (preg_of src).
- rewrite H2; rewrite H3. rewrite B. simpl in H. rewrite H. auto.
- unfold preg_of; rewrite H0; auto.
- intros. rewrite nextinstr_inv; auto.
+ exists (nextinstr rs'); split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one; auto.
+ simpl. unfold store2. rewrite B. rewrite ! C; auto with asmgen. rewrite H0. auto.
+ intuition Simpl.
Qed.
(** Float comparisons. *)
@@ -920,7 +498,7 @@ Qed.
Lemma floatcomp_correct:
forall cmp (r1 r2: freg) k rs m,
exists rs',
- exec_straight (floatcomp cmp r1 r2 k) rs m k rs' m
+ exec_straight ge fn (floatcomp cmp r1 r2 k) rs m k rs' m
/\ rs'#(reg_of_crbit (fst (crbit_for_fcmp cmp))) =
(if snd (crbit_for_fcmp cmp)
then Val.cmpf cmp rs#r1 rs#r2
@@ -938,10 +516,10 @@ Proof.
case cmp; tauto.
unfold floatcomp. elim H; intro; clear H.
exists rs1.
- split. generalize H0; intros [EQ|[EQ|[EQ|EQ]]]; subst cmp;
+ split. destruct H0 as [EQ|[EQ|[EQ|EQ]]]; subst cmp;
apply exec_straight_one; reflexivity.
split.
- generalize H0; intros [EQ|[EQ|[EQ|EQ]]]; subst cmp; simpl; auto.
+ destruct H0 as [EQ|[EQ|[EQ|EQ]]]; subst cmp; simpl; auto.
rewrite Val.negate_cmpf_eq. auto.
auto.
(* two instrs *)
@@ -958,155 +536,132 @@ Proof.
split. elim H0; intro; subst cmp; simpl.
reflexivity.
reflexivity.
- intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+ intros. Simpl.
Qed.
-Ltac TypeInv :=
- match goal with
- | H: (List.map ?f ?x = nil) |- _ =>
- destruct x; [clear H | simpl in H; discriminate]
- | H: (List.map ?f ?x = ?hd :: ?tl) |- _ =>
- destruct x; simpl in H;
- [ discriminate |
- injection H; clear H; let T := fresh "T" in (
- intros H T; TypeInv) ]
- | _ => idtac
- end.
-
-Ltac UseTypeInfo :=
- match goal with
- | T: (mreg_type ?r = ?t), H: context[preg_of ?r] |- _ =>
- unfold preg_of in H; UseTypeInfo
- | T: (mreg_type ?r = ?t), H: context[mreg_type ?r] |- _ =>
- rewrite T in H; UseTypeInfo
- | T: (mreg_type ?r = ?t) |- context[preg_of ?r] =>
- unfold preg_of; UseTypeInfo
- | T: (mreg_type ?r = ?t) |- context[mreg_type ?r] =>
- rewrite T; UseTypeInfo
- | _ => idtac
- end.
-
(** Translation of conditions. *)
+Ltac ArgsInv :=
+ repeat (match goal with
+ | [ H: Error _ = OK _ |- _ ] => discriminate
+ | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args
+ | [ H: bind _ _ = OK _ |- _ ] => monadInv H
+ | [ H: assertion _ = OK _ |- _ ] => monadInv H
+ end);
+ subst;
+ repeat (match goal with
+ | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *
+ | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *
+ end).
+
Lemma transl_cond_correct_1:
- forall cond args k rs m,
- map mreg_type args = type_of_condition cond ->
+ forall cond args k rs m c,
+ transl_cond cond args k = OK c ->
exists rs',
- exec_straight (transl_cond cond args k) rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
(if snd (crbit_for_cond cond)
then Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)
else Val.notbool (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)))
- /\ forall r, is_data_reg r = true -> rs'#r = rs#r.
+ /\ forall r, data_preg r = true -> rs'#r = rs#r.
Proof.
intros.
Opaque Int.eq.
- destruct cond; simpl in H; TypeInv; simpl; UseTypeInfo.
+ unfold transl_cond in H; destruct cond; ArgsInv; simpl.
(* Ccomp *)
- fold (Val.cmp c (rs (ireg_of m0)) (rs (ireg_of m1))).
- destruct (compare_sint_spec rs (rs (ireg_of m0)) (rs (ireg_of m1)))
- as [A [B [C D]]].
+ fold (Val.cmp c0 (rs x) (rs x0)).
+ destruct (compare_sint_spec rs (rs x) (rs x0)) as [A [B [C D]]].
econstructor; split.
apply exec_straight_one. simpl; reflexivity. reflexivity.
split.
- case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
- auto with ppcgen.
+ case c0; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
+ auto with asmgen.
(* Ccompu *)
- fold (Val.cmpu (Mem.valid_pointer m) c (rs (ireg_of m0)) (rs (ireg_of m1))).
- destruct (compare_uint_spec rs m (rs (ireg_of m0)) (rs (ireg_of m1)))
- as [A [B [C D]]].
+ fold (Val.cmpu (Mem.valid_pointer m) c0 (rs x) (rs x0)).
+ destruct (compare_uint_spec rs m (rs x) (rs x0)) as [A [B [C D]]].
econstructor; split.
apply exec_straight_one. simpl; reflexivity. reflexivity.
split.
- case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
- auto with ppcgen.
+ case c0; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
+ auto with asmgen.
(* Ccompimm *)
- fold (Val.cmp c (rs (ireg_of m0)) (Vint i)).
- case (Int.eq (high_s i) Int.zero).
- destruct (compare_sint_spec rs (rs (ireg_of m0)) (Vint i))
- as [A [B [C D]]].
+ fold (Val.cmp c0 (rs x) (Vint i)).
+ destruct (Int.eq (high_s i) Int.zero); inv EQ0.
+ destruct (compare_sint_spec rs (rs x) (Vint i)) as [A [B [C D]]].
econstructor; split.
- apply exec_straight_one. simpl. eauto. reflexivity.
+ apply exec_straight_one. simpl; reflexivity. reflexivity.
split.
- case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
- auto with ppcgen.
- generalize (loadimm_correct GPR0 i (Pcmpw (ireg_of m0) GPR0 :: k) rs m).
- intros [rs1 [EX1 [RES1 OTH1]]].
- destruct (compare_sint_spec rs1 (rs (ireg_of m0)) (Vint i))
- as [A [B [C D]]].
- assert (rs1 (ireg_of m0) = rs (ireg_of m0)).
- apply OTH1; auto with ppcgen.
- exists (nextinstr (compare_sint rs1 (rs1 (ireg_of m0)) (Vint i))).
+ case c0; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
+ auto with asmgen.
+ destruct (loadimm_correct GPR0 i (Pcmpw x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]].
+ destruct (compare_sint_spec rs1 (rs x) (Vint i)) as [A [B [C D]]].
+ assert (SAME: rs1 x = rs x) by (apply OTH1; eauto with asmgen).
+ exists (nextinstr (compare_sint rs1 (rs1 x) (Vint i))).
split. eapply exec_straight_trans. eexact EX1.
- apply exec_straight_one. simpl. rewrite RES1; rewrite H; auto.
+ apply exec_straight_one. simpl. rewrite RES1; rewrite SAME; auto.
reflexivity.
- split. rewrite H.
- case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
- intros. rewrite H; rewrite D; auto with ppcgen.
+ split. rewrite SAME.
+ case c0; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
+ intros. rewrite SAME; rewrite D; auto with asmgen.
(* Ccompuimm *)
- fold (Val.cmpu (Mem.valid_pointer m) c (rs (ireg_of m0)) (Vint i)).
- case (Int.eq (high_u i) Int.zero).
- destruct (compare_uint_spec rs m (rs (ireg_of m0)) (Vint i))
- as [A [B [C D]]].
+ fold (Val.cmpu (Mem.valid_pointer m) c0 (rs x) (Vint i)).
+ destruct (Int.eq (high_u i) Int.zero); inv EQ0.
+ destruct (compare_uint_spec rs m (rs x) (Vint i)) as [A [B [C D]]].
econstructor; split.
- apply exec_straight_one. simpl. eauto. reflexivity.
+ apply exec_straight_one. simpl; reflexivity. reflexivity.
split.
- case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
- auto with ppcgen.
- generalize (loadimm_correct GPR0 i (Pcmplw (ireg_of m0) GPR0 :: k) rs m).
- intros [rs1 [EX1 [RES1 OTH1]]].
- destruct (compare_uint_spec rs1 m (rs (ireg_of m0)) (Vint i))
- as [A [B [C D]]].
- assert (rs1 (ireg_of m0) = rs (ireg_of m0)). apply OTH1; auto with ppcgen.
- exists (nextinstr (compare_uint rs1 m (rs1 (ireg_of m0)) (Vint i))).
+ case c0; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
+ auto with asmgen.
+ destruct (loadimm_correct GPR0 i (Pcmplw x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]].
+ destruct (compare_uint_spec rs1 m (rs x) (Vint i)) as [A [B [C D]]].
+ assert (SAME: rs1 x = rs x) by (apply OTH1; eauto with asmgen).
+ exists (nextinstr (compare_uint rs1 m (rs1 x) (Vint i))).
split. eapply exec_straight_trans. eexact EX1.
- apply exec_straight_one. simpl. rewrite RES1; rewrite H; auto.
+ apply exec_straight_one. simpl. rewrite RES1; rewrite SAME; auto.
reflexivity.
- split. rewrite H.
- case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
- intros. rewrite H; rewrite D; auto with ppcgen.
+ split. rewrite SAME.
+ case c0; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
+ intros. rewrite SAME; rewrite D; auto with asmgen.
(* Ccompf *)
- fold (Val.cmpf c (rs (freg_of m0)) (rs (freg_of m1))).
- destruct (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m)
- as [rs' [EX [RES OTH]]].
+ fold (Val.cmpf c0 (rs x) (rs x0)).
+ destruct (floatcomp_correct c0 x x0 k rs m) as [rs' [EX [RES OTH]]].
exists rs'. split. auto.
split. apply RES.
- auto with ppcgen.
+ auto with asmgen.
(* Cnotcompf *)
rewrite Val.notbool_negb_3. rewrite Val.notbool_idem4.
- fold (Val.cmpf c (rs (freg_of m0)) (rs (freg_of m1))).
- destruct (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m)
- as [rs' [EX [RES OTH]]].
+ fold (Val.cmpf c0 (rs x) (rs x0)).
+ destruct (floatcomp_correct c0 x x0 k rs m) as [rs' [EX [RES OTH]]].
exists rs'. split. auto.
- split. rewrite RES. destruct (snd (crbit_for_fcmp c)); auto.
- auto with ppcgen.
+ split. rewrite RES. destruct (snd (crbit_for_fcmp c0)); auto.
+ auto with asmgen.
(* Cmaskzero *)
- destruct (andimm_base_correct GPR0 (ireg_of m0) i k rs m)
- as [rs' [A [B [C D]]]]. auto with ppcgen.
+ destruct (andimm_base_correct GPR0 x i k rs m) as [rs' [A [B [C D]]]].
+ eauto with asmgen.
exists rs'. split. assumption.
- split. rewrite C. destruct (rs (ireg_of m0)); auto.
- auto with ppcgen.
+ split. rewrite C. destruct (rs x); auto.
+ auto with asmgen.
(* Cmasknotzero *)
- destruct (andimm_base_correct GPR0 (ireg_of m0) i k rs m)
- as [rs' [A [B [C D]]]]. auto with ppcgen.
+ destruct (andimm_base_correct GPR0 x i k rs m) as [rs' [A [B [C D]]]].
+ eauto with asmgen.
exists rs'. split. assumption.
- split. rewrite C. destruct (rs (ireg_of m0)); auto.
+ split. rewrite C. destruct (rs x); auto.
fold (option_map negb (Some (Int.eq (Int.and i0 i) Int.zero))).
rewrite Val.notbool_negb_3. rewrite Val.notbool_idem4. auto.
- auto with ppcgen.
+ auto with asmgen.
Qed.
Lemma transl_cond_correct_2:
- forall cond args k rs m b,
- map mreg_type args = type_of_condition cond ->
+ forall cond args k rs m b c,
+ transl_cond cond args k = OK c ->
eval_condition cond (map rs (map preg_of args)) m = Some b ->
exists rs',
- exec_straight (transl_cond cond args k) rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
(if snd (crbit_for_cond cond)
then Val.of_bool b
else Val.notbool (Val.of_bool b))
- /\ forall r, is_data_reg r = true -> rs'#r = rs#r.
+ /\ forall r, data_preg r = true -> rs'#r = rs#r.
Proof.
intros.
replace (Val.of_bool b)
@@ -1115,14 +670,14 @@ Proof.
rewrite H0; auto.
Qed.
-Lemma transl_cond_correct:
- forall cond args k ms sp rs m b m',
- map mreg_type args = type_of_condition cond ->
+Lemma transl_cond_correct_3:
+ forall cond args k ms sp rs m b m' c,
+ transl_cond cond args k = OK c ->
agree ms sp rs ->
eval_condition cond (map ms args) m = Some b ->
Mem.extends m m' ->
exists rs',
- exec_straight (transl_cond cond args k) rs m' k rs' m'
+ exec_straight ge fn c rs m' k rs' m'
/\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
(if snd (crbit_for_cond cond)
then Val.of_bool b
@@ -1184,66 +739,60 @@ Transparent Int.eq.
Qed.
Lemma transl_cond_op_correct:
- forall cond args r k rs m,
- mreg_type r = Tint ->
- map mreg_type args = type_of_condition cond ->
+ forall cond args r k rs m c,
+ transl_cond_op cond args r k = OK c ->
exists rs',
- exec_straight (transl_cond_op cond args r k) rs m k rs' m
- /\ rs'#(ireg_of r) = Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)
- /\ forall r', is_data_reg r' = true -> r' <> ireg_of r -> rs'#r' = rs#r'.
+ exec_straight ge fn c rs m k rs' m
+ /\ rs'#(preg_of r) = Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)
+ /\ forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r'.
Proof.
intros until args. unfold transl_cond_op.
- destruct (classify_condition cond args);
- intros until m; intros TY1 TY2; simpl in TY2.
+ destruct (classify_condition cond args); intros; monadInv H; simpl;
+ erewrite ! ireg_of_eq; eauto.
(* eq 0 *)
- inv TY2. simpl. unfold preg_of; rewrite H0.
econstructor; split.
eapply exec_straight_two; simpl; reflexivity.
- split. repeat SIMP. destruct (rs (ireg_of r)); simpl; auto.
+ split. Simpl. destruct (rs x0); simpl; auto.
apply add_carry_eq0.
- intros; repeat SIMP.
+ intros; Simpl.
(* ne 0 *)
- inv TY2. simpl. unfold preg_of; rewrite H0.
econstructor; split.
eapply exec_straight_two; simpl; reflexivity.
- split. repeat SIMP. rewrite gpr_or_zero_not_zero; auto with ppcgen.
- destruct (rs (ireg_of r)); simpl; auto.
+ rewrite gpr_or_zero_not_zero; eauto with asmgen.
+ split. Simpl. destruct (rs x0); simpl; auto.
apply add_carry_ne0.
- intros; repeat SIMP.
+ intros; Simpl.
(* ge 0 *)
- inv TY2. simpl. unfold preg_of; rewrite H0.
econstructor; split.
eapply exec_straight_two; simpl; reflexivity.
- split. repeat SIMP. rewrite Val.rolm_ge_zero. auto.
- intros; repeat SIMP.
+ split. Simpl. rewrite Val.rolm_ge_zero. auto.
+ intros; Simpl.
(* lt 0 *)
- inv TY2. simpl. unfold preg_of; rewrite H0.
econstructor; split.
apply exec_straight_one; simpl; reflexivity.
- split. repeat SIMP. rewrite Val.rolm_lt_zero. auto.
- intros; repeat SIMP.
+ split. Simpl. rewrite Val.rolm_lt_zero. auto.
+ intros; Simpl.
(* default *)
- set (bit := fst (crbit_for_cond c)).
- set (isset := snd (crbit_for_cond c)).
+ set (bit := fst (crbit_for_cond c)) in *.
+ set (isset := snd (crbit_for_cond c)) in *.
set (k1 :=
- Pmfcrbit (ireg_of r) bit ::
+ Pmfcrbit x bit ::
(if isset
then k
- else Pxori (ireg_of r) (ireg_of r) (Cint Int.one) :: k)).
- generalize (transl_cond_correct_1 c rl k1 rs m TY2).
+ else Pxori x x (Cint Int.one) :: k)).
+ generalize (transl_cond_correct_1 c rl k1 rs m c0 EQ0).
fold bit; fold isset.
intros [rs1 [EX1 [RES1 AG1]]].
destruct isset.
(* bit set *)
econstructor; split. eapply exec_straight_trans. eexact EX1.
- unfold k1. apply exec_straight_one; simpl; reflexivity.
- split. repeat SIMP. intros; repeat SIMP.
+ unfold k1. apply exec_straight_one; simpl; reflexivity.
+ intuition Simpl.
(* bit clear *)
econstructor; split. eapply exec_straight_trans. eexact EX1.
- unfold k1. eapply exec_straight_two; simpl; reflexivity.
- split. repeat SIMP. rewrite RES1.
- destruct (eval_condition c rs ## (preg_of ## rl) m). destruct b; auto. auto.
- intros; repeat SIMP.
+ unfold k1. eapply exec_straight_two; simpl; reflexivity.
+ intuition Simpl.
+ rewrite RES1. destruct (eval_condition c rs ## (preg_of ## rl) m). destruct b; auto. auto.
Qed.
(** Translation of arithmetic operations. *)
@@ -1251,137 +800,123 @@ Qed.
Ltac TranslOpSimpl :=
econstructor; split;
[ apply exec_straight_one; [simpl; eauto | reflexivity]
- | split; intros; (repeat SIMP; fail) ].
+ | split; intros; Simpl; fail ].
Lemma transl_op_correct_aux:
- forall op args res k (rs: regset) m v,
- wt_instr (Mop op args res) ->
+ forall op args res k (rs: regset) m v c,
+ transl_op op args res k = OK c ->
eval_operation ge (rs#GPR1) op (map rs (map preg_of args)) m = Some v ->
exists rs',
- exec_straight (transl_op op args res k) rs m k rs' m
+ exec_straight ge fn c rs m k rs' m
/\ rs'#(preg_of res) = v
/\ forall r,
- match op with Omove => is_data_reg r = true | _ => is_nontemp_reg r = true end ->
+ match op with Omove => data_preg r = true | _ => nontemp_preg r = true end ->
r <> preg_of res -> rs'#r = rs#r.
Proof.
- intros until v; intros WT EV.
- inv WT.
+Opaque Int.eq. Opaque Int.repr.
+ intros. unfold transl_op in H; destruct op; ArgsInv; simpl in H0; try (inv H0); try TranslOpSimpl.
(* Omove *)
- simpl in *. inv EV.
- exists (nextinstr (rs#(preg_of res) <- (rs#(preg_of r1)))).
- split. unfold preg_of. rewrite <- H0.
- destruct (mreg_type r1); apply exec_straight_one; auto.
- split. repeat SIMP. intros; repeat SIMP.
- (* Other instructions *)
-Opaque Int.eq.
- destruct op; simpl; simpl in H3; injection H3; clear H3; intros;
- TypeInv; simpl in *; UseTypeInfo; inv EV; try (TranslOpSimpl).
+ destruct (preg_of res) eqn:RES; destruct (preg_of m0) eqn:ARG; inv H.
+ TranslOpSimpl.
+ TranslOpSimpl.
(* Ointconst *)
- destruct (loadimm_correct (ireg_of res) i k rs m) as [rs' [A [B C]]].
- exists rs'. split. auto. split. auto. auto with ppcgen.
+ destruct (loadimm_correct x i k rs m) as [rs' [A [B C]]].
+ exists rs'. auto with asmgen.
(* Oaddrsymbol *)
change (symbol_address ge i i0) with (symbol_offset ge i i0).
set (v' := symbol_offset ge i i0).
- caseEq (symbol_is_small_data i i0); intro SD.
+ destruct (symbol_is_small_data i i0) eqn:SD.
(* small data *)
econstructor; split. apply exec_straight_one; simpl; reflexivity.
- split. repeat SIMP.
- rewrite (small_data_area_addressing _ _ _ SD). unfold v', symbol_offset.
+ split. Simpl. rewrite (small_data_area_addressing _ _ _ SD). unfold v', symbol_offset.
destruct (Genv.find_symbol ge i); auto. rewrite Int.add_zero; auto.
- intros; repeat SIMP.
+ intros; Simpl.
(* not small data *)
Opaque Val.add.
econstructor; split. eapply exec_straight_two; simpl; reflexivity.
- split. repeat SIMP. rewrite gpr_or_zero_zero.
- rewrite gpr_or_zero_not_zero; auto with ppcgen. repeat SIMP.
+ split. Simpl. rewrite gpr_or_zero_zero.
+ rewrite gpr_or_zero_not_zero; eauto with asmgen. Simpl.
rewrite (Val.add_commut Vzero). rewrite high_half_zero.
rewrite Val.add_commut. rewrite low_high_half. auto.
- intros; repeat SIMP.
+ intros; Simpl.
(* Oaddrstack *)
- destruct (addimm_correct (ireg_of res) GPR1 i k rs m) as [rs' [EX [RES OTH]]].
- auto with ppcgen. congruence.
- exists rs'; auto with ppcgen.
+ destruct (addimm_correct x GPR1 i k rs m) as [rs' [EX [RES OTH]]]; eauto with asmgen.
+ exists rs'; auto with asmgen.
(* Oaddimm *)
- destruct (addimm_correct (ireg_of res) (ireg_of m0) i k rs m) as [rs' [A [B C]]]; auto with ppcgen.
- exists rs'; auto with ppcgen.
+ destruct (addimm_correct x0 x i k rs m) as [rs' [A [B C]]]; eauto with asmgen.
+ exists rs'; auto with asmgen.
(* Osubimm *)
case (Int.eq (high_s i) Int.zero).
TranslOpSimpl.
- destruct (loadimm_correct GPR0 i (Psubfc (ireg_of res) (ireg_of m0) GPR0 :: k) rs m) as [rs1 [EX [RES OTH]]].
+ destruct (loadimm_correct GPR0 i (Psubfc x0 x GPR0 :: k) rs m) as [rs1 [EX [RES OTH]]].
econstructor; split.
eapply exec_straight_trans. eexact EX. apply exec_straight_one; simpl; reflexivity.
- split. repeat SIMP. rewrite RES. rewrite OTH; auto with ppcgen.
- intros; repeat SIMP.
+ split. Simpl. rewrite RES. rewrite OTH; eauto with asmgen.
+ intros; Simpl.
(* Omulimm *)
case (Int.eq (high_s i) Int.zero).
TranslOpSimpl.
- destruct (loadimm_correct GPR0 i (Pmullw (ireg_of res) (ireg_of m0) GPR0 :: k) rs m) as [rs1 [EX [RES OTH]]].
+ destruct (loadimm_correct GPR0 i (Pmullw x0 x GPR0 :: k) rs m) as [rs1 [EX [RES OTH]]].
econstructor; split.
eapply exec_straight_trans. eexact EX. apply exec_straight_one; simpl; reflexivity.
- split. repeat SIMP. rewrite RES. rewrite OTH; auto with ppcgen.
- intros; repeat SIMP.
+ split. Simpl. rewrite RES. rewrite OTH; eauto with asmgen.
+ intros; Simpl.
(* Odivs *)
- replace v with (Val.maketotal (Val.divs (rs (ireg_of m0)) (rs (ireg_of m1)))).
+ replace v with (Val.maketotal (Val.divs (rs x) (rs x0))).
TranslOpSimpl.
- rewrite H2; auto.
+ rewrite H1; auto.
(* Odivu *)
- replace v with (Val.maketotal (Val.divu (rs (ireg_of m0)) (rs (ireg_of m1)))).
+ replace v with (Val.maketotal (Val.divu (rs x) (rs x0))).
TranslOpSimpl.
- rewrite H2; auto.
+ rewrite H1; auto.
(* Oand *)
- set (v' := Val.and (rs (ireg_of m0)) (rs (ireg_of m1))) in *.
- pose (rs1 := rs#(ireg_of res) <- v').
- generalize (compare_sint_spec rs1 v' Vzero).
- intros [A [B [C D]]].
+ set (v' := Val.and (rs x) (rs x0)) in *.
+ pose (rs1 := rs#x1 <- v').
+ destruct (compare_sint_spec rs1 v' Vzero) as [A [B [C D]]].
econstructor; split. apply exec_straight_one; simpl; reflexivity.
- split. rewrite D; auto with ppcgen. unfold rs1. SIMP.
- intros. rewrite D; auto with ppcgen. unfold rs1. SIMP.
+ split. rewrite D; auto with asmgen. unfold rs1; Simpl.
+ intros. rewrite D; auto with asmgen. unfold rs1; Simpl.
(* Oandimm *)
- destruct (andimm_correct (ireg_of res) (ireg_of m0) i k rs m) as [rs' [A [B C]]]; auto with ppcgen.
- exists rs'; auto with ppcgen.
+ destruct (andimm_correct x0 x i k rs m) as [rs' [A [B C]]]; eauto with asmgen.
+ exists rs'; auto with asmgen.
(* Oorimm *)
- destruct (orimm_correct (ireg_of res) (ireg_of m0) i k rs m) as [rs' [A [B C]]].
- exists rs'; auto with ppcgen.
+ destruct (orimm_correct x0 x i k rs m) as [rs' [A [B C]]].
+ exists rs'; auto with asmgen.
(* Oxorimm *)
- destruct (xorimm_correct (ireg_of res) (ireg_of m0) i k rs m) as [rs' [A [B C]]].
- exists rs'; auto with ppcgen.
+ destruct (xorimm_correct x0 x i k rs m) as [rs' [A [B C]]].
+ exists rs'; auto with asmgen.
(* Onor *)
- replace (Val.notint (rs (ireg_of m0)))
- with (Val.notint (Val.or (rs (ireg_of m0)) (rs (ireg_of m0)))).
+ replace (Val.notint (rs x))
+ with (Val.notint (Val.or (rs x) (rs x))).
TranslOpSimpl.
- destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.or_idem. auto.
+ destruct (rs x); simpl; auto. rewrite Int.or_idem. auto.
(* Oshrximm *)
econstructor; split.
eapply exec_straight_two; simpl; reflexivity.
- split. repeat SIMP. apply Val.shrx_carry. auto.
- intros; repeat SIMP.
+ split. Simpl. apply Val.shrx_carry. auto.
+ intros; Simpl.
(* Orolm *)
- destruct (rolm_correct (ireg_of res) (ireg_of m0) i i0 k rs m) as [rs' [A [B C]]]; auto with ppcgen.
- exists rs'; auto with ppcgen.
- (* Oroli *)
- destruct (mreg_eq m0 res). subst m0.
- TranslOpSimpl.
- econstructor; split.
- eapply exec_straight_three; simpl; reflexivity.
- split. repeat SIMP. intros; repeat SIMP.
+ destruct (rolm_correct x0 x i i0 k rs m) as [rs' [A [B C]]]; eauto with asmgen.
+ exists rs'; auto with asmgen.
(* Ointoffloat *)
- replace v with (Val.maketotal (Val.intoffloat (rs (freg_of m0)))).
+ replace v with (Val.maketotal (Val.intoffloat (rs x))).
TranslOpSimpl.
- rewrite H2; auto.
+ rewrite H1; auto.
(* Ocmp *)
- destruct (transl_cond_op_correct c args res k rs m) as [rs' [A [B C]]]; auto.
- exists rs'; auto with ppcgen.
+ destruct (transl_cond_op_correct c0 args res k rs m c) as [rs' [A [B C]]]; auto.
+ exists rs'; auto with asmgen.
Qed.
Lemma transl_op_correct:
- forall op args res k ms sp rs m v m',
- wt_instr (Mop op args res) ->
+ forall op args res k ms sp rs m v m' c,
+ transl_op op args res k = OK c ->
agree ms sp rs ->
eval_operation ge sp op (map ms args) m = Some v ->
Mem.extends m m' ->
exists rs',
- exec_straight (transl_op op args res k) rs m' k rs' m'
- /\ agree (Regmap.set res v (undef_op op ms)) sp rs'.
+ exec_straight ge fn c rs m' k rs' m'
+ /\ agree (Regmap.set res v (undef_op op ms)) sp rs'
+ /\ forall r, op = Omove -> data_preg r = true -> r <> preg_of res -> rs'#r = rs#r.
Proof.
intros.
exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eauto.
@@ -1389,74 +924,67 @@ Proof.
exploit transl_op_correct_aux; eauto. intros [rs' [P [Q R]]].
rewrite <- Q in B.
exists rs'; split. eexact P.
- unfold undef_op. destruct op;
- (apply agree_set_mreg_undef_temps with rs || apply agree_set_mreg with rs);
+ split. unfold undef_op. destruct op;
+ (apply agree_set_undef_mreg with rs || apply agree_set_mreg with rs);
auto.
+ intros. subst op. auto.
Qed.
-Lemma transl_load_store_correct:
- forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction)
- addr args (temp: ireg) k ms sp rs m ms' m',
+(** Translation of memory accesses *)
+
+Lemma transl_memory_access_correct:
+ forall (P: regset -> Prop) mk1 mk2 addr args temp k c (rs: regset) a m m',
+ transl_memory_access mk1 mk2 addr args temp k = OK c ->
+ eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a ->
+ temp <> GPR0 ->
(forall cst (r1: ireg) (rs1: regset) k,
- eval_addressing ge sp addr (map rs (map preg_of args)) =
- Some(Val.add (gpr_or_zero rs1 r1) (const_low ge cst)) ->
- (forall (r: preg), r <> PC -> r <> temp -> rs1 r = rs r) ->
+ Val.add (gpr_or_zero rs1 r1) (const_low ge cst) = a ->
+ (forall r, r <> PC -> r <> temp -> rs1 r = rs r) ->
exists rs',
- exec_straight (mk1 cst r1 :: k) rs1 m k rs' m' /\
- agree ms' sp rs') ->
- (forall (r1 r2: ireg) k,
- eval_addressing ge sp addr (map rs (map preg_of args)) = Some(Val.add rs#r1 rs#r2) ->
+ exec_straight ge fn (mk1 cst r1 :: k) rs1 m k rs' m' /\ P rs') ->
+ (forall (r1 r2: ireg) (rs1: regset) k,
+ Val.add rs1#r1 rs1#r2 = a ->
+ (forall r, r <> PC -> r <> temp -> rs1 r = rs r) ->
exists rs',
- exec_straight (mk2 r1 r2 :: k) rs m k rs' m' /\
- agree ms' sp rs') ->
- agree ms sp rs ->
- map mreg_type args = type_of_addressing addr ->
- temp <> GPR0 ->
+ exec_straight ge fn (mk2 r1 r2 :: k) rs1 m k rs' m' /\ P rs') ->
exists rs',
- exec_straight (transl_load_store mk1 mk2 addr args temp k) rs m
- k rs' m'
- /\ agree ms' sp rs'.
+ exec_straight ge fn c rs m k rs' m' /\ P rs'.
Proof.
- intros. destruct addr; simpl in H2; TypeInv; simpl.
+ intros until m'; intros TR ADDR TEMP MK1 MK2.
+ unfold transl_memory_access in TR; destruct addr; ArgsInv; simpl in ADDR; inv ADDR.
(* Aindexed *)
case (Int.eq (high_s i) Int.zero).
(* Aindexed short *)
- apply H.
- simpl. UseTypeInfo. rewrite gpr_or_zero_not_zero; auto with ppcgen.
- auto.
+ apply MK1. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
(* Aindexed long *)
- set (rs1 := nextinstr (rs#temp <- (Val.add (rs (ireg_of m0)) (Vint (Int.shl (high_s i) (Int.repr 16)))))).
- exploit (H (Cint (low_s i)) temp rs1 k).
- simpl. UseTypeInfo. rewrite gpr_or_zero_not_zero; auto.
- unfold rs1; repeat SIMP. rewrite Val.add_assoc.
+ set (rs1 := nextinstr (rs#temp <- (Val.add (rs x) (Vint (Int.shl (high_s i) (Int.repr 16)))))).
+ exploit (MK1 (Cint (low_s i)) temp rs1 k).
+ simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen.
+ unfold rs1; Simpl. rewrite Val.add_assoc.
Transparent Val.add.
simpl. rewrite low_high_s. auto.
- intros; unfold rs1; repeat SIMP.
+ intros; unfold rs1; Simpl.
intros [rs' [EX' AG']].
exists rs'. split. apply exec_straight_step with rs1 m.
- simpl. rewrite gpr_or_zero_not_zero; auto with ppcgen. auto.
+ simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
auto. auto.
(* Aindexed2 *)
- apply H0.
- simpl. UseTypeInfo; auto.
+ apply MK2; auto.
(* Aglobal *)
- case_eq (symbol_is_small_data i i0); intro SISD.
+ destruct (symbol_is_small_data i i0) eqn:SISD; inv TR.
(* Aglobal from small data *)
- apply H. rewrite gpr_or_zero_zero. simpl const_low.
- rewrite small_data_area_addressing; auto. simpl.
+ apply MK1. simpl. rewrite small_data_area_addressing; auto.
unfold symbol_address, symbol_offset.
destruct (Genv.find_symbol ge i); auto. rewrite Int.add_zero. auto.
auto.
(* Aglobal general case *)
set (rs1 := nextinstr (rs#temp <- (const_high ge (Csymbol_high i i0)))).
- exploit (H (Csymbol_low i i0) temp rs1 k).
- simpl. rewrite gpr_or_zero_not_zero; auto.
- unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss.
- unfold const_high, const_low.
- set (v := symbol_offset ge i i0).
- symmetry. rewrite Val.add_commut. unfold v. rewrite low_high_half. auto.
- discriminate.
- intros; unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+ exploit (MK1 (Csymbol_low i i0) temp rs1 k).
+ simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen.
+ unfold rs1. Simpl.
+ unfold const_high, const_low.
+ rewrite Val.add_commut. rewrite low_high_half. auto.
+ intros; unfold rs1; Simpl.
intros [rs' [EX' AG']].
exists rs'. split. apply exec_straight_step with rs1 m.
unfold exec_instr. rewrite gpr_or_zero_zero.
@@ -1465,27 +993,24 @@ Transparent Val.add.
reflexivity. reflexivity.
assumption. assumption.
(* Abased *)
- set (rs1 := nextinstr (rs#temp <- (Val.add (rs (ireg_of m0)) (const_high ge (Csymbol_high i i0))))).
- exploit (H (Csymbol_low i i0) temp rs1 k).
- simpl. rewrite gpr_or_zero_not_zero; auto.
- unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss.
+ set (rs1 := nextinstr (rs#temp <- (Val.add (rs x) (const_high ge (Csymbol_high i i0))))).
+ exploit (MK1 (Csymbol_low i i0) temp rs1 k).
+ simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen.
+ unfold rs1. Simpl.
rewrite Val.add_assoc.
unfold const_high, const_low.
- set (v := symbol_offset ge i i0).
- symmetry. rewrite Val.add_commut. decEq. decEq.
- unfold v. rewrite Val.add_commut. rewrite low_high_half. auto.
- UseTypeInfo. auto. discriminate.
- intros. unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+ symmetry. rewrite Val.add_commut. f_equal. f_equal.
+ rewrite Val.add_commut. rewrite low_high_half. auto.
+ intros; unfold rs1; Simpl.
intros [rs' [EX' AG']].
exists rs'. split. apply exec_straight_step with rs1 m.
- unfold exec_instr. rewrite gpr_or_zero_not_zero; auto with ppcgen. auto.
+ unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
assumption. assumption.
(* Ainstack *)
- case (Int.eq (high_s i) Int.zero).
- apply H. simpl. rewrite gpr_or_zero_not_zero; auto with ppcgen.
- rewrite (sp_val ms sp rs); auto. auto.
- set (rs1 := nextinstr (rs#temp <- (Val.add sp (Vint (Int.shl (high_s i) (Int.repr 16)))))).
- exploit (H (Cint (low_s i)) temp rs1 k).
+ destruct (Int.eq (high_s i) Int.zero); inv TR.
+ apply MK1. simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
+ set (rs1 := nextinstr (rs#temp <- (Val.add rs#GPR1 (Vint (Int.shl (high_s i) (Int.repr 16)))))).
+ exploit (MK1 (Cint (low_s i)) temp rs1 k).
simpl. rewrite gpr_or_zero_not_zero; auto.
unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss.
rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
@@ -1493,120 +1018,149 @@ Transparent Val.add.
intros. unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
intros [rs' [EX' AG']].
exists rs'. split. apply exec_straight_step with rs1 m.
- unfold exec_instr. rewrite gpr_or_zero_not_zero; auto with ppcgen.
- rewrite <- (sp_val ms sp rs); auto. auto.
+ unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
assumption. assumption.
Qed.
-(** Translation of memory loads. *)
+(** Translation of loads *)
Lemma transl_load_correct:
- forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction)
- chunk addr args k ms sp rs m m' dst a v,
- (forall cst (r1: ireg) (rs1: regset),
- exec_instr ge fn (mk1 cst r1) rs1 m' =
- load1 ge chunk (preg_of dst) cst r1 rs1 m') ->
- (forall (r1 r2: ireg) (rs1: regset),
- exec_instr ge fn (mk2 r1 r2) rs1 m' =
- load2 chunk (preg_of dst) r1 r2 rs1 m') ->
- agree ms sp rs ->
- map mreg_type args = type_of_addressing addr ->
- eval_addressing ge sp addr (map ms args) = Some a ->
+ forall chunk addr args dst k c (rs: regset) m a v,
+ transl_load chunk addr args dst k = OK c ->
+ eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a ->
Mem.loadv chunk m a = Some v ->
- Mem.extends m m' ->
exists rs',
- exec_straight (transl_load_store mk1 mk2 addr args GPR12 k) rs m'
- k rs' m'
- /\ agree (Regmap.set dst v (undef_temps ms)) sp rs'.
+ exec_straight ge fn c rs m k rs' m
+ /\ rs'#(preg_of dst) = v
+ /\ forall r, r <> PC -> r <> GPR12 -> r <> preg_of dst -> rs' r = rs r.
Proof.
intros.
- exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto.
- unfold PregEq.t.
- intros [a' [A B]].
- exploit Mem.loadv_extends; eauto. intros [v' [C D]].
- apply transl_load_store_correct with ms; auto.
-(* mk1 *)
- intros. exists (nextinstr (rs1#(preg_of dst) <- v')).
- split. apply exec_straight_one. rewrite H.
- unfold load1. rewrite A in H6. inv H6. rewrite C. auto.
- unfold nextinstr. SIMP. decEq. SIMP. apply sym_not_equal; auto with ppcgen.
- apply agree_set_mreg with rs1.
- apply agree_undef_temps with rs; auto with ppcgen.
- repeat SIMP.
- intros; repeat SIMP.
-(* mk2 *)
- intros. exists (nextinstr (rs#(preg_of dst) <- v')).
- split. apply exec_straight_one. rewrite H0.
- unfold load2. rewrite A in H6. inv H6. rewrite C. auto.
- unfold nextinstr. SIMP. decEq. SIMP. apply sym_not_equal; auto with ppcgen.
- apply agree_set_mreg with rs.
- apply agree_undef_temps with rs; auto with ppcgen.
- repeat SIMP.
- intros; repeat SIMP.
-(* not GPR0 *)
- congruence.
-Qed.
-
-(** Translation of memory stores. *)
+ assert (BASE: forall mk1 mk2 k' chunk' v',
+ transl_memory_access mk1 mk2 addr args GPR12 k' = OK c ->
+ Mem.loadv chunk' m a = Some v' ->
+ (forall cst (r1: ireg) (rs1: regset),
+ exec_instr ge fn (mk1 cst r1) rs1 m =
+ load1 ge chunk' (preg_of dst) cst r1 rs1 m) ->
+ (forall (r1 r2: ireg) (rs1: regset),
+ exec_instr ge fn (mk2 r1 r2) rs1 m =
+ load2 chunk' (preg_of dst) r1 r2 rs1 m) ->
+ exists rs',
+ exec_straight ge fn c rs m k' rs' m
+ /\ rs'#(preg_of dst) = v'
+ /\ forall r, r <> PC -> r <> GPR12 -> r <> preg_of dst -> rs' r = rs r).
+ {
+ intros. eapply transl_memory_access_correct; eauto. congruence.
+ intros. econstructor; split. apply exec_straight_one.
+ rewrite H4. unfold load1. rewrite H6. rewrite H3. eauto.
+ unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso; auto with asmgen.
+ intuition Simpl.
+ intros. econstructor; split. apply exec_straight_one.
+ rewrite H5. unfold load2. rewrite H6. rewrite H3. eauto.
+ unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso; auto with asmgen.
+ intuition Simpl.
+ }
+ destruct chunk; monadInv H.
+- (* Mint8signed *)
+ assert (exists v1, Mem.loadv Mint8unsigned m a = Some v1 /\ v = Val.sign_ext 8 v1).
+ {
+ destruct a; simpl in *; try discriminate.
+ rewrite Mem.load_int8_signed_unsigned in H1.
+ destruct (Mem.load Mint8unsigned m b (Int.unsigned i)); simpl in H1; inv H1.
+ exists v0; auto.
+ }
+ destruct H as [v1 [LD SG]]. clear H1.
+ exploit BASE; eauto; erewrite ireg_of_eq by eauto; auto.
+ intros [rs1 [A [B C]]].
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto.
+ split. Simpl. congruence. intros. Simpl.
+- (* Mint8unsigned *)
+ eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
+- (* Mint816signed *)
+ eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
+- (* Mint16unsigned *)
+ eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
+- (* Mint32 *)
+ eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
+- (* Mfloat32 *)
+ eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
+- (* Mfloat64 *)
+ apply Mem.loadv_float64al32 in H1. eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
+- (* Mfloat64al32 *)
+ eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
+Qed.
+
+(** Translation of stores *)
Lemma transl_store_correct:
- forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction)
- chunk addr args k ms sp rs m src a m' m1,
- (forall cst (r1: ireg) (rs1 rs2: regset) (m2: mem),
- store1 ge chunk (preg_of src) cst r1 rs1 m1 = OK rs2 m2 ->
- exists rs3,
- exec_instr ge fn (mk1 cst r1) rs1 m1 = OK rs3 m2
- /\ (forall (r: preg), r <> FPR13 -> rs3 r = rs2 r)) ->
- (forall (r1 r2: ireg) (rs1 rs2: regset) (m2: mem),
- store2 chunk (preg_of src) r1 r2 rs1 m1 = OK rs2 m2 ->
- exists rs3,
- exec_instr ge fn (mk2 r1 r2) rs1 m1 = OK rs3 m2
- /\ (forall (r: preg), r <> FPR13 -> rs3 r = rs2 r)) ->
- agree ms sp rs ->
- map mreg_type args = type_of_addressing addr ->
- eval_addressing ge sp addr (map ms args) = Some a ->
- Mem.storev chunk m a (ms src) = Some m' ->
- Mem.extends m m1 ->
- exists m1',
- Mem.extends m' m1'
- /\ exists rs',
- exec_straight (transl_load_store mk1 mk2 addr args (int_temp_for src) k) rs m1
- k rs' m1'
- /\ agree (undef_temps ms) sp rs'.
+ forall chunk addr args src k c (rs: regset) m a m',
+ transl_store chunk addr args src k = OK c ->
+ eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a ->
+ Mem.storev chunk m a (rs (preg_of src)) = Some m' ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m'
+ /\ forall r, r <> PC -> r <> GPR11 -> r <> GPR12 -> r <> FPR13 -> rs' r = rs r.
Proof.
intros.
- exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto.
- unfold PregEq.t.
- intros [a' [A B]].
- assert (Z: Val.lessdef (ms src) (rs (preg_of src))). eapply preg_val; eauto.
- exploit Mem.storev_extends; eauto. intros [m1' [C D]].
- exists m1'; split; auto.
- apply transl_load_store_correct with ms; auto.
-(* mk1 *)
- intros.
- exploit (H cst r1 rs1 (nextinstr rs1) m1').
- unfold store1. rewrite A in H6. inv H6.
- replace (rs1 (preg_of src)) with (rs (preg_of src)).
- rewrite C. auto.
- symmetry. apply H7. auto with ppcgen.
- apply sym_not_equal. apply int_temp_for_diff.
- intros [rs3 [U V]].
- exists rs3; split.
- apply exec_straight_one. auto. rewrite V; auto with ppcgen.
- apply agree_undef_temps with rs. auto.
- intros. rewrite V; auto with ppcgen. SIMP. apply H7; auto with ppcgen.
- unfold int_temp_for. destruct (mreg_eq src IT2); auto with ppcgen.
-(* mk2 *)
- intros.
- exploit (H0 r1 r2 rs (nextinstr rs) m1').
- unfold store2. rewrite A in H6. inv H6. rewrite C. auto.
- intros [rs3 [U V]].
- exists rs3; split.
- apply exec_straight_one. auto. rewrite V; auto with ppcgen.
- eapply agree_undef_temps; eauto. intros.
- rewrite V; auto with ppcgen.
- unfold int_temp_for. destruct (mreg_eq src IT2); congruence.
-Qed.
-
-End STRAIGHTLINE.
+ assert (TEMP0: int_temp_for src = GPR11 \/ int_temp_for src = GPR12).
+ unfold int_temp_for. destruct (mreg_eq src IT2); auto.
+ assert (TEMP1: int_temp_for src <> GPR0).
+ destruct TEMP0; congruence.
+ assert (TEMP2: IR (int_temp_for src) <> preg_of src).
+ unfold int_temp_for. destruct (mreg_eq src IT2).
+ subst src; simpl; congruence.
+ change (IR GPR12) with (preg_of IT2). red; intros; elim n.
+ eapply preg_of_injective; eauto.
+ assert (BASE: forall mk1 mk2 chunk',
+ transl_memory_access mk1 mk2 addr args (int_temp_for src) k = OK c ->
+ Mem.storev chunk' m a (rs (preg_of src)) = Some m' ->
+ (forall cst (r1: ireg) (rs1: regset),
+ exec_instr ge fn (mk1 cst r1) rs1 m =
+ store1 ge chunk' (preg_of src) cst r1 rs1 m) ->
+ (forall (r1 r2: ireg) (rs1: regset),
+ exec_instr ge fn (mk2 r1 r2) rs1 m =
+ store2 chunk' (preg_of src) r1 r2 rs1 m) ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m'
+ /\ forall r, r <> PC -> r <> GPR11 -> r <> GPR12 -> r <> FPR13 -> rs' r = rs r).
+ {
+ intros. eapply transl_memory_access_correct; eauto.
+ intros. econstructor; split. apply exec_straight_one.
+ rewrite H4. unfold store1. rewrite H6. rewrite H7; auto with asmgen. rewrite H3. eauto. auto.
+ intros; Simpl. apply H7; auto. destruct TEMP0; congruence.
+ intros. econstructor; split. apply exec_straight_one.
+ rewrite H5. unfold store2. rewrite H6. rewrite H7; auto with asmgen. rewrite H3. eauto. auto.
+ intros; Simpl. apply H7; auto. destruct TEMP0; congruence.
+ }
+ destruct chunk; monadInv H.
+- (* Mint8signed *)
+ assert (Mem.storev Mint8unsigned m a (rs (preg_of src)) = Some m').
+ rewrite <- H1. destruct a; simpl; auto. symmetry. apply Mem.store_signed_unsigned_8.
+ clear H1. eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
+- (* Mint8unsigned *)
+ eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
+- (* Mint16signed *)
+ assert (Mem.storev Mint16unsigned m a (rs (preg_of src)) = Some m').
+ rewrite <- H1. destruct a; simpl; auto. symmetry. apply Mem.store_signed_unsigned_16.
+ clear H1. eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
+- (* Mint16unsigned *)
+ eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
+- (* Mint32 *)
+ eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
+- (* Mfloat32 *)
+ rewrite (freg_of_eq _ _ EQ) in H1.
+ eapply transl_memory_access_correct. eauto. eauto. eauto.
+ intros. econstructor; split. apply exec_straight_one.
+ simpl. unfold store1. rewrite H. rewrite H2; auto with asmgen. rewrite H1. eauto. auto.
+ intros. Simpl. apply H2; auto with asmgen. destruct TEMP0; congruence.
+ intros. econstructor; split. apply exec_straight_one.
+ simpl. unfold store2. rewrite H. rewrite H2; auto with asmgen. rewrite H1. eauto. auto.
+ intros. Simpl. apply H2; auto with asmgen. destruct TEMP0; congruence.
+- (* Mfloat64 *)
+ apply Mem.storev_float64al32 in H1. eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
+- (* Mfloat64al32 *)
+ eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
+Qed.
+
+End CONSTRUCTORS.
diff --git a/powerpc/Asmgenretaddr.v b/powerpc/Asmgenretaddr.v
deleted file mode 100644
index ddbfda6..0000000
--- a/powerpc/Asmgenretaddr.v
+++ /dev/null
@@ -1,204 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Xavier Leroy, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-(** Predictor for return addresses in generated PPC code.
-
- The [return_address_offset] predicate defined here is used in the
- semantics for Mach (module [Machsem]) to determine the
- return addresses that are stored in activation records. *)
-
-Require Import Coqlib.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Op.
-Require Import Locations.
-Require Import Mach.
-Require Import Asm.
-Require Import Asmgen.
-
-(** The ``code tail'' of an instruction list [c] is the list of instructions
- starting at PC [pos]. *)
-
-Inductive code_tail: Z -> code -> code -> Prop :=
- | code_tail_0: forall c,
- code_tail 0 c c
- | code_tail_S: forall pos i c1 c2,
- code_tail pos c1 c2 ->
- code_tail (pos + 1) (i :: c1) c2.
-
-Lemma code_tail_pos:
- forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0.
-Proof.
- induction 1. omega. omega.
-Qed.
-
-(** Consider a Mach function [f] and a sequence [c] of Mach instructions
- representing the Mach code that remains to be executed after a
- function call returns. The predicate [return_address_offset f c ofs]
- holds if [ofs] is the integer offset of the PPC instruction
- following the call in the PPC code obtained by translating the
- code of [f]. Graphically:
-<<
- Mach function f |--------- Mcall ---------|
- Mach code c | |--------|
- | \ \
- | \ \
- | \ \
- PPC code | |--------|
- PPC function |--------------- Pbl ---------|
-
- <-------- ofs ------->
->>
-*)
-
-Inductive return_address_offset: Mach.function -> Mach.code -> int -> Prop :=
- | return_address_offset_intro:
- forall c f ofs,
- code_tail ofs (transl_function f) (transl_code f c) ->
- return_address_offset f c (Int.repr ofs).
-
-(** We now show that such an offset always exists if the Mach code [c]
- is a suffix of [f.(fn_code)]. This holds because the translation
- from Mach to PPC is compositional: each Mach instruction becomes
- zero, one or several PPC instructions, but the order of instructions
- is preserved. *)
-
-Lemma is_tail_code_tail:
- forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1.
-Proof.
- induction 1. exists 0; constructor.
- destruct IHis_tail as [ofs CT]. exists (ofs + 1); constructor; auto.
-Qed.
-
-Hint Resolve is_tail_refl: ppcretaddr.
-
-Ltac IsTail :=
- auto with ppcretaddr;
- match goal with
- | [ |- is_tail _ (_ :: _) ] => constructor; IsTail
- | [ |- is_tail _ (match ?x with true => _ | false => _ end) ] => destruct x; IsTail
- | [ |- is_tail _ (match ?x with left _ => _ | right _ => _ end) ] => destruct x; IsTail
- | [ |- is_tail _ (match ?x with nil => _ | _ :: _ => _ end) ] => destruct x; IsTail
- | [ |- is_tail _ (match ?x with Tint => _ | Tfloat => _ end) ] => destruct x; IsTail
- | [ |- is_tail _ (?f _ _ _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail
- | [ |- is_tail _ (?f _ _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail
- | [ |- is_tail _ (?f _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail
- | [ |- is_tail _ (?f _ _ _ ?k) ] => apply is_tail_trans with k; IsTail
- | [ |- is_tail _ (?f _ _ ?k) ] => apply is_tail_trans with k; IsTail
- | _ => idtac
- end.
-
-Lemma loadimm_tail:
- forall r n k, is_tail k (loadimm r n k).
-Proof. unfold loadimm; intros; IsTail. Qed.
-Hint Resolve loadimm_tail: ppcretaddr.
-
-Lemma addimm_tail:
- forall r1 r2 n k, is_tail k (addimm r1 r2 n k).
-Proof. unfold addimm; intros; IsTail. Qed.
-Hint Resolve addimm_tail: ppcretaddr.
-
-Lemma andimm_base_tail:
- forall r1 r2 n k, is_tail k (andimm_base r1 r2 n k).
-Proof. unfold andimm_base; intros; IsTail. Qed.
-Hint Resolve andimm_base_tail: ppcretaddr.
-
-Lemma andimm_tail:
- forall r1 r2 n k, is_tail k (andimm r1 r2 n k).
-Proof. unfold andimm; intros; IsTail. Qed.
-Hint Resolve andimm_tail: ppcretaddr.
-
-Lemma orimm_tail:
- forall r1 r2 n k, is_tail k (orimm r1 r2 n k).
-Proof. unfold orimm; intros; IsTail. Qed.
-Hint Resolve orimm_tail: ppcretaddr.
-
-Lemma xorimm_tail:
- forall r1 r2 n k, is_tail k (xorimm r1 r2 n k).
-Proof. unfold xorimm; intros; IsTail. Qed.
-Hint Resolve xorimm_tail: ppcretaddr.
-
-Lemma rolm_tail:
- forall r1 r2 amount mask k, is_tail k (rolm r1 r2 amount mask k).
-Proof. unfold rolm; intros; IsTail. Qed.
-Hint Resolve rolm_tail: ppcretaddr.
-
-Lemma loadind_tail:
- forall base ofs ty dst k, is_tail k (loadind base ofs ty dst k).
-Proof. unfold loadind; intros. destruct ty; IsTail. Qed.
-Hint Resolve loadind_tail: ppcretaddr.
-
-Lemma storeind_tail:
- forall src base ofs ty k, is_tail k (storeind src base ofs ty k).
-Proof. unfold storeind; intros. destruct ty; IsTail. Qed.
-Hint Resolve storeind_tail: ppcretaddr.
-
-Lemma floatcomp_tail:
- forall cmp r1 r2 k, is_tail k (floatcomp cmp r1 r2 k).
-Proof. unfold floatcomp; intros; destruct cmp; IsTail. Qed.
-Hint Resolve floatcomp_tail: ppcretaddr.
-
-Lemma transl_cond_tail:
- forall cond args k, is_tail k (transl_cond cond args k).
-Proof. unfold transl_cond; intros; destruct cond; IsTail. Qed.
-Hint Resolve transl_cond_tail: ppcretaddr.
-
-Lemma transl_cond_op_tail:
- forall cond args r k, is_tail k (transl_cond_op cond args r k).
-Proof.
- unfold transl_cond_op; intros.
- destruct (classify_condition cond args); IsTail.
-Qed.
-Hint Resolve transl_cond_op_tail: ppcretaddr.
-
-Lemma transl_op_tail:
- forall op args r k, is_tail k (transl_op op args r k).
-Proof.
- unfold transl_op; intros; destruct op; IsTail.
-Qed.
-Hint Resolve transl_op_tail: ppcretaddr.
-
-Lemma transl_load_store_tail:
- forall mk1 mk2 addr args temp k,
- is_tail k (transl_load_store mk1 mk2 addr args temp k).
-Proof. unfold transl_load_store; intros; destruct addr; IsTail. Qed.
-Hint Resolve transl_load_store_tail: ppcretaddr.
-
-Lemma transl_instr_tail:
- forall f i k, is_tail k (transl_instr f i k).
-Proof.
- unfold transl_instr; intros; destruct i; IsTail.
- destruct m; IsTail.
- destruct m; IsTail.
- destruct s0; IsTail.
- destruct s0; IsTail.
-Qed.
-Hint Resolve transl_instr_tail: ppcretaddr.
-
-Lemma transl_code_tail:
- forall f c1 c2, is_tail c1 c2 -> is_tail (transl_code f c1) (transl_code f c2).
-Proof.
- induction 1; simpl. constructor. eapply is_tail_trans; eauto with ppcretaddr.
-Qed.
-
-Lemma return_address_exists:
- forall f sg ros c, is_tail (Mcall sg ros :: c) f.(fn_code) ->
- exists ra, return_address_offset f c ra.
-Proof.
- intros. assert (is_tail (transl_code f c) (transl_function f)).
- unfold transl_function. IsTail. apply transl_code_tail; eauto with coqlib.
- destruct (is_tail_code_tail _ _ H0) as [ofs A].
- exists (Int.repr ofs). constructor. auto.
-Qed.
-
-
diff --git a/powerpc/PrintAsm.ml b/powerpc/PrintAsm.ml
index c9203ec..152a4f7 100644
--- a/powerpc/PrintAsm.ml
+++ b/powerpc/PrintAsm.ml
@@ -536,7 +536,8 @@ let print_instruction oc tbl pc fallthrough = function
fprintf oc "%s jumptable [ " comment;
List.iter (fun l -> fprintf oc "%a " label (transl_label l)) tbl;
fprintf oc "]\n";
- fprintf oc " addis %a, %a, %a\n" ireg GPR12 ireg r label_high lbl;
+ fprintf oc " slwi %a, %a, 2\n" ireg GPR12 ireg r;
+ fprintf oc " addis %a, %a, %a\n" ireg GPR12 ireg GPR12 label_high lbl;
fprintf oc " lwz %a, %a(%a)\n" ireg GPR12 label_low lbl ireg GPR12;
fprintf oc " mtctr %a\n" ireg GPR12;
fprintf oc " bctr\n";
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-17 21:10:14 +0000