summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.depend4
-rw-r--r--arm/Asm.v13
-rw-r--r--arm/Asmgen.v4
-rw-r--r--arm/Asmgenproof.v402
-rw-r--r--arm/Asmgenproof1.v1077
-rw-r--r--arm/ConstpropOp.v7
-rw-r--r--arm/Op.v88
-rw-r--r--arm/PrintAsm.ml29
-rw-r--r--arm/PrintOp.ml8
-rw-r--r--arm/SelectOp.v168
-rw-r--r--arm/SelectOpproof.v143
-rw-r--r--arm/linux/Conventions1.v4
-rw-r--r--backend/Allocproof.v32
-rw-r--r--backend/CSE.v19
-rw-r--r--backend/Coloring.v2
-rw-r--r--backend/Coloringaux.ml93
-rw-r--r--backend/Coloringproof.v4
-rw-r--r--backend/LTL.v16
-rw-r--r--backend/LTLin.v12
-rw-r--r--backend/Linear.v30
-rw-r--r--backend/Locations.v23
-rw-r--r--backend/Mach.v16
-rw-r--r--backend/Machabstr.v16
-rw-r--r--backend/Machabstr2concr.v39
-rw-r--r--backend/Machconcr.v16
-rw-r--r--backend/Machtyping.v88
-rw-r--r--backend/RTLgen.v35
-rw-r--r--backend/RTLgenproof.v17
-rw-r--r--backend/RTLgenspec.v76
-rw-r--r--backend/RTLtypingaux.ml2
-rw-r--r--backend/Reloadproof.v214
-rw-r--r--backend/Reloadtyping.v3
-rw-r--r--backend/Selection.v4
-rw-r--r--backend/Stacking.v10
-rw-r--r--backend/Stackingproof.v143
-rw-r--r--backend/Stackingtyping.v2
-rw-r--r--common/Errors.v40
-rw-r--r--common/Memdataaux.ml1
-rw-r--r--common/Values.v6
-rwxr-xr-xconfigure30
-rw-r--r--driver/Driver.ml4
-rw-r--r--extraction/extraction.v1
-rw-r--r--ia32/Asm.v759
-rw-r--r--ia32/Asmgen.v505
-rw-r--r--ia32/Asmgenproof.v1229
-rw-r--r--ia32/Asmgenproof1.v1436
-rw-r--r--ia32/Asmgenretaddr.v244
-rw-r--r--ia32/CBuiltins.ml28
-rw-r--r--ia32/ConstpropOp.v1010
-rw-r--r--ia32/ConstpropOpproof.v497
-rw-r--r--ia32/Machregs.v76
-rw-r--r--ia32/Machregsaux.ml40
-rw-r--r--ia32/Machregsaux.mli17
-rw-r--r--ia32/Op.v974
-rw-r--r--ia32/PrintAsm.ml625
-rw-r--r--ia32/PrintAsm.mli13
-rw-r--r--ia32/PrintOp.ml105
-rw-r--r--ia32/SelectOp.v839
-rw-r--r--ia32/SelectOpproof.v935
-rw-r--r--ia32/extractionMachdep.v14
-rw-r--r--ia32/standard/CPragmas.ml28
-rw-r--r--ia32/standard/Conventions1.v455
-rw-r--r--ia32/standard/Stacklayout.v76
-rw-r--r--lib/Floats.v118
-rw-r--r--powerpc/Asm.v112
-rw-r--r--powerpc/Asmgen.v157
-rw-r--r--powerpc/Asmgenproof.v472
-rw-r--r--powerpc/Asmgenproof1.v1074
-rw-r--r--powerpc/Asmgenretaddr.v10
-rw-r--r--powerpc/ConstpropOp.v30
-rw-r--r--powerpc/Machregs.v27
-rw-r--r--powerpc/Machregsaux.ml7
-rw-r--r--powerpc/Op.v90
-rw-r--r--powerpc/PrintAsm.ml62
-rw-r--r--powerpc/PrintOp.ml6
-rw-r--r--powerpc/SelectOp.v179
-rw-r--r--powerpc/SelectOpproof.v106
-rw-r--r--powerpc/eabi/Conventions1.v5
-rw-r--r--powerpc/macosx/Conventions1.v10
-rw-r--r--test/c/Makefile4
-rw-r--r--test/raytracer/Makefile4
-rw-r--r--test/regression/Makefile5
-rw-r--r--test/regression/Results/casts31
-rw-r--r--test/regression/Results/expr12
-rw-r--r--test/regression/casts3.c60
-rw-r--r--test/regression/expr1.c2
-rw-r--r--test/spass/Makefile4
-rw-r--r--test/spass/dfgparser.c14
-rw-r--r--test/spass/iaparser.c14
89 files changed, 12842 insertions, 2579 deletions
diff --git a/.depend b/.depend
index 008f206..24ba8a7 100644
--- a/.depend
+++ b/.depend
@@ -70,13 +70,13 @@ backend/Parallelmove.vo: backend/Parallelmove.v lib/Coqlib.vo lib/Parmov.vo comm
backend/Reload.vo: backend/Reload.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTLin.vo backend/Conventions.vo backend/Parallelmove.vo backend/Linear.vo
backend/Reloadproof.vo: backend/Reloadproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Allocproof.vo backend/RTLtyping.vo backend/LTLin.vo backend/LTLintyping.vo backend/Linear.vo backend/Parallelmove.vo backend/Reload.vo
backend/Reloadtyping.vo: backend/Reloadtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTLin.vo backend/LTLintyping.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo backend/Parallelmove.vo backend/Reload.vo backend/Reloadproof.vo
-backend/Mach.vo: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo
+backend/Mach.vo: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo
backend/Machabstr.vo: backend/Machabstr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Memory.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Stacklayout.vo
backend/Machtyping.vo: backend/Machtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Memory.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo backend/Machabstr.vo
backend/Bounds.vo: backend/Bounds.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo
$(ARCH)/$(VARIANT)/Stacklayout.vo: $(ARCH)/$(VARIANT)/Stacklayout.v lib/Coqlib.vo backend/Bounds.vo
backend/Stacking.vo: backend/Stacking.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo backend/Bounds.vo backend/Mach.vo backend/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo
-backend/Stackingproof.vo: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo common/Values.vo $(ARCH)/Op.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machabstr.vo backend/Bounds.vo backend/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo
+backend/Stackingproof.vo: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo common/Values.vo $(ARCH)/Op.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machabstr.vo backend/Bounds.vo backend/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo
backend/Stackingtyping.vo: backend/Stackingtyping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machtyping.vo backend/Bounds.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo backend/Stackingproof.vo
backend/Machconcr.vo: backend/Machconcr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Stacklayout.vo $(ARCH)/Asmgenretaddr.vo
backend/Machabstr2concr.vo: backend/Machabstr2concr.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/Machabstr.vo backend/Machconcr.vo backend/Conventions.vo $(ARCH)/Asmgenretaddr.vo
diff --git a/arm/Asm.v b/arm/Asm.v
index d160be7..7ea1a8a 100644
--- a/arm/Asm.v
+++ b/arm/Asm.v
@@ -152,9 +152,7 @@ Inductive instruction : Type :=
| Pcmf: freg -> freg -> instruction (**r float comparison *)
| Pdvfd: freg -> freg -> freg -> instruction (**r float division *)
| Pfixz: ireg -> freg -> instruction (**r float to signed int *)
- | Pfixzu: ireg -> freg -> instruction (**r float to unsigned int *)
| Pfltd: freg -> ireg -> instruction (**r signed int to float *)
- | Pfltud: freg -> ireg -> instruction (**r unsigned int to float *)
| Pldfd: freg -> ireg -> int -> instruction (**r float64 load *)
| Pldfs: freg -> ireg -> int -> instruction (**r float32 load *)
| Plifd: freg -> float -> instruction (**r load float constant *)
@@ -470,12 +468,8 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
OK (nextinstr (rs#r1 <- (Val.divf rs#r2 rs#r3))) m
| Pfixz r1 r2 =>
OK (nextinstr (rs#r1 <- (Val.intoffloat rs#r2))) m
- | Pfixzu r1 r2 =>
- OK (nextinstr (rs#r1 <- (Val.intuoffloat rs#r2))) m
| Pfltd r1 r2 =>
OK (nextinstr (rs#r1 <- (Val.floatofint rs#r2))) m
- | Pfltud r1 r2 =>
- OK (nextinstr (rs#r1 <- (Val.floatofintu rs#r2))) m
| Pldfd r1 r2 n =>
exec_load Mfloat64 (Val.add rs#r2 (Vint n)) r1 rs m
| Pldfs r1 r2 n =>
@@ -492,8 +486,11 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
OK (nextinstr (rs#r1 <- (Val.mulf rs#r2 rs#r3))) m
| Pstfd r1 r2 n =>
exec_store Mfloat64 (Val.add rs#r2 (Vint n)) r1 rs m
- | Pstfs r1 r2 n =>
- exec_store Mfloat32 (Val.add rs#r2 (Vint n)) r1 rs m
+ | Pstfs r1 r2 n =>
+ match exec_store Mfloat32 (Val.add rs#r2 (Vint n)) r1 rs m with
+ | OK rs' m' => OK (rs'#FR3 <- Vundef) m'
+ | Error => Error
+ end
| Psufd r1 r2 r3 =>
OK (nextinstr (rs#r1 <- (Val.subf rs#r2 rs#r3))) m
(* Pseudo-instructions *)
diff --git a/arm/Asmgen.v b/arm/Asmgen.v
index 775bb37..b3412fb 100644
--- a/arm/Asmgen.v
+++ b/arm/Asmgen.v
@@ -300,12 +300,8 @@ Definition transl_op
Pmvfs (freg_of r) (freg_of a1) :: k
| Ointoffloat, a1 :: nil =>
Pfixz (ireg_of r) (freg_of a1) :: k
- | Ointuoffloat, a1 :: nil =>
- Pfixzu (ireg_of r) (freg_of a1) :: k
| Ofloatofint, a1 :: nil =>
Pfltd (freg_of r) (ireg_of a1) :: k
- | Ofloatofintu, a1 :: nil =>
- Pfltud (freg_of r) (ireg_of a1) :: k
| Ocmp cmp, _ =>
transl_cond cmp args
(Pmov (ireg_of r) (SOimm Int.zero) ::
diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v
index cc4d7ac..d3e082f 100644
--- a/arm/Asmgenproof.v
+++ b/arm/Asmgenproof.v
@@ -558,56 +558,84 @@ Inductive match_stack: list Machconcr.stackframe -> Prop :=
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: Machconcr.state -> Asm.state -> Prop :=
| match_states_intro:
- forall s fb sp c ms m rs f
+ 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 f.(fn_code))
(AT: transl_code_at_pc (rs PC) fb f c)
- (AG: agree ms sp rs),
+ (AG: agree ms sp rs)
+ (MEXT: Mem.extends m m'),
match_states (Machconcr.State s fb sp c ms m)
- (Asm.State rs m)
+ (Asm.State rs m')
| match_states_call:
- forall s fb ms m rs
+ forall s fb ms m rs m'
(STACKS: match_stack s)
(AG: agree ms (parent_sp s) rs)
(ATPC: rs PC = Vptr fb Int.zero)
- (ATLR: rs IR14 = parent_ra s),
+ (ATLR: rs IR14 = parent_ra s)
+ (MEXT: Mem.extends m m'),
match_states (Machconcr.Callstate s fb ms m)
- (Asm.State rs m)
+ (Asm.State rs m')
| match_states_return:
- forall s ms m rs
+ forall s ms m rs m'
(STACKS: match_stack s)
(AG: agree ms (parent_sp s) rs)
- (ATPC: rs PC = parent_ra s),
+ (ATPC: rs PC = parent_ra s)
+ (MEXT: Mem.extends m m'),
match_states (Machconcr.Returnstate s ms m)
- (Asm.State rs m).
+ (Asm.State rs m').
Lemma exec_straight_steps:
- forall s fb sp m1 f c1 rs1 c2 m2 ms2,
+ 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 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
+ Mem.extends m1 m1' ->
+ (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) ->
exists st',
- plus step tge (State rs1 m1) E0 st' /\
+ plus step tge (State rs1 m1') E0 st' /\
match_states (Machconcr.State s fb sp c2 ms2 m2) st'.
Proof.
- intros. destruct H4 as [rs2 [A B]].
- exists (State rs2 m2); split.
+ intros. destruct H5 as [m2' [A [rs2 [B C]]]].
+ exists (State rs2 m2'); split.
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.
+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 ARM side. Actually, all Mach transitions
@@ -642,6 +670,7 @@ Lemma exec_Mlabel_prop:
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.
@@ -658,18 +687,15 @@ Proof.
intros; red; intros; inv MS.
unfold load_stack in H.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inversion WTI.
- rewrite (sp_val _ _ _ AG) in H.
- generalize (loadind_correct tge (transl_function f) IR13 ofs ty
- dst (transl_code f c) rs m v H H1).
+ 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; eauto with coqlib.
- simpl. exists rs2; split. auto.
- apply agree_exten_2 with (rs#(preg_of dst) <- v).
- auto with ppcgen.
- intros. case (preg_eq r0 (preg_of dst)); intro.
- subst r0. rewrite Pregmap.gss. auto.
- rewrite Pregmap.gso; auto.
+ exists m'; split; auto.
+ simpl. exists rs2; split. eauto.
+ apply agree_set_mreg with rs; auto. congruence. auto with ppcgen.
Qed.
Lemma exec_Msetstack_prop:
@@ -683,16 +709,16 @@ Proof.
intros; red; intros; inv MS.
unfold store_stack in H.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inversion WTI.
- rewrite (sp_val _ _ _ AG) in H.
- rewrite (preg_val ms sp rs) in H; auto.
- assert (NOTE: IR13 <> IR14) by congruence.
- generalize (storeind_correct tge (transl_function f) IR13 ofs ty
- src (transl_code f c) rs m m' H H1 NOTE).
+ 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; eauto with coqlib.
- exists rs2; split; auto.
- apply agree_exten_2 with rs; auto.
+ exists m2; split; auto.
+ exists rs2; split; eauto.
+ apply agree_exten with rs; auto with ppcgen.
Qed.
Lemma exec_Mgetparam_prop:
@@ -703,29 +729,33 @@ Lemma exec_Mgetparam_prop:
load_stack m sp Tint f.(fn_link_ofs) = Some parent ->
load_stack m parent ty ofs = Some v ->
exec_instr_prop (Machconcr.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0
- (Machconcr.State s fb sp c (Regmap.set dst v ms) m).
+ (Machconcr.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). inv B. auto. simpl in H1; discriminate. subst parent'.
+ exploit Mem.loadv_extends. eauto. eexact H1. eauto.
+ intros [v' [C D]].
exploit (loadind_int_correct tge (transl_function f) IR13 f.(fn_link_ofs) IR14
- rs m parent (loadind IR14 ofs ty dst (transl_code f c))).
- rewrite <- (sp_val ms sp rs); auto.
+ rs m' parent (loadind IR14 ofs (mreg_type dst) dst (transl_code f c))).
+ auto.
intros [rs1 [EX1 [RES1 OTH1]]].
- exploit (loadind_correct tge (transl_function f) IR14 ofs ty dst
- (transl_code f c) rs1 m v).
- rewrite RES1. auto.
- generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inversion WTI. auto.
+ exploit (loadind_correct tge (transl_function f) IR14 ofs (mreg_type dst) dst
+ (transl_code f c) rs1 m' v').
+ rewrite RES1. auto. auto.
intros [rs2 [EX2 [RES2 OTH2]]].
left. eapply exec_straight_steps; eauto with coqlib.
+ exists m'; split; auto.
exists rs2; split; simpl.
eapply exec_straight_trans; eauto.
- apply agree_exten_2 with (rs1#(preg_of dst) <- v).
- apply agree_set_mreg.
- apply agree_exten_2 with rs; auto.
- intros. case (preg_eq r (preg_of dst)); intro.
- subst r. rewrite Pregmap.gss. auto.
- rewrite Pregmap.gso; auto.
+ 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:
@@ -734,14 +764,27 @@ Lemma exec_Mop_prop:
(ms : mreg -> val) (m : mem) (v : val),
eval_operation ge sp op ms ## args = Some v ->
exec_instr_prop (Machconcr.State s fb sp (Mop op args res :: c) ms m) E0
- (Machconcr.State s fb sp c (Regmap.set res v ms) m).
+ (Machconcr.State s fb sp c (Regmap.set res v (undef_op op ms)) m).
Proof.
intros; red; intros; inv MS.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
intro WTI.
+ exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto.
+ intros [v' [A B]].
+ assert (C: eval_operation tge sp op rs ## (preg_of ## args) = Some v').
+ rewrite <- A. apply eval_operation_preserved. exact symbols_preserved.
+ rewrite (sp_val _ _ _ AG) in C.
+ exploit transl_op_correct; eauto. intros [rs' [P [Q R]]].
left; eapply exec_straight_steps; eauto with coqlib.
- simpl. eapply transl_op_correct; auto.
- rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
+ exists m'; split; auto.
+ exists rs'; split. simpl. eexact P.
+ assert (agree (Regmap.set res v ms) sp rs').
+ apply agree_set_mreg with rs; auto. congruence.
+ auto with ppcgen.
+ assert (agree (Regmap.set res v (undef_temps ms)) sp rs').
+ apply agree_set_undef_mreg with rs; auto. congruence.
+ auto with ppcgen.
+ destruct op; assumption.
Qed.
Lemma exec_Mload_prop:
@@ -752,7 +795,7 @@ Lemma exec_Mload_prop:
eval_addressing ge sp addr ms ## args = Some a ->
Mem.loadv chunk m a = Some v ->
exec_instr_prop (Machconcr.State s fb sp (Mload chunk addr args dst :: c) ms m)
- E0 (Machconcr.State s fb sp c (Regmap.set dst v ms) m).
+ E0 (Machconcr.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 _ _))).
@@ -760,12 +803,14 @@ Proof.
assert (eval_addressing tge sp addr ms##args = Some a).
rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
left; eapply exec_straight_steps; eauto with coqlib.
+ exists m'; split; auto.
destruct chunk; simpl; simpl in H6;
(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 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)
@@ -774,7 +819,7 @@ Lemma exec_Mstore_prop:
eval_addressing ge sp addr ms ## args = Some a ->
Mem.storev chunk m a (ms src) = Some m' ->
exec_instr_prop (Machconcr.State s fb sp (Mstore chunk addr args src :: c) ms m) E0
- (Machconcr.State s fb sp c ms m').
+ (Machconcr.State s fb sp c (undef_temps ms) m').
Proof.
intros; red; intros; inv MS.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
@@ -788,6 +833,7 @@ Proof.
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:
@@ -817,17 +863,20 @@ Proof.
rewrite RA_EQ.
change (rs2 IR14) with (Val.add (rs PC) Vone).
rewrite <- H2. reflexivity.
- assert (AG3: agree ms sp rs2).
- unfold rs2; auto 8 with ppcgen.
- left; exists (State rs2 m); split.
+ 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. rewrite <- (ireg_val ms sp rs); auto.
- simpl in H. destruct (ms m0); try congruence.
- generalize H; predSpec Int.eq Int.eq_spec i Int.zero; intros; inv H7.
- auto.
+ 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.
@@ -835,8 +884,19 @@ Proof.
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 (- f.(fn_framesize)) f.(fn_stacksize) = Some m' -> exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0 (Callstate s f' ms m'). Proof.
intros; red; intros; inv MS.
assert (f0 = f) by congruence. subst f0.
@@ -848,23 +908,31 @@ Lemma exec_Mtailcall_prop: forall (s : list stackframe) (fb stk : block) (soff
loadind_int IR13 (fn_retaddr_ofs f) IR14
(Pfreeframe (-f.(fn_framesize)) f.(fn_stacksize) (fn_link_ofs f) :: call_instr :: transl_code f c)).
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 (transl_function f) IR13 f.(fn_retaddr_ofs) IR14
- rs m (parent_ra s)
+ rs m'0 (parent_ra s)
(Pfreeframe (-f.(fn_framesize)) 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 (transl_function f)
- (transl_code f (Mtailcall sig ros :: c)) rs m
- (call_instr :: transl_code f c) rs2 m').
+ (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.
- unfold load_stack in H1. simpl in H1. simpl. rewrite H1.
- rewrite H3. auto. 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 m'); split.
+ left. exists (State rs3 m2'); split.
(* Execution *)
eapply plus_right'. eapply exec_straight_exec; eauto.
inv AT. exploit exec_straight_steps_2; eauto.
@@ -877,24 +945,19 @@ Lemma exec_Mtailcall_prop: forall (s : list stackframe) (fb stk : block) (soff
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.
- rewrite <- (ireg_val ms (Vptr stk soff) rs); auto.
- destruct (ms m0); try discriminate.
- generalize H. predSpec Int.eq Int.eq_spec i Int.zero; intros; inv H10.
- auto.
- decEq. auto with ppcgen. decEq. auto with ppcgen. decEq. auto with ppcgen.
- replace (symbol_offset tge i Int.zero) with (Vptr f' Int.zero). auto.
- unfold symbol_offset. rewrite symbols_preserved. rewrite H. auto.
+ 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.
traceEq.
(* Match states *)
constructor; auto.
- assert (AG1: agree ms (Vptr stk soff) rs1).
- eapply agree_exten_2; eauto.
- assert (AG2: agree ms (parent_sp s) rs2).
- inv AG1. constructor. auto. intros. unfold rs2.
- rewrite nextinstr_inv; auto with ppcgen.
- rewrite Pregmap.gso. auto. auto with ppcgen.
- unfold rs3. apply agree_exten_2 with rs2; auto.
- intros. rewrite Pregmap.gso; 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:
@@ -904,28 +967,29 @@ Lemma exec_Mbuiltin_prop:
(t : trace) (v : val) (m' : mem),
external_call ef ge ms ## args m t v m' ->
exec_instr_prop (Machconcr.State s f sp (Mbuiltin ef args res :: b) ms m) t
- (Machconcr.State s f sp b (Regmap.set res v ms) m').
+ (Machconcr.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.
+ 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.
- replace (rs##(preg_of##args)) with (ms##args).
- eapply external_call_symbols_preserved; eauto.
- exact symbols_preserved. exact varinfo_preserved.
- rewrite list_map_compose. apply list_map_exten. intros.
- symmetry. eapply preg_val; 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.
- auto with ppcgen.
+ apply sym_not_equal. auto with ppcgen.
+ apply agree_nextinstr. eapply agree_set_undef_mreg; eauto.
+ rewrite Pregmap.gss; auto.
+ intros. rewrite Pregmap.gso; auto.
Qed.
Lemma exec_Mgoto_prop:
@@ -940,16 +1004,16 @@ 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).
+ 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.
+ left; exists (State rs2 m'); split.
apply plus_one. econstructor; eauto.
apply functions_transl; eauto.
eapply find_instr_tail; eauto.
simpl; auto.
econstructor; eauto.
eapply Mach.find_label_incl; eauto.
- apply agree_exten_2 with rs; auto.
+ apply agree_exten with rs; auto with ppcgen.
Qed.
Lemma exec_Mcond_true_prop:
@@ -961,32 +1025,32 @@ Lemma exec_Mcond_true_prop:
Genv.find_funct_ptr ge fb = Some (Internal f) ->
Mach.find_label lbl (fn_code f) = Some c' ->
exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0
- (Machconcr.State s fb sp c' ms m).
+ (Machconcr.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 := Pbc (crbit_for_cond cond) lbl :: transl_code f c).
- generalize (transl_cond_correct tge (transl_function f)
- cond args k1 ms sp rs m true H3 AG H).
- simpl. intros [rs2 [EX [RES AG2]]].
+ exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. intros A.
+ exploit transl_cond_correct. eauto. eauto.
+ 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).
+ generalize (find_label_goto_label f lbl rs2 m' _ _ _ FIND PC2 H1).
intros [rs3 [GOTO [AT3 INV3]]].
- left; exists (State rs3 m); split.
+ left; exists (State rs3 m'); split.
eapply plus_right'.
eapply exec_straight_steps_1; eauto.
econstructor; eauto.
- eapply find_instr_tail. unfold k1 in CT2. eauto.
+ eapply find_instr_tail. eauto.
simpl. rewrite RES. simpl. auto.
traceEq.
econstructor; eauto.
eapply Mach.find_label_incl; eauto.
- apply agree_exten_2 with rs2; auto.
+ apply agree_exten_temps with rs; auto. intros.
+ rewrite INV3; auto with ppcgen.
Qed.
Lemma exec_Mcond_false_prop:
@@ -995,36 +1059,34 @@ Lemma exec_Mcond_false_prop:
(c : list Mach.instruction) (ms : mreg -> val) (m : mem),
eval_condition cond ms ## args = Some false ->
exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0
- (Machconcr.State s fb sp c ms m).
+ (Machconcr.State s fb sp c (undef_temps ms) m).
Proof.
intros; red; intros; inv MS.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inversion WTI.
- pose (k1 := Pbc (crbit_for_cond cond) lbl :: transl_code f c).
- generalize (transl_cond_correct tge (transl_function f)
- cond args k1 ms sp rs m false H1 AG H).
- simpl. intros [rs2 [EX [RES AG2]]].
+ intro WTI. inv WTI.
+ exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. intros A.
+ exploit transl_cond_correct. eauto. eauto.
+ 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.
- unfold k1; apply exec_straight_one.
- simpl. rewrite RES. reflexivity.
- reflexivity.
- auto with ppcgen.
+ 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 : function) (sp : val)
(arg : mreg) (tbl : list Mach.label) (c : list Mach.instruction)
- (rs : mreg -> val) (m : mem) (n : int) (lbl : Mach.label)
+ (ms : mreg -> val) (m : mem) (n : int) (lbl : Mach.label)
(c' : Mach.code),
- rs arg = Vint n ->
+ ms arg = Vint n ->
list_nth_z tbl (Int.signed n) = Some lbl ->
Genv.find_funct_ptr ge fb = Some (Internal f) ->
Mach.find_label lbl (fn_code f) = Some c' ->
exec_instr_prop
- (Machconcr.State s fb sp (Mjumptable arg tbl :: c) rs m) E0
- (Machconcr.State s fb sp c' rs m).
+ (Machconcr.State s fb sp (Mjumptable arg tbl :: c) ms m) E0
+ (Machconcr.State s fb sp c' (undef_temps ms) m).
Proof.
intros; red; intros; inv MS.
assert (f0 = f) by congruence. subst f0.
@@ -1039,19 +1101,21 @@ Proof.
omega.
inv AT. simpl in H7.
set (k1 := Pbtbl IR14 tbl :: transl_code f c).
- set (rs1 := nextinstr (rs0 # IR14 <- (Vint (Int.shl n (Int.repr 2))))).
+ 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 (transl_function f)
- (Pmov IR14 (SOlslimm (ireg_of arg) (Int.repr 2)) :: k1) rs0 m
- k1 rs1 m).
+ (Pmov IR14 (SOlslimm (ireg_of arg) (Int.repr 2)) :: k1) rs m'
+ k1 rs1 m').
apply exec_straight_one.
- simpl. rewrite <- (ireg_val _ _ _ _ AG H5). rewrite H. reflexivity. reflexivity.
+ 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).
+ generalize (find_label_goto_label f lbl rs1 m' _ _ _ FIND PC1 H2).
intros [rs3 [GOTO [AT3 INV3]]].
- left; exists (State rs3 m); split.
+ left; exists (State rs3 m'); split.
eapply plus_right'.
eapply exec_straight_steps_1; eauto.
econstructor; eauto.
@@ -1064,15 +1128,25 @@ Opaque Zmod. Opaque Zdiv.
change label with Mach.label; rewrite H0. exact GOTO. omega. traceEq.
econstructor; eauto.
eapply Mach.find_label_incl; eauto.
- apply agree_exten_2 with rs1; auto.
+ 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 (- f.(fn_framesize)) f.(fn_stacksize) = Some m' -> exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0 (Returnstate s ms m'). Proof.
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 (transl_function f) IR13 f.(fn_retaddr_ofs) IR14
- rs m (parent_ra s)
+ rs m'0 (parent_ra s)
(Pfreeframe (-f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: Pbreg IR14 :: transl_code f c)).
rewrite <- (sp_val ms (Vptr stk soff) rs); auto.
intros [rs1 [EXEC1 [RES1 OTH1]]].
@@ -1080,14 +1154,13 @@ Lemma exec_Mreturn_prop: forall (s : list stackframe) (fb stk : block) (soff :
assert (EXEC2: exec_straight tge (transl_function f)
(loadind_int IR13 (fn_retaddr_ofs f) IR14
(Pfreeframe (-f.(fn_framesize)) f.(fn_stacksize) (fn_link_ofs f) :: Pbreg IR14 :: transl_code f c))
- rs m (Pbreg IR14 :: transl_code f c) rs2 m').
+ rs m'0 (Pbreg IR14 :: transl_code f c) rs2 m2').
eapply exec_straight_trans. eexact EXEC1.
apply exec_straight_one. simpl. rewrite OTH1; try congruence.
- rewrite <- (sp_val ms (Vptr stk soff) rs); auto.
- unfold load_stack in H0. simpl in H0; simpl; rewrite H0. rewrite H2. reflexivity.
- reflexivity.
+ 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 m'); split.
+ left; exists (State rs3 m2'); split.
(* execution *)
eapply plus_right'. eapply exec_straight_exec; eauto.
inv AT. exploit exec_straight_steps_2; eauto.
@@ -1100,15 +1173,13 @@ Lemma exec_Mreturn_prop: forall (s : list stackframe) (fb stk : block) (soff :
traceEq.
(* match states *)
constructor. auto.
- assert (AG1: agree ms (Vptr stk soff) rs1).
- apply agree_exten_2 with rs; auto.
- assert (AG2: agree ms (parent_sp s) rs2).
- constructor. reflexivity. intros; unfold rs2.
- rewrite nextinstr_inv; auto with ppcgen.
- rewrite Pregmap.gso; auto with ppcgen.
- inv AG1; auto.
- unfold rs3. auto with ppcgen.
- reflexivity.
+ 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.
@@ -1132,21 +1203,26 @@ Proof.
generalize (functions_transl_no_overflow _ _ H); intro NOOV.
set (rs2 := nextinstr (rs#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]].
(* Execution of function prologue *)
assert (EXEC_PROLOGUE:
exec_straight tge (transl_function f)
- (transl_function f) rs m
- (transl_code f f.(fn_code)) rs3 m3).
+ (transl_function f) rs m'
+ (transl_code f f.(fn_code)) rs3 m3').
unfold transl_function at 2.
- apply exec_straight_two with rs2 m2.
- unfold exec_instr. rewrite H0. fold sp.
- rewrite <- (sp_val ms (parent_sp s) rs); auto.
- unfold store_stack in H1. change Mint32 with (chunk_of_type Tint). rewrite H1.
- auto.
+ apply exec_straight_two with rs2 m2'.
+ unfold exec_instr. rewrite A. fold sp.
+ rewrite <- (sp_val ms (parent_sp s) rs); auto. rewrite C. auto.
unfold exec_instr. unfold eval_shift_addr. unfold exec_store.
change (rs2 IR13) with sp. change (rs2 IR14) with (rs IR14). rewrite ATLR.
- unfold store_stack in H2. change Mint32 with (chunk_of_type Tint). rewrite H2.
- auto. auto. auto.
+ rewrite E. auto.
+ auto. auto.
(* Agreement at end of prologue *)
assert (AT3: transl_code_at_pc rs3#PC fb f f.(fn_code)).
change (rs3 PC) with (Val.add (Val.add (rs PC) Vone) Vone).
@@ -1155,14 +1231,12 @@ Proof.
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.
- intros. unfold rs2. rewrite nextinstr_inv.
- repeat (rewrite Pregmap.gso). elim AG; auto.
- auto with ppcgen. auto with ppcgen.
assert (AG3: agree ms sp rs3).
- unfold rs3; auto with ppcgen.
- left; exists (State rs3 m3); split.
+ unfold rs3. apply agree_nextinstr.
+ unfold rs2. apply agree_nextinstr.
+ apply agree_change_sp with (parent_sp s); auto.
+ unfold sp. congruence.
+ left; exists (State rs3 m3'); split.
(* execution *)
eapply exec_straight_steps_1; eauto.
change (Int.unsigned Int.zero) with 0. constructor.
@@ -1183,15 +1257,21 @@ Lemma exec_function_external_prop:
Proof.
intros; red; intros; inv MS.
exploit functions_translated; eauto.
- intros [tf [A B]]. simpl in B. inv B.
- left; exists (State (rs#(loc_external_result (ef_sig ef)) <- res #PC <- (rs IR14))
- m'); split.
+ 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.
exact symbols_preserved. exact varinfo_preserved.
- eapply extcall_arguments_match; eauto.
econstructor; eauto.
- unfold loc_external_result. auto with ppcgen.
+ 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.
Lemma exec_return_prop:
@@ -1241,6 +1321,8 @@ Proof.
with (Vptr fb Int.zero).
econstructor; eauto. constructor.
split. auto. intros. repeat rewrite Pregmap.gso; auto with ppcgen.
+ intros. unfold Regmap.init. auto.
+ apply Mem.extends_refl.
unfold symbol_offset.
rewrite (transform_partial_program_main _ _ TRANSF).
rewrite symbols_preserved. unfold ge; rewrite H1. auto.
@@ -1251,8 +1333,8 @@ Lemma transf_final_states:
match_states st1 st2 -> Machconcr.final_state st1 r -> Asm.final_state st2 r.
Proof.
intros. inv H0. inv H. constructor. auto.
- compute in H1.
- rewrite (ireg_val _ _ _ R0 AG) in H1. auto. auto.
+ compute in H1. exploit ireg_val; eauto. instantiate (1 := R0); auto.
+ simpl. intros LD. inv LD; congruence.
Qed.
Theorem transf_program_correct:
diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v
index fc2ce7f..c10c9df 100644
--- a/arm/Asmgenproof1.v
+++ b/arm/Asmgenproof1.v
@@ -27,7 +27,7 @@ Require Import Machconcr.
Require Import Machtyping.
Require Import Asm.
Require Import Asmgen.
-Require Conventions.
+Require Import Conventions.
(** * Correspondence between Mach registers and PPC registers *)
@@ -41,91 +41,86 @@ 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) : Prop :=
- match r with
- | IR IR14 => False
- | CR _ => False
- | PC => False
- | _ => True
- end.
-
-Lemma ireg_of_is_data_reg:
- forall (r: mreg), is_data_reg (ireg_of r).
-Proof.
- destruct r; exact I.
-Qed.
-
-Lemma freg_of_is_data_reg:
- forall (r: mreg), is_data_reg (ireg_of r).
-Proof.
- destruct r; exact I.
-Qed.
-
-Lemma preg_of_is_data_reg:
- forall (r: mreg), is_data_reg (preg_of r).
-Proof.
- destruct r; exact I.
-Qed.
-
Lemma ireg_of_not_IR13:
forall r, ireg_of r <> IR13.
Proof.
- intro. case r; discriminate.
+ destruct r; simpl; congruence.
Qed.
+
Lemma ireg_of_not_IR14:
forall r, ireg_of r <> IR14.
Proof.
- intro. case r; discriminate.
+ destruct r; simpl; congruence.
Qed.
-Hint Resolve ireg_of_not_IR13 ireg_of_not_IR14: ppcgen.
+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:
- forall r1 r2, ~(is_data_reg r2) -> preg_of r1 <> r2.
+Lemma preg_of_not_IR14:
+ forall r, preg_of r <> IR14.
Proof.
- intros; red; intro. subst r2. elim H. apply preg_of_is_data_reg.
+ unfold preg_of; intros. destruct (mreg_type r).
+ generalize (ireg_of_not_IR14 r); congruence.
+ congruence.
Qed.
-Hint Resolve preg_of_not: ppcgen.
-Lemma preg_of_not_IR13:
- forall r, preg_of r <> IR13.
+Lemma preg_of_not_PC:
+ forall r, preg_of r <> PC.
Proof.
- intro. case r; discriminate.
+ intros. unfold preg_of. destruct (mreg_type r); congruence.
Qed.
-Hint Resolve preg_of_not_IR13: ppcgen.
-(** Agreement between Mach register sets and PPC register sets. *)
+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. *)
-Definition agree (ms: Mach.regset) (sp: val) (rs: Asm.regset) :=
- rs#IR13 = sp /\ forall r: mreg, ms r = rs#(preg_of r).
+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 -> ms r = rs#(preg_of 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.
- intros. elim H. auto.
+ 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 ->
- ms r = rs#(ireg_of r).
+ Val.lessdef (ms r) rs#(ireg_of r).
Proof.
- intros. elim H; intros.
- generalize (H2 r). unfold preg_of. rewrite H0. auto.
+ 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 ->
- ms r = rs#(freg_of r).
+ Val.lessdef (ms r) rs#(freg_of r).
Proof.
- intros. elim H; intros.
- generalize (H2 r). unfold preg_of. rewrite H0. auto.
+ intros. generalize (preg_val _ _ _ r H). unfold preg_of. rewrite H0. auto.
Qed.
Lemma sp_val:
@@ -133,76 +128,71 @@ Lemma sp_val:
agree ms sp rs ->
sp = rs#IR13.
Proof.
- intros. elim H; auto.
+ intros. destruct H; auto.
Qed.
-Lemma agree_exten_1:
- forall ms sp rs rs',
- agree ms sp rs ->
- (forall r, is_data_reg r -> rs'#r = rs#r) ->
- agree ms sp rs'.
+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.
- unfold agree; intros. elim H; intros.
- split. rewrite H0. auto. exact I.
- intros. rewrite H0. auto. apply preg_of_is_data_reg.
+ intros. destruct r; reflexivity.
Qed.
-Lemma agree_exten_2:
+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, r <> PC -> r <> IR14 -> rs'#r = rs#r) ->
+ (forall r, important_preg r = true -> rs'#r = rs#r) ->
agree ms sp rs'.
Proof.
- intros. eapply agree_exten_1; eauto.
- intros. apply H0; red; intro; subst r; elim H1.
+ 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,
+ forall ms sp rs r v rs',
agree ms sp rs ->
- agree (Regmap.set r v ms) sp (rs#(preg_of r) <- v).
-Proof.
- unfold agree; intros. elim H; intros; clear H.
- split. rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_IR13.
- intros. unfold Regmap.set. case (RegEq.eq r0 r); intro.
- subst r0. rewrite Pregmap.gss. auto.
- rewrite Pregmap.gso. auto. red; intro.
- elim n. apply preg_of_injective; auto.
-Qed.
-Hint Resolve agree_set_mreg: ppcgen.
-
-Lemma agree_set_mireg:
- forall ms sp rs r v,
- agree ms sp (rs#(preg_of r) <- v) ->
- mreg_type r = Tint ->
- agree ms sp (rs#(ireg_of r) <- v).
-Proof.
- intros. unfold preg_of in H. rewrite H0 in H. auto.
-Qed.
-Hint Resolve agree_set_mireg: ppcgen.
-
-Lemma agree_set_mfreg:
- forall ms sp rs r v,
- agree ms sp (rs#(preg_of r) <- v) ->
- mreg_type r = Tfloat ->
- agree ms sp (rs#(freg_of r) <- v).
+ 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. unfold preg_of in H. rewrite H0 in H. auto.
+ 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.
-Hint Resolve agree_set_mfreg: ppcgen.
Lemma agree_set_other:
forall ms sp rs r v,
agree ms sp rs ->
- ~(is_data_reg r) ->
+ important_preg r = false ->
agree ms sp (rs#r <- v).
Proof.
- intros. apply agree_exten_1 with rs.
- auto. intros. apply Pregmap.gso. red; intro; subst r0; contradiction.
+ 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,
@@ -210,139 +200,159 @@ Lemma agree_nextinstr:
Proof.
intros. unfold nextinstr. apply agree_set_other. auto. auto.
Qed.
-Hint Resolve agree_nextinstr: ppcgen.
-Lemma agree_set_mireg_twice:
- forall ms sp rs r v v',
- agree ms sp rs ->
- mreg_type r = Tint ->
- agree (Regmap.set r v ms) sp (rs #(ireg_of r) <- v' #(ireg_of r) <- v).
+Definition nontemp_preg (r: preg) : bool :=
+ match r with
+ | IR IR14 => false
+ | IR IR10 => false
+ | IR IR12 => false
+ | IR _ => true
+ | FR FR2 => false
+ | FR FR3 => 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.
- intros. replace (IR (ireg_of r)) with (preg_of r). elim H; intros.
- split. repeat (rewrite Pregmap.gso; auto with ppcgen).
- intros. case (mreg_eq r r0); intro.
- subst r0. rewrite Regmap.gss. rewrite Pregmap.gss. auto.
- assert (preg_of r <> preg_of r0).
- red; intro. elim n. apply preg_of_injective. auto.
- rewrite Regmap.gso; auto.
- repeat (rewrite Pregmap.gso; auto).
- unfold preg_of. rewrite H0. auto.
+ congruence.
Qed.
-Hint Resolve agree_set_mireg_twice: ppcgen.
-Lemma agree_set_twice_mireg:
- forall ms sp rs r v v',
- agree (Regmap.set r v' ms) sp rs ->
- mreg_type r = Tint ->
- agree (Regmap.set r v ms) sp (rs#(ireg_of r) <- v).
+Hint Resolve nontemp_diff: ppcgen.
+
+Lemma nontemp_important:
+ forall r, nontemp_preg r = true -> important_preg r = true.
Proof.
- intros. elim H; intros.
- split. rewrite Pregmap.gso. auto.
- generalize (ireg_of_not_IR13 r); congruence.
- intros. generalize (H2 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.
+ unfold nontemp_preg, important_preg; destruct r; auto. destruct i; auto.
Qed.
-Hint Resolve agree_set_twice_mireg: ppcgen.
-Lemma agree_set_commut:
- forall ms sp rs r1 r2 v1 v2,
- r1 <> r2 ->
- agree ms sp ((rs#r2 <- v2)#r1 <- v1) ->
- agree ms sp ((rs#r1 <- v1)#r2 <- v2).
+Hint Resolve nontemp_important: ppcgen.
+
+Remark undef_regs_1:
+ forall l ms r, ms r = Vundef -> Mach.undef_regs l ms r = Vundef.
Proof.
- intros. apply agree_exten_1 with ((rs#r2 <- v2)#r1 <- v1). auto.
- intros.
- case (preg_eq r r1); intro.
- subst r1. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss.
- auto. auto.
- case (preg_eq r r2); intro.
- subst r2. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss.
- auto. auto.
- repeat (rewrite Pregmap.gso; auto).
-Qed.
-Hint Resolve agree_set_commut: ppcgen.
-
-Lemma agree_nextinstr_commut:
- forall ms sp rs r v,
- agree ms sp (rs#r <- v) ->
- r <> PC ->
- agree ms sp ((nextinstr rs)#r <- v).
+ induction l; simpl; intros. auto. apply IHl. unfold Regmap.set.
+ destruct (RegEq.eq r a); congruence.
+Qed.
+
+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.
- intros. unfold nextinstr. apply agree_set_commut. auto.
- apply agree_set_other. auto. auto.
+ induction l; simpl; intros. auto.
+ rewrite IHl. apply Regmap.gso. intuition. intuition.
Qed.
-Hint Resolve agree_nextinstr_commut: ppcgen.
-Lemma agree_set_mireg_exten:
- forall ms sp rs r v (rs': regset),
+Lemma agree_exten_temps:
+ forall ms sp rs rs',
agree ms sp rs ->
- mreg_type r = Tint ->
- rs'#(ireg_of r) = v ->
- (forall r', r' <> PC -> r' <> ireg_of r -> r' <> IR14 -> rs'#r' = rs#r') ->
- agree (Regmap.set r v ms) sp rs'.
+ (forall r, nontemp_preg r = true -> rs'#r = rs#r) ->
+ agree (undef_temps ms) sp rs'.
Proof.
- intros. apply agree_exten_2 with (rs#(ireg_of r) <- v).
- auto with ppcgen.
- intros. unfold Pregmap.set. case (PregEq.eq r0 (ireg_of r)); intro.
- subst r0. auto. apply H2; auto.
+ 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.
-(** Useful properties of the PC and GPR0 registers. *)
+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_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.
+ 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. unfold nextinstr. apply Pregmap.gso. auto.
+ intros. apply nextinstr_inv. red; intro; subst; discriminate.
Qed.
-Hint Resolve nextinstr_inv: ppcgen.
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. auto with ppcgen.
+ rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_PC.
Qed.
-Hint Resolve nextinstr_set_preg: ppcgen.
(** Connection between Mach and Asm calling conventions for external
functions. *)
Lemma extcall_arg_match:
- forall ms sp rs m l v,
+ forall ms sp rs m m' l v,
agree ms sp rs ->
Machconcr.extcall_arg ms m sp l v ->
- Asm.extcall_arg rs m l v.
+ Mem.extends m m' ->
+ exists v', Asm.extcall_arg rs m' l v' /\ Val.lessdef v v'.
Proof.
- intros. inv H0.
- rewrite (preg_val _ _ _ r H). constructor.
- rewrite (sp_val _ _ _ H) in H1.
- destruct ty; unfold load_stack in H1.
- econstructor. reflexivity. assumption.
- econstructor. reflexivity. assumption.
+ 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, agree ms sp rs ->
+ forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' ->
forall ll vl,
Machconcr.extcall_args ms m sp ll vl ->
- Asm.extcall_args rs m ll vl.
+ exists vl', Asm.extcall_args rs m' ll vl' /\ Val.lessdef_list vl vl'.
Proof.
- induction 2; constructor; auto. eapply extcall_arg_match; eauto.
+ induction 3.
+ exists (@nil val); split; constructor.
+ exploit extcall_arg_match; eauto. intros [v1' [A B]].
+ exploit IHextcall_args; eauto. intros [vl' [C D]].
+ exists(v1' :: vl'); split. constructor; auto. constructor; auto.
Qed.
Lemma extcall_arguments_match:
- forall ms m sp rs sg args,
+ forall ms m sp rs sg args m',
agree ms sp rs ->
Machconcr.extcall_arguments ms m sp sg args ->
- Asm.extcall_arguments rs m sg args.
+ Mem.extends m m' ->
+ exists args', Asm.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'.
Proof.
unfold Machconcr.extcall_arguments, Asm.extcall_arguments; intros.
eapply extcall_args_match; eauto.
@@ -564,7 +574,7 @@ Proof.
exploit loadimm_correct. intros [rs' [A [B C]]].
exists (nextinstr (rs'#r1 <- (Val.and rs#r2 (Vint n)))).
split. eapply exec_straight_trans. eauto. apply exec_straight_one.
- simpl. rewrite B. rewrite C; auto with ppcgen. congruence.
+ simpl. rewrite B. rewrite C; auto with ppcgen.
auto.
split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
@@ -756,20 +766,6 @@ Qed.
(** Translation of conditions *)
-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.
-
-(** Translation of conditions. *)
-
Lemma compare_int_spec:
forall rs v1 v2,
let rs1 := nextinstr (compare_int rs v1 v2) in
@@ -783,11 +779,11 @@ 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', is_data_reg r' -> rs1#r' = rs#r'.
+ /\ forall r', important_preg r' = true -> rs1#r' = rs#r'.
Proof.
intros. unfold rs1. intuition; try reflexivity.
- rewrite nextinstr_inv; [unfold compare_int; repeat rewrite Pregmap.gso; auto | idtac];
- red; intro; subst r'; elim H.
+ rewrite nextinstr_inv; auto with ppcgen.
+ unfold compare_int. repeat rewrite Pregmap.gso; auto with ppcgen.
Qed.
Lemma compare_float_spec:
@@ -803,302 +799,237 @@ 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', is_data_reg r' -> rs'#r' = rs#r'.
+ /\ forall r', important_preg r' = true -> rs'#r' = rs#r'.
Proof.
intros. unfold rs'. intuition; try reflexivity.
- rewrite nextinstr_inv; [unfold compare_float; repeat rewrite Pregmap.gso; auto | idtac];
- red; intro; subst r'; elim H.
+ 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.
+
Lemma transl_cond_correct:
- forall cond args k ms sp rs m b,
+ forall cond args k rs m b,
map mreg_type args = type_of_condition cond ->
- agree ms sp rs ->
- eval_condition cond (map ms args) = Some b ->
+ eval_condition cond (map rs (map preg_of args)) = Some b ->
exists rs',
exec_straight (transl_cond cond args k) rs m k rs' m
/\ rs'#(CR (crbit_for_cond cond)) = Val.of_bool b
- /\ agree ms sp rs'.
+ /\ forall r, important_preg r = true -> rs'#r = rs r.
Proof.
- intros.
- rewrite <- (eval_condition_weaken _ _ H1). clear H1.
- destruct cond; simpl in H; TypeInv; simpl.
+ intros until b; intros TY EV. rewrite <- (eval_condition_weaken _ _ EV). clear EV.
+ destruct cond; simpl in TY; TypeInv.
(* Ccomp *)
- generalize (compare_int_spec rs ms#m0 ms#m1).
+ generalize (compare_int_spec rs (rs (ireg_of m0)) (rs (ireg_of m1))).
intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
- exists (nextinstr (compare_int rs ms#m0 ms#m1)).
- split. apply exec_straight_one. simpl.
- repeat rewrite <- (ireg_val ms sp rs); trivial.
- reflexivity.
- split.
- case c; simpl; auto.
- apply agree_exten_1 with rs; auto.
+ econstructor.
+ split. apply exec_straight_one. simpl. eauto. auto.
+ split. case c; assumption.
+ auto.
(* Ccompu *)
- generalize (compare_int_spec rs ms#m0 ms#m1).
+ generalize (compare_int_spec rs (rs (ireg_of m0)) (rs (ireg_of m1))).
intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
- exists (nextinstr (compare_int rs ms#m0 ms#m1)).
- split. apply exec_straight_one. simpl.
- repeat rewrite <- (ireg_val ms sp rs); trivial.
- reflexivity.
- split.
- case c; simpl; auto.
- apply agree_exten_1 with rs; auto.
+ econstructor.
+ split. apply exec_straight_one. simpl. eauto. auto.
+ split. case c; assumption.
+ auto.
(* Ccompshift *)
- generalize (compare_int_spec rs ms#m0 (eval_shift_total s ms#m1)).
+ generalize (compare_int_spec rs (rs (ireg_of m0)) (eval_shift_total s (rs (ireg_of m1)))).
intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
- exists (nextinstr (compare_int rs ms#m0 (eval_shift_total s ms#m1))).
- split. apply exec_straight_one. simpl.
- rewrite transl_shift_correct.
- repeat rewrite <- (ireg_val ms sp rs); trivial.
- reflexivity.
- split.
- case c; simpl; auto.
- apply agree_exten_1 with rs; auto.
+ econstructor.
+ split. apply exec_straight_one. simpl. eauto. auto.
+ split. rewrite transl_shift_correct. case c; assumption.
+ rewrite transl_shift_correct. auto.
(* Ccompushift *)
- generalize (compare_int_spec rs ms#m0 (eval_shift_total s ms#m1)).
+ generalize (compare_int_spec rs (rs (ireg_of m0)) (eval_shift_total s (rs (ireg_of m1)))).
intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
- exists (nextinstr (compare_int rs ms#m0 (eval_shift_total s ms#m1))).
- split. apply exec_straight_one. simpl.
- rewrite transl_shift_correct.
- repeat rewrite <- (ireg_val ms sp rs); trivial.
- reflexivity.
- split.
- case c; simpl; auto.
- apply agree_exten_1 with rs; auto.
+ econstructor.
+ split. apply exec_straight_one. simpl. eauto. auto.
+ split. rewrite transl_shift_correct. case c; assumption.
+ rewrite transl_shift_correct. auto.
(* Ccompimm *)
destruct (is_immed_arith i).
- generalize (compare_int_spec rs ms#m0 (Vint i)).
+ generalize (compare_int_spec rs (rs (ireg_of m0)) (Vint i)).
intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
- exists (nextinstr (compare_int rs ms#m0 (Vint i))).
- split. apply exec_straight_one. simpl.
- rewrite <- (ireg_val ms sp rs); trivial. auto.
- split.
- case c; simpl; auto.
- apply agree_exten_1 with rs; auto.
+ econstructor.
+ split. apply exec_straight_one. simpl. eauto. auto.
+ split. case c; assumption.
+ auto.
exploit (loadimm_correct IR14). intros [rs' [P [Q R]]].
- assert (AG: agree ms sp rs'). apply agree_exten_2 with rs; auto.
- generalize (compare_int_spec rs' ms#m0 (Vint i)).
+ generalize (compare_int_spec rs' (rs (ireg_of m0)) (Vint i)).
intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
- exists (nextinstr (compare_int rs' ms#m0 (Vint i))).
+ econstructor.
split. eapply exec_straight_trans. eexact P. apply exec_straight_one. simpl.
- rewrite Q. rewrite <- (ireg_val ms sp rs'); trivial. auto.
- split.
- case c; simpl; auto.
- apply agree_exten_1 with rs'; auto.
+ rewrite Q. rewrite R; eauto with ppcgen. auto.
+ split. case c; assumption.
+ intros. rewrite K; auto with ppcgen.
(* Ccompuimm *)
destruct (is_immed_arith i).
- generalize (compare_int_spec rs ms#m0 (Vint i)).
+ generalize (compare_int_spec rs (rs (ireg_of m0)) (Vint i)).
intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
- exists (nextinstr (compare_int rs ms#m0 (Vint i))).
- split. apply exec_straight_one. simpl.
- rewrite <- (ireg_val ms sp rs); trivial. auto.
- split.
- case c; simpl; auto.
- apply agree_exten_1 with rs; auto.
+ econstructor.
+ split. apply exec_straight_one. simpl. eauto. auto.
+ split. case c; assumption.
+ auto.
exploit (loadimm_correct IR14). intros [rs' [P [Q R]]].
- assert (AG: agree ms sp rs'). apply agree_exten_2 with rs; auto.
- generalize (compare_int_spec rs' ms#m0 (Vint i)).
+ generalize (compare_int_spec rs' (rs (ireg_of m0)) (Vint i)).
intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]].
- exists (nextinstr (compare_int rs' ms#m0 (Vint i))).
+ econstructor.
split. eapply exec_straight_trans. eexact P. apply exec_straight_one. simpl.
- rewrite Q. rewrite <- (ireg_val ms sp rs'); trivial. auto.
- split.
- case c; simpl; auto.
- apply agree_exten_1 with rs'; auto.
+ rewrite Q. rewrite R; eauto with ppcgen. auto.
+ split. case c; assumption.
+ intros. rewrite K; auto with ppcgen.
(* Ccompf *)
- generalize (compare_float_spec rs ms#m0 ms#m1).
+ 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]]]]]]]]]].
- exists (nextinstr (compare_float rs ms#m0 ms#m1)).
- split. apply exec_straight_one. simpl.
- repeat rewrite <- (freg_val ms sp rs); trivial. auto.
- split.
- case c; simpl; auto.
- apply agree_exten_1 with rs; auto.
+ econstructor.
+ split. apply exec_straight_one. simpl. eauto. auto.
+ split. case c; assumption.
+ auto.
(* Cnotcompf *)
- generalize (compare_float_spec rs ms#m0 ms#m1).
+ 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]]]]]]]]]].
- exists (nextinstr (compare_float rs ms#m0 ms#m1)).
- split. apply exec_straight_one. simpl.
- repeat rewrite <- (freg_val ms sp rs); trivial. auto.
- split.
- case c; simpl; auto.
+ econstructor.
+ split. apply exec_straight_one. simpl. eauto. auto.
+ split. case c; try assumption.
rewrite Val.negate_cmpf_ne. auto.
rewrite Val.negate_cmpf_eq. auto.
- apply agree_exten_1 with rs; auto.
+ auto.
Qed.
(** Translation of arithmetic operations. *)
-Ltac TranslOpSimpl :=
+Ltac Simpl :=
match goal with
- | |- exists rs' : regset,
- exec_straight ?c ?rs ?m ?k rs' ?m /\
- agree (Regmap.set ?res ?v ?ms) ?sp rs' =>
- (exists (nextinstr (rs#(ireg_of res) <- v));
- split;
- [ apply exec_straight_one;
- [ repeat (rewrite (ireg_val ms sp rs); auto);
- simpl; try rewrite transl_shift_correct; reflexivity
- | reflexivity ]
- | auto with ppcgen ])
- ||
- (exists (nextinstr (rs#(freg_of res) <- v));
- split;
- [ apply exec_straight_one;
- [ repeat (rewrite (freg_val ms sp rs); auto); reflexivity
- | reflexivity ]
- | auto with ppcgen ])
+ | [ |- nextinstr _ _ = _ ] => rewrite nextinstr_inv; [auto | auto with ppcgen]
+ | [ |- Pregmap.get ?x (Pregmap.set ?x _ _) = _ ] => rewrite Pregmap.gss; auto
+ | [ |- Pregmap.set ?x _ _ ?x = _ ] => rewrite Pregmap.gss; auto
+ | [ |- Pregmap.get _ (Pregmap.set _ _ _) = _ ] => rewrite Pregmap.gso; [auto | auto with ppcgen]
+ | [ |- Pregmap.set _ _ _ _ = _ ] => rewrite Pregmap.gso; [auto | auto with ppcgen]
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:
- forall op args res k ms sp rs m v,
+ forall op args res k (rs: regset) m v,
wt_instr (Mop op args res) ->
- agree ms sp rs ->
- eval_operation ge sp op (map ms args) = Some v ->
+ eval_operation ge rs#IR13 op (map rs (map preg_of args)) = Some v ->
exists rs',
exec_straight (transl_op op args res k) rs m k rs' m
- /\ agree (Regmap.set res v ms) sp rs'.
+ /\ rs'#(preg_of res) = v
+ /\ forall r, important_preg r = true -> r <> preg_of res -> rs'#r = rs#r.
Proof.
- intros. rewrite <- (eval_operation_weaken _ _ _ _ H1). (*clear H1; clear v.*)
- inversion H.
+ intros. rewrite <- (eval_operation_weaken _ _ _ _ H0). inv H.
(* Omove *)
- simpl. exists (nextinstr (rs#(preg_of res) <- (ms r1))).
- split. caseEq (mreg_type r1); intro.
- apply exec_straight_one. simpl. rewrite (ireg_val ms sp rs); auto.
- simpl. unfold preg_of. rewrite <- H3. rewrite H6. reflexivity.
- auto with ppcgen.
- apply exec_straight_one. simpl. rewrite (freg_val ms sp rs); auto.
- simpl. unfold preg_of. rewrite <- H3. rewrite H6. reflexivity.
- auto with ppcgen.
- auto with ppcgen.
+ simpl.
+ exists (nextinstr (rs#(preg_of res) <- (rs#(preg_of r1)))).
+ split. unfold preg_of; rewrite <- H2.
+ destruct (mreg_type r1); apply exec_straight_one; auto.
+ split. Simpl. Simpl.
+ intros. Simpl. Simpl.
(* Other instructions *)
- clear H2 H3 H5.
- destruct op; simpl in H6; injection H6; clear H6; intros;
- TypeInv; simpl; try (TranslOpSimpl).
+ destruct op; simpl in H5; inv H5; TypeInv; try (TranslOpSimpl; fail).
(* Omove again *)
congruence.
(* Ointconst *)
- generalize (loadimm_correct (ireg_of res) i k rs m).
- intros [rs' [A [B C]]].
- exists rs'. split. auto.
- apply agree_set_mireg_exten with rs; auto.
+ generalize (loadimm_correct (ireg_of res) i k rs m). intros [rs' [A [B C]]].
+ exists rs'. split. auto. split. auto. intros. auto with ppcgen.
(* Oaddrstack *)
generalize (addimm_correct (ireg_of res) IR13 i k rs m).
intros [rs' [EX [RES OTH]]].
- exists rs'. split. auto.
- apply agree_set_mireg_exten with rs; auto.
- rewrite (sp_val ms sp rs). auto. auto.
+ exists rs'. split. auto. split. auto. auto with ppcgen.
(* Ocast8signed *)
- set (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shl (ms m0) (Vint (Int.repr 24))))).
- set (rs2 := nextinstr (rs1#(ireg_of res) <- (Val.shr (rs1 (ireg_of res)) (Vint (Int.repr 24))))).
- exists rs2. split.
- apply exec_straight_two with rs1 m; auto.
- simpl. rewrite <- (ireg_val ms sp rs); auto.
- unfold rs2.
- replace (Val.shr (rs1 (ireg_of res)) (Vint (Int.repr 24))) with (Val.sign_ext 8 (ms m0)).
- apply agree_nextinstr. unfold rs1. apply agree_nextinstr_commut.
- apply agree_set_mireg_twice; auto with ppcgen. auto with ppcgen.
- unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
- destruct (ms m0); simpl; auto. rewrite Int.sign_ext_shr_shl. reflexivity.
- vm_compute; auto.
+ econstructor; split.
+ eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto.
+ split. Simpl. Simpl. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
+ destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.sign_ext_shr_shl. reflexivity.
+ compute; auto.
+ intros. repeat Simpl.
(* Ocast8unsigned *)
- exists (nextinstr (rs#(ireg_of res) <- (Val.and (ms m0) (Vint (Int.repr 255))))).
- split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity.
- replace (Val.zero_ext 8 (ms m0))
- with (Val.and (ms m0) (Vint (Int.repr 255))).
- auto with ppcgen.
- destruct (ms m0); simpl; auto. rewrite Int.zero_ext_and. reflexivity.
- vm_compute; auto.
+ econstructor; split.
+ eapply exec_straight_one. simpl; eauto. auto.
+ split. Simpl. Simpl.
+ destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.zero_ext_and. reflexivity.
+ compute; auto.
+ intros. repeat Simpl.
(* Ocast16signed *)
- set (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shl (ms m0) (Vint (Int.repr 16))))).
- set (rs2 := nextinstr (rs1#(ireg_of res) <- (Val.shr (rs1 (ireg_of res)) (Vint (Int.repr 16))))).
- exists rs2. split.
- apply exec_straight_two with rs1 m; auto.
- simpl. rewrite <- (ireg_val ms sp rs); auto.
- unfold rs2.
- replace (Val.shr (rs1 (ireg_of res)) (Vint (Int.repr 16))) with (Val.sign_ext 16 (ms m0)).
- apply agree_nextinstr. unfold rs1. apply agree_nextinstr_commut.
- apply agree_set_mireg_twice; auto with ppcgen. auto with ppcgen.
- unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
- destruct (ms m0); simpl; auto. rewrite Int.sign_ext_shr_shl. reflexivity.
- vm_compute; auto.
+ econstructor; split.
+ eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto.
+ split. Simpl. Simpl. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
+ destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.sign_ext_shr_shl. reflexivity.
+ compute; auto.
+ intros. repeat Simpl.
(* Ocast16unsigned *)
- set (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shl (ms m0) (Vint (Int.repr 16))))).
- set (rs2 := nextinstr (rs1#(ireg_of res) <- (Val.shru (rs1 (ireg_of res)) (Vint (Int.repr 16))))).
- exists rs2. split.
- apply exec_straight_two with rs1 m; auto.
- simpl. rewrite <- (ireg_val ms sp rs); auto.
- unfold rs2.
- replace (Val.shru (rs1 (ireg_of res)) (Vint (Int.repr 16))) with (Val.zero_ext 16 (ms m0)).
- apply agree_nextinstr. unfold rs1. apply agree_nextinstr_commut.
- apply agree_set_mireg_twice; auto with ppcgen. auto with ppcgen.
- unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
- destruct (ms m0); simpl; auto. rewrite Int.zero_ext_shru_shl. reflexivity.
- vm_compute; auto.
+ econstructor; split.
+ eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto.
+ split. Simpl. Simpl. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
+ destruct (rs (ireg_of m0)); simpl; auto. rewrite Int.zero_ext_shru_shl. reflexivity.
+ compute; auto.
+ intros. repeat Simpl.
(* Oaddimm *)
generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m).
intros [rs' [A [B C]]].
- exists rs'. split. auto.
- apply agree_set_mireg_exten with rs; auto.
- rewrite (ireg_val ms sp rs); auto.
+ exists rs'. split. auto. split. auto. auto with ppcgen.
(* Orsbimm *)
exploit (makeimm_correct Prsb (fun v1 v2 => Val.sub v2 v1) (ireg_of res) (ireg_of m0));
auto with ppcgen.
intros [rs' [A [B C]]].
exists rs'.
- split. eauto.
- apply agree_set_mireg_exten with rs; auto. rewrite B.
- rewrite <- (ireg_val ms sp rs); auto.
+ split. eauto. split. rewrite B. auto. auto with ppcgen.
(* Omul *)
destruct (ireg_eq (ireg_of res) (ireg_of m0) || ireg_eq (ireg_of res) (ireg_of m1)).
- set (rs1 := nextinstr (rs#IR14 <- (Val.mul (ms m0) (ms m1)))).
- set (rs2 := nextinstr (rs1#(ireg_of res) <- (rs1#IR14))).
- exists rs2; split.
- apply exec_straight_two with rs1 m; auto.
- simpl. repeat rewrite <- (ireg_val ms sp rs); auto.
- unfold rs2. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss.
- apply agree_nextinstr. apply agree_nextinstr_commut.
- apply agree_set_mireg; auto. apply agree_set_mreg. apply agree_set_other. auto.
- simpl; auto. auto with ppcgen. discriminate.
+ econstructor; split.
+ eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto.
+ split. repeat Simpl.
+ intros. repeat Simpl.
TranslOpSimpl.
(* Oandimm *)
generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m
(ireg_of_not_IR14 m0)).
intros [rs' [A [B C]]].
- exists rs'. split. auto.
- apply agree_set_mireg_exten with rs; auto.
- rewrite (ireg_val ms sp rs); auto.
+ exists rs'. split. auto. split. auto. auto with ppcgen.
(* Oorimm *)
exploit (makeimm_correct Porr Val.or (ireg_of res) (ireg_of m0));
auto with ppcgen.
- intros [rs' [A [B C]]].
- exists rs'.
- split. eauto.
- apply agree_set_mireg_exten with rs; auto. rewrite B.
- rewrite <- (ireg_val ms sp rs); auto.
+ intros [rs' [A [B C]]].
+ exists rs'. split. eauto. split. auto. auto with ppcgen.
(* Oxorimm *)
exploit (makeimm_correct Peor Val.xor (ireg_of res) (ireg_of m0));
auto with ppcgen.
- intros [rs' [A [B C]]].
- exists rs'.
- split. eauto.
- apply agree_set_mireg_exten with rs; auto. rewrite B.
- rewrite <- (ireg_val ms sp rs); auto.
+ intros [rs' [A [B C]]].
+ exists rs'. split. eauto. split. auto. auto with ppcgen.
(* Oshrximm *)
- assert (exists n, ms m0 = Vint n /\ Int.ltu i (Int.repr 31) = true).
- simpl in H1. destruct (ms m0); try discriminate.
+ assert (exists n, rs (ireg_of m0) = Vint n /\ Int.ltu i (Int.repr 31) = true).
+ destruct (rs (ireg_of m0)); try discriminate.
exists i0; split; auto. destruct (Int.ltu i (Int.repr 31)); discriminate || auto.
- destruct H3 as [n [ARG1 LTU]].
+ destruct H as [n [ARG1 LTU]]. clear H0.
assert (LTU': Int.ltu i Int.iwordsize = true).
exploit Int.ltu_inv. eexact LTU. intro.
unfold Int.ltu. apply zlt_true.
- assert (Int.unsigned (Int.repr 31) < Int.unsigned Int.iwordsize). vm_compute; auto.
+ assert (Int.unsigned (Int.repr 31) < Int.unsigned Int.iwordsize). compute; auto.
omega.
- assert (RSm0: rs (ireg_of m0) = Vint n).
- rewrite <- ARG1. symmetry. eapply ireg_val; eauto.
set (islt := Int.lt n Int.zero).
set (rs1 := nextinstr (compare_int rs (Vint n) (Vint Int.zero))).
- assert (OTH1: forall r', is_data_reg r' -> rs1#r' = rs#r').
+ assert (OTH1: forall r', important_preg r' = true -> rs1#r' = rs#r').
generalize (compare_int_spec rs (Vint n) (Vint Int.zero)).
fold rs1. intros [A B]. intuition.
exploit (addimm_correct IR14 (ireg_of m0) (Int.sub (Int.shl Int.one i) Int.one)).
@@ -1107,83 +1038,47 @@ Proof.
set (rs4 := nextinstr (rs3#(ireg_of res) <- (Val.shr rs3#IR14 (Vint i)))).
exists rs4; split.
apply exec_straight_step with rs1 m.
- simpl. rewrite RSm0. auto. auto.
+ 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)).
unfold Val.cmp. change (Int.cmp Cge n Int.zero) with (negb islt).
- rewrite OTH2. rewrite OTH1. rewrite RSm0.
+ rewrite OTH2. rewrite OTH1. rewrite ARG1.
unfold rs3. case islt; reflexivity.
- apply ireg_of_is_data_reg. decEq; auto with ppcgen. auto with ppcgen. congruence. congruence.
+ destruct m0; reflexivity. auto with ppcgen. auto with ppcgen. discriminate. discriminate.
simpl. auto.
auto. unfold rs3. case islt; auto. auto.
- (* agreement *)
- assert (RES4: rs4#(ireg_of res) = Vint(Int.shrx n i)).
- unfold rs4. rewrite nextinstr_inv; auto. rewrite Pregmap.gss.
- rewrite Int.shrx_shr. fold islt. unfold rs3.
- repeat rewrite nextinstr_inv; auto.
- case islt. rewrite RES2. rewrite OTH1. rewrite RSm0.
- simpl. rewrite LTU'. auto.
- apply ireg_of_is_data_reg.
- rewrite Pregmap.gss. simpl. rewrite LTU'. auto. congruence.
- exact LTU. auto with ppcgen.
- assert (OTH4: forall r, is_data_reg r -> r <> ireg_of res -> rs4#r = rs#r).
- intros.
- assert (r <> PC). red; intro; subst r; elim H3.
- assert (r <> IR14). red; intro; subst r; elim H3.
- unfold rs4. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
- unfold rs3. rewrite nextinstr_inv; auto.
- transitivity (rs2 r).
- case islt. auto. apply Pregmap.gso; auto.
- rewrite OTH2; auto.
- apply agree_exten_1 with (rs#(ireg_of res) <- (Val.shrx (ms m0) (Vint i))).
- auto with ppcgen.
- intros. unfold Pregmap.set. destruct (PregEq.eq r (ireg_of res)).
- subst r. rewrite ARG1. simpl. rewrite LTU'. auto.
- auto.
- (* Ointoffloat *)
- exists (nextinstr (rs#(ireg_of res) <- (Val.intoffloat (ms m0)))).
- split. apply exec_straight_one.
- repeat (rewrite (freg_val ms sp rs); auto).
- reflexivity. auto with ppcgen.
- (* Ointuoffloat *)
- exists (nextinstr (rs#(ireg_of res) <- (Val.intuoffloat (ms m0)))).
- split. apply exec_straight_one.
- repeat (rewrite (freg_val ms sp rs); auto).
- reflexivity. auto with ppcgen.
- (* Ofloatofint *)
- exists (nextinstr (rs#(freg_of res) <- (Val.floatofint (ms m0)))).
- split. apply exec_straight_one.
- repeat (rewrite (ireg_val ms sp rs); auto).
- reflexivity. auto 10 with ppcgen.
- (* Ofloatofintu *)
- exists (nextinstr (rs#(freg_of res) <- (Val.floatofintu (ms m0)))).
- split. apply exec_straight_one.
- repeat (rewrite (ireg_val ms sp rs); auto).
- reflexivity. auto 10 with ppcgen.
+ split. unfold rs4. repeat Simpl. rewrite ARG1. simpl. rewrite LTU'. rewrite Int.shrx_shr.
+ fold islt. unfold rs3. rewrite nextinstr_inv; auto with ppcgen.
+ destruct islt. rewrite RES2. change (rs1 (IR (ireg_of m0))) with (rs (IR (ireg_of m0))).
+ rewrite ARG1. simpl. rewrite LTU'. auto.
+ rewrite Pregmap.gss. simpl. rewrite LTU'. auto.
+ assumption.
+ intros. unfold rs4; repeat Simpl. unfold rs3; repeat Simpl.
+ transitivity (rs2 r). destruct islt; auto. Simpl.
+ rewrite OTH2; auto with ppcgen.
(* Ocmp *)
- assert (exists b, eval_condition c ms##args = Some b /\ v = Val.of_bool b).
- simpl in H1. destruct (eval_condition c ms##args).
- destruct b; inv H1. exists true; auto. exists false; auto.
- discriminate.
- destruct H5 as [b [EVC EQ]].
- exploit transl_cond_correct; eauto. intros [rs' [A [B C]]].
- rewrite (eval_condition_weaken _ _ EVC).
- set (rs1 := nextinstr (rs'#(ireg_of res) <- (Vint Int.zero))).
- set (rs2 := nextinstr (if b then (rs1#(ireg_of res) <- Vtrue) else rs1)).
- exists rs2; split.
- eapply exec_straight_trans. eauto.
- apply exec_straight_two with rs1 m; auto.
- simpl. replace (rs1 (crbit_for_cond c)) with (Val.of_bool b).
- unfold rs2. destruct b; auto.
- unfold rs2. destruct b; auto.
- apply agree_set_mireg_exten with rs'; auto.
- unfold rs2. rewrite nextinstr_inv; auto with ppcgen.
- destruct b. apply Pregmap.gss.
- unfold rs1. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
- intros. unfold rs2. rewrite nextinstr_inv; auto.
- transitivity (rs1 r'). destruct b; auto. rewrite Pregmap.gso; auto.
- unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+ fold preg_of in *.
+ assert (exists b, eval_condition c rs ## (preg_of ## args) = Some b /\ v = Val.of_bool b).
+ fold preg_of in H0. destruct (eval_condition c rs ## (preg_of ## args)).
+ exists b; split; auto. destruct b; inv H0; auto. congruence.
+ clear H0. destruct H as [b [EVC VBO]]. rewrite (eval_condition_weaken _ _ EVC).
+ destruct (transl_cond_correct c args
+ (Pmov (ireg_of res) (SOimm Int.zero)
+ :: Pmovc (crbit_for_cond c) (ireg_of res) (SOimm Int.one) :: k)
+ rs m b H1 EVC)
+ as [rs1 [A [B C]]].
+ set (rs2 := nextinstr (rs1#(ireg_of res) <- (Vint Int.zero))).
+ set (rs3 := nextinstr (if b then (rs2#(ireg_of res) <- Vtrue) else rs2)).
+ exists rs3.
+ split. eapply exec_straight_trans. eauto.
+ apply exec_straight_two with rs2 m; auto.
+ simpl. replace (rs2 (crbit_for_cond c)) with (Val.of_bool b).
+ unfold rs3. destruct b; auto.
+ unfold rs3. destruct b; auto.
+ split. unfold rs3. Simpl. destruct b. Simpl. unfold rs2. repeat Simpl.
+ intros. unfold rs3. Simpl. transitivity (rs2 r).
+ destruct b; auto; Simpl. unfold rs2. repeat Simpl.
Qed.
Remark val_add_add_zero:
@@ -1191,15 +1086,15 @@ Remark val_add_add_zero:
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)
(mk_instr_gen: option (ireg -> shift_addr -> instruction))
(is_immed: int -> bool)
addr args k ms sp rs m ms' m',
(forall (r1: ireg) (rs1: regset) n k,
- eval_addressing_total sp addr (map ms args) = Val.add rs1#r1 (Vint n) ->
- agree ms sp rs1 ->
+ eval_addressing_total sp addr (map rs (map preg_of args)) = Val.add rs1#r1 (Vint n) ->
+ (forall (r: preg), r <> PC -> r <> IR14 -> rs1 r = rs r) ->
exists rs',
exec_straight (mk_instr_imm r1 n :: k) rs1 m k rs' m' /\
agree ms' sp rs') ->
@@ -1207,8 +1102,8 @@ Lemma transl_load_store_correct:
| None => True
| Some mk =>
(forall (r1: ireg) (sa: shift_addr) (rs1: regset) k,
- eval_addressing_total sp addr (map ms args) = Val.add rs1#r1 (eval_shift_addr sa rs1) ->
- agree ms sp rs1 ->
+ eval_addressing_total sp addr (map rs (map preg_of args)) = Val.add rs1#r1 (eval_shift_addr sa rs1) ->
+ (forall (r: preg), r <> PC -> r <> IR14 -> rs1 r = rs r) ->
exists rs',
exec_straight (mk r1 sa :: k) rs1 m k rs' m' /\
agree ms' sp rs')
@@ -1224,62 +1119,53 @@ Proof.
(* Aindexed *)
case (is_immed i).
(* Aindexed, small displacement *)
- apply H; eauto. simpl. rewrite (ireg_val ms sp rs); auto.
+ apply H; auto.
(* Aindexed, large displacement *)
- exploit (addimm_correct IR14 (ireg_of t)); eauto with ppcgen.
- intros [rs' [A [B C]]].
- exploit (H IR14 rs' Int.zero); eauto.
- simpl. rewrite (ireg_val ms sp rs); auto. rewrite B.
- rewrite Val.add_assoc. simpl Val.add. rewrite Int.add_zero. reflexivity.
- apply agree_exten_2 with rs; auto.
+ destruct (addimm_correct IR14 (ireg_of m0) i (mk_instr_imm IR14 Int.zero :: k) rs m)
+ as [rs' [A [B C]]].
+ exploit (H 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.
eapply exec_straight_trans. eexact A. eexact D. auto.
(* Aindexed2 *)
destruct mk_instr_gen as [mk | ].
(* binary form available *)
- apply H0; auto. simpl. repeat rewrite (ireg_val ms sp rs); auto.
+ apply H0; auto.
(* binary form not available *)
- set (rs' := nextinstr (rs#IR14 <- (Val.add (ms t) (ms t0)))).
+ set (rs' := nextinstr (rs#IR14 <- (Val.add (rs (ireg_of m0)) (rs (ireg_of m1))))).
exploit (H IR14 rs' Int.zero); eauto.
- simpl. repeat rewrite (ireg_val ms sp rs); auto.
unfold rs'. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
- repeat rewrite (ireg_val ms sp rs); auto. apply val_add_add_zero.
- unfold rs'; auto with ppcgen.
+ apply val_add_add_zero.
+ unfold rs'. intros. repeat Simpl.
intros [rs'' [A B]].
exists rs''; split.
eapply exec_straight_step with (rs2 := rs'); eauto.
- simpl. repeat rewrite <- (ireg_val ms sp rs); auto.
- auto.
+ simpl. auto. auto.
(* Aindexed2shift *)
destruct mk_instr_gen as [mk | ].
(* binary form available *)
- apply H0; auto. simpl. repeat rewrite (ireg_val ms sp rs); auto.
- rewrite transl_shift_addr_correct. auto.
+ apply H0; auto. rewrite transl_shift_addr_correct. auto.
(* binary form not available *)
- set (rs' := nextinstr (rs#IR14 <- (Val.add (ms t) (eval_shift_total s (ms t0))))).
+ set (rs' := nextinstr (rs#IR14 <- (Val.add (rs (ireg_of m0)) (eval_shift_total s (rs (ireg_of m1)))))).
exploit (H IR14 rs' Int.zero); eauto.
- simpl. repeat rewrite (ireg_val ms sp rs); auto.
unfold rs'. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
- repeat rewrite (ireg_val ms sp rs); auto. apply val_add_add_zero.
- unfold rs'; auto with ppcgen.
+ apply val_add_add_zero.
+ unfold rs'; intros; repeat Simpl.
intros [rs'' [A B]].
exists rs''; split.
eapply exec_straight_step with (rs2 := rs'); eauto.
- simpl. rewrite transl_shift_correct.
- repeat rewrite <- (ireg_val ms sp rs); auto.
+ simpl. rewrite transl_shift_correct. auto.
auto.
(* Ainstack *)
destruct (is_immed i).
(* Ainstack, short displacement *)
- apply H. simpl. rewrite (sp_val ms sp rs); auto. auto.
+ apply H; auto. rewrite (sp_val _ _ _ H1). auto.
(* Ainstack, large displacement *)
- exploit (addimm_correct IR14 IR13); eauto with ppcgen.
- intros [rs' [A [B C]]].
+ 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.
- simpl. rewrite (sp_val ms sp rs); auto. rewrite B.
- rewrite Val.add_assoc. simpl Val.add. rewrite Int.add_zero. reflexivity.
- apply agree_exten_2 with rs; auto.
+ rewrite (sp_val _ _ _ H1). rewrite B. rewrite Val.add_assoc. simpl Val.add. rewrite Int.add_zero. auto.
intros [rs'' [D E]].
exists rs''; split.
eapply exec_straight_trans. eexact A. eexact D. auto.
@@ -1288,116 +1174,159 @@ 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 chunk a v,
+ (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) ->
+ 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 ->
Mem.loadv chunk m a = Some v ->
+ Mem.extends m 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 ms) sp 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'.
Proof.
intros. unfold transl_load_store_int.
- exploit eval_addressing_weaken. eauto. intros.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto.
+ intros [a' [A B]].
+ exploit Mem.loadv_extends; eauto. intros [v' [C D]].
+ exploit eval_addressing_weaken. eexact A. intros E.
apply transl_load_store_correct with ms; auto.
- intros. exists (nextinstr (rs1#(ireg_of rd) <- v)); split.
- apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5.
- unfold exec_load. rewrite H4. auto. auto.
- auto with ppcgen.
- intros. exists (nextinstr (rs1#(ireg_of rd) <- v)); split.
- apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5.
- unfold exec_load. rewrite H4. auto. auto.
- auto with ppcgen.
+ 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.
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 chunk a v,
+ (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) ->
+ 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 ->
Mem.loadv chunk m a = Some v ->
+ Mem.extends m 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 ms) sp 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'.
Proof.
- intros. unfold transl_load_store_float.
- exploit eval_addressing_weaken. eauto. intros.
+ intros. unfold transl_load_store_int.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto.
+ intros [a' [A B]].
+ exploit Mem.loadv_extends; eauto. intros [v' [C D]].
+ exploit eval_addressing_weaken. eexact A. intros E.
apply transl_load_store_correct with ms; auto.
- intros. exists (nextinstr (rs1#(freg_of rd) <- v)); split.
- apply exec_straight_one. rewrite H. rewrite <- H6. rewrite H5.
- unfold exec_load. rewrite H4. auto. auto.
- auto with ppcgen.
+ 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.
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 m chunk a m',
+ (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 m =
- exec_store chunk (Val.add rs1#r2 (eval_shift_addr sa rs1)) r1 rs1 m) ->
+ 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 m a (ms rd) = Some m' ->
- exists rs',
- exec_straight (transl_load_store_int mk_instr is_immed rd addr args k) rs m
- k rs' m'
- /\ agree ms sp rs'.
+ 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_weaken. eauto. intros.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto.
+ intros [a' [A B]].
+ exploit preg_val; eauto. instantiate (1 := rd). intros C.
+ exploit Mem.storev_extends; eauto. unfold preg_of; rewrite H2. intros [m2' [D E]].
+ exploit eval_addressing_weaken. eexact A. intros F.
+ exists m2'; split; auto.
apply transl_load_store_correct with ms; auto.
- intros. exists (nextinstr rs1); split.
- apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5.
- unfold exec_store. rewrite <- (ireg_val ms sp rs1); auto.
- rewrite H4. auto. auto.
- auto with ppcgen.
- intros. exists (nextinstr rs1); split.
- apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5.
- unfold exec_store. rewrite <- (ireg_val ms sp rs1); auto.
- rewrite H4. auto. auto.
- auto with ppcgen.
+ 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.
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 m chunk a m',
- (forall (c: code) (r1: freg) (r2: ireg) (n: int) (rs1: regset),
- exec_instr ge c (mk_instr r1 r2 n) rs1 m =
- exec_store chunk (Val.add rs1#r2 (Vint n)) r1 rs1 m) ->
+ (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 <> FR3 -> 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 m a (ms rd) = Some m' ->
- exists rs',
- exec_straight (transl_load_store_float mk_instr is_immed rd addr args k) rs m
- k rs' m'
- /\ agree ms sp rs'.
+ 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_weaken. eauto. intros.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto.
+ intros [a' [A B]].
+ exploit preg_val; eauto. instantiate (1 := rd). intros C.
+ exploit Mem.storev_extends; eauto. unfold preg_of; rewrite H2. intros [m2' [D E]].
+ exploit eval_addressing_weaken. eexact A. intros F.
+ exists m2'; split; auto.
apply transl_load_store_correct with ms; auto.
- intros. exists (nextinstr rs1); split.
- apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5.
- unfold exec_store. rewrite <- (freg_val ms sp rs1); auto.
- rewrite H4. auto. auto.
- auto with ppcgen.
+ 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.
End STRAIGHTLINE.
diff --git a/arm/ConstpropOp.v b/arm/ConstpropOp.v
index e55c7f9..a56a5ef 100644
--- a/arm/ConstpropOp.v
+++ b/arm/ConstpropOp.v
@@ -345,9 +345,6 @@ Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx),
| eval_static_operation_case49:
forall n1,
eval_static_operation_cases (Ofloatofint) (I n1 :: nil)
- | eval_static_operation_case50:
- forall n1,
- eval_static_operation_cases (Ofloatofintu) (I n1 :: nil)
| eval_static_operation_case51:
forall c vl,
eval_static_operation_cases (Ocmp c) (vl)
@@ -458,8 +455,6 @@ Definition eval_static_operation_match (op: operation) (vl: list approx) :=
eval_static_operation_case48 n1
| Ofloatofint, I n1 :: nil =>
eval_static_operation_case49 n1
- | Ofloatofintu, I n1 :: nil =>
- eval_static_operation_case50 n1
| Ocmp c, vl =>
eval_static_operation_case51 c vl
| Oshrximm n, I n1 :: nil =>
@@ -568,8 +563,6 @@ Definition eval_static_operation (op: operation) (vl: list approx) :=
I(Float.intoffloat n1)
| eval_static_operation_case49 n1 =>
F(Float.floatofint n1)
- | eval_static_operation_case50 n1 =>
- F(Float.floatofintu n1)
| eval_static_operation_case51 c vl =>
match eval_static_condition c vl with
| None => Unknown
diff --git a/arm/Op.v b/arm/Op.v
index 1f26a72..606281d 100644
--- a/arm/Op.v
+++ b/arm/Op.v
@@ -110,10 +110,8 @@ Inductive operation : Type :=
| Odivf: operation (**r [rd = r1 / r2] *)
| Osingleoffloat: operation (**r [rd] is [r1] truncated to single-precision float *)
(*c Conversions between int and float: *)
- | Ointoffloat: operation (**r [rd = int_of_float(r1)] *)
- | Ointuoffloat: operation (**r [rd = unsigned_int_of_float(r1)] *)
+ | Ointoffloat: operation (**r [rd = signed_int_of_float(r1)] *)
| Ofloatofint: operation (**r [rd = float_of_signed_int(r1)] *)
- | Ofloatofintu: operation (**r [rd = float_of_unsigned_int(r1)] *)
(*c Boolean tests: *)
| Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
@@ -282,16 +280,9 @@ Definition eval_operation
| Osubf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.sub f1 f2))
| Omulf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.mul f1 f2))
| Odivf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.div f1 f2))
- | Osingleoffloat, v1 :: nil =>
- Some (Val.singleoffloat v1)
- | Ointoffloat, Vfloat f1 :: nil =>
- Some (Vint (Float.intoffloat f1))
- | Ointuoffloat, Vfloat f1 :: nil =>
- Some (Vint (Float.intuoffloat f1))
- | Ofloatofint, Vint n1 :: nil =>
- Some (Vfloat (Float.floatofint n1))
- | Ofloatofintu, Vint n1 :: nil =>
- Some (Vfloat (Float.floatofintu n1))
+ | Osingleoffloat, v1 :: nil => Some (Val.singleoffloat v1)
+ | Ointoffloat, Vfloat f1 :: nil => Some (Vint (Float.intoffloat f1))
+ | Ofloatofint, Vint n1 :: nil => Some (Vfloat (Float.floatofint n1))
| Ocmp c, _ =>
match eval_condition c vl with
| None => None
@@ -493,9 +484,7 @@ Definition type_of_operation (op: operation) : list typ * typ :=
| Odivf => (Tfloat :: Tfloat :: nil, Tfloat)
| Osingleoffloat => (Tfloat :: nil, Tfloat)
| Ointoffloat => (Tfloat :: nil, Tint)
- | Ointuoffloat => (Tfloat :: nil, Tint)
| Ofloatofint => (Tint :: nil, Tfloat)
- | Ofloatofintu => (Tint :: nil, Tfloat)
| Ocmp c => (type_of_condition c, Tint)
end.
@@ -659,9 +648,7 @@ Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val :
| Odivf, v1::v2::nil => Val.divf v1 v2
| Osingleoffloat, v1::nil => Val.singleoffloat v1
| Ointoffloat, v1::nil => Val.intoffloat v1
- | Ointuoffloat, v1::nil => Val.intuoffloat v1
| Ofloatofint, v1::nil => Val.floatofint v1
- | Ofloatofintu, v1::nil => Val.floatofintu v1
| Ocmp c, _ => eval_condition_total c vl
| _, _ => Vundef
end.
@@ -919,3 +906,70 @@ Lemma type_op_for_binary_addressing:
Proof.
intros. destruct addr; simpl in H; reflexivity || omegaContradiction.
Qed.
+
+(** Two-address operations. There are none in the ARM architecture. *)
+
+Definition two_address_op (op: operation) : bool := false.
+
+(** Operations that are so cheap to recompute that CSE should not factor them out. *)
+
+Definition is_trivial_op (op: operation) : bool :=
+ match op with
+ | Omove => true
+ | Ointconst _ => true
+ | Oaddrsymbol _ _ => true
+ | Oaddrstack _ => true
+ | _ => false
+ end.
+
+(** Shifting stack-relative references. This is used in [Stacking]. *)
+
+Definition shift_stack_addressing (delta: int) (addr: addressing) :=
+ match addr with
+ | Ainstack ofs => Ainstack (Int.add delta ofs)
+ | _ => addr
+ end.
+
+Definition shift_stack_operation (delta: int) (op: operation) :=
+ match op with
+ | Oaddrstack ofs => Oaddrstack (Int.add delta ofs)
+ | _ => op
+ end.
+
+Lemma shift_stack_eval_addressing:
+ forall (F V: Type) (ge: Genv.t F V) sp addr args delta,
+ eval_addressing ge (Val.sub sp (Vint delta)) (shift_stack_addressing delta addr) args =
+ eval_addressing ge sp addr args.
+Proof.
+ intros. destruct addr; simpl; auto.
+ destruct args; auto. unfold offset_sp. destruct sp; simpl; auto.
+ decEq. decEq. rewrite <- Int.add_assoc. decEq.
+ rewrite Int.sub_add_opp. rewrite Int.add_assoc.
+ rewrite (Int.add_commut (Int.neg delta)). rewrite <- Int.sub_add_opp.
+ rewrite Int.sub_idem. apply Int.add_zero.
+Qed.
+
+Lemma shift_stack_eval_operation:
+ forall (F V: Type) (ge: Genv.t F V) sp op args delta,
+ eval_operation ge (Val.sub sp (Vint delta)) (shift_stack_operation delta op) args =
+ eval_operation ge sp op args.
+Proof.
+ intros. destruct op; simpl; auto.
+ destruct args; auto. unfold offset_sp. destruct sp; simpl; auto.
+ decEq. decEq. rewrite <- Int.add_assoc. decEq.
+ rewrite Int.sub_add_opp. rewrite Int.add_assoc.
+ rewrite (Int.add_commut (Int.neg delta)). rewrite <- Int.sub_add_opp.
+ rewrite Int.sub_idem. apply Int.add_zero.
+Qed.
+
+Lemma type_shift_stack_addressing:
+ forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr.
+Proof.
+ intros. destruct addr; auto.
+Qed.
+
+Lemma type_shift_stack_operation:
+ forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op.
+Proof.
+ intros. destruct op; auto.
+Qed.
diff --git a/arm/PrintAsm.ml b/arm/PrintAsm.ml
index 9e1cae7..4f470ce 100644
--- a/arm/PrintAsm.ml
+++ b/arm/PrintAsm.ml
@@ -79,6 +79,11 @@ let float_reg_name = function
let ireg oc r = output_string oc (int_reg_name r)
let freg oc r = output_string oc (float_reg_name r)
+let preg oc = function
+ | IR r -> ireg oc r
+ | FR r -> freg oc r
+ | _ -> assert false
+
let condition_name = function
| CReq -> "eq"
| CRne -> "ne"
@@ -417,30 +422,8 @@ let print_instruction oc labels = function
fprintf oc " dvfd %a, %a, %a\n" freg r1 freg r2 freg r3; 1
| Pfixz(r1, r2) ->
fprintf oc " fixz %a, %a\n" ireg r1 freg r2; 1
- | Pfixzu(r1, r2) ->
- (* F3 = second float temporary is unused at this point,
- but this should be reflected in the proof *)
- let lbl = label_float 2147483648.0 in
- let lbl2 = new_label() in
- fprintf oc " ldfd f3, .L%d\n" lbl;
- fprintf oc " cmfe %a, f3\n" freg r2;
- fprintf oc " fixltz %a, %a\n" ireg r1 freg r2;
- fprintf oc " blt .L%d\n" lbl2;
- fprintf oc " sufd f3, %a, f3\n" freg r2;
- fprintf oc " fixz %a, f3\n" ireg r1;
- fprintf oc " eor %a, %a, #-2147483648\n" ireg r1 ireg r1;
- fprintf oc ".L%d\n" lbl2;
- 7
| Pfltd(r1, r2) ->
fprintf oc " fltd %a, %a\n" freg r1 ireg r2; 1
- | Pfltud(r1, r2) ->
- fprintf oc " fltd %a, %a\n" freg r1 ireg r2;
- fprintf oc " cmp %a, #0\n" ireg r2;
- (* F3 = second float temporary is unused at this point,
- but this should be reflected in the proof *)
- let lbl = label_float 4294967296.0 in
- fprintf oc " ldfltd f3, .L%d\n" lbl;
- fprintf oc " adfltd %a, %a, f3\n" freg r1 freg r1; 4
| Pldfd(r1, r2, n) ->
fprintf oc " ldfd %a, [%a, #%a]\n" freg r1 ireg r2 coqint n; 1
| Pldfs(r1, r2, n) ->
@@ -465,8 +448,6 @@ let print_instruction oc labels = function
| Pstfd(r1, r2, n) ->
fprintf oc " stfd %a, [%a, #%a]\n" freg r1 ireg r2 coqint n; 1
| Pstfs(r1, r2, n) ->
- (* F3 = second float temporary is unused at this point,
- but this should be reflected in the proof *)
fprintf oc " mvfs f3, %a\n" freg r1;
fprintf oc " stfs f3, [%a, #%a]\n" ireg r2 coqint n; 2
| Psufd(r1, r2, r3) ->
diff --git a/arm/PrintOp.ml b/arm/PrintOp.ml
index 75d8593..dff4e4f 100644
--- a/arm/PrintOp.ml
+++ b/arm/PrintOp.ml
@@ -38,7 +38,7 @@ let print_condition reg pp = function
fprintf pp "%a %su %a" reg r1 (comparison_name c) reg r2
| (Ccompshift(c, s), [r1;r2]) ->
fprintf pp "%a %ss %a %a" reg r1 (comparison_name c) reg r2 shift s
- | (Ccompu(c, s), [r1;r2]) ->
+ | (Ccompushift(c, s), [r1;r2]) ->
fprintf pp "%a %su %a %a" reg r1 (comparison_name c) reg r2 shift s
| (Ccompimm(c, n), [r1]) ->
fprintf pp "%a %ss %ld" reg r1 (comparison_name c) (camlint_of_coqint n)
@@ -68,7 +68,7 @@ let print_operation reg pp = function
| Oaddimm n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n)
| Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2
| Osubshift s, [r1;r2] -> fprintf pp "%a - %a %a" reg r1 reg r2 shift s
- | Osubrshift s, [r1;r2] -> fprintf pp "%a %a - %a" reg r2 shift s reg r1
+ | Orsubshift s, [r1;r2] -> fprintf pp "%a %a - %a" reg r2 shift s reg r1
| Orsubimm n, [r1] -> fprintf pp "%ld - %a" (camlint_of_coqint n) reg r1
| Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2
| Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2
@@ -99,9 +99,7 @@ let print_operation reg pp = function
| Odivf, [r1;r2] -> fprintf pp "%a /f %a" reg r1 reg r2
| Osingleoffloat, [r1] -> fprintf pp "singleoffloat(%a)" reg r1
| Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1
- | Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1
| Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1
- | Ofloatofintu, [r1] -> fprintf pp "floatofintu(%a)" reg r1
| Ocmp c, args -> print_condition reg pp (c, args)
| _ -> fprintf pp "<bad operator>"
@@ -111,5 +109,3 @@ let print_addressing reg pp = function
| Aindexed2shift s, [r1; r2] -> fprintf pp "%a + %a %a" reg r1 reg r2 shift s
| Ainstack ofs, [] -> fprintf pp "stack(%ld)" (camlint_of_coqint ofs)
| _ -> fprintf pp "<bad addressing>"
-
-
diff --git a/arm/SelectOp.v b/arm/SelectOp.v
index 66c1299..df2413a 100644
--- a/arm/SelectOp.v
+++ b/arm/SelectOp.v
@@ -50,6 +50,14 @@ Require Import CminorSel.
Open Local Scope cminorsel_scope.
+(** ** Constants **)
+
+Definition addrsymbol (id: ident) (ofs: int) :=
+ Eop (Oaddrsymbol id ofs) Enil.
+
+Definition addrstack (ofs: int) :=
+ Eop (Oaddrstack ofs) Enil.
+
(** ** Integer logical negation *)
(** The natural way to write smart constructors is by pattern-matching
@@ -788,22 +796,24 @@ Definition same_expr_pure (e1 e2: expr) :=
Definition or (e1: expr) (e2: expr) :=
match e1, e2 with
| Eop (Oshift (Olsl n1) (t1:::Enil), Eop (Oshift (Olsr n2) (t2:::Enil)) => ...
+ | Eop (Oshift (Olsr n1) (t1:::Enil), Eop (Oshift (Olsl n2) (t2:::Enil)) => ...
| Eop (Oshift s) (t1:::Enil), t2 => Eop (Oorshift s) (t2:::t1:::Enil)
| t1, Eop (Oshift s) (t2:::Enil) => Eop (Oorshift s) (t1:::t2:::Enil)
| _, _ => Eop Oor (e1:::e2:::Enil)
end.
*)
-(* TODO: symmetric of first case *)
-
Inductive or_cases: forall (e1: expr) (e2: expr), Type :=
| or_case1:
forall n1 t1 n2 t2,
or_cases (Eop (Oshift (Slsl n1)) (t1:::Enil)) (Eop (Oshift (Slsr n2)) (t2:::Enil))
| or_case2:
+ forall n1 t1 n2 t2,
+ or_cases (Eop (Oshift (Slsr n1)) (t1:::Enil)) (Eop (Oshift (Slsl n2)) (t2:::Enil))
+ | or_case3:
forall s t1 t2,
or_cases (Eop (Oshift s) (t1:::Enil)) (t2)
- | or_case3:
+ | or_case4:
forall t1 s t2,
or_cases (t1) (Eop (Oshift s) (t2:::Enil))
| or_default:
@@ -814,10 +824,12 @@ Definition or_match (e1: expr) (e2: expr) :=
match e1 as z1, e2 as z2 return or_cases z1 z2 with
| Eop (Oshift (Slsl n1)) (t1:::Enil), Eop (Oshift (Slsr n2)) (t2:::Enil) =>
or_case1 n1 t1 n2 t2
+ | Eop (Oshift (Slsr n1)) (t1:::Enil), Eop (Oshift (Slsl n2)) (t2:::Enil) =>
+ or_case2 n1 t1 n2 t2
| Eop (Oshift s) (t1:::Enil), t2 =>
- or_case2 s t1 t2
+ or_case3 s t1 t2
| t1, Eop (Oshift s) (t2:::Enil) =>
- or_case3 t1 s t2
+ or_case4 t1 s t2
| e1, e2 =>
or_default e1 e2
end.
@@ -829,9 +841,14 @@ Definition or (e1: expr) (e2: expr) :=
&& same_expr_pure t1 t2
then Eop (Oshift (Sror n2)) (t1:::Enil)
else Eop (Oorshift (Slsr n2)) (e1:::t2:::Enil)
- | or_case2 s t1 t2 =>
+ | or_case2 n1 t1 n2 t2 =>
+ if Int.eq (Int.add (s_amount n2) (s_amount n1)) Int.iwordsize
+ && same_expr_pure t1 t2
+ then Eop (Oshift (Sror n1)) (t1:::Enil)
+ else Eop (Oorshift (Slsl n2)) (e1:::t2:::Enil)
+ | or_case3 s t1 t2 =>
Eop (Oorshift s) (t2:::t1:::Enil)
- | or_case3 t1 s t2 =>
+ | or_case4 t1 s t2 =>
Eop (Oorshift s) (t1:::t2:::Enil)
| or_default e1 e2 =>
Eop Oor (e1:::e2:::Enil)
@@ -919,118 +936,6 @@ Definition shr (e1: expr) (e2: expr) :=
Eop Oshr (e1:::e2:::Enil)
end.
-(** ** Truncations and sign extensions *)
-
-Inductive cast8signed_cases: forall (e1: expr), Type :=
- | cast8signed_case1:
- forall (e2: expr),
- cast8signed_cases (Eop Ocast8signed (e2 ::: Enil))
- | cast8signed_default:
- forall (e1: expr),
- cast8signed_cases e1.
-
-Definition cast8signed_match (e1: expr) :=
- match e1 as z1 return cast8signed_cases z1 with
- | Eop Ocast8signed (e2 ::: Enil) =>
- cast8signed_case1 e2
- | e1 =>
- cast8signed_default e1
- end.
-
-Definition cast8signed (e: expr) :=
- match cast8signed_match e with
- | cast8signed_case1 e1 => e
- | cast8signed_default e1 => Eop Ocast8signed (e1 ::: Enil)
- end.
-
-Inductive cast8unsigned_cases: forall (e1: expr), Type :=
- | cast8unsigned_case1:
- forall (e2: expr),
- cast8unsigned_cases (Eop Ocast8unsigned (e2 ::: Enil))
- | cast8unsigned_default:
- forall (e1: expr),
- cast8unsigned_cases e1.
-
-Definition cast8unsigned_match (e1: expr) :=
- match e1 as z1 return cast8unsigned_cases z1 with
- | Eop Ocast8unsigned (e2 ::: Enil) =>
- cast8unsigned_case1 e2
- | e1 =>
- cast8unsigned_default e1
- end.
-
-Definition cast8unsigned (e: expr) :=
- match cast8unsigned_match e with
- | cast8unsigned_case1 e1 => e
- | cast8unsigned_default e1 => Eop Ocast8unsigned (e1 ::: Enil)
- end.
-
-Inductive cast16signed_cases: forall (e1: expr), Type :=
- | cast16signed_case1:
- forall (e2: expr),
- cast16signed_cases (Eop Ocast16signed (e2 ::: Enil))
- | cast16signed_default:
- forall (e1: expr),
- cast16signed_cases e1.
-
-Definition cast16signed_match (e1: expr) :=
- match e1 as z1 return cast16signed_cases z1 with
- | Eop Ocast16signed (e2 ::: Enil) =>
- cast16signed_case1 e2
- | e1 =>
- cast16signed_default e1
- end.
-
-Definition cast16signed (e: expr) :=
- match cast16signed_match e with
- | cast16signed_case1 e1 => e
- | cast16signed_default e1 => Eop Ocast16signed (e1 ::: Enil)
- end.
-
-Inductive cast16unsigned_cases: forall (e1: expr), Type :=
- | cast16unsigned_case1:
- forall (e2: expr),
- cast16unsigned_cases (Eop Ocast16unsigned (e2 ::: Enil))
- | cast16unsigned_default:
- forall (e1: expr),
- cast16unsigned_cases e1.
-
-Definition cast16unsigned_match (e1: expr) :=
- match e1 as z1 return cast16unsigned_cases z1 with
- | Eop Ocast16unsigned (e2 ::: Enil) =>
- cast16unsigned_case1 e2
- | e1 =>
- cast16unsigned_default e1
- end.
-
-Definition cast16unsigned (e: expr) :=
- match cast16unsigned_match e with
- | cast16unsigned_case1 e1 => e
- | cast16unsigned_default e1 => Eop Ocast16unsigned (e1 ::: Enil)
- end.
-
-Inductive singleoffloat_cases: forall (e1: expr), Type :=
- | singleoffloat_case1:
- forall (e2: expr),
- singleoffloat_cases (Eop Osingleoffloat (e2 ::: Enil))
- | singleoffloat_default:
- forall (e1: expr),
- singleoffloat_cases e1.
-
-Definition singleoffloat_match (e1: expr) :=
- match e1 as z1 return singleoffloat_cases z1 with
- | Eop Osingleoffloat (e2 ::: Enil) =>
- singleoffloat_case1 e2
- | e1 =>
- singleoffloat_default e1
- end.
-
-Definition singleoffloat (e: expr) :=
- match singleoffloat_match e with
- | singleoffloat_case1 e1 => e
- | singleoffloat_default e1 => Eop Osingleoffloat (e1 ::: Enil)
- end.
-
(** ** Comparisons *)
(*
@@ -1106,20 +1011,39 @@ Definition compu (c: comparison) (e1: expr) (e2: expr) :=
Definition compf (c: comparison) (e1: expr) (e2: expr) :=
Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil).
-(** ** Other operators, not optimized. *)
+(** ** Non-optimized operators. *)
+Definition cast8unsigned (e: expr) := Eop Ocast8unsigned (e ::: Enil).
+Definition cast8signed (e: expr) := Eop Ocast8signed (e ::: Enil).
+Definition cast16unsigned (e: expr) := Eop Ocast16unsigned (e ::: Enil).
+Definition cast16signed (e: expr) := Eop Ocast16signed (e ::: Enil).
+Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil).
Definition negint (e: expr) := Eop (Orsubimm Int.zero) (e ::: Enil).
Definition negf (e: expr) := Eop Onegf (e ::: Enil).
Definition absf (e: expr) := Eop Oabsf (e ::: Enil).
Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil).
-Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil).
Definition floatofint (e: expr) := Eop Ofloatofint (e ::: Enil).
-Definition floatofintu (e: expr) := Eop Ofloatofintu (e ::: Enil).
Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil).
Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil).
Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil).
Definition divf (e1 e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil).
+(** ** Conversions between unsigned ints and floats *)
+
+Definition intuoffloat (e: expr) :=
+ let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in
+ Elet e
+ (Econdition (CEcond (Ccompf Clt) (Eletvar O ::: f ::: Enil))
+ (intoffloat (Eletvar O))
+ (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar O) f)))).
+
+Definition floatofintu (e: expr) :=
+ let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in
+ Elet e
+ (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil))
+ (floatofint (Eletvar O))
+ (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f)).
+
(** ** Recognition of addressing modes for load and store operations *)
(*
diff --git a/arm/SelectOpproof.v b/arm/SelectOpproof.v
index b260346..c8f177b 100644
--- a/arm/SelectOpproof.v
+++ b/arm/SelectOpproof.v
@@ -100,6 +100,24 @@ Ltac InvEval := InvEval1; InvEval2; InvEval2.
by the smart constructor.
*)
+Theorem eval_addrsymbol:
+ forall le id ofs b,
+ Genv.find_symbol ge id = Some b ->
+ eval_expr ge sp e m le (addrsymbol id ofs) (Vptr b ofs).
+Proof.
+ intros. unfold addrsymbol. econstructor. constructor.
+ simpl. rewrite H. auto.
+Qed.
+
+Theorem eval_addrstack:
+ forall le ofs b n,
+ sp = Vptr b n ->
+ eval_expr ge sp e m le (addrstack ofs) (Vptr b (Int.add n ofs)).
+Proof.
+ intros. unfold addrstack. econstructor. constructor.
+ simpl. unfold offset_sp. rewrite H. auto.
+Qed.
+
Theorem eval_notint:
forall le a x,
eval_expr ge sp e m le a (Vint x) ->
@@ -644,7 +662,18 @@ Proof.
destruct n1; auto. destruct n2; auto. auto.
EvalOp. econstructor. EvalOp. simpl. reflexivity.
econstructor; eauto with evalexpr.
- simpl. congruence.
+ simpl. congruence.
+ caseEq (Int.eq (Int.add (s_amount n2) (s_amount n1)) Int.iwordsize
+ && same_expr_pure t1 t2); intro.
+ destruct (andb_prop _ _ H1).
+ generalize (Int.eq_spec (Int.add (s_amount n2) (s_amount n1)) Int.iwordsize).
+ rewrite H4. intro.
+ exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2.
+ simpl. EvalOp. simpl. decEq. decEq. rewrite Int.or_commut. apply Int.or_ror.
+ destruct n2; auto. destruct n1; auto. auto.
+ EvalOp. econstructor. EvalOp. simpl. reflexivity.
+ econstructor; eauto with evalexpr.
+ simpl. congruence.
EvalOp. simpl. rewrite Int.or_commut. congruence.
EvalOp. simpl. congruence.
EvalOp.
@@ -702,55 +731,31 @@ Theorem eval_cast8signed:
forall le a v,
eval_expr ge sp e m le a v ->
eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v).
-Proof.
- intros until v; unfold cast8signed; case (cast8signed_match a); intros; InvEval.
- EvalOp. simpl. subst v. destruct v1; simpl; auto.
- rewrite Int.sign_ext_idem. reflexivity. vm_compute; auto.
- EvalOp.
-Qed.
+Proof. TrivialOp cast8signed. Qed.
Theorem eval_cast8unsigned:
forall le a v,
eval_expr ge sp e m le a v ->
eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v).
-Proof.
- intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros; InvEval.
- EvalOp. simpl. subst v. destruct v1; simpl; auto.
- rewrite Int.zero_ext_idem. reflexivity. vm_compute; auto.
- EvalOp.
-Qed.
+Proof. TrivialOp cast8unsigned. Qed.
Theorem eval_cast16signed:
forall le a v,
eval_expr ge sp e m le a v ->
eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v).
-Proof.
- intros until v; unfold cast16signed; case (cast16signed_match a); intros; InvEval.
- EvalOp. simpl. subst v. destruct v1; simpl; auto.
- rewrite Int.sign_ext_idem. reflexivity. vm_compute; auto.
- EvalOp.
-Qed.
+Proof. TrivialOp cast16signed. Qed.
Theorem eval_cast16unsigned:
forall le a v,
eval_expr ge sp e m le a v ->
eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v).
-Proof.
- intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros; InvEval.
- EvalOp. simpl. subst v. destruct v1; simpl; auto.
- rewrite Int.zero_ext_idem. reflexivity. vm_compute; auto.
- EvalOp.
-Qed.
+Proof. TrivialOp cast16unsigned. Qed.
Theorem eval_singleoffloat:
forall le a v,
eval_expr ge sp e m le a v ->
eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v).
-Proof.
- intros until v; unfold singleoffloat; case (singleoffloat_match a); intros; InvEval.
- EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity.
- EvalOp.
-Qed.
+Proof. TrivialOp singleoffloat. Qed.
Theorem eval_comp_int:
forall le c a x b y,
@@ -894,30 +899,6 @@ Theorem eval_absf:
eval_expr ge sp e m le (absf a) (Vfloat (Float.abs x)).
Proof. intros; unfold absf; EvalOp. Qed.
-Theorem eval_intoffloat:
- forall le a x,
- eval_expr ge sp e m le a (Vfloat x) ->
- eval_expr ge sp e m le (intoffloat a) (Vint (Float.intoffloat x)).
-Proof. intros; unfold intoffloat; EvalOp. Qed.
-
-Theorem eval_intuoffloat:
- forall le a x,
- eval_expr ge sp e m le a (Vfloat x) ->
- eval_expr ge sp e m le (intuoffloat a) (Vint (Float.intuoffloat x)).
-Proof. intros; unfold intuoffloat; EvalOp. Qed.
-
-Theorem eval_floatofint:
- forall le a x,
- eval_expr ge sp e m le a (Vint x) ->
- eval_expr ge sp e m le (floatofint a) (Vfloat (Float.floatofint x)).
-Proof. intros; unfold floatofint; EvalOp. Qed.
-
-Theorem eval_floatofintu:
- forall le a x,
- eval_expr ge sp e m le a (Vint x) ->
- eval_expr ge sp e m le (floatofintu a) (Vfloat (Float.floatofintu x)).
-Proof. intros; unfold floatofintu; EvalOp. Qed.
-
Theorem eval_addf:
forall le a x b y,
eval_expr ge sp e m le a (Vfloat x) ->
@@ -946,6 +927,60 @@ Theorem eval_divf:
eval_expr ge sp e m le (divf a b) (Vfloat (Float.div x y)).
Proof. intros; unfold divf; EvalOp. Qed.
+Theorem eval_intoffloat:
+ forall le a x,
+ eval_expr ge sp e m le a (Vfloat x) ->
+ eval_expr ge sp e m le (intoffloat a) (Vint (Float.intoffloat x)).
+Proof. TrivialOp intoffloat. Qed.
+
+Theorem eval_intuoffloat:
+ forall le a x,
+ eval_expr ge sp e m le a (Vfloat x) ->
+ eval_expr ge sp e m le (intuoffloat a) (Vint (Float.intuoffloat x)).
+Proof.
+ intros. unfold intuoffloat.
+ econstructor. eauto.
+ set (f := Float.floatofintu Float.ox8000_0000).
+ assert (eval_expr ge sp e m (Vfloat x :: le) (Eletvar O) (Vfloat x)).
+ constructor. auto.
+ apply eval_Econdition with (v1 := Float.cmp Clt x f).
+ econstructor. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
+ simpl. auto.
+ caseEq (Float.cmp Clt x f); intros.
+ rewrite Float.intuoffloat_intoffloat_1; auto.
+ EvalOp.
+ rewrite Float.intuoffloat_intoffloat_2; auto.
+ apply eval_addimm. apply eval_intoffloat. apply eval_subf; auto. EvalOp.
+Qed.
+
+Theorem eval_floatofint:
+ forall le a x,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le (floatofint a) (Vfloat (Float.floatofint x)).
+Proof. intros; unfold floatofint; EvalOp. Qed.
+
+Theorem eval_floatofintu:
+ forall le a x,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le (floatofintu a) (Vfloat (Float.floatofintu x)).
+Proof.
+ intros. unfold floatofintu.
+ econstructor. eauto.
+ set (f := Float.floatofintu Float.ox8000_0000).
+ assert (eval_expr ge sp e m (Vint x :: le) (Eletvar O) (Vint x)).
+ constructor. auto.
+ apply eval_Econdition with (v1 := Int.ltu x Float.ox8000_0000).
+ econstructor. constructor. eauto. constructor.
+ simpl. auto.
+ caseEq (Int.ltu x Float.ox8000_0000); intros.
+ rewrite Float.floatofintu_floatofint_1; auto.
+ apply eval_floatofint; auto.
+ rewrite Float.floatofintu_floatofint_2; auto.
+ fold f. apply eval_addf. apply eval_floatofint.
+ rewrite Int.sub_add_opp. apply eval_addimm; auto.
+ EvalOp.
+Qed.
+
Lemma eval_addressing:
forall le chunk a v b ofs,
eval_expr ge sp e m le a v ->
diff --git a/arm/linux/Conventions1.v b/arm/linux/Conventions1.v
index 703dc12..fdccf75 100644
--- a/arm/linux/Conventions1.v
+++ b/arm/linux/Conventions1.v
@@ -56,6 +56,9 @@ Definition float_temporaries := FT1 :: FT2 :: nil.
Definition temporaries :=
R IT1 :: R IT2 :: R FT1 :: R FT2 :: nil.
+Definition dummy_int_reg := R0. (**r Used in [Coloring]. *)
+Definition dummy_float_reg := F0. (**r Used in [Coloring]. *)
+
(** The [index_int_callee_save] and [index_float_callee_save] associate
a unique positive integer to callee-save registers. This integer is
used in [Stacking] to determine where to save these registers in
@@ -641,4 +644,3 @@ Proof.
intro; simpl. ElimOrEq; reflexivity.
intro; simpl. ElimOrEq; reflexivity.
Qed.
-
diff --git a/backend/Allocproof.v b/backend/Allocproof.v
index d06c26f..5a5e4c4 100644
--- a/backend/Allocproof.v
+++ b/backend/Allocproof.v
@@ -235,6 +235,14 @@ Proof.
rewrite H0. apply H. auto. eapply regalloc_not_temporary; eauto.
Qed.
+Lemma agree_undef_temps:
+ forall live rs ls,
+ agree live rs ls -> agree live rs (undef_temps ls).
+Proof.
+ intros. apply agree_exten with ls; auto.
+ intros. apply Locmap.guo; auto.
+Qed.
+
(** If a register is dead, assigning it an arbitrary value in [rs]
and leaving [ls] unchanged preserves agreement. (This corresponds
to an operation over a dead register in the original program
@@ -603,7 +611,11 @@ Proof.
(* sub-case: non-redundant move *)
econstructor; split. eapply exec_Lop; eauto. simpl. eauto.
MatchStates.
- rewrite <- H1. eapply agree_move_live; eauto.
+ rewrite <- H1. set (ls1 := undef_temps ls).
+ replace (ls (assign arg)) with (ls1 (assign arg)).
+ eapply agree_move_live; eauto.
+ unfold ls1. eapply agree_undef_temps; eauto.
+ unfold ls1. simpl. apply Locmap.guo. eapply regalloc_not_temporary; eauto.
(* Not a move *)
intros INMO CORR CODE.
assert (eval_operation tge sp op (map ls (map assign args)) = Some v).
@@ -612,6 +624,7 @@ Proof.
eapply agree_eval_regs; eauto.
econstructor; split. eapply exec_Lop; eauto. MatchStates.
apply agree_assign_live with f env live; auto.
+ eapply agree_undef_temps; eauto.
eapply agree_reg_list_live; eauto.
(* Result is not live, instruction turned into a nop *)
intro CODE. econstructor; split. eapply exec_Lnop; eauto.
@@ -633,6 +646,7 @@ Proof.
unfold correct_alloc_instr. intro CORR.
MatchStates.
eapply agree_assign_live; eauto.
+ eapply agree_undef_temps; eauto.
eapply agree_reg_list_live; eauto.
(* dst is dead *)
econstructor; split.
@@ -650,7 +664,9 @@ Proof.
econstructor; split.
eapply exec_Lstore; eauto. TranslInstr.
rewrite <- ESRC. eauto.
- MatchStates. eapply agree_reg_live. eapply agree_reg_list_live. eauto.
+ MatchStates.
+ eapply agree_undef_temps; eauto.
+ eapply agree_reg_live. eapply agree_reg_list_live. eauto.
(* Icall *)
exploit transl_find_function; eauto. intros [tf [TFIND TF]].
@@ -695,20 +711,26 @@ Proof.
eapply agree_eval_regs; eauto.
econstructor; split.
eapply exec_Lcond_true; eauto. TranslInstr.
- MatchStates. eapply agree_reg_list_live. eauto.
+ MatchStates.
+ eapply agree_undef_temps; eauto.
+ eapply agree_reg_list_live. eauto.
(* Icond, false *)
assert (COND: eval_condition cond (map ls (map assign args)) = Some false).
replace (map ls (map assign args)) with (rs##args). auto.
eapply agree_eval_regs; eauto.
econstructor; split.
eapply exec_Lcond_false; eauto. TranslInstr.
- MatchStates. eapply agree_reg_list_live. eauto.
+ MatchStates.
+ eapply agree_undef_temps; eauto.
+ eapply agree_reg_list_live. eauto.
(* Ijumptable *)
assert (rs#arg = ls (assign arg)). apply AG. apply Regset.add_1. auto.
econstructor; split.
eapply exec_Ljumptable; eauto. TranslInstr. congruence.
- MatchStates. eapply list_nth_z_in; eauto. eapply agree_reg_live; eauto.
+ MatchStates. eapply list_nth_z_in; eauto.
+ eapply agree_undef_temps; eauto.
+ eapply agree_reg_live; eauto.
(* Ireturn *)
econstructor; split.
diff --git a/backend/CSE.v b/backend/CSE.v
index dab8fc3..4347c33 100644
--- a/backend/CSE.v
+++ b/backend/CSE.v
@@ -375,23 +375,14 @@ Definition analyze (f: RTL.function): PMap.t numbering :=
(** * Code transformation *)
-(** Some operations are so cheap to compute that it is generally not
- worth reusing their results. These operations are detected by the
- function below. *)
-
-Definition is_trivial_op (op: operation) : bool :=
- match op with
- | Omove => true
- | Ointconst _ => true
- | Oaddrsymbol _ _ => true
- | Oaddrstack _ => true
- | _ => false
- end.
-
(** The code transformation is performed instruction by instruction.
[Iload] instructions and non-trivial [Iop] instructions are turned
into move instructions if their result is already available in a
- register, as indicated by the numbering inferred at that program point. *)
+ register, as indicated by the numbering inferred at that program point.
+
+ Some operations are so cheap to compute that it is generally not
+ worth reusing their results. These operations are detected by the
+ function [is_trivial_op] in module [Op]. *)
Definition transf_instr (n: numbering) (instr: instruction) :=
match instr with
diff --git a/backend/Coloring.v b/backend/Coloring.v
index 28626cb..6d34e2c 100644
--- a/backend/Coloring.v
+++ b/backend/Coloring.v
@@ -282,7 +282,7 @@ Definition alloc_of_coloring (coloring: reg -> loc) (env: regenv) (rs: Regset.t)
fun r =>
if Regset.mem r rs
then coloring r
- else match env r with Tint => R R3 | Tfloat => R F1 end.
+ else match env r with Tint => R dummy_int_reg | Tfloat => R dummy_float_reg end.
(** * Coloring of the interference graph *)
diff --git a/backend/Coloringaux.ml b/backend/Coloringaux.ml
index 922506f..0420972 100644
--- a/backend/Coloringaux.ml
+++ b/backend/Coloringaux.ml
@@ -41,6 +41,7 @@ type node =
typ: typ; (*r its type *)
regname: reg option; (*r the RTL register it comes from *)
regclass: int; (*r identifier of register class *)
+ mutable accesses: int; (*r number of defs and uses *)
mutable spillcost: float; (*r estimated cost of spilling *)
mutable adjlist: node list; (*r all nodes it interferes with *)
mutable degree: int; (*r number of adjacent nodes *)
@@ -109,7 +110,7 @@ module DLinkNode = struct
let make state =
let rec empty =
{ ident = 0; typ = Tint; regname = None; regclass = 0;
- adjlist = []; degree = 0; spillcost = 0.0;
+ adjlist = []; degree = 0; accesses = 0; spillcost = 0.0;
movelist = []; alias = None; color = None;
nstate = state; nprev = empty; nnext = empty }
in empty
@@ -196,6 +197,8 @@ let num_available_registers = Array.make num_register_classes 0
let reserved_registers = ref ([]: mreg list)
+let allocatable_registers = ref ([]: mreg list)
+
let rec remove_reserved = function
| [] -> []
| hd :: tl ->
@@ -204,14 +207,17 @@ let rec remove_reserved = function
else hd :: remove_reserved tl
let init_regs() =
- caller_save_registers.(0) <-
- Array.of_list (remove_reserved int_caller_save_regs);
- caller_save_registers.(1) <-
- Array.of_list (remove_reserved float_caller_save_regs);
- callee_save_registers.(0) <-
- Array.of_list (remove_reserved int_callee_save_regs);
- callee_save_registers.(1) <-
- Array.of_list (remove_reserved float_callee_save_regs);
+ let int_caller_save = remove_reserved int_caller_save_regs
+ and float_caller_save = remove_reserved float_caller_save_regs
+ and int_callee_save = remove_reserved int_callee_save_regs
+ and float_callee_save = remove_reserved float_callee_save_regs in
+ allocatable_registers :=
+ List.flatten [int_caller_save; float_caller_save;
+ int_callee_save; float_callee_save];
+ caller_save_registers.(0) <- Array.of_list int_caller_save;
+ caller_save_registers.(1) <- Array.of_list float_caller_save;
+ callee_save_registers.(0) <- Array.of_list int_callee_save;
+ callee_save_registers.(1) <- Array.of_list float_callee_save;
for i = 0 to num_register_classes - 1 do
num_available_registers.(i) <-
Array.length caller_save_registers.(i)
@@ -365,9 +371,10 @@ let checkInvariants () =
let nodeOfReg r typenv spillcosts =
let ty = typenv r in
incr nextRegIdent;
+ let (acc, cost) = spillcosts r in
{ ident = !nextRegIdent; typ = ty;
regname = Some r; regclass = class_of_type ty;
- spillcost = float(spillcosts r);
+ accesses = acc; spillcost = float cost;
adjlist = []; degree = 0; movelist = []; alias = None;
color = None;
nstate = Initial;
@@ -378,7 +385,7 @@ let nodeOfMreg mr =
incr nextRegIdent;
{ ident = !nextRegIdent; typ = ty;
regname = None; regclass = class_of_type ty;
- spillcost = 0.0;
+ accesses = 0; spillcost = 0.0;
adjlist = []; degree = 0; movelist = []; alias = None;
color = Some (R mr);
nstate = Colored;
@@ -426,7 +433,9 @@ let build g typenv spillcosts =
g.pref_reg_reg ();
SetRegMreg.fold
(fun (Coq_pair(r1, mr2)) () ->
- add_move (find_reg_node r1) (find_mreg_node mr2))
+ let r1' = find_reg_node r1 in
+ if List.mem mr2 !allocatable_registers then
+ add_move r1' (find_mreg_node mr2))
g.pref_reg_mreg ();
(* Initial partition of nodes into spill / freeze / simplify *)
Hashtbl.iter
@@ -568,14 +577,14 @@ let canCoalesceGeorge u v =
so George's criterion is safe in this case.
*)
-let thresholdGeorge = 2.0 (* = 1 def + 1 use *)
+let thresholdGeorge = 2 (* = 1 def + 1 use *)
let canCoalesce u v =
if u.nstate = Colored
then canCoalesceGeorge u v
else canCoalesceBriggs u v
- || (v.spillcost <= thresholdGeorge && canCoalesceGeorge u v)
- || (u.spillcost <= thresholdGeorge && canCoalesceGeorge v u)
+ || (v.accesses <= thresholdGeorge && canCoalesceGeorge u v)
+ || (u.accesses <= thresholdGeorge && canCoalesceGeorge v u)
(* Update worklists after a move was processed *)
@@ -652,7 +661,12 @@ let freeze () =
(* Chaitin's cost measure *)
-let spillCost n = n.spillcost /. float n.degree
+let spillCost n =
+(*i
+ Printf.printf "spillCost %s: uses = %.0f degree = %d cost = %f\n"
+ (name_of_node n) n.spillcost n.degree (n.spillcost /. float n.degree);
+*)
+ n.spillcost /. float n.degree
(* Spill a node *)
@@ -778,35 +792,40 @@ let location_of_node n =
| None -> assert false
| Some loc -> loc
-(* Estimate spilling costs. Currently, just count the number of accesses
- to each pseudoregister. To do: take loops into account. *)
+(* Estimate spilling costs and counts the number of defs and uses.
+ Currently, we charge 10 for each access and 1 for each move.
+ To do: take loops into account. *)
let spill_costs f =
- let costs = ref (PTree.empty : int PTree.t) in
+ let costs = ref (PMap.init (0,0)) in
let cost r =
- match PTree.get r !costs with None -> 0 | Some n -> n in
- let incr r =
- costs := PTree.set r (1 + cost r) !costs in
- let incr_list rl =
- List.iter incr rl in
- let incr_ros ros =
- match ros with Coq_inl r -> incr r | Coq_inr _ -> () in
+ PMap.get r !costs in
+ let charge amount r =
+ let (n, c) = cost r in
+ costs := PMap.set r (n + 1, c + amount) !costs in
+ let charge_list amount rl =
+ List.iter (charge amount) rl in
+ let charge_ros amount ros =
+ match ros with Coq_inl r -> charge amount r | Coq_inr _ -> () in
let process_instr () pc i =
match i with
| Inop _ -> ()
- | Iop(op, args, res, _) -> incr_list args; incr res
- | Iload(chunk, addr, args, dst, _) -> incr_list args; incr dst
- | Istore(chunk, addr, args, src, _) -> incr_list args; incr src
- | Icall(sg, ros, args, res, _) -> incr_ros ros; incr_list args; incr res
- | Itailcall(sg, ros, args) -> incr_ros ros; incr_list args
- | Ibuiltin(ef, args, res, _) -> incr_list args; incr res
- | Icond(cond, args, _, _) -> incr_list args
- | Ijumptable(arg, _) -> incr arg
- | Ireturn(Some r) -> incr r
+ | Iop(Op.Omove, arg::nil, res, _) -> charge 1 arg; charge 1 res
+ | Iop(op, args, res, _) -> charge_list 10 args; charge 10 res
+ | Iload(chunk, addr, args, dst, _) -> charge_list 10 args; charge 10 dst
+ | Istore(chunk, addr, args, src, _) -> charge_list 10 args; charge 10 src
+ | Icall(sg, ros, args, res, _) ->
+ charge_ros 10 ros; charge_list 1 args; charge 1 res
+ | Itailcall(sg, ros, args) ->
+ charge_ros 10 ros; charge_list 1 args
+ | Ibuiltin(ef, args, res, _) -> charge_list 10 args; charge 10 res
+ | Icond(cond, args, _, _) -> charge_list 10 args
+ | Ijumptable(arg, _) -> charge 10 arg
+ | Ireturn(Some r) -> charge 1 r
| Ireturn None -> () in
- incr_list f.fn_params;
+ charge_list 1 f.fn_params;
PTree.fold process_instr f.fn_code ();
- (* Result is cost function reg -> integer cost *)
+ (* Result is cost function reg -> (num accesses, integer cost *)
cost
(* This is the entry point for graph coloring. *)
diff --git a/backend/Coloringproof.v b/backend/Coloringproof.v
index 5f035b4..bb97c87 100644
--- a/backend/Coloringproof.v
+++ b/backend/Coloringproof.v
@@ -719,7 +719,9 @@ Proof.
elim (andb_prop _ _ H1); intros.
caseEq (Regset.mem r allregs); intro.
generalize (check_coloring_3_correct _ _ _ r H3 H4). tauto.
- case (env r); simpl; intuition congruence.
+ case (env r); simpl.
+ unfold dummy_int_reg. intuition congruence.
+ unfold dummy_float_reg. intuition congruence.
Qed.
Lemma alloc_of_coloring_correct_4:
diff --git a/backend/LTL.v b/backend/LTL.v
index e1222a5..2eff67c 100644
--- a/backend/LTL.v
+++ b/backend/LTL.v
@@ -101,6 +101,10 @@ Definition postcall_locs (ls: locset) : locset :=
| S s => ls (S s)
end.
+(** Temporaries destroyed across instructions *)
+
+Definition undef_temps (ls: locset) := Locmap.undef temporaries ls.
+
(** LTL execution states. *)
Inductive stackframe : Type :=
@@ -166,21 +170,21 @@ Inductive step: state -> trace -> state -> Prop :=
(fn_code f)!pc = Some(Lop op args res pc') ->
eval_operation ge sp op (map rs args) = Some v ->
step (State s f sp pc rs m)
- E0 (State s f sp pc' (Locmap.set res v rs) m)
+ E0 (State s f sp pc' (Locmap.set res v (undef_temps rs)) m)
| exec_Lload:
forall s f sp pc rs m chunk addr args dst pc' a v,
(fn_code f)!pc = Some(Lload chunk addr args dst pc') ->
eval_addressing ge sp addr (map rs args) = Some a ->
Mem.loadv chunk m a = Some v ->
step (State s f sp pc rs m)
- E0 (State s f sp pc' (Locmap.set dst v rs) m)
+ E0 (State s f sp pc' (Locmap.set dst v (undef_temps rs)) m)
| exec_Lstore:
forall s f sp pc rs m chunk addr args src pc' a m',
(fn_code f)!pc = Some(Lstore chunk addr args src pc') ->
eval_addressing ge sp addr (map rs args) = Some a ->
Mem.storev chunk m a (rs src) = Some m' ->
step (State s f sp pc rs m)
- E0 (State s f sp pc' rs m')
+ E0 (State s f sp pc' (undef_temps rs) m')
| exec_Lcall:
forall s f sp pc rs m sig ros args res pc' f',
(fn_code f)!pc = Some(Lcall sig ros args res pc') ->
@@ -208,20 +212,20 @@ Inductive step: state -> trace -> state -> Prop :=
(fn_code f)!pc = Some(Lcond cond args ifso ifnot) ->
eval_condition cond (map rs args) = Some true ->
step (State s f sp pc rs m)
- E0 (State s f sp ifso rs m)
+ E0 (State s f sp ifso (undef_temps rs) m)
| exec_Lcond_false:
forall s f sp pc rs m cond args ifso ifnot,
(fn_code f)!pc = Some(Lcond cond args ifso ifnot) ->
eval_condition cond (map rs args) = Some false ->
step (State s f sp pc rs m)
- E0 (State s f sp ifnot rs m)
+ E0 (State s f sp ifnot (undef_temps rs) m)
| exec_Ljumptable:
forall s f sp pc rs m arg tbl n pc',
(fn_code f)!pc = Some(Ljumptable arg tbl) ->
rs arg = Vint n ->
list_nth_z tbl (Int.signed n) = Some pc' ->
step (State s f sp pc rs m)
- E0 (State s f sp pc' rs m)
+ E0 (State s f sp pc' (undef_temps rs) m)
| exec_Lreturn:
forall s f stk pc rs m or m',
(fn_code f)!pc = Some(Lreturn or) ->
diff --git a/backend/LTLin.v b/backend/LTLin.v
index ee4cb94..d6c5fa7 100644
--- a/backend/LTLin.v
+++ b/backend/LTLin.v
@@ -160,19 +160,19 @@ Inductive step: state -> trace -> state -> Prop :=
forall s f sp op args res b rs m v,
eval_operation ge sp op (map rs args) = Some v ->
step (State s f sp (Lop op args res :: b) rs m)
- E0 (State s f sp b (Locmap.set res v rs) m)
+ E0 (State s f sp b (Locmap.set res v (undef_temps rs)) m)
| exec_Lload:
forall s f sp chunk addr args dst b rs m a v,
eval_addressing ge sp addr (map rs args) = Some a ->
Mem.loadv chunk m a = Some v ->
step (State s f sp (Lload chunk addr args dst :: b) rs m)
- E0 (State s f sp b (Locmap.set dst v rs) m)
+ E0 (State s f sp b (Locmap.set dst v (undef_temps rs)) m)
| exec_Lstore:
forall s f sp chunk addr args src b rs m m' a,
eval_addressing ge sp addr (map rs args) = Some a ->
Mem.storev chunk m a (rs src) = Some m' ->
step (State s f sp (Lstore chunk addr args src :: b) rs m)
- E0 (State s f sp b rs m')
+ E0 (State s f sp b (undef_temps rs) m')
| exec_Lcall:
forall s f sp sig ros args res b rs m f',
find_function ros rs = Some f' ->
@@ -206,19 +206,19 @@ Inductive step: state -> trace -> state -> Prop :=
eval_condition cond (map rs args) = Some true ->
find_label lbl f.(fn_code) = Some b' ->
step (State s f sp (Lcond cond args lbl :: b) rs m)
- E0 (State s f sp b' rs m)
+ E0 (State s f sp b' (undef_temps rs) m)
| exec_Lcond_false:
forall s f sp cond args lbl b rs m,
eval_condition cond (map rs args) = Some false ->
step (State s f sp (Lcond cond args lbl :: b) rs m)
- E0 (State s f sp b rs m)
+ E0 (State s f sp b (undef_temps rs) m)
| exec_Ljumptable:
forall s f sp arg tbl b rs m n lbl b',
rs arg = Vint n ->
list_nth_z tbl (Int.signed n) = Some lbl ->
find_label lbl f.(fn_code) = Some b' ->
step (State s f sp (Ljumptable arg tbl :: b) rs m)
- E0 (State s f sp b' rs m)
+ E0 (State s f sp b' (undef_temps rs) m)
| exec_Lreturn:
forall s f stk rs m or b m',
Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
diff --git a/backend/Linear.v b/backend/Linear.v
index 0f44206..40f7e41 100644
--- a/backend/Linear.v
+++ b/backend/Linear.v
@@ -163,6 +163,20 @@ Definition return_regs (caller callee: locset) : locset :=
| S s => caller (S s)
end.
+(** Temporaries destroyed across operations *)
+
+Definition undef_op (op: operation) (rs: locset) :=
+ match op with
+ | Omove => rs
+ | _ => undef_temps rs
+ end.
+
+Definition undef_getstack (s: slot) (rs: locset) :=
+ match s with
+ | Incoming _ _ => Locmap.set (R IT1) Vundef rs
+ | _ => rs
+ end.
+
(** Linear execution states. *)
Inductive stackframe: Type :=
@@ -241,7 +255,7 @@ Inductive step: state -> trace -> state -> Prop :=
| exec_Lgetstack:
forall s f sp sl r b rs m,
step (State s f sp (Lgetstack sl r :: b) rs m)
- E0 (State s f sp b (Locmap.set (R r) (rs (S sl)) rs) m)
+ E0 (State s f sp b (Locmap.set (R r) (rs (S sl)) (undef_getstack sl rs)) m)
| exec_Lsetstack:
forall s f sp r sl b rs m,
step (State s f sp (Lsetstack r sl :: b) rs m)
@@ -250,19 +264,19 @@ Inductive step: state -> trace -> state -> Prop :=
forall s f sp op args res b rs m v,
eval_operation ge sp op (reglist rs args) = Some v ->
step (State s f sp (Lop op args res :: b) rs m)
- E0 (State s f sp b (Locmap.set (R res) v rs) m)
+ E0 (State s f sp b (Locmap.set (R res) v (undef_op op rs)) m)
| exec_Lload:
forall s f sp chunk addr args dst b rs m a v,
eval_addressing ge sp addr (reglist rs args) = Some a ->
Mem.loadv chunk m a = Some v ->
step (State s f sp (Lload chunk addr args dst :: b) rs m)
- E0 (State s f sp b (Locmap.set (R dst) v rs) m)
+ E0 (State s f sp b (Locmap.set (R dst) v (undef_temps rs)) m)
| exec_Lstore:
forall s f sp chunk addr args src b rs m m' a,
eval_addressing ge sp addr (reglist rs args) = Some a ->
Mem.storev chunk m a (rs (R src)) = Some m' ->
step (State s f sp (Lstore chunk addr args src :: b) rs m)
- E0 (State s f sp b rs m')
+ E0 (State s f sp b (undef_temps rs) m')
| exec_Lcall:
forall s f sp sig ros b rs m f',
find_function ros rs = Some f' ->
@@ -280,7 +294,7 @@ Inductive step: state -> trace -> state -> Prop :=
forall s f sp rs m ef args res b t v m',
external_call ef ge (reglist rs args) m t v m' ->
step (State s f sp (Lbuiltin ef args res :: b) rs m)
- t (State s f sp b (Locmap.set (R res) v rs) m')
+ t (State s f sp b (Locmap.set (R res) v (undef_temps rs)) m')
| exec_Llabel:
forall s f sp lbl b rs m,
step (State s f sp (Llabel lbl :: b) rs m)
@@ -295,19 +309,19 @@ Inductive step: state -> trace -> state -> Prop :=
eval_condition cond (reglist rs args) = Some true ->
find_label lbl f.(fn_code) = Some b' ->
step (State s f sp (Lcond cond args lbl :: b) rs m)
- E0 (State s f sp b' rs m)
+ E0 (State s f sp b' (undef_temps rs) m)
| exec_Lcond_false:
forall s f sp cond args lbl b rs m,
eval_condition cond (reglist rs args) = Some false ->
step (State s f sp (Lcond cond args lbl :: b) rs m)
- E0 (State s f sp b rs m)
+ E0 (State s f sp b (undef_temps rs) m)
| exec_Ljumptable:
forall s f sp arg tbl b rs m n lbl b',
rs (R arg) = Vint n ->
list_nth_z tbl (Int.signed n) = Some lbl ->
find_label lbl f.(fn_code) = Some b' ->
step (State s f sp (Ljumptable arg tbl :: b) rs m)
- E0 (State s f sp b' rs m)
+ E0 (State s f sp b' (undef_temps rs) m)
| exec_Lreturn:
forall s f stk b rs m m',
Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
diff --git a/backend/Locations.v b/backend/Locations.v
index c2fda9c..1270e1d 100644
--- a/backend/Locations.v
+++ b/backend/Locations.v
@@ -423,4 +423,27 @@ Module Locmap.
auto.
Qed.
+ Fixpoint undef (ll: list loc) (m: t) {struct ll} : t :=
+ match ll with
+ | nil => m
+ | l1 :: ll' => undef ll' (set l1 Vundef m)
+ end.
+
+ Lemma guo: forall ll l m, Loc.notin l ll -> (undef ll m) l = m l.
+ Proof.
+ induction ll; simpl; intros. auto.
+ destruct H. rewrite IHll; auto. apply gso. apply Loc.diff_sym; auto.
+ Qed.
+
+ Lemma gus: forall ll l m, In l ll -> (undef ll m) l = Vundef.
+ Proof.
+ assert (P: forall ll l m, m l = Vundef -> (undef ll m) l = Vundef).
+ induction ll; simpl; intros. auto. apply IHll.
+ unfold set. destruct (Loc.eq a l); auto.
+ destruct (Loc.overlap a l); auto.
+ induction ll; simpl; intros. contradiction.
+ destruct H. apply P. subst a. apply gss.
+ auto.
+ Qed.
+
End Locmap.
diff --git a/backend/Mach.v b/backend/Mach.v
index 2ec312e..c6a692a 100644
--- a/backend/Mach.v
+++ b/backend/Mach.v
@@ -27,6 +27,7 @@ Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
+Require Import Conventions.
(** * Abstract syntax *)
@@ -101,6 +102,21 @@ Definition regset := Regmap.t val.
Notation "a ## b" := (List.map a b) (at level 1).
Notation "a # b <- c" := (Regmap.set b c a) (at level 1, b at next level).
+Fixpoint undef_regs (rl: list mreg) (rs: regset) {struct rl} : regset :=
+ match rl with
+ | nil => rs
+ | r1 :: rl' => undef_regs rl' (Regmap.set r1 Vundef rs)
+ end.
+
+Definition undef_temps (rs: regset) :=
+ undef_regs (int_temporaries ++ float_temporaries) rs.
+
+Definition undef_op (op: operation) (rs: regset) :=
+ match op with
+ | Omove => rs
+ | _ => undef_temps rs
+ end.
+
Definition is_label (lbl: label) (instr: instruction) : bool :=
match instr with
| Mlabel lbl' => if peq lbl lbl' then true else false
diff --git a/backend/Machabstr.v b/backend/Machabstr.v
index 291a468..23ca895 100644
--- a/backend/Machabstr.v
+++ b/backend/Machabstr.v
@@ -238,24 +238,24 @@ Inductive step: state -> trace -> state -> Prop :=
forall s f sp ofs ty dst c rs fr m v,
get_slot (parent_function s) (parent_frame s) ty (Int.signed ofs) v ->
step (State s f sp (Mgetparam ofs ty dst :: c) rs fr m)
- E0 (State s f sp c (rs#dst <- v) fr m)
+ E0 (State s f sp c (rs # IT1 <- Vundef # dst <- v) fr m)
| exec_Mop:
forall s f sp op args res c rs fr m v,
eval_operation ge sp op rs##args = Some v ->
step (State s f sp (Mop op args res :: c) rs fr m)
- E0 (State s f sp c (rs#res <- v) fr m)
+ E0 (State s f sp c ((undef_op op rs)#res <- v) fr m)
| exec_Mload:
forall s f sp chunk addr args dst c rs fr m a v,
eval_addressing ge sp addr rs##args = Some a ->
Mem.loadv chunk m a = Some v ->
step (State s f sp (Mload chunk addr args dst :: c) rs fr m)
- E0 (State s f sp c (rs#dst <- v) fr m)
+ E0 (State s f sp c ((undef_temps rs)#dst <- v) fr m)
| exec_Mstore:
forall s f sp chunk addr args src c rs fr m m' a,
eval_addressing ge sp addr rs##args = Some a ->
Mem.storev chunk m a (rs src) = Some m' ->
step (State s f sp (Mstore chunk addr args src :: c) rs fr m)
- E0 (State s f sp c rs fr m')
+ E0 (State s f sp c (undef_temps rs) fr m')
| exec_Mcall:
forall s f sp sig ros c rs fr m f',
find_function ros rs = Some f' ->
@@ -271,7 +271,7 @@ Inductive step: state -> trace -> state -> Prop :=
forall s f sp rs fr 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 fr m)
- t (State s f sp b (rs#res <- v) fr m')
+ t (State s f sp b ((undef_temps rs)#res <- v) fr m')
| exec_Mgoto:
forall s f sp lbl c rs fr m c',
find_label lbl f.(fn_code) = Some c' ->
@@ -282,19 +282,19 @@ Inductive step: state -> trace -> state -> Prop :=
eval_condition cond rs##args = Some true ->
find_label lbl f.(fn_code) = Some c' ->
step (State s f sp (Mcond cond args lbl :: c) rs fr m)
- E0 (State s f sp c' rs fr m)
+ E0 (State s f sp c' (undef_temps rs) fr m)
| exec_Mcond_false:
forall s f sp cond args lbl c rs fr m,
eval_condition cond rs##args = Some false ->
step (State s f sp (Mcond cond args lbl :: c) rs fr m)
- E0 (State s f sp c rs fr m)
+ E0 (State s f sp c (undef_temps rs) fr m)
| exec_Mjumptable:
forall s f sp arg tbl c rs fr m n lbl c',
rs arg = Vint n ->
list_nth_z tbl (Int.signed n) = Some lbl ->
find_label lbl f.(fn_code) = Some c' ->
step (State s f sp (Mjumptable arg tbl :: c) rs fr m)
- E0 (State s f sp c' rs fr m)
+ E0 (State s f sp c' (undef_temps rs) fr m)
| exec_Mreturn:
forall s f stk soff c rs fr m m',
Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
diff --git a/backend/Machabstr2concr.v b/backend/Machabstr2concr.v
index 1a97dda..fa7f580 100644
--- a/backend/Machabstr2concr.v
+++ b/backend/Machabstr2concr.v
@@ -618,6 +618,23 @@ Proof.
destruct (RegEq.eq r0 r); auto.
Qed.
+Lemma regset_lessdef_undef_temps:
+ forall rs1 rs2,
+ regset_lessdef rs1 rs2 -> regset_lessdef (undef_temps rs1) (undef_temps rs2).
+Proof.
+ unfold undef_temps.
+ generalize (int_temporaries ++ float_temporaries).
+ induction l; simpl; intros. auto. apply IHl. apply regset_lessdef_set; auto.
+Qed.
+
+Lemma regset_lessdef_undef_op:
+ forall op rs1 rs2,
+ regset_lessdef rs1 rs2 -> regset_lessdef (undef_op op rs1) (undef_op op rs2).
+Proof.
+ intros. set (D := regset_lessdef_undef_temps _ _ H).
+ destruct op; simpl; auto.
+Qed.
+
Lemma regset_lessdef_find_function_ptr:
forall ge ros rs1 rs2 fb,
find_function_ptr ge ros rs1 = Some fb ->
@@ -965,40 +982,44 @@ Proof.
(* Mgetparam *)
assert (WTF: wt_function f) by (inv WTS; auto).
exploit match_stacks_get_parent; eauto. intros [v' [A B]].
- exists (State ts fb (Vptr sp0 base) c (trs#dst <- v') ms); split.
+ exists (State ts fb (Vptr sp0 base) c (trs # IT1 <- Vundef # dst <- v') ms); split.
eapply exec_Mgetparam; eauto.
eapply frame_match_load_link; eauto.
eapply match_stacks_parent_sp_pointer; eauto.
- econstructor; eauto with coqlib. apply regset_lessdef_set; eauto.
+ econstructor; eauto with coqlib.
+ apply regset_lessdef_set; eauto. apply regset_lessdef_set; eauto.
(* Mop *)
exploit eval_operation_lessdef. 2: eauto.
eapply regset_lessdef_list; eauto.
intros [v' [A B]].
- exists (State ts fb (Vptr sp0 base) c (trs#res <- v') ms); split.
+ exists (State ts fb (Vptr sp0 base) c ((undef_op op trs)#res <- v') ms); split.
apply exec_Mop; auto.
econstructor; eauto with coqlib. apply regset_lessdef_set; eauto.
+ apply regset_lessdef_undef_op; auto.
(* Mload *)
exploit eval_addressing_lessdef. 2: eauto. eapply regset_lessdef_list; eauto.
intros [a' [A B]].
exploit Mem.loadv_extends. eauto. eauto. eexact B.
intros [v' [C D]].
- exists (State ts fb (Vptr sp0 base) c (trs#dst <- v') ms); split.
+ exists (State ts fb (Vptr sp0 base) c ((undef_temps trs)#dst <- v') ms); split.
eapply exec_Mload; eauto.
econstructor; eauto with coqlib. apply regset_lessdef_set; eauto.
+ apply regset_lessdef_undef_temps; auto.
(* Mstore *)
exploit eval_addressing_lessdef. 2: eauto. eapply regset_lessdef_list; eauto.
intros [a' [A B]].
exploit Mem.storev_extends. eauto. eauto. eexact B. apply RLD.
intros [ms' [C D]].
- exists (State ts fb (Vptr sp0 base) c trs ms'); split.
+ exists (State ts fb (Vptr sp0 base) c (undef_temps trs) ms'); split.
eapply exec_Mstore; eauto.
destruct a; simpl in H0; try congruence. inv B. simpl in C.
econstructor; eauto with coqlib.
eapply match_stacks_store. eauto. eexact H0. eexact C.
eapply frame_match_store; eauto.
+ apply regset_lessdef_undef_temps; auto.
(* Mcall *)
exploit find_function_find_function_ptr; eauto.
@@ -1032,7 +1053,7 @@ Proof.
econstructor; eauto with coqlib.
eapply match_stacks_external_call; eauto.
eapply frame_match_external_call; eauto.
- apply regset_lessdef_set; eauto.
+ apply regset_lessdef_set; eauto. apply regset_lessdef_undef_temps; auto.
(* Mgoto *)
econstructor; split.
@@ -1043,17 +1064,17 @@ Proof.
econstructor; split.
eapply exec_Mcond_true; eauto.
eapply eval_condition_lessdef; eauto. apply regset_lessdef_list; auto.
- econstructor; eauto.
+ econstructor; eauto. apply regset_lessdef_undef_temps; auto.
econstructor; split.
eapply exec_Mcond_false; eauto.
eapply eval_condition_lessdef; eauto. apply regset_lessdef_list; auto.
- econstructor; eauto.
+ econstructor; eauto. apply regset_lessdef_undef_temps; auto.
(* Mjumptable *)
econstructor; split.
eapply exec_Mjumptable; eauto.
generalize (RLD arg); intro LD. rewrite H in LD. inv LD. auto.
- econstructor; eauto.
+ econstructor; eauto. apply regset_lessdef_undef_temps; auto.
(* Mreturn *)
assert (WTF: wt_function f) by (inv WTS; auto).
diff --git a/backend/Machconcr.v b/backend/Machconcr.v
index b736c8f..5a98dd9 100644
--- a/backend/Machconcr.v
+++ b/backend/Machconcr.v
@@ -152,24 +152,24 @@ Inductive step: state -> trace -> state -> Prop :=
load_stack m sp Tint f.(fn_link_ofs) = Some parent ->
load_stack m parent ty ofs = Some v ->
step (State s fb sp (Mgetparam ofs ty dst :: c) rs m)
- E0 (State s fb sp c (rs#dst <- v) m)
+ E0 (State s fb sp c (rs # IT1 <- Vundef # dst <- v) m)
| exec_Mop:
forall s f sp op args res c rs m v,
eval_operation ge sp op rs##args = Some v ->
step (State s f sp (Mop op args res :: c) rs m)
- E0 (State s f sp c (rs#res <- v) 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 (rs#dst <- v) 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 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' ->
@@ -191,7 +191,7 @@ Inductive step: state -> trace -> state -> Prop :=
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 (rs#res <- v) m')
+ t (State s f sp b ((undef_temps rs)#res <- v) m')
| exec_Mgoto:
forall s fb f sp lbl c rs m c',
Genv.find_funct_ptr ge fb = Some (Internal f) ->
@@ -204,12 +204,12 @@ Inductive step: state -> trace -> state -> Prop :=
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' rs m)
+ E0 (State s fb sp c' (undef_temps rs) m)
| exec_Mcond_false:
forall s f sp cond args lbl c rs m,
eval_condition cond rs##args = Some false ->
step (State s f sp (Mcond cond args lbl :: c) rs m)
- E0 (State s f sp c rs m)
+ E0 (State s f sp c (undef_temps rs) m)
| exec_Mjumptable:
forall s fb f sp arg tbl c rs m n lbl c',
rs arg = Vint n ->
@@ -217,7 +217,7 @@ Inductive step: state -> trace -> state -> Prop :=
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' rs m)
+ E0 (State s fb 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) ->
diff --git a/backend/Machtyping.v b/backend/Machtyping.v
index 7013e29..93ac00c 100644
--- a/backend/Machtyping.v
+++ b/backend/Machtyping.v
@@ -156,6 +156,30 @@ Proof.
apply H0.
Qed.
+Lemma wt_undef_temps:
+ forall rs, wt_regset rs -> wt_regset (undef_temps rs).
+Proof.
+ unfold undef_temps.
+ generalize (int_temporaries ++ float_temporaries).
+ induction l; simpl; intros. auto.
+ apply IHl. red; intros. unfold Regmap.set.
+ destruct (RegEq.eq r a). constructor. auto.
+Qed.
+
+Lemma wt_undef_op:
+ forall op rs, wt_regset rs -> wt_regset (undef_op op rs).
+Proof.
+ intros. set (W := wt_undef_temps rs H).
+ destruct op; simpl; auto.
+Qed.
+
+Lemma wt_undef_getparam:
+ forall rs, wt_regset rs -> wt_regset (rs#IT1 <- Vundef).
+Proof.
+ intros; red; intros. unfold Regmap.set.
+ destruct (RegEq.eq r IT1). constructor. auto.
+Qed.
+
Lemma wt_get_slot:
forall f fr ty ofs v,
get_slot f fr ty ofs v ->
@@ -237,31 +261,41 @@ Lemma subject_reduction:
forall (WTS: wt_state s1), wt_state s2.
Proof.
induction 1; intros; inv WTS;
- try (generalize (wt_function_instrs _ WTF _ (is_tail_in TAIL)); intro;
+ try (generalize (wt_function_instrs _ WTF _ (is_tail_in TAIL)); intro WTI;
eapply wt_state_intro; eauto with coqlib).
- apply wt_setreg; auto.
- inversion H0. rewrite H2. eapply wt_get_slot; eauto.
+ apply wt_setreg; auto. inv WTI. eapply wt_get_slot; eauto.
- inversion H0. eapply wt_set_slot; eauto.
- rewrite <- H2. apply WTRS.
+ eapply wt_set_slot; eauto. inv WTI; auto.
+ assert (mreg_type dst = ty).
+ inv WTI; auto.
assert (wt_frame (parent_frame s)).
destruct s; simpl. apply wt_empty_frame.
generalize (STK s (in_eq _ _)); intro. inv H1. auto.
- inversion H0. apply wt_setreg; auto.
- rewrite H3. eapply wt_get_slot; eauto.
-
- apply wt_setreg; auto. inv H0.
- simpl in H.
- rewrite <- H2. replace v with (rs r1). apply WTRS. congruence.
- replace (mreg_type res) with (snd (type_of_operation op)).
- apply type_of_operation_sound with fundef unit ge rs##args sp; auto.
- rewrite <- H5; reflexivity.
-
- apply wt_setreg; auto. inversion H1. rewrite H7.
- eapply type_of_chunk_correct; eauto.
-
+ apply wt_setreg; auto.
+ rewrite H0. eapply wt_get_slot; eauto.
+ apply wt_undef_getparam; auto.
+
+(* op *)
+ apply wt_setreg; auto.
+ inv WTI.
+ (* move *)
+ simpl in H. inv H. rewrite <- H1. apply WTRS.
+ (* not move *)
+ replace (mreg_type res) with (snd (type_of_operation op)).
+ apply type_of_operation_sound with fundef unit ge rs##args sp; auto.
+ rewrite <- H4; reflexivity.
+ apply wt_undef_op; auto.
+
+(* load *)
+ apply wt_setreg; auto. inv WTI. rewrite H6. eapply type_of_chunk_correct; eauto.
+ apply wt_undef_temps; auto.
+
+(* store *)
+ apply wt_undef_temps; auto.
+
+(* call *)
assert (WTFD: wt_fundef f').
destruct ros; simpl in H.
apply (Genv.find_funct_prop wt_fundef _ _ wt_p H).
@@ -271,6 +305,7 @@ Proof.
intros. elim H0; intro. subst s0. econstructor; eauto with coqlib.
auto.
+(* tailcall *)
assert (WTFD: wt_fundef f').
destruct ros; simpl in H.
apply (Genv.find_funct_prop wt_fundef _ _ wt_p H).
@@ -278,17 +313,27 @@ Proof.
apply (Genv.find_funct_ptr_prop wt_fundef _ _ wt_p H).
econstructor; eauto.
- inv H0. apply wt_setreg; auto. rewrite H5. eapply external_call_well_typed; eauto.
+(* extcall *)
+ apply wt_setreg; auto.
+ inv WTI. rewrite H4. eapply external_call_well_typed; eauto.
+ apply wt_undef_temps; auto.
+(* goto *)
apply is_tail_find_label with lbl; congruence.
- apply is_tail_find_label with lbl; congruence.
- apply is_tail_find_label with lbl; congruence.
+(* cond *)
+ apply is_tail_find_label with lbl; congruence. apply wt_undef_temps; auto.
+ apply wt_undef_temps; auto.
+(* jumptable *)
+ apply is_tail_find_label with lbl; congruence. apply wt_undef_temps; auto.
+(* return *)
econstructor; eauto.
+(* internal function *)
econstructor; eauto with coqlib. inv H5; auto. exact I.
apply wt_empty_frame.
+(* external function *)
econstructor; eauto. apply wt_setreg; auto.
generalize (external_call_well_typed _ _ _ _ _ _ _ H).
unfold proj_sig_res, loc_result.
@@ -296,6 +341,7 @@ Proof.
destruct t0; simpl; auto.
simpl; auto.
+(* returnstate *)
generalize (H1 _ (in_eq _ _)); intro. inv H.
econstructor; eauto.
eauto with coqlib.
diff --git a/backend/RTLgen.v b/backend/RTLgen.v
index b728829..e918449 100644
--- a/backend/RTLgen.v
+++ b/backend/RTLgen.v
@@ -363,6 +363,18 @@ Fixpoint alloc_regs (map: mapping) (al: exprlist)
ret (r :: rl)
end.
+(** A variant of [alloc_regs] for two-address instructions:
+ reuse the result register as destination for the first argument. *)
+
+Definition alloc_regs_2addr (map: mapping) (al: exprlist) (rd: reg)
+ : mon (list reg) :=
+ match al with
+ | Enil =>
+ ret nil
+ | Econs a bl =>
+ do rl <- alloc_regs map bl; ret (rd :: rl)
+ end.
+
(** [alloc_optreg] is used for function calls. If a destination is
specified for the call, it is returned. Otherwise, a fresh
register is returned. *)
@@ -395,9 +407,11 @@ Fixpoint transl_expr (map: mapping) (a: expr) (rd: reg) (nd: node)
| Evar v =>
do r <- find_var map v; add_move r rd nd
| Eop op al =>
- do rl <- alloc_regs map al;
+ do rl <- if two_address_op op
+ then alloc_regs_2addr map al rd
+ else alloc_regs map al;
do no <- add_instr (Iop op rl rd nd);
- transl_exprlist map al rl no
+ transl_exprlist map al rl no
| Eload chunk addr al =>
do rl <- alloc_regs map al;
do no <- add_instr (Iload chunk addr rl rd nd);
@@ -502,6 +516,16 @@ Fixpoint transl_switch (r: reg) (nexits: list node) (t: comptree)
add_instr (Iop op (r :: nil) rt n3)
end.
+(** Detect a two-address operator at the top of an expression. *)
+
+Fixpoint expr_is_2addr_op (e: expr) : bool :=
+ match e with
+ | Eop op _ => two_address_op op
+ | Econdition e1 e2 e3 => expr_is_2addr_op e2 || expr_is_2addr_op e3
+ | Elet e1 e2 => expr_is_2addr_op e2
+ | _ => false
+ end.
+
(** Translation of statements. [transl_stmt map s nd nexits nret rret]
enriches the current CFG with the RTL instructions necessary to
execute the CminorSel statement [s], and returns the node of the first
@@ -521,7 +545,12 @@ Fixpoint transl_stmt (map: mapping) (s: stmt) (nd: node)
ret nd
| Sassign v b =>
do r <- find_var map v;
- transl_expr map b r nd
+ if expr_is_2addr_op b then
+ do rd <- new_reg;
+ do n1 <- add_move rd r nd;
+ transl_expr map b rd n1
+ else
+ transl_expr map b r nd
| Sstore chunk addr al b =>
do rl <- alloc_regs map al;
do r <- alloc_reg map b;
diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v
index 12a8e2b..b49b671 100644
--- a/backend/RTLgenproof.v
+++ b/backend/RTLgenproof.v
@@ -587,7 +587,8 @@ Lemma transl_expr_Eop_correct:
eval_operation ge sp op vargs = Some v ->
transl_expr_prop le (Eop op args) v.
Proof.
- intros; red; intros. inv TE.
+ intros; red; intros. inv TE.
+(* normal case *)
exploit H0; eauto. intros [rs1 [EX1 [ME1 [RR1 RO1]]]].
exists (rs1#rd <- v).
(* Exec *)
@@ -1116,12 +1117,24 @@ Proof.
constructor; auto.
(* assign *)
- inv TS.
+ inv TS.
+ (* optimized translation (not 2 addr) *)
exploit transl_expr_correct; eauto.
intros [rs' [A [B [C D]]]].
econstructor; split.
right; split. eauto. Lt_state.
econstructor; eauto. constructor.
+ (* alternate translation (2 addr) *)
+ exploit transl_expr_correct; eauto.
+ intros [rs' [A [B [C D]]]].
+ exploit tr_move_correct; eauto.
+ intros [rs'' [P [Q R]]].
+ econstructor; split.
+ right; split. eapply star_trans. eexact A. eexact P. traceEq. Lt_state.
+ econstructor; eauto. constructor.
+ simpl in B. apply match_env_invariant with (rs'#r <- v).
+ apply match_env_update_var; auto.
+ intros. rewrite Regmap.gsspec. destruct (peq r0 r). congruence. auto.
(* store *)
inv TS.
diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v
index 22a1e79..44e7c41 100644
--- a/backend/RTLgenspec.v
+++ b/backend/RTLgenspec.v
@@ -504,6 +504,32 @@ Proof.
right; eauto with rtlg.
Qed.
+Lemma alloc_regs_2addr_valid:
+ forall al rd s1 s2 map rl i,
+ map_valid map s1 ->
+ reg_valid rd s1 ->
+ alloc_regs_2addr map al rd s1 = OK rl s2 i ->
+ regs_valid rl s2.
+Proof.
+ unfold alloc_regs_2addr; intros.
+ destruct al; monadInv H1.
+ apply regs_valid_nil.
+ apply regs_valid_cons. eauto with rtlg. eauto with rtlg.
+Qed.
+Hint Resolve alloc_regs_2addr_valid: rtlg.
+
+Lemma alloc_regs_2addr_fresh_or_in_map:
+ forall map al rd s rl s' i,
+ map_valid map s ->
+ alloc_regs_2addr map al rd s = OK rl s' i ->
+ forall r, In r rl -> r = rd \/ reg_in_map map r \/ reg_fresh r s.
+Proof.
+ unfold alloc_regs_2addr; intros.
+ destruct al; monadInv H0.
+ elim H1.
+ simpl in H1; destruct H1. auto. right. eapply alloc_regs_fresh_or_in_map; eauto.
+Qed.
+
(** A register is an adequate target for holding the value of an
expression if
- either the register is associated with a Cminor let-bound variable
@@ -606,7 +632,24 @@ Proof.
apply regs_valid_cons; eauto with rtlg.
Qed.
-Hint Resolve new_reg_target_ok alloc_reg_target_ok alloc_regs_target_ok: rtlg.
+Lemma alloc_regs_2addr_target_ok:
+ forall map al rd pr s1 rl s2 i,
+ map_valid map s1 ->
+ regs_valid pr s1 ->
+ reg_valid rd s1 ->
+ ~(reg_in_map map rd) -> ~In rd pr ->
+ alloc_regs_2addr map al rd s1 = OK rl s2 i ->
+ target_regs_ok map pr al rl.
+Proof.
+ unfold alloc_regs_2addr; intros. destruct al; monadInv H4.
+ constructor.
+ constructor. constructor; auto.
+ eapply alloc_regs_target_ok; eauto.
+ apply regs_valid_cons; auto.
+Qed.
+
+Hint Resolve new_reg_target_ok alloc_reg_target_ok
+ alloc_regs_target_ok alloc_regs_2addr_target_ok: rtlg.
(** The following predicate is a variant of [target_reg_ok] used
to characterize registers that are adequate for holding the return
@@ -804,9 +847,14 @@ Inductive tr_stmt (c: code) (map: mapping):
| tr_Sskip: forall ns nexits ngoto nret rret,
tr_stmt c map Sskip ns ns nexits ngoto nret rret
| tr_Sassign: forall id a ns nd nexits ngoto nret rret r,
- map.(map_vars)!id = Some r ->
+ map.(map_vars)!id = Some r -> expr_is_2addr_op a = false ->
tr_expr c map nil a ns nd r (Some id) ->
tr_stmt c map (Sassign id a) ns nd nexits ngoto nret rret
+ | tr_Sassign_2: forall id a ns n1 nd nexits ngoto nret rret rd r,
+ map.(map_vars)!id = Some r ->
+ tr_expr c map nil a ns n1 rd None ->
+ tr_move c n1 rd nd r ->
+ tr_stmt c map (Sassign id a) ns nd nexits ngoto nret rret
| tr_Sstore: forall chunk addr al b ns nd nexits ngoto nret rret rd n1 rl n2,
tr_exprlist c map nil al ns n1 rl ->
tr_expr c map rl b n1 n2 rd None ->
@@ -970,7 +1018,9 @@ Proof.
inv OK. left; split; congruence. right; eauto with rtlg.
eapply add_move_charact; eauto.
(* Eop *)
- inv OK.
+ inv OK. destruct (two_address_op o).
+ econstructor; eauto with rtlg.
+ eapply transl_exprlist_charact; eauto with rtlg.
econstructor; eauto with rtlg.
eapply transl_exprlist_charact; eauto with rtlg.
(* Eload *)
@@ -1047,21 +1097,25 @@ Lemma transl_expr_assign_charact:
forall id a map rd nd s ns s' INCR
(TR: transl_expr map a rd nd s = OK ns s' INCR)
(WF: map_valid map s)
- (OK: reg_map_ok map rd (Some id)),
+ (OK: reg_map_ok map rd (Some id))
+ (NOT2ADDR: expr_is_2addr_op a = false),
tr_expr s'.(st_code) map nil a ns nd rd (Some id).
Proof.
+Opaque two_address_op.
induction a; intros; monadInv TR; saturateTrans.
(* Evar *)
generalize EQ; unfold find_var. caseEq (map_vars map)!i; intros; inv EQ1.
econstructor; eauto.
eapply add_move_charact; eauto.
(* Eop *)
- econstructor; eauto with rtlg.
+ simpl in NOT2ADDR. rewrite NOT2ADDR in EQ.
+ econstructor; eauto with rtlg.
eapply transl_exprlist_charact; eauto with rtlg.
(* Eload *)
econstructor; eauto with rtlg.
eapply transl_exprlist_charact; eauto with rtlg.
(* Econdition *)
+ simpl in NOT2ADDR. destruct (orb_false_elim _ _ NOT2ADDR).
econstructor; eauto with rtlg.
eapply transl_condexpr_charact; eauto with rtlg.
apply tr_expr_incr with s1; auto.
@@ -1069,6 +1123,7 @@ Proof.
apply tr_expr_incr with s0; auto.
eapply IHa2; eauto 2 with rtlg.
(* Elet *)
+ simpl in NOT2ADDR.
econstructor. eapply new_reg_not_in_map; eauto with rtlg.
eapply transl_expr_charact; eauto 3 with rtlg.
apply tr_expr_incr with s1; auto.
@@ -1112,8 +1167,9 @@ Proof.
intros s1 s2 EXT.
generalize tr_expr_incr tr_condition_incr tr_exprlist_incr; intros I1 I2 I3.
pose (AT := fun pc i => instr_at_incr s1 s2 pc i EXT).
- induction 1; econstructor; eauto.
- eapply tr_switch_incr; eauto.
+ induction 1; try (econstructor; eauto; fail).
+ eapply tr_Sassign_2; eauto. eapply tr_move_incr; eauto.
+ econstructor; eauto. eapply tr_switch_incr; eauto.
Qed.
Lemma transl_exit_charact:
@@ -1181,7 +1237,11 @@ Proof.
constructor.
(* Sassign *)
revert EQ. unfold find_var. case_eq (map_vars map)!i; intros; monadInv EQ.
- econstructor. eauto.
+ remember (expr_is_2addr_op e) as is2a. destruct is2a.
+ monadInv EQ0. eapply tr_Sassign_2; eauto.
+ eapply transl_expr_charact; eauto with rtlg.
+ apply tr_move_incr with s1; auto. eapply add_move_charact; eauto.
+ eapply tr_Sassign; eauto.
eapply transl_expr_assign_charact; eauto with rtlg.
constructor. auto.
(* Sstore *)
diff --git a/backend/RTLtypingaux.ml b/backend/RTLtypingaux.ml
index 657c4da..7549ff4 100644
--- a/backend/RTLtypingaux.ml
+++ b/backend/RTLtypingaux.ml
@@ -45,6 +45,8 @@ let type_instr retty (Coq_pair(pc, i)) =
| Iop(Omove, _, _, _) ->
()
| Iop(op, args, res, _) ->
+ if two_address_op op && List.length args >= 1 && List.hd args <> res
+ then raise (Type_error "two-address constraint violation");
let (Coq_pair(targs, tres)) = type_of_operation op in
set_types args targs; set_type res tres
| Iload(chunk, addr, args, dst, _) ->
diff --git a/backend/Reloadproof.v b/backend/Reloadproof.v
index 286a266..a3ed303 100644
--- a/backend/Reloadproof.v
+++ b/backend/Reloadproof.v
@@ -98,19 +98,10 @@ Lemma enough_temporaries_op_args:
Proof.
intros. apply arity_ok_enough.
replace (map Loc.type args) with (fst (type_of_operation op)).
- destruct op; try (destruct c); compute; reflexivity.
+ destruct op; try (destruct c); try (destruct a); compute; reflexivity.
rewrite <- H. auto.
Qed.
-Lemma enough_temporaries_cond:
- forall (cond: condition) (args: list loc),
- List.map Loc.type args = type_of_condition cond ->
- enough_temporaries args = true.
-Proof.
- intros. apply arity_ok_enough. rewrite H.
- destruct cond; compute; reflexivity.
-Qed.
-
Lemma enough_temporaries_addr:
forall (addr: addressing) (args: list loc),
List.map Loc.type args = type_of_addressing addr ->
@@ -120,6 +111,15 @@ Proof.
destruct addr; compute; reflexivity.
Qed.
+Lemma enough_temporaries_cond:
+ forall (cond: condition) (args: list loc),
+ List.map Loc.type args = type_of_condition cond ->
+ enough_temporaries args = true.
+Proof.
+ intros. apply arity_ok_enough. rewrite H.
+ destruct cond; compute; reflexivity.
+Qed.
+
Lemma arity_ok_rec_length:
forall tys itmps ftmps,
(length tys <= length itmps)%nat ->
@@ -225,7 +225,10 @@ Lemma add_reload_correct:
star step ge (State stk f sp (add_reload src dst k) rs m)
E0 (State stk f sp k rs' m) /\
rs' (R dst) = rs src /\
- forall l, Loc.diff (R dst) l -> rs' l = rs l.
+ forall l,
+ Loc.diff (R dst) l ->
+ loc_acceptable src \/ Loc.diff (R IT1) l ->
+ rs' l = rs l.
Proof.
intros. unfold add_reload. destruct src.
case (mreg_eq m0 dst); intro.
@@ -234,29 +237,40 @@ Proof.
split. apply star_one; apply exec_Lop. reflexivity.
split. apply Locmap.gss.
intros; apply Locmap.gso; auto.
- exists (Locmap.set (R dst) (rs (S s)) rs).
+ exists (Locmap.set (R dst) (rs (S s)) (undef_getstack s rs)).
split. apply star_one; apply exec_Lgetstack.
- split. apply Locmap.gss.
- intros; apply Locmap.gso; auto.
+ split. apply Locmap.gss.
+ intros. rewrite Locmap.gso; auto.
+ destruct s; unfold undef_getstack; unfold loc_acceptable in H0; auto.
+ apply Locmap.gso. tauto.
Qed.
Lemma add_reload_correct_2:
forall src k rs m,
+ loc_acceptable src ->
exists rs',
star step ge (State stk f sp (add_reload src (reg_for src) k) rs m)
E0 (State stk f sp k rs' m) /\
rs' (R (reg_for src)) = rs src /\
- (forall l, Loc.diff (R (reg_for src)) l -> rs' l = rs l) /\
- (forall l, Loc.notin l temporaries -> rs' l = rs l).
+ (forall l, Loc.notin l temporaries -> rs' l = rs l) /\
+ rs' (R IT2) = rs (R IT2).
Proof.
- intros. destruct (reg_for_spec src).
- set (rf := reg_for src) in *.
- unfold add_reload. rewrite <- H. rewrite dec_eq_true.
- exists rs. split. constructor. auto.
- destruct (add_reload_correct src (reg_for src) k rs m)
- as [rs' [A [B C]]].
- exists rs'; intuition.
- apply C. apply Loc.diff_sym. eapply Loc.in_notin_diff; eauto.
+ intros. unfold reg_for, add_reload; destruct src.
+ rewrite dec_eq_true. exists rs; split. constructor. auto.
+ set (t := match slot_type s with
+ | Tint => IT1
+ | Tfloat => FT1
+ end).
+ exists (Locmap.set (R t) (rs (S s)) (undef_getstack s rs)).
+ split. apply star_one; apply exec_Lgetstack.
+ split. apply Locmap.gss.
+ split. intros. rewrite Locmap.gso; auto.
+ destruct s; unfold undef_getstack; unfold loc_acceptable in H; auto.
+ apply Locmap.gso. tauto.
+ apply Loc.diff_sym. simpl in H0; unfold t; destruct (slot_type s); tauto.
+ rewrite Locmap.gso. unfold undef_getstack. destruct s; auto.
+ apply Locmap.gso. red; congruence.
+ unfold t; destruct (slot_type s); red; congruence.
Qed.
Lemma add_spill_correct:
@@ -282,6 +296,7 @@ Qed.
Lemma add_reloads_correct_rec:
forall srcs itmps ftmps k rs m,
+ locs_acceptable srcs ->
enough_temporaries_rec srcs itmps ftmps = true ->
(forall r, In (R r) srcs -> In r itmps -> False) ->
(forall r, In (R r) srcs -> In r ftmps -> False) ->
@@ -300,6 +315,8 @@ Proof.
(* base case *)
exists rs. split. apply star_refl. tauto.
(* inductive case *)
+ assert (ACC1: loc_acceptable a) by (auto with coqlib).
+ assert (ACC2: locs_acceptable srcs) by (red; auto with coqlib).
destruct a as [r | s].
(* a is a register *)
simpl add_reload. rewrite dec_eq_true.
@@ -311,41 +328,42 @@ Proof.
(* a is a stack slot *)
destruct (slot_type s).
(* ... of integer type *)
- destruct itmps as [ | it1 itmps ]. discriminate. inv H3.
+ destruct itmps as [ | it1 itmps ]. discriminate. inv H4.
destruct (add_reload_correct (S s) it1 (add_reloads srcs (regs_for_rec srcs itmps ftmps) k) rs m)
as [rs1 [A [B C]]].
exploit IHsrcs; eauto.
- intros. apply H0 with r. tauto. simpl. tauto. eapply list_disjoint_cons_left; eauto.
+ intros. apply H1 with r. tauto. simpl. tauto. eapply list_disjoint_cons_left; eauto.
intros [rs' [P [Q [T U]]]].
exists rs'. split. eapply star_trans; eauto.
split. simpl. decEq. rewrite <- B. apply T. auto.
eapply list_disjoint_notin; eauto with coqlib.
rewrite Q. apply list_map_exten. intros. symmetry. apply C.
- simpl. destruct x; auto. red; intro; subst m0. apply H0 with it1; auto with coqlib.
+ simpl. destruct x; auto. red; intro; subst m0. apply H1 with it1; auto with coqlib.
+ auto.
split. simpl. intros. transitivity (rs1 (R r)).
- apply T; tauto. apply C. simpl. tauto.
- intros. transitivity (rs1 (S s0)). auto. apply C. simpl. auto.
+ apply T; tauto. apply C. simpl. tauto. auto.
+ intros. transitivity (rs1 (S s0)). auto. apply C. simpl. auto. auto.
(* ... of float type *)
- destruct ftmps as [ | ft1 ftmps ]. discriminate. inv H4.
+ destruct ftmps as [ | ft1 ftmps ]. discriminate. inv H5.
destruct (add_reload_correct (S s) ft1 (add_reloads srcs (regs_for_rec srcs itmps ftmps) k) rs m)
as [rs1 [A [B C]]].
exploit IHsrcs; eauto.
- intros. apply H1 with r. tauto. simpl. tauto. eapply list_disjoint_cons_right; eauto.
+ intros. apply H2 with r. tauto. simpl. tauto. eapply list_disjoint_cons_right; eauto.
intros [rs' [P [Q [T U]]]].
exists rs'. split. eapply star_trans; eauto.
split. simpl. decEq. rewrite <- B. apply T; auto.
eapply list_disjoint_notin; eauto. apply list_disjoint_sym. eauto. auto with coqlib.
rewrite Q. apply list_map_exten. intros. symmetry. apply C.
- simpl. destruct x; auto. red; intro; subst m0. apply H1 with ft1; auto with coqlib.
+ simpl. destruct x; auto. red; intro; subst m0. apply H2 with ft1; auto with coqlib. auto.
split. simpl. intros. transitivity (rs1 (R r)).
- apply T; tauto. apply C. simpl. tauto.
- intros. transitivity (rs1 (S s0)). auto. apply C. simpl. auto.
+ apply T; tauto. apply C. simpl. tauto. auto.
+ intros. transitivity (rs1 (S s0)). auto. apply C. simpl. auto. auto.
Qed.
Lemma add_reloads_correct:
forall srcs k rs m,
enough_temporaries srcs = true ->
- Loc.disjoint srcs temporaries ->
+ locs_acceptable srcs ->
exists rs',
star step ge (State stk f sp (add_reloads srcs (regs_for srcs) k) rs m)
E0 (State stk f sp k rs' m) /\
@@ -355,10 +373,10 @@ Proof.
intros.
unfold enough_temporaries in H.
exploit add_reloads_correct_rec; eauto.
- intros. exploit (H0 (R r) (R r)); auto.
- simpl in H2. simpl. intuition congruence.
- intros. exploit (H0 (R r) (R r)); auto.
- simpl in H2. simpl. intuition congruence.
+ intros. generalize (H0 _ H1). unfold loc_acceptable. generalize H2.
+ simpl. intuition congruence.
+ intros. generalize (H0 _ H1). unfold loc_acceptable. generalize H2.
+ simpl. intuition congruence.
red; intros r1 r2; simpl. intuition congruence.
unfold int_temporaries. NoRepet.
unfold float_temporaries. NoRepet.
@@ -389,7 +407,7 @@ Proof.
destruct dst.
(* src is a stack slot, dst a register *)
generalize (add_reload_correct (S s) m0 k rs m); intros [rs' [EX [RES OTH]]].
- exists rs'; intuition. apply OTH; apply Loc.diff_sym; auto.
+ exists rs'; intuition. apply OTH. apply Loc.diff_sym; auto. right; apply Loc.diff_sym; auto.
(* src and dst are stack slots *)
set (tmp := match slot_type s with Tint => IT1 | Tfloat => FT1 end).
generalize (add_reload_correct (S s) tmp (add_spill tmp (S s0) k) rs m);
@@ -401,6 +419,7 @@ Proof.
split. congruence.
intros. rewrite OTH2. apply OTH1.
apply Loc.diff_sym. unfold tmp; case (slot_type s); auto.
+ right. apply Loc.diff_sym; auto.
apply Loc.diff_sym; auto.
Qed.
@@ -535,6 +554,37 @@ Proof.
apply temporaries_not_acceptable; auto.
Qed.
+Remark undef_temps_others:
+ forall rs l,
+ Loc.notin l temporaries -> LTL.undef_temps rs l = rs l.
+Proof.
+ intros. apply Locmap.guo; auto.
+Qed.
+
+Remark undef_op_others:
+ forall op rs l,
+ Loc.notin l temporaries -> undef_op op rs l = rs l.
+Proof.
+ intros. generalize (undef_temps_others rs l H); intro.
+ destruct op; simpl; auto.
+Qed.
+
+Lemma agree_undef_temps:
+ forall rs1 rs2,
+ agree rs1 rs2 -> agree (LTL.undef_temps rs1) rs2.
+Proof.
+ intros; red; intros. rewrite undef_temps_others; auto.
+ apply Conventions.temporaries_not_acceptable. auto.
+Qed.
+
+Lemma agree_undef_temps2:
+ forall rs1 rs2,
+ agree rs1 rs2 -> agree (LTL.undef_temps rs1) (LTL.undef_temps rs2).
+Proof.
+ intros. apply agree_exten with rs2. apply agree_undef_temps; auto.
+ intros. apply undef_temps_others; auto.
+Qed.
+
Lemma agree_set:
forall rs1 rs2 rs2' l v,
loc_acceptable l ->
@@ -550,6 +600,16 @@ Proof.
apply temporaries_not_acceptable; auto.
Qed.
+Lemma agree_set2:
+ forall rs1 rs2 rs2' l v,
+ loc_acceptable l ->
+ Val.lessdef v (rs2' l) ->
+ (forall l', Loc.diff l l' -> Loc.notin l' temporaries -> rs2' l' = rs2 l') ->
+ agree rs1 rs2 -> agree (Locmap.set l v (LTL.undef_temps rs1)) rs2'.
+Proof.
+ intros. eapply agree_set; eauto. apply agree_undef_temps; auto.
+Qed.
+
Lemma agree_find_funct:
forall (ge: Linear.genv) rs ls r f,
Genv.find_funct ge (rs r) = Some f ->
@@ -938,11 +998,11 @@ Proof.
inv A.
right. split. omega. split. auto.
rewrite H1. rewrite H1. econstructor; eauto with coqlib.
- apply agree_set with ls2; auto.
+ apply agree_set2 with ls2; auto.
rewrite B. simpl in H; inversion H. auto.
left; econstructor; split. eapply plus_left; eauto.
econstructor; eauto with coqlib.
- apply agree_set with ls; auto.
+ apply agree_set2 with ls; auto.
rewrite B. simpl in H; inversion H. auto.
intros. apply C. apply Loc.diff_sym; auto.
simpl in H7; tauto. simpl in H7; tauto.
@@ -953,8 +1013,7 @@ Proof.
auto.
rewrite H0.
exploit add_reloads_correct.
- eapply enough_temporaries_op_args; eauto.
- apply locs_acceptable_disj_temporaries; auto.
+ eapply enough_temporaries_op_args; eauto. auto.
intros [ls2 [A [B C]]]. instantiate (1 := ls) in B.
assert (exists tv, eval_operation tge sp op (reglist ls2 (regs_for args)) = Some tv
/\ Val.lessdef v tv).
@@ -969,16 +1028,15 @@ Proof.
eapply plus_left. eapply exec_Lop with (v := tv); eauto.
eexact D. eauto. traceEq.
econstructor; eauto with coqlib.
- apply agree_set with ls; auto.
+ apply agree_set2 with ls; auto.
rewrite E. rewrite Locmap.gss. auto.
- intros. rewrite F; auto. rewrite Locmap.gso. auto.
+ intros. rewrite F; auto. rewrite Locmap.gso. rewrite undef_op_others; auto.
apply reg_for_diff; auto.
(* Lload *)
ExploitWT; inv WTI.
exploit add_reloads_correct.
- eapply enough_temporaries_addr; eauto.
- apply locs_acceptable_disj_temporaries; auto.
+ eapply enough_temporaries_addr; eauto. auto.
intros [ls2 [A [B C]]].
assert (exists ta, eval_addressing tge sp addr (reglist ls2 (regs_for args)) = Some ta
/\ Val.lessdef a ta).
@@ -994,9 +1052,9 @@ Proof.
eapply plus_left. eapply exec_Lload; eauto.
eauto. auto. traceEq.
econstructor; eauto with coqlib.
- apply agree_set with ls; auto.
+ apply agree_set2 with ls; auto.
rewrite E. rewrite Locmap.gss. auto.
- intros. rewrite F; auto. rewrite Locmap.gso. auto.
+ intros. rewrite F; auto. rewrite Locmap.gso. rewrite undef_temps_others; auto.
apply reg_for_diff; auto.
(* Lstore *)
@@ -1004,8 +1062,7 @@ Proof.
caseEq (enough_temporaries (src :: args)); intro ENOUGH.
destruct (regs_for_cons src args) as [rsrc [rargs EQ]]. rewrite EQ.
exploit add_reloads_correct.
- eauto. apply locs_acceptable_disj_temporaries; auto.
- red; intros. elim H1; intro; auto. subst l; auto.
+ eauto. red; simpl; intros. destruct H1. congruence. auto.
intros [ls2 [A [B C]]]. rewrite EQ in A. rewrite EQ in B.
injection B. intros D E.
simpl in B.
@@ -1024,7 +1081,7 @@ Proof.
eapply exec_Lstore with (a := ta); eauto.
traceEq.
econstructor; eauto with coqlib.
- apply agree_exten with ls; auto.
+ apply agree_undef_temps2. apply agree_exten with ls; auto.
(* not enough temporaries *)
destruct (add_reloads_correct tge s' (transf_function f) sp args
(Lop (op_for_binary_addressing addr) (regs_for args) IT2
@@ -1032,25 +1089,24 @@ Proof.
(Lstore chunk (Aindexed Int.zero) (IT2 :: nil) (reg_for src)
:: transf_code f b)) ls tm)
as [ls2 [A [B C]]].
- eapply enough_temporaries_addr; eauto.
- apply locs_acceptable_disj_temporaries; auto.
+ eapply enough_temporaries_addr; eauto. auto.
assert (exists ta, eval_addressing tge sp addr (reglist ls2 (regs_for args)) = Some ta
/\ Val.lessdef a ta).
apply eval_addressing_lessdef with (map rs args).
rewrite B. eapply agree_locs; eauto.
rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
destruct H1 as [ta [P Q]].
- set (ls3 := Locmap.set (R IT2) ta ls2).
+ set (ls3 := Locmap.set (R IT2) ta (undef_op (op_for_binary_addressing addr) ls2)).
destruct (add_reload_correct_2 tge s' (transf_function f) sp src
(Lstore chunk (Aindexed Int.zero) (IT2 :: nil) (reg_for src)
:: transf_code f b)
- ls3 tm)
+ ls3 tm H8)
as [ls4 [D [E [F G]]]].
+ assert (NT: Loc.notin src temporaries) by (apply temporaries_not_acceptable; auto).
assert (X: Val.lessdef (rs src) (ls4 (R (reg_for src)))).
- rewrite E. unfold ls3. rewrite Locmap.gso. eapply agree_loc; eauto.
- eapply agree_exten; eauto.
- apply Loc.diff_sym. apply loc_acceptable_noteq_diff. auto.
- red; intros; subst src. simpl in H8. intuition congruence.
+ rewrite E. unfold ls3. rewrite Locmap.gso.
+ rewrite undef_op_others; auto. rewrite C; auto.
+ apply Loc.diff_sym. simpl in NT; tauto.
exploit Mem.storev_extends. eexact MMD. eauto. eexact Q. eexact X.
intros [tm2 [Y Z]].
left; econstructor; split.
@@ -1060,14 +1116,14 @@ Proof.
rewrite <- B; auto.
eapply star_right. eauto.
eapply exec_Lstore with (a := ta); eauto.
- simpl reglist. rewrite F. unfold ls3. rewrite Locmap.gss. simpl.
+ simpl reglist. rewrite G. unfold ls3. rewrite Locmap.gss. simpl.
destruct ta; simpl in Y; try discriminate. rewrite Int.add_zero. auto.
- simpl. apply reg_for_not_IT2; auto.
reflexivity. reflexivity. traceEq.
econstructor; eauto with coqlib.
- apply agree_exten with ls; auto.
- intros. rewrite G; auto. unfold ls3. rewrite Locmap.gso. auto.
- simpl. destruct l; auto. simpl in H1. intuition congruence.
+ apply agree_undef_temps2. apply agree_exten with ls; auto.
+ intros. rewrite F; auto. unfold ls3. rewrite Locmap.gso.
+ rewrite undef_op_others; auto.
+ apply Loc.diff_sym. simpl in H1; tauto.
(* Lcall *)
ExploitWT. inversion WTI. subst ros0 args0 res0. rewrite <- H0.
@@ -1086,13 +1142,13 @@ Proof.
destruct (add_reload_correct_2 tge s' (transf_function f) sp fn
(Lcall sig (inl ident (reg_for fn))
:: add_spill (loc_result sig) res (transf_code f b))
- ls2 tm)
+ ls2 tm OK2)
as [ls3 [D [E [F G]]]].
assert (ARGS: Val.lessdef_list (map rs args)
(map ls3 (loc_arguments sig))).
replace (map ls3 (loc_arguments sig)) with (map ls2 (loc_arguments sig)).
rewrite B. apply agree_locs; auto.
- apply list_map_exten; intros. apply G.
+ apply list_map_exten; intros. apply F.
apply Loc.disjoint_notin with (loc_arguments sig).
apply loc_arguments_not_temporaries. auto.
left; econstructor; split.
@@ -1108,7 +1164,7 @@ Proof.
econstructor; eauto with coqlib.
rewrite H0. auto.
apply agree_postcall_call with ls sig; auto.
- intros. rewrite G; auto. congruence.
+ intros. rewrite F; auto. congruence.
(* direct call *)
rewrite <- H0 in H4.
destruct (parallel_move_arguments_correct tge s' (transf_function f) sp
@@ -1158,6 +1214,7 @@ Proof.
apply list_map_exten; intros. apply F.
apply Loc.diff_sym.
apply (loc_arguments_not_temporaries sig x (R IT1)); simpl; auto.
+ auto.
left; econstructor; split.
eapply star_plus_trans. eexact A. eapply plus_right. eexact D.
eapply exec_Ltailcall; eauto.
@@ -1197,8 +1254,7 @@ Proof.
(* Lbuiltin *)
ExploitWT; inv WTI.
exploit add_reloads_correct.
- instantiate (1 := args). apply arity_ok_enough. rewrite H3. auto.
- apply locs_acceptable_disj_temporaries; auto.
+ instantiate (1 := args). apply arity_ok_enough. rewrite H3. auto. auto.
intros [ls2 [A [B C]]].
exploit external_call_mem_extends; eauto.
apply agree_locs; eauto.
@@ -1214,7 +1270,7 @@ Proof.
econstructor; eauto with coqlib.
apply agree_set with ls; auto.
rewrite E. rewrite Locmap.gss. auto.
- intros. rewrite F; auto. rewrite Locmap.gso. auto.
+ intros. rewrite F; auto. rewrite Locmap.gso. rewrite undef_temps_others; auto.
apply reg_for_diff; auto.
(* Llabel *)
@@ -1231,8 +1287,7 @@ Proof.
(* Lcond true *)
ExploitWT; inv WTI.
exploit add_reloads_correct.
- eapply enough_temporaries_cond; eauto.
- apply locs_acceptable_disj_temporaries; auto.
+ eapply enough_temporaries_cond; eauto. auto.
intros [ls2 [A [B C]]].
left; econstructor; split.
eapply plus_right. eauto. eapply exec_Lcond_true; eauto.
@@ -1241,14 +1296,13 @@ Proof.
apply find_label_transf_function; eauto.
traceEq.
econstructor; eauto.
- apply agree_exten with ls; auto.
+ apply agree_undef_temps2. apply agree_exten with ls; auto.
eapply LTLin.find_label_is_tail; eauto.
(* Lcond false *)
ExploitWT; inv WTI.
exploit add_reloads_correct.
- eapply enough_temporaries_cond; eauto.
- apply locs_acceptable_disj_temporaries; auto.
+ eapply enough_temporaries_cond; eauto. auto.
intros [ls2 [A [B C]]].
left; econstructor; split.
eapply plus_right. eauto. eapply exec_Lcond_false; eauto.
@@ -1256,11 +1310,11 @@ Proof.
eapply agree_locs; eauto.
traceEq.
econstructor; eauto with coqlib.
- apply agree_exten with ls; auto.
+ apply agree_undef_temps2. apply agree_exten with ls; auto.
(* Ljumptable *)
ExploitWT; inv WTI.
- exploit add_reload_correct_2.
+ exploit add_reload_correct_2; eauto.
intros [ls2 [A [B [C D]]]].
left; econstructor; split.
eapply plus_right. eauto. eapply exec_Ljumptable; eauto.
@@ -1269,7 +1323,7 @@ Proof.
apply find_label_transf_function; eauto.
traceEq.
econstructor; eauto with coqlib.
- apply agree_exten with ls; auto.
+ apply agree_undef_temps2. apply agree_exten with ls; auto.
eapply LTLin.find_label_is_tail; eauto.
(* Lreturn *)
diff --git a/backend/Reloadtyping.v b/backend/Reloadtyping.v
index 1bb462d..60be59b 100644
--- a/backend/Reloadtyping.v
+++ b/backend/Reloadtyping.v
@@ -197,7 +197,8 @@ Proof.
destruct a.
simpl. decEq. eauto.
caseEq (slot_type s); intro SLOTTYPE; rewrite SLOTTYPE in H.
- destruct itmps. discriminate. simpl. decEq.
+ destruct itmps. discriminate.
+ simpl. decEq.
rewrite SLOTTYPE. auto with coqlib.
apply IHlocs; auto with coqlib.
destruct ftmps. discriminate. simpl. decEq.
diff --git a/backend/Selection.v b/backend/Selection.v
index ebdad8a..68fb9ba 100644
--- a/backend/Selection.v
+++ b/backend/Selection.v
@@ -101,8 +101,8 @@ Definition sel_constant (cst: Cminor.constant) : expr :=
match cst with
| Cminor.Ointconst n => Eop (Ointconst n) Enil
| Cminor.Ofloatconst f => Eop (Ofloatconst f) Enil
- | Cminor.Oaddrsymbol id ofs => Eop (Oaddrsymbol id ofs) Enil
- | Cminor.Oaddrstack ofs => Eop (Oaddrstack ofs) Enil
+ | Cminor.Oaddrsymbol id ofs => addrsymbol id ofs
+ | Cminor.Oaddrstack ofs => addrstack ofs
end.
Definition sel_unop (op: Cminor.unary_operation) (arg: expr) : expr :=
diff --git a/backend/Stacking.v b/backend/Stacking.v
index f289793..2ea08be 100644
--- a/backend/Stacking.v
+++ b/backend/Stacking.v
@@ -127,16 +127,10 @@ Definition restore_callee_save (fe: frame_env) (k: Mach.code) :=
behaviour. *)
Definition transl_op (fe: frame_env) (op: operation) :=
- match op with
- | Oaddrstack ofs => Oaddrstack (Int.add (Int.repr fe.(fe_size)) ofs)
- | _ => op
- end.
+ shift_stack_operation (Int.repr fe.(fe_size)) op.
Definition transl_addr (fe: frame_env) (addr: addressing) :=
- match addr with
- | Ainstack ofs => Ainstack (Int.add (Int.repr fe.(fe_size)) ofs)
- | _ => addr
- end.
+ shift_stack_addressing (Int.repr fe.(fe_size)) addr.
(** Translation of a Linear instruction. Prepends the corresponding
Mach instructions to the given list of instructions.
diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v
index 68d179a..5b06c71 100644
--- a/backend/Stackingproof.v
+++ b/backend/Stackingproof.v
@@ -32,6 +32,7 @@ Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Locations.
+Require LTL.
Require Import Linear.
Require Import Lineartyping.
Require Import Mach.
@@ -575,6 +576,58 @@ Proof.
intros. rewrite get_set_index_val_other; eauto with stacking. red; auto.
Qed.
+Lemma agree_undef_regs:
+ forall rl ls ls0 rs fr cs,
+ agree ls ls0 rs fr cs ->
+ (forall r, In r rl -> In (R r) temporaries) ->
+ agree (Locmap.undef (List.map R rl) ls) ls0 (undef_regs rl rs) fr cs.
+Proof.
+ induction rl; intros; simpl.
+ auto.
+ eapply IHrl; eauto.
+ apply agree_set_reg; auto with coqlib.
+ assert (In (R a) temporaries) by auto with coqlib.
+ red. destruct (mreg_type a).
+ destruct (zlt (index_int_callee_save a) 0).
+ generalize (bound_int_callee_save_pos b). omega.
+ elim (int_callee_save_not_destroyed a). auto. apply index_int_callee_save_pos2; auto.
+ destruct (zlt (index_float_callee_save a) 0).
+ generalize (bound_float_callee_save_pos b). omega.
+ elim (float_callee_save_not_destroyed a). auto. apply index_float_callee_save_pos2; auto.
+ intros. apply H0. auto with coqlib.
+Qed.
+
+Lemma agree_undef_temps:
+ forall ls ls0 rs fr cs,
+ agree ls ls0 rs fr cs ->
+ agree (LTL.undef_temps ls) ls0 (Mach.undef_temps rs) fr cs.
+Proof.
+ intros. unfold undef_temps, LTL.undef_temps.
+ change temporaries with (List.map R (int_temporaries ++ float_temporaries)).
+ apply agree_undef_regs; auto.
+ intros.
+ change temporaries with (List.map R (int_temporaries ++ float_temporaries)).
+ apply List.in_map. auto.
+Qed.
+
+Lemma agree_undef_op:
+ forall op env ls ls0 rs fr cs,
+ agree ls ls0 rs fr cs ->
+ agree (Linear.undef_op op ls) ls0 (Mach.undef_op (transl_op env op) rs) fr cs.
+Proof.
+ intros. exploit agree_undef_temps; eauto. intro.
+ destruct op; simpl; auto.
+Qed.
+
+Lemma agree_undef_getparam:
+ forall ls ls0 rs fr cs,
+ agree ls ls0 rs fr cs ->
+ agree (Locmap.set (R IT1) Vundef ls) ls0 (rs#IT1 <- Vundef) fr cs.
+Proof.
+ intros. exploit (agree_undef_regs (IT1 :: nil)); eauto.
+ simpl; intros. intuition congruence.
+Qed.
+
Lemma agree_return_regs:
forall ls ls0 rs fr cs rs',
agree ls ls0 rs fr cs ->
@@ -831,9 +884,10 @@ Proof.
intros until idx. destruct idx; simpl; auto. congruence.
apply incl_refl.
apply float_callee_save_norepet. eauto.
- intros [fr' [A [B C]]].
- exists fr'; intuition. unfold save_callee_save_float; eauto.
- apply C. auto. intros; subst idx. auto.
+ intros [fr' [A [B C]]].
+ exists fr'. split. unfold save_callee_save_float; eauto.
+ split. auto.
+ intros. apply C. auto. intros; subst. red; intros; subst idx. contradiction.
Qed.
Lemma save_callee_save_correct:
@@ -1216,24 +1270,15 @@ Qed.
Definition shift_sp (tf: Mach.function) (sp: val) :=
Val.add sp (Vint (Int.repr (-tf.(fn_framesize)))).
-Remark shift_offset_sp:
- forall f tf sp n v,
+Remark shift_sp_eq:
+ forall f tf sp,
transf_function f = OK tf ->
- offset_sp sp n = Some v ->
- offset_sp (shift_sp tf sp)
- (Int.add (Int.repr (fe_size (make_env (function_bounds f)))) n) = Some v.
+ shift_sp tf sp = Val.sub sp (Vint (Int.repr (fe_size (make_env (function_bounds f))))).
Proof.
- intros. destruct sp; try discriminate.
- unfold offset_sp in *.
- unfold shift_sp.
- rewrite (unfold_transf_function _ _ H). unfold fn_framesize.
- unfold Val.add. rewrite <- Int.neg_repr.
- set (p := Int.repr (fe_size (make_env (function_bounds f)))).
- inversion H0. decEq. decEq.
- rewrite Int.add_assoc. decEq.
- rewrite <- Int.add_assoc.
- rewrite (Int.add_commut (Int.neg p) p). rewrite Int.add_neg_zero.
- rewrite Int.add_commut. apply Int.add_zero.
+ intros. unfold shift_sp.
+ replace (fe_size (make_env (function_bounds f))) with (fn_framesize tf).
+ rewrite <- Int.neg_repr. destruct sp; simpl; auto; rewrite Int.sub_add_opp; auto.
+ rewrite (unfold_transf_function _ _ H). auto.
Qed.
Lemma shift_eval_operation:
@@ -1243,10 +1288,10 @@ Lemma shift_eval_operation:
eval_operation tge (shift_sp tf sp)
(transl_op (make_env (function_bounds f)) op) args = Some v.
Proof.
- intros until v. destruct op; intros; auto.
- simpl in *. rewrite symbols_preserved. auto.
- destruct args; auto. unfold eval_operation in *. unfold transl_op.
- apply shift_offset_sp; auto.
+ intros. rewrite <- H0. rewrite (shift_sp_eq f tf sp H). unfold transl_op.
+ rewrite (eval_operation_preserved ge tge).
+ apply shift_stack_eval_operation.
+ exact symbols_preserved.
Qed.
Lemma shift_eval_addressing:
@@ -1257,11 +1302,10 @@ Lemma shift_eval_addressing:
(transl_addr (make_env (function_bounds f)) addr) args =
Some v.
Proof.
- intros.
- unfold transl_addr, eval_addressing in *;
- destruct addr; try (rewrite symbols_preserved); auto.
- destruct args; try discriminate.
- apply shift_offset_sp; auto.
+ intros. rewrite <- H0. rewrite (shift_sp_eq f tf sp H). unfold transl_addr.
+ rewrite (eval_addressing_preserved ge tge).
+ apply shift_stack_eval_addressing.
+ exact symbols_preserved.
Qed.
(** Preservation of the arguments to an external call. *)
@@ -1389,23 +1433,29 @@ Proof.
intro BOUND; simpl in BOUND);
unfold transl_instr.
(* Lgetstack *)
- inv WTI. destruct BOUND.
- exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b)
- (rs0#r <- (rs (S sl))) fr m).
- split. destruct sl.
+ inv WTI. destruct BOUND. unfold undef_getstack; destruct sl.
(* Lgetstack, local *)
+ exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b)
+ (rs0#r <- (rs (S (Local z t)))) fr m); split.
apply plus_one. apply exec_Mgetstack.
apply get_slot_index. auto. apply index_local_valid. auto. congruence. congruence. auto.
eapply agree_locals; eauto.
+ econstructor; eauto with coqlib.
+ apply agree_set_reg; auto.
(* Lgetstack, incoming *)
- apply plus_one; apply exec_Mgetparam.
+ exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b)
+ (rs0 # IT1 <- Vundef # r <- (rs (S (Incoming z t)))) fr m); split.
+ apply plus_one. apply exec_Mgetparam.
change (get_parent_slot ts z t (rs (S (Incoming z t)))).
eapply agree_incoming; eauto.
+ econstructor; eauto with coqlib.
+ apply agree_set_reg; auto. apply agree_undef_getparam; auto.
(* Lgetstack, outgoing *)
- apply plus_one; apply exec_Mgetstack.
- apply get_slot_index. auto. apply index_arg_valid. auto. congruence. congruence. auto.
+ exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b)
+ (rs0#r <- (rs (S (Outgoing z t)))) fr m); split.
+ apply plus_one. apply exec_Mgetstack.
+ apply get_slot_index. auto. apply index_arg_valid. auto. congruence. congruence. auto.
eapply agree_outgoing; eauto.
- (* Lgetstack, common *)
econstructor; eauto with coqlib.
apply agree_set_reg; auto.
@@ -1432,22 +1482,23 @@ Proof.
symmetry. eapply agree_reg; eauto.
(* Lop *)
- exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) (rs0#res <- v) fr m); split.
+ set (op' := transl_op (make_env (function_bounds f)) op).
+ exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) ((undef_op op' rs0)#res <- v) fr m); split.
apply plus_one. apply exec_Mop.
apply shift_eval_operation. auto.
change mreg with RegEq.t.
rewrite (agree_eval_regs _ _ _ _ _ _ _ args AG). auto.
econstructor; eauto with coqlib.
- apply agree_set_reg; auto.
+ apply agree_set_reg; auto. apply agree_undef_op; auto.
(* Lload *)
- exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) (rs0#dst <- v) fr m); split.
+ exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) ((undef_temps rs0)#dst <- v) fr m); split.
apply plus_one; eapply exec_Mload; eauto.
apply shift_eval_addressing; auto.
change mreg with RegEq.t.
rewrite (agree_eval_regs _ _ _ _ _ _ _ args AG). eauto.
econstructor; eauto with coqlib.
- apply agree_set_reg; auto.
+ apply agree_set_reg; auto. apply agree_undef_temps; auto.
(* Lstore *)
econstructor; split.
@@ -1456,7 +1507,7 @@ Proof.
change mreg with RegEq.t.
rewrite (agree_eval_regs _ _ _ _ _ _ _ args AG). eauto.
rewrite (agree_eval_reg _ _ _ _ _ _ _ src AG). eauto.
- econstructor; eauto with coqlib.
+ econstructor; eauto with coqlib. apply agree_undef_temps; auto.
(* Lcall *)
assert (WTF': wt_fundef f'). eapply find_function_well_typed; eauto.
@@ -1504,14 +1555,14 @@ Proof.
apply agree_callee_save_return_regs.
(* Lbuiltin *)
- exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) (rs0#res <- v) fr m'); split.
+ econstructor; split.
apply plus_one. apply exec_Mbuiltin.
change mreg with RegEq.t.
rewrite (agree_eval_regs _ _ _ _ _ _ _ args AG).
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
econstructor; eauto with coqlib.
- apply agree_set_reg; auto.
+ apply agree_set_reg; auto. apply agree_undef_temps; auto.
(* Llabel *)
econstructor; split.
@@ -1530,14 +1581,14 @@ Proof.
apply plus_one; apply exec_Mcond_true.
rewrite <- (agree_eval_regs _ _ _ _ _ _ _ args AG) in H; eauto.
apply transl_find_label; eauto.
- econstructor; eauto.
+ econstructor; eauto. apply agree_undef_temps; auto.
eapply find_label_incl; eauto.
(* Lcond, false *)
econstructor; split.
apply plus_one; apply exec_Mcond_false.
rewrite <- (agree_eval_regs _ _ _ _ _ _ _ args AG) in H; auto.
- econstructor; eauto with coqlib.
+ econstructor; eauto with coqlib. apply agree_undef_temps; auto.
(* Ljumptable *)
econstructor; split.
@@ -1545,7 +1596,7 @@ Proof.
rewrite <- (agree_eval_reg _ _ _ _ _ _ _ arg AG) in H; eauto.
eauto.
apply transl_find_label; eauto.
- econstructor; eauto.
+ econstructor; eauto. apply agree_undef_temps; auto.
eapply find_label_incl; eauto.
(* Lreturn *)
diff --git a/backend/Stackingtyping.v b/backend/Stackingtyping.v
index 6ef8669..b42dbbb 100644
--- a/backend/Stackingtyping.v
+++ b/backend/Stackingtyping.v
@@ -160,7 +160,7 @@ Proof.
apply wt_instrs_cons; auto.
constructor.
destruct o; simpl; congruence.
- rewrite H6. destruct o; reflexivity || congruence.
+ rewrite H6. symmetry. apply type_shift_stack_operation.
(* load *)
apply wt_instrs_cons; auto.
constructor; auto.
diff --git a/common/Errors.v b/common/Errors.v
index 2165db3..36e70c5 100644
--- a/common/Errors.v
+++ b/common/Errors.v
@@ -93,10 +93,37 @@ Proof.
intros; discriminate.
Qed.
-Open Local Scope error_monad_scope.
+(** Assertions *)
+
+Definition assertion (b: bool) : res unit :=
+ if b then OK tt else Error(msg "Assertion failed").
+
+Remark assertion_inversion:
+ forall b x, assertion b = OK x -> b = true.
+Proof.
+ unfold assertion; intros. destruct b; inv H; auto.
+Qed.
+
+Remark assertion_inversion_1:
+ forall (P Q: Prop) (a: {P}+{Q}) x,
+ assertion (proj_sumbool a) = OK x -> P.
+Proof.
+ intros. exploit assertion_inversion; eauto.
+ unfold proj_sumbool. destruct a. auto. congruence.
+Qed.
+
+Remark assertion_inversion_2:
+ forall (P Q: Prop) (a: {P}+{Q}) x,
+ assertion (negb(proj_sumbool a)) = OK x -> Q.
+Proof.
+ intros. exploit assertion_inversion; eauto.
+ unfold proj_sumbool. destruct a; simpl. congruence. auto.
+Qed.
(** This is the familiar monadic map iterator. *)
+Open Local Scope error_monad_scope.
+
Fixpoint mmap (A B: Type) (f: A -> res B) (l: list A) {struct l} : res (list B) :=
match l with
| nil => OK nil
@@ -152,6 +179,15 @@ Ltac monadInv1 H :=
destruct (bind2_inversion F G H) as [x1 [x2 [EQ1 EQ2]]];
clear H;
try (monadInv1 EQ2)))))
+ | (assertion (negb (proj_sumbool ?a)) = OK ?X) =>
+ let A := fresh "A" in (generalize (assertion_inversion_2 _ H); intro A);
+ clear H
+ | (assertion (proj_sumbool ?a) = OK ?X) =>
+ let A := fresh "A" in (generalize (assertion_inversion_1 _ H); intro A);
+ clear H
+ | (assertion ?b = OK ?X) =>
+ let A := fresh "A" in (generalize (assertion_inversion _ H); intro A);
+ clear H
| (mmap ?F ?L = OK ?M) =>
generalize (mmap_inversion F L H); intro
end.
@@ -162,6 +198,7 @@ Ltac monadInv H :=
| (Error _ = OK _) => monadInv1 H
| (bind ?F ?G = OK ?X) => monadInv1 H
| (bind2 ?F ?G = OK ?X) => monadInv1 H
+ | (assertion _ = OK _) => monadInv1 H
| (?F _ _ _ _ _ _ _ _ = OK _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ _ _ _ = OK _) =>
@@ -179,4 +216,3 @@ Ltac monadInv H :=
| (?F _ = OK _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
end.
-
diff --git a/common/Memdataaux.ml b/common/Memdataaux.ml
index 0ec7523..8bfd434 100644
--- a/common/Memdataaux.ml
+++ b/common/Memdataaux.ml
@@ -14,4 +14,5 @@ let big_endian =
match Configuration.arch with
| "powerpc" -> true
| "arm" -> false
+ | "ia32" -> false
| _ -> assert false
diff --git a/common/Values.v b/common/Values.v
index 236a5ae..af242c9 100644
--- a/common/Values.v
+++ b/common/Values.v
@@ -139,6 +139,12 @@ Definition floatofintu (v: val) : val :=
| _ => Vundef
end.
+Definition floatofwords (v1 v2: val) : val :=
+ match v1, v2 with
+ | Vint n1, Vint n2 => Vfloat (Float.from_words n1 n2)
+ | _, _ => Vundef
+ end.
+
Definition notint (v: val) : val :=
match v with
| Vint n => Vint (Int.xor n Int.mone)
diff --git a/configure b/configure
index f72e981..d061396 100755
--- a/configure
+++ b/configure
@@ -33,6 +33,9 @@ Supported targets:
ppc-macosx (PowerPC, MacOS X)
ppc-linux (PowerPC, Linux)
arm-linux (ARM, Linux)
+ ia32-linux (x86 32 bits, Linux)
+ ia32-bsd (x86 32 bits, BSD)
+ ia32-macosx (x86 32 bits, MacOS X)
manual (edit configuration file by hand)
Options:
@@ -89,6 +92,33 @@ case "$target" in
casm="gcc -c"
clinker="gcc"
libmath="-lm";;
+ ia32-linux)
+ arch="ia32"
+ variant="standard"
+ system="linux"
+ cc="gcc -m32"
+ cprepro="gcc -m32 -U__GNUC__ -E"
+ casm="gcc -m32 -c"
+ clinker="gcc -m32"
+ libmath="-lm";;
+ ia32-bsd)
+ arch="ia32"
+ variant="standard"
+ system="bsd"
+ cc="gcc -m32"
+ cprepro="gcc -m32 -U__GNUC__ -E"
+ casm="gcc -m32 -c"
+ clinker="gcc -m32"
+ libmath="-lm";;
+ ia32-macosx)
+ arch="ia32"
+ variant="standard"
+ system="macosx"
+ cc="gcc -arch i386"
+ cprepro="gcc -arch i386 -U__GNUC__ -U__BLOCKS__ -E"
+ casm="gcc -arch i386 -c"
+ clinker="gcc -arch i386"
+ libmath="";;
manual)
;;
"")
diff --git a/driver/Driver.ml b/driver/Driver.ml
index 4f98be2..56bdb01 100644
--- a/driver/Driver.ml
+++ b/driver/Driver.ml
@@ -235,7 +235,7 @@ Code generation options:
-fsmall-const <n> Set maximal size <n> for allocation in small constant area
Tracing options:
-dparse Save C file after parsing and elaboration in <file>.parse.c
- -dcmedium Save generated Cmedium in <file>.medium.c
+ -dc Save generated Compcert C in <file>.compcert.c
-dclight Save generated Clight in <file>.light.c
-dasm Save generated assembly in <file>.s
Linking options:
@@ -312,7 +312,7 @@ let cmdline_actions =
"-o$", String(fun s -> exe_name := s);
"-stdlib$", String(fun s -> stdlib_path := s);
"-dparse$", Set option_dparse;
- "-dcmedium$", Set option_dcmedium;
+ "-dc$", Set option_dcmedium;
"-dclight$", Set option_dclight;
"-dcminor", Set option_dcminor;
"-drtl$", Set option_drtl;
diff --git a/extraction/extraction.v b/extraction/extraction.v
index 706d1db..8e3c1aa 100644
--- a/extraction/extraction.v
+++ b/extraction/extraction.v
@@ -28,7 +28,6 @@ Extract Inductive List.list => "list" [ "[]" "(::)" ].
(* Float *)
Extract Inlined Constant Floats.float => "float".
Extract Constant Floats.Float.zero => "0.".
-Extract Constant Floats.Float.one => "1.".
Extract Constant Floats.Float.neg => "( ~-. )".
Extract Constant Floats.Float.abs => "abs_float".
Extract Constant Floats.Float.singleoffloat => "Floataux.singleoffloat".
diff --git a/ia32/Asm.v b/ia32/Asm.v
new file mode 100644
index 0000000..9c23d9d
--- /dev/null
+++ b/ia32/Asm.v
@@ -0,0 +1,759 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Abstract syntax and semantics for PowerPC assembly language *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Events.
+Require Import Globalenvs.
+Require Import Smallstep.
+Require Import Locations.
+Require Import Stacklayout.
+Require Import Conventions.
+
+(** * Abstract syntax *)
+
+(** ** Registers. *)
+
+(** Integer registers. *)
+
+Inductive ireg: Type :=
+ | EAX: ireg | EBX: ireg | ECX: ireg | EDX: ireg
+ | ESI: ireg | EDI: ireg | EBP: ireg | ESP: ireg.
+
+(** Floating-point registers, i.e. SSE2 registers *)
+
+Inductive freg: Type :=
+ | XMM0: freg | XMM1: freg | XMM2: freg | XMM3: freg
+ | XMM4: freg | XMM5: freg | XMM6: freg | XMM7: freg.
+
+Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}.
+Proof. decide equality. Defined.
+
+Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}.
+Proof. decide equality. Defined.
+
+(** Condition bits *)
+
+Inductive crbit: Type :=
+ | ZF | CF | PF | SOF.
+
+(** All registers modeled here. *)
+
+Inductive preg: Type :=
+ | PC: preg (**r program counter *)
+ | IR: ireg -> preg (**r integer register *)
+ | FR: freg -> preg (**r XMM register *)
+ | ST0: preg (**r top of FP stack *)
+ | CR: crbit -> preg (**r bit of the condition register *)
+ | RA: preg. (**r pseudo-reg representing return address *)
+
+Coercion IR: ireg >-> preg.
+Coercion FR: freg >-> preg.
+Coercion CR: crbit >-> preg.
+
+(** ** Instruction set. *)
+
+Definition label := positive.
+
+(** General form of an addressing mode. *)
+
+Inductive addrmode: Type :=
+ | Addrmode (base: option ireg)
+ (ofs: option (ireg * int))
+ (const: int + ident * int).
+
+(** Testable conditions (for conditional jumps and more). *)
+
+Inductive testcond: Type :=
+ | Cond_e | Cond_ne
+ | Cond_b | Cond_be | Cond_ae | Cond_a
+ | Cond_l | Cond_le | Cond_ge | Cond_g
+ | Cond_p | Cond_np
+ | Cond_nep (**r synthetic: P or (not Z) *)
+ | Cond_enp. (**r synthetic: (not P) and Z *)
+
+(** Instructions. IA32 instructions accept many combinations of
+ registers, memory references and immediate constants as arguments.
+ Here, we list the combinations that we actually use.
+ Naming conventions:
+- [r]: integer register operand
+- [f]: XMM register operand
+- [m]: memory operand
+- [i]: immediate integer operand
+- [s]: immediate symbol operand
+- [l]: immediate label operand
+- [st0]: top of floating-point stack
+- [cl]: the [CL] register
+- For two-operand instructions, the first suffix describes the result
+ (and first argument), the second suffix describes the second argument.
+*)
+
+Inductive instruction: Type :=
+ (** Moves *)
+ | Pmov_rr (rd: ireg) (r1: ireg) (**r [mov] (32-bit int) *)
+ | Pmov_ri (rd: ireg) (n: int)
+ | Pmov_rm (rd: ireg) (a: addrmode)
+ | Pmov_mr (a: addrmode) (rs: ireg)
+ | Pmovd_fr (rd: freg) (r1: ireg) (**r [movd] (32-bit int) *)
+ | Pmovd_rf (rd: ireg) (rd: freg)
+ | Pmovsd_ff (rd: freg) (r1: freg) (**r [movsd] (single 64-bit float) *)
+ | Pmovsd_fi (rd: freg) (n: float) (**r (pseudo-instruction) *)
+ | Pmovsd_fm (rd: freg) (a: addrmode)
+ | Pmovsd_mf (a: addrmode) (r1: freg)
+ | Pfld_f (r1: freg) (**r [fld] from XMM register (pseudo) *)
+ | Pfld_m (a: addrmode) (**r [fld] from memory *)
+ | Pfstp_f (rd: freg) (**r [fstp] to XMM register (pseudo) *)
+ | Pfstp_m (a: addrmode) (**r [fstp] to memory *)
+ (** Moves with conversion *)
+ | Pmovb_mr (a: addrmode) (rs: ireg) (**r [mov] (8-bit int) *)
+ | Pmovw_mr (a: addrmode) (rs: ireg) (**r [mov] (16-bit int) *)
+ | Pmovzb_rr (rd: ireg) (rs: ireg) (**r [movzb] (8-bit zero-extension) *)
+ | Pmovzb_rm (rd: ireg) (a: addrmode)
+ | Pmovsb_rr (rd: ireg) (rs: ireg) (**r [movsb] (8-bit sign-extension) *)
+ | Pmovsb_rm (rd: ireg) (a: addrmode)
+ | Pmovzw_rr (rd: ireg) (rs: ireg) (**r [movzw] (16-bit zero-extension) *)
+ | Pmovzw_rm (rd: ireg) (a: addrmode)
+ | Pmovsw_rr (rd: ireg) (rs: ireg) (**r [movsw] (16-bit sign-extension) *)
+ | Pmovsw_rm (rd: ireg) (a: addrmode)
+ | Pcvtss2sd_fm (rd: freg) (a: addrmode) (**r [cvtss2sd] (single float load) *)
+ | Pcvtsd2ss_ff (rd: freg) (r1: freg) (**r pseudo (single conversion) *)
+ | Pcvtsd2ss_mf (a: addrmode) (r1: freg) (**r [cvtsd2ss] (single float store *)
+ | Pcvttsd2si_rf (rd: ireg) (r1: freg) (**r double to signed int *)
+ | Pcvtsi2sd_fr (rd: freg) (r1: ireg) (**r signed int to double *)
+ (** Integer arithmetic *)
+ | Plea (rd: ireg) (a: addrmode)
+ | Pneg (rd: ireg)
+ | Psub_rr (rd: ireg) (r1: ireg)
+ | Pimul_rr (rd: ireg) (r1: ireg)
+ | Pimul_ri (rd: ireg) (n: int)
+ | Pdiv (r1: ireg)
+ | Pidiv (r1: ireg)
+ | Pand_rr (rd: ireg) (r1: ireg)
+ | Pand_ri (rd: ireg) (n: int)
+ | Por_rr (rd: ireg) (r1: ireg)
+ | Por_ri (rd: ireg) (n: int)
+ | Pxor_rr (rd: ireg) (r1: ireg)
+ | Pxor_ri (rd: ireg) (n: int)
+ | Psal_rcl (rd: ireg)
+ | Psal_ri (rd: ireg) (n: int)
+ | Pshr_rcl (rd: ireg)
+ | Pshr_ri (rd: ireg) (n: int)
+ | Psar_rcl (rd: ireg)
+ | Psar_ri (rd: ireg) (n: int)
+ | Pror_ri (rd: ireg) (n: int)
+ | Pcmp_rr (r1 r2: ireg)
+ | Pcmp_ri (r1: ireg) (n: int)
+ | Ptest_rr (r1 r2: ireg)
+ | Ptest_ri (r1: ireg) (n: int)
+ | Pcmov (c: testcond) (rd: ireg) (r1: ireg)
+ | Psetcc (c: testcond) (rd: ireg)
+ (** Floating-point arithmetic *)
+ | Paddd_ff (rd: freg) (r1: freg)
+ | Psubd_ff (rd: freg) (r1: freg)
+ | Pmuld_ff (rd: freg) (r1: freg)
+ | Pdivd_ff (rd: freg) (r1: freg)
+ | Pnegd (rd: freg)
+ | Pabsd (rd: freg)
+ | Pcomisd_ff (r1 r2: freg)
+ (** Branches and calls *)
+ | Pjmp_l (l: label)
+ | Pjmp_s (symb: ident)
+ | Pjmp_r (r: ireg)
+ | Pjcc (c: testcond)(l: label)
+ | Pjmptbl (r: ireg) (tbl: list label) (**r pseudo *)
+ | Pcall_s (symb: ident)
+ | Pcall_r (r: ireg)
+ | Pret
+ (** Pseudo-instructions *)
+ | Plabel(l: label)
+ | Pallocframe(lo hi: Z)(ofs_ra ofs_link: int)
+ | Pfreeframe(lo hi: Z)(ofs_ra ofs_link: int)
+ | Pbuiltin(ef: external_function)(args: list preg)(res: preg).
+
+Definition code := list instruction.
+Definition fundef := AST.fundef code.
+Definition program := AST.program fundef unit.
+
+(** * Operational semantics *)
+
+Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}.
+Proof. decide equality. apply ireg_eq. apply freg_eq. decide equality. Defined.
+
+Module PregEq.
+ Definition t := preg.
+ Definition eq := preg_eq.
+End PregEq.
+
+Module Pregmap := EMap(PregEq).
+
+Definition regset := Pregmap.t val.
+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. *)
+
+Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction :=
+ match c with
+ | nil => None
+ | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il
+ end.
+
+(** Position corresponding to a label *)
+
+Definition is_label (lbl: label) (instr: instruction) : bool :=
+ match instr with
+ | Plabel lbl' => if peq lbl lbl' then true else false
+ | _ => false
+ end.
+
+Lemma is_label_correct:
+ forall lbl instr,
+ if is_label lbl instr then instr = Plabel lbl else instr <> Plabel lbl.
+Proof.
+ intros. destruct instr; simpl; try discriminate.
+ case (peq lbl l); intro; congruence.
+Qed.
+
+Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z :=
+ match c with
+ | nil => None
+ | instr :: c' =>
+ if is_label lbl instr then Some (pos + 1) else label_pos lbl (pos + 1) c'
+ end.
+
+Variable ge: genv.
+
+Definition symbol_offset (id: ident) (ofs: int) : val :=
+ match Genv.find_symbol ge id with
+ | Some b => Vptr b ofs
+ | None => Vundef
+ end.
+
+(** Evaluating an addressing mode *)
+
+Definition eval_addrmode (a: addrmode) (rs: regset) : val :=
+ match a with Addrmode base ofs const =>
+ Val.add (match base with
+ | None => Vzero
+ | Some r => rs r
+ end)
+ (Val.add (match ofs with
+ | None => Vzero
+ | Some(r, sc) =>
+ if Int.eq sc Int.one then rs r else Val.mul (rs r) (Vint sc)
+ end)
+ (match const with
+ | inl ofs => Vint ofs
+ | inr(id, ofs) => symbol_offset id ofs
+ end))
+ end.
+
+(** Performing a comparison *)
+
+(** Integer comparison between x and y:
+- ZF = 1 if x = y, 0 if x != y
+- CF = 1 if x <u y, 0 if x >=u y
+- SOF = 1 if x <s y, 0 if x >=s y
+- PF is undefined
+
+SOF is (morally) the XOR of the SF and OF flags of the processor. *)
+
+Definition compare_ints (x y: val) (rs: regset) : regset :=
+ rs #ZF <- (Val.cmp Ceq x y)
+ #CF <- (Val.cmpu Clt x y)
+ #SOF <- (Val.cmp Clt x y)
+ #PF <- Vundef.
+
+(** Floating-point comparison between x and y:
+- ZF = 1 if x=y or unordered, 0 if x<>y
+- CF = 1 if x<y or unordered, 0 if x>=y
+- PF = 1 if unordered, 0 if ordered.
+- SOF is undefined
+*)
+
+Definition compare_floats (vx vy: val) (rs: regset) : regset :=
+ match vx, vy with
+ | Vfloat x, Vfloat y =>
+ rs #ZF <- (Val.of_bool (negb (Float.cmp Cne x y)))
+ #CF <- (Val.of_bool (negb (Float.cmp Cge x y)))
+ #PF <- (Val.of_bool (negb (Float.cmp Ceq x y || Float.cmp Clt x y || Float.cmp Cgt x y)))
+ #SOF <- Vundef
+ | _, _ =>
+ undef_regs (CR ZF :: CR CF :: CR PF :: CR SOF :: nil) rs
+ end.
+
+(** Testing a condition *)
+
+Definition eval_testcond (c: testcond) (rs: regset) : option bool :=
+ match c with
+ | Cond_e =>
+ match rs ZF with
+ | Vint n => Some (Int.eq n Int.one)
+ | _ => None
+ end
+ | Cond_ne =>
+ match rs ZF with
+ | Vint n => Some (Int.eq n Int.zero)
+ | _ => None
+ end
+ | Cond_b =>
+ match rs CF with
+ | Vint n => Some (Int.eq n Int.one)
+ | _ => None
+ end
+ | Cond_be =>
+ match rs CF, rs ZF with
+ | Vint c, Vint z => Some (Int.eq c Int.one || Int.eq z Int.one)
+ | _, _ => None
+ end
+ | Cond_ae =>
+ match rs CF with
+ | Vint n => Some (Int.eq n Int.zero)
+ | _ => None
+ end
+ | Cond_a =>
+ match rs CF, rs ZF with
+ | Vint c, Vint z => Some (Int.eq c Int.zero && Int.eq z Int.zero)
+ | _, _ => None
+ end
+ | Cond_l =>
+ match rs SOF with
+ | Vint n => Some (Int.eq n Int.one)
+ | _ => None
+ end
+ | Cond_le =>
+ match rs SOF, rs ZF with
+ | Vint s, Vint z => Some (Int.eq s Int.one || Int.eq z Int.one)
+ | _, _ => None
+ end
+ | Cond_ge =>
+ match rs SOF with
+ | Vint n => Some (Int.eq n Int.zero)
+ | _ => None
+ end
+ | Cond_g =>
+ match rs SOF, rs ZF with
+ | Vint s, Vint z => Some (Int.eq s Int.zero && Int.eq z Int.zero)
+ | _, _ => None
+ end
+ | Cond_p =>
+ match rs PF with
+ | Vint n => Some (Int.eq n Int.one)
+ | _ => None
+ end
+ | Cond_np =>
+ match rs PF with
+ | Vint n => Some (Int.eq n Int.zero)
+ | _ => None
+ end
+ | Cond_nep =>
+ match rs PF, rs ZF with
+ | Vint p, Vint z => Some (Int.eq p Int.one || Int.eq z Int.zero)
+ | _, _ => None
+ end
+ | Cond_enp =>
+ match rs PF, rs ZF with
+ | Vint p, Vint z => Some (Int.eq p Int.zero && Int.eq z Int.one)
+ | _, _ => None
+ end
+ end.
+
+(** The semantics is purely small-step and defined as a function
+ from the current state (a register set + a memory state)
+ 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 [Stuck] if the processor is stuck. *)
+
+Inductive outcome: Type :=
+ | Next: regset -> mem -> outcome
+ | Stuck: outcome.
+
+(** Manipulations over the [PC] register: continuing with the next
+ instruction ([nextinstr]) or branching to a label ([goto_label]). *)
+
+Definition nextinstr (rs: regset) :=
+ rs#PC <- (Val.add rs#PC Vone).
+
+Definition nextinstr_nf (rs: regset) : regset :=
+ nextinstr (undef_regs (CR ZF :: CR CF :: CR PF :: CR SOF :: nil) rs).
+
+Definition goto_label (c: code) (lbl: label) (rs: regset) (m: mem) :=
+ match label_pos lbl 0 c with
+ | None => Stuck
+ | Some pos =>
+ match rs#PC with
+ | Vptr b ofs => Next (rs#PC <- (Vptr b (Int.repr pos))) m
+ | _ => Stuck
+ end
+ end.
+
+(** Auxiliaries for memory accesses. *)
+
+Definition exec_load (chunk: memory_chunk) (m: mem)
+ (a: addrmode) (rs: regset) (rd: preg) :=
+ match Mem.loadv chunk m (eval_addrmode a rs) with
+ | Some v => Next (nextinstr_nf (rs#rd <- v)) m
+ | None => Stuck
+ end.
+
+Definition exec_store (chunk: memory_chunk) (m: mem)
+ (a: addrmode) (rs: regset) (r1: preg) :=
+ match Mem.storev chunk m (eval_addrmode a rs) (rs r1) with
+ | Some m' => Next (nextinstr_nf rs) m'
+ | None => Stuck
+ end.
+
+(** Execution of a single instruction [i] in initial state
+ [rs] and [m]. Return updated state. For instructions
+ that correspond to actual PowerPC instructions, the cases are
+ straightforward transliterations of the informal descriptions
+ given in the PowerPC reference manuals. For pseudo-instructions,
+ refer to the informal descriptions given above. Note that
+ we set to [Vundef] the registers used as temporaries by the
+ expansions of the pseudo-instructions, so that the PPC code
+ we generate cannot use those registers to hold values that
+ must survive the execution of the pseudo-instruction.
+*)
+
+Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome :=
+ match i with
+ (** Moves *)
+ | Pmov_rr rd r1 =>
+ Next (nextinstr (rs#rd <- (rs r1))) m
+ | Pmov_ri rd n =>
+ Next (nextinstr (rs#rd <- (Vint n))) m
+ | Pmov_rm rd a =>
+ exec_load Mint32 m a rs rd
+ | Pmov_mr a r1 =>
+ exec_store Mint32 m a rs r1
+ | Pmovd_fr rd r1 =>
+ Next (nextinstr (rs#rd <- (rs r1))) m
+ | Pmovd_rf rd r1 =>
+ Next (nextinstr (rs#rd <- (rs r1))) m
+ | Pmovsd_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (rs r1))) m
+ | Pmovsd_fi rd n =>
+ Next (nextinstr (rs#rd <- (Vfloat n))) m
+ | Pmovsd_fm rd a =>
+ exec_load Mfloat64 m a rs rd
+ | Pmovsd_mf a r1 =>
+ exec_store Mfloat64 m a rs r1
+ | Pfld_f r1 =>
+ Next (nextinstr (rs#ST0 <- (rs r1))) m
+ | Pfld_m a =>
+ exec_load Mfloat64 m a rs ST0
+ | Pfstp_f rd =>
+ Next (nextinstr (rs#rd <- (rs ST0))) m
+ | Pfstp_m a =>
+ exec_store Mfloat64 m a rs ST0
+ (** Moves with conversion *)
+ | Pmovb_mr a r1 =>
+ exec_store Mint8unsigned m a rs r1
+ | Pmovw_mr a r1 =>
+ exec_store Mint16unsigned m a rs r1
+ | Pmovzb_rr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.zero_ext 8 rs#r1))) m
+ | Pmovzb_rm rd a =>
+ exec_load Mint8unsigned m a rs rd
+ | Pmovsb_rr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.sign_ext 8 rs#r1))) m
+ | Pmovsb_rm rd a =>
+ exec_load Mint8signed m a rs rd
+ | Pmovzw_rr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.zero_ext 16 rs#r1))) m
+ | Pmovzw_rm rd a =>
+ exec_load Mint16unsigned m a rs rd
+ | Pmovsw_rr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m
+ | Pmovsw_rm rd a =>
+ exec_load Mint16signed m a rs rd
+ | Pcvtss2sd_fm rd a =>
+ exec_load Mfloat32 m a rs rd
+ | Pcvtsd2ss_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m
+ | Pcvtsd2ss_mf a r1 =>
+ exec_store Mfloat32 m a rs r1
+ | Pcvttsd2si_rf rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.intoffloat rs#r1))) m
+ | Pcvtsi2sd_fr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.floatofint rs#r1))) m
+ (** Integer arithmetic *)
+ | Plea rd a =>
+ Next (nextinstr (rs#rd <- (eval_addrmode a rs))) m
+ | Pneg rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.neg rs#rd))) m
+ | Psub_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.sub rs#rd rs#r1))) m
+ | Pimul_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.mul rs#rd rs#r1))) m
+ | Pimul_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.mul rs#rd (Vint n)))) m
+ | Pdiv r1 =>
+ Next (nextinstr_nf (rs#EAX <- (Val.divu rs#EAX (rs#EDX <- Vundef)#r1)
+ #EDX <- (Val.modu rs#EAX (rs#EDX <- Vundef)#r1))) m
+ | Pidiv r1 =>
+ Next (nextinstr_nf (rs#EAX <- (Val.divs rs#EAX (rs#EDX <- Vundef)#r1)
+ #EDX <- (Val.mods rs#EAX (rs#EDX <- Vundef)#r1))) m
+ | Pand_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.and rs#rd rs#r1))) m
+ | Pand_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.and rs#rd (Vint n)))) m
+ | Por_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.or rs#rd rs#r1))) m
+ | Por_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.or rs#rd (Vint n)))) m
+ | Pxor_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.xor rs#rd rs#r1))) m
+ | Pxor_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.xor rs#rd (Vint n)))) m
+ | Psal_rcl rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.shl rs#rd rs#ECX))) m
+ | Psal_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.shl rs#rd (Vint n)))) m
+ | Pshr_rcl rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.shru rs#rd rs#ECX))) m
+ | Pshr_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.shru rs#rd (Vint n)))) m
+ | Psar_rcl rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.shr rs#rd rs#ECX))) m
+ | Psar_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.shr rs#rd (Vint n)))) m
+ | Pror_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.ror rs#rd (Vint n)))) m
+ | Pcmp_rr r1 r2 =>
+ Next (nextinstr (compare_ints (rs r1) (rs r2) rs)) m
+ | Pcmp_ri r1 n =>
+ Next (nextinstr (compare_ints (rs r1) (Vint n) rs)) m
+ | Ptest_rr r1 r2 =>
+ Next (nextinstr (compare_ints (Val.and (rs r1) (rs r2)) Vzero rs)) m
+ | Ptest_ri r1 n =>
+ Next (nextinstr (compare_ints (Val.and (rs r1) (Vint n)) Vzero rs)) m
+ | Pcmov c rd r1 =>
+ match eval_testcond c rs with
+ | Some true => Next (nextinstr (rs#rd <- (rs#r1))) m
+ | Some false => Next (nextinstr rs) m
+ | None => Stuck
+ end
+ | Psetcc c rd =>
+ match eval_testcond c rs with
+ | Some true => Next (nextinstr (rs#ECX <- Vundef #EDX <- Vundef #rd <- Vtrue)) m
+ | Some false => Next (nextinstr (rs#ECX <- Vundef #EDX <- Vundef #rd <- Vfalse)) m
+ | None => Stuck
+ end
+ (** Arithmetic operations over floats *)
+ | Paddd_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.addf rs#rd rs#r1))) m
+ | Psubd_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.subf rs#rd rs#r1))) m
+ | Pmuld_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.mulf rs#rd rs#r1))) m
+ | Pdivd_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.divf rs#rd rs#r1))) m
+ | Pnegd rd =>
+ Next (nextinstr (rs#rd <- (Val.negf rs#rd))) m
+ | Pabsd rd =>
+ Next (nextinstr (rs#rd <- (Val.absf rs#rd))) m
+ | Pcomisd_ff r1 r2 =>
+ Next (nextinstr (compare_floats (rs r1) (rs r2) rs)) m
+ (** Branches and calls *)
+ | Pjmp_l lbl =>
+ goto_label c lbl rs m
+ | Pjmp_s id =>
+ Next (rs#PC <- (symbol_offset id Int.zero)) m
+ | Pjmp_r r =>
+ Next (rs#PC <- (rs r)) m
+ | Pjcc cond lbl =>
+ match eval_testcond cond rs with
+ | Some true => goto_label c lbl rs m
+ | Some false => Next (nextinstr rs) m
+ | None => Stuck
+ end
+ | Pjmptbl r tbl =>
+ match rs#r with
+ | Vint n =>
+ match list_nth_z tbl (Int.signed n) with
+ | None => Stuck
+ | Some lbl => goto_label c lbl (rs #ECX <- Vundef #EDX <- Vundef) m
+ end
+ | _ => Stuck
+ end
+ | Pcall_s id =>
+ Next (rs#RA <- (Val.add rs#PC Vone) #PC <- (symbol_offset id Int.zero)) m
+ | Pcall_r r =>
+ Next (rs#RA <- (Val.add rs#PC Vone) #PC <- (rs r)) m
+ | Pret =>
+ Next (rs#PC <- (rs#RA)) m
+ (** Pseudo-instructions *)
+ | Plabel lbl =>
+ Next (nextinstr rs) m
+ | Pallocframe lo hi ofs_ra ofs_link =>
+ let (m1, stk) := Mem.alloc m lo hi in
+ let sp := Vptr stk (Int.repr lo) in
+ match Mem.storev Mint32 m1 (Val.add sp (Vint ofs_link)) rs#ESP with
+ | None => Stuck
+ | Some m2 =>
+ match Mem.storev Mint32 m2 (Val.add sp (Vint ofs_ra)) rs#RA with
+ | None => Stuck
+ | Some m3 => Next (nextinstr (rs#ESP <- sp)) m3
+ end
+ end
+ | Pfreeframe lo hi ofs_ra ofs_link =>
+ match Mem.loadv Mint32 m (Val.add rs#ESP (Vint ofs_ra)) with
+ | None => Stuck
+ | Some ra =>
+ match Mem.loadv Mint32 m (Val.add rs#ESP (Vint ofs_link)) with
+ | None => Stuck
+ | Some sp =>
+ match rs#ESP with
+ | Vptr stk ofs =>
+ match Mem.free m stk lo hi with
+ | None => Stuck
+ | Some m' => Next (nextinstr (rs#ESP <- sp #RA <- ra)) m'
+ end
+ | _ => Stuck
+ end
+ end
+ end
+ | Pbuiltin ef args res =>
+ Stuck (**r treated specially below *)
+ end.
+
+(** Translation of the LTL/Linear/Mach view of machine registers
+ to the Asm view. *)
+
+Definition preg_of (r: mreg) : preg :=
+ match r with
+ | AX => IR EAX
+ | BX => IR EBX
+ | SI => IR ESI
+ | DI => IR EDI
+ | BP => IR EBP
+ | X0 => FR XMM0
+ | X1 => FR XMM1
+ | X2 => FR XMM2
+ | X3 => FR XMM3
+ | X4 => FR XMM4
+ | X5 => FR XMM5
+ | IT1 => IR EDX
+ | IT2 => IR ECX
+ | FT1 => FR XMM6
+ | FT2 => FR XMM7
+ | FP0 => ST0
+ end.
+
+(** Extract the values of the arguments of an external call.
+ We exploit the calling conventions from module [Conventions], except that
+ we use machine registers instead of locations. *)
+
+Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop :=
+ | extcall_arg_reg: forall r,
+ extcall_arg rs m (R r) (rs (preg_of r))
+ | extcall_arg_int_stack: forall ofs bofs v,
+ bofs = Stacklayout.fe_ofs_arg + 4 * ofs ->
+ Mem.loadv Mint32 m (Val.add (rs (IR ESP)) (Vint (Int.repr bofs))) = Some v ->
+ extcall_arg rs m (S (Outgoing ofs Tint)) v
+ | extcall_arg_float_stack: forall ofs bofs v,
+ bofs = Stacklayout.fe_ofs_arg + 4 * ofs ->
+ Mem.loadv Mfloat64 m (Val.add (rs (IR ESP)) (Vint (Int.repr bofs))) = Some v ->
+ extcall_arg rs m (S (Outgoing ofs Tfloat)) v.
+
+Inductive extcall_args (rs: regset) (m: mem): list loc -> list val -> Prop :=
+ | extcall_args_nil:
+ extcall_args rs m nil nil
+ | extcall_args_cons: forall l1 ll v1 vl,
+ extcall_arg rs m l1 v1 -> extcall_args rs m ll vl ->
+ extcall_args rs m (l1 :: ll) (v1 :: vl).
+
+Definition extcall_arguments
+ (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop :=
+ extcall_args rs m (loc_arguments sg) args.
+
+Definition loc_external_result (sg: signature) : preg :=
+ preg_of (loc_result sg).
+
+(** Execution of the instruction at [rs#PC]. *)
+
+Inductive state: Type :=
+ | State: regset -> mem -> state.
+
+Inductive step: state -> trace -> state -> Prop :=
+ | exec_step_internal:
+ forall b ofs c i rs m rs' m',
+ rs PC = Vptr b ofs ->
+ Genv.find_funct_ptr ge b = Some (Internal c) ->
+ find_instr (Int.unsigned ofs) c = Some i ->
+ 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',
+ rs PC = Vptr b ofs ->
+ Genv.find_funct_ptr ge b = Some (Internal c) ->
+ find_instr (Int.unsigned ofs) c = Some (Pbuiltin ef args res) ->
+ external_call ef ge (map rs args) m t v m' ->
+ step (State rs m) t
+ (State (nextinstr_nf(rs #EDX <- Vundef #ECX <- Vundef
+ #XMM6 <- Vundef #XMM7 <- Vundef
+ #ST0 <- Vundef
+ #res <- v)) m')
+ | exec_step_external:
+ forall b ef args res rs m t rs' m',
+ rs PC = Vptr b Int.zero ->
+ Genv.find_funct_ptr ge b = Some (External ef) ->
+ external_call ef ge args m t res m' ->
+ extcall_arguments rs m ef.(ef_sig) args ->
+ rs' = (rs#(loc_external_result ef.(ef_sig)) <- res
+ #PC <- (rs RA)) ->
+ step (State rs m) t (State rs' m').
+
+End RELSEM.
+
+(** Execution of whole programs. *)
+
+Inductive initial_state (p: program): state -> Prop :=
+ | initial_state_intro: forall m0,
+ Genv.init_mem p = Some m0 ->
+ let ge := Genv.globalenv p in
+ let rs0 :=
+ (Pregmap.init Vundef)
+ # PC <- (symbol_offset ge p.(prog_main) Int.zero)
+ # RA <- Vzero
+ # ESP <- (Vptr Mem.nullptr Int.zero) in
+ initial_state p (State rs0 m0).
+
+Inductive final_state: state -> int -> Prop :=
+ | final_state_intro: forall rs m r,
+ rs#PC = Vzero ->
+ rs#EAX = Vint r ->
+ final_state (State rs m) r.
+
+Definition exec_program (p: program) (beh: program_behavior) : Prop :=
+ program_behaves step (initial_state p) final_state (Genv.globalenv p) beh.
+
diff --git a/ia32/Asmgen.v b/ia32/Asmgen.v
new file mode 100644
index 0000000..70929ff
--- /dev/null
+++ b/ia32/Asmgen.v
@@ -0,0 +1,505 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Translation from Mach to IA32 Asm. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import Errors.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Op.
+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:
+- Argument and result registers are of the correct type.
+- For two-address instructions, the result and the first argument
+ are in the same register. (True by construction in [RTLgen], and preserved by [Reload].)
+- The first argument register is never [ECX] (a.k.a. [IT2]) nor [XMM7]
+ (a.k.a [FT2]).
+- The top of the floating-point stack ([ST0], a.k.a. [FP0]) can only
+ appear in [mov] instructions, but never in arithmetic instructions.
+
+All these properties are true by construction, but it is painful to track them statically. Instead, we 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.
+
+(** Smart constructors for various operations. *)
+
+Definition mk_mov (rd rs: preg) (k: code) : res code :=
+ match rd, rs with
+ | IR rd, IR rs => OK (Pmov_rr rd rs :: k)
+ | FR rd, FR rs => OK (Pmovsd_ff rd rs :: k)
+ | ST0, FR rs => OK (Pfld_f rs :: k)
+ | FR rd, ST0 => OK (Pfstp_f rd :: k)
+ | _, _ => Error(msg "Asmgen.mk_mov")
+ end.
+
+Definition mk_shift (shift_instr: ireg -> instruction)
+ (r1 r2: ireg) (k: code) : res code :=
+ if ireg_eq r2 ECX then
+ OK (shift_instr r1 :: k)
+ else
+ do x <- assertion (negb (ireg_eq r1 ECX));
+ OK (Pmov_rr ECX r2 :: shift_instr r1 :: k).
+
+Definition mk_div (div_instr: ireg -> instruction)
+ (r1 r2: ireg) (k: code) : res code :=
+ if ireg_eq r1 EAX then
+ if ireg_eq r2 EDX then
+ OK (Pmov_rr ECX EDX :: div_instr ECX :: k)
+ else
+ OK (div_instr r2 :: k)
+ else
+ do x <- assertion (negb (ireg_eq r1 ECX));
+ if ireg_eq r2 EAX then
+ OK (Pmov_rr ECX EAX :: Pmov_rr EAX r1 ::
+ div_instr ECX ::
+ Pmov_rr r1 EAX :: Pmov_rr EAX ECX :: k)
+ else
+ OK (Pmovd_fr XMM7 EAX :: Pmov_rr ECX r2 :: Pmov_rr EAX r1 ::
+ div_instr ECX ::
+ Pmov_rr r2 ECX :: Pmov_rr r1 EAX :: Pmovd_rf EAX XMM7 :: k).
+
+Definition mk_mod (div_instr: ireg -> instruction)
+ (r1 r2: ireg) (k: code) : res code :=
+ if ireg_eq r1 EAX then
+ if ireg_eq r2 EDX then
+ OK (Pmov_rr ECX EDX :: div_instr ECX :: Pmov_rr EAX EDX :: k)
+ else
+ OK (div_instr r2 :: Pmov_rr EAX EDX :: k)
+ else
+ do x <- assertion (negb (ireg_eq r1 ECX));
+ if ireg_eq r2 EDX then
+ OK (Pmovd_fr XMM7 EAX :: Pmov_rr ECX EDX :: Pmov_rr EAX r1 ::
+ div_instr ECX ::
+ Pmov_rr r1 EDX :: Pmovd_rf EAX XMM7 :: k)
+ else
+ OK (Pmovd_fr XMM7 EAX :: Pmov_rr ECX r2 :: Pmov_rr EAX r1 ::
+ div_instr ECX ::
+ Pmov_rr r2 ECX :: Pmov_rr r1 EDX :: Pmovd_rf EAX XMM7 :: k).
+
+Definition mk_shrximm (r: ireg) (n: int) (k: code) : res code :=
+ do x <- assertion (negb (ireg_eq r ECX));
+ let p := Int.sub (Int.shl Int.one n) Int.one in
+ OK (Ptest_rr r r ::
+ Plea ECX (Addrmode (Some r) None (inl _ p)) ::
+ Pcmov Cond_l r ECX ::
+ Psar_ri r n :: k).
+
+Definition low_ireg (r: ireg) : bool :=
+ match r with
+ | EAX | EBX | ECX | EDX => true
+ | ESI | EDI | EBP | ESP => false
+ end.
+
+Definition mk_intconv (mk: ireg -> ireg -> instruction) (rd rs: ireg) (k: code) :=
+ if low_ireg rs then
+ OK (mk rd rs :: k)
+ else
+ OK (Pmov_rr EDX rs :: mk rd EDX :: k).
+
+Definition mk_smallstore (sto: addrmode -> ireg ->instruction)
+ (addr: addrmode) (rs: ireg) (k: code) :=
+ if low_ireg rs then
+ OK (sto addr rs :: k)
+ else
+ OK (Plea ECX addr :: Pmov_rr EDX rs ::
+ sto (Addrmode (Some ECX) None (inl _ Int.zero)) EDX :: k).
+
+(** Accessing slots in the stack frame. *)
+
+Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) :=
+ match ty with
+ | Tint =>
+ do r <- ireg_of dst;
+ OK (Pmov_rm r (Addrmode (Some base) None (inl _ ofs)) :: k)
+ | Tfloat =>
+ match preg_of dst with
+ | FR r => OK (Pmovsd_fm r (Addrmode (Some base) None (inl _ ofs)) :: k)
+ | ST0 => OK (Pfld_m (Addrmode (Some base) None (inl _ ofs)) :: k)
+ | _ => Error (msg "Asmgen.loadind")
+ end
+ end.
+
+Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) :=
+ match ty with
+ | Tint =>
+ do r <- ireg_of src;
+ OK (Pmov_mr (Addrmode (Some base) None (inl _ ofs)) r :: k)
+ | Tfloat =>
+ match preg_of src with
+ | FR r => OK (Pmovsd_mf (Addrmode (Some base) None (inl _ ofs)) r :: k)
+ | ST0 => OK (Pfstp_m (Addrmode (Some base) None (inl _ ofs)) :: k)
+ | _ => Error (msg "Asmgen.loadind")
+ end
+ end.
+
+(** Translation of addressing modes *)
+
+Definition transl_addressing (a: addressing) (args: list mreg): res addrmode :=
+ match a, args with
+ | Aindexed n, a1 :: nil =>
+ do r1 <- ireg_of a1; OK(Addrmode (Some r1) None (inl _ n))
+ | Aindexed2 n, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK(Addrmode (Some r1) (Some(r2, Int.one)) (inl _ n))
+ | Ascaled sc n, a1 :: nil =>
+ do r1 <- ireg_of a1; OK(Addrmode None (Some(r1, sc)) (inl _ n))
+ | Aindexed2scaled sc n, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK(Addrmode (Some r1) (Some(r2, sc)) (inl _ n))
+ | Aglobal id ofs, nil =>
+ OK(Addrmode None None (inr _ (id, ofs)))
+ | Abased id ofs, a1 :: nil =>
+ do r1 <- ireg_of a1; OK(Addrmode (Some r1) None (inr _ (id, ofs)))
+ | Abasedscaled sc id ofs, a1 :: nil =>
+ do r1 <- ireg_of a1; OK(Addrmode None (Some(r1, sc)) (inr _ (id, ofs)))
+ | Ainstack n, nil =>
+ OK(Addrmode (Some ESP) None (inl _ n))
+ | _, _ =>
+ Error(msg "Asmgen.transl_addressing")
+ end.
+
+(** Floating-point comparison. We swap the operands in some cases
+ to simplify the handling of the unordered case. *)
+
+Definition floatcomp (cmp: comparison) (r1 r2: freg) : instruction :=
+ match cmp with
+ | Clt | Cle => Pcomisd_ff r2 r1
+ | Ceq | Cne | Cgt | Cge => Pcomisd_ff r1 r2
+ end.
+
+(** Translation of a condition. Prepends to [k] the instructions
+ that evaluate the condition and leave its boolean result in bits
+ of the condition register. *)
+
+Definition transl_cond
+ (cond: condition) (args: list mreg) (k: code) : res code :=
+ match cond, args with
+ | Ccomp c, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmp_rr r1 r2 :: k)
+ | Ccompu c, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmp_rr r1 r2 :: k)
+ | Ccompimm c n, a1 :: nil =>
+ do r1 <- ireg_of a1; OK (Pcmp_ri r1 n :: k)
+ | Ccompuimm c n, a1 :: nil =>
+ do r1 <- ireg_of a1;
+ OK (if Int.eq_dec n Int.zero then Ptest_rr r1 r1 :: k else Pcmp_ri r1 n :: k)
+ | Ccompf cmp, a1 :: a2 :: nil =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp cmp r1 r2 :: k)
+ | Cnotcompf cmp, a1 :: a2 :: nil =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp cmp r1 r2 :: k)
+ | Cmaskzero n, a1 :: nil =>
+ do r1 <- ireg_of a1; OK (Ptest_ri r1 n :: k)
+ | Cmasknotzero n, a1 :: nil =>
+ do r1 <- ireg_of a1; OK (Ptest_ri r1 n :: k)
+ | _, _ =>
+ Error(msg "Asmgen.transl_cond")
+ end.
+
+(** What processor condition to test for a given Mach condition. *)
+
+Definition testcond_for_signed_comparison (cmp: comparison) :=
+ match cmp with
+ | Ceq => Cond_e
+ | Cne => Cond_ne
+ | Clt => Cond_l
+ | Cle => Cond_le
+ | Cgt => Cond_g
+ | Cge => Cond_ge
+ end.
+
+Definition testcond_for_unsigned_comparison (cmp: comparison) :=
+ match cmp with
+ | Ceq => Cond_e
+ | Cne => Cond_ne
+ | Clt => Cond_b
+ | Cle => Cond_be
+ | Cgt => Cond_a
+ | Cge => Cond_ae
+ end.
+
+Definition testcond_for_condition (cond: condition) : testcond :=
+ match cond with
+ | Ccomp c => testcond_for_signed_comparison c
+ | Ccompu c => testcond_for_unsigned_comparison c
+ | Ccompimm c n => testcond_for_signed_comparison c
+ | Ccompuimm c n => testcond_for_unsigned_comparison c
+ | Ccompf c =>
+ match c with
+ | Ceq => Cond_enp
+ | Cne => Cond_nep
+ | Clt => Cond_a
+ | Cle => Cond_ae
+ | Cgt => Cond_a
+ | Cge => Cond_ae
+ end
+ | Cnotcompf c =>
+ match c with
+ | Ceq => Cond_nep
+ | Cne => Cond_enp
+ | Clt => Cond_be
+ | Cle => Cond_b
+ | Cgt => Cond_be
+ | Cge => Cond_b
+ end
+ | Cmaskzero n => Cond_e
+ | Cmasknotzero n => Cond_ne
+ end.
+
+(** Translation of the arithmetic operation [r <- op(args)].
+ The corresponding instructions are prepended to [k]. *)
+
+Definition transl_op
+ (op: operation) (args: list mreg) (res: mreg) (k: code) : Errors.res code :=
+ match op, args with
+ | Omove, a1 :: nil =>
+ mk_mov (preg_of res) (preg_of a1) k
+ | Ointconst n, nil =>
+ do r <- ireg_of res; OK (Pmov_ri r n :: k)
+ | Ofloatconst f, nil =>
+ do r <- freg_of res; OK (Pmovsd_fi r f :: k)
+ | Ocast8signed, a1 :: nil =>
+ do r1 <- ireg_of a1; do r <- ireg_of res; mk_intconv Pmovsb_rr r r1 k
+ | Ocast8unsigned, a1 :: nil =>
+ do r1 <- ireg_of a1; do r <- ireg_of res; mk_intconv Pmovzb_rr r r1 k
+ | Ocast16signed, a1 :: nil =>
+ do r1 <- ireg_of a1; do r <- ireg_of res; mk_intconv Pmovsw_rr r r1 k
+ | Ocast16unsigned, a1 :: nil =>
+ do r1 <- ireg_of a1; do r <- ireg_of res; mk_intconv Pmovzw_rr r r1 k
+ | Oneg, a1 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pneg r :: k)
+ | Osub, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Psub_rr r r2 :: k)
+ | Omul, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pimul_rr r r2 :: k)
+ | Omulimm n, a1 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pimul_ri r n :: k)
+ | Odiv, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; mk_div Pidiv r r2 k
+ | Odivu, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; mk_div Pdiv r r2 k
+ | Omod, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; mk_mod Pidiv r r2 k
+ | Omodu, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; mk_mod Pdiv r r2 k
+ | Oand, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pand_rr r r2 :: k)
+ | Oandimm n, a1 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pand_ri r n :: k)
+ | Oor, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Por_rr r r2 :: k)
+ | Oorimm n, a1 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Por_ri r n :: k)
+ | Oxor, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pxor_rr r r2 :: k)
+ | Oxorimm n, a1 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pxor_ri r n :: k)
+ | Oshl, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; mk_shift Psal_rcl r r2 k
+ | Oshlimm n, a1 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Psal_ri r n :: k)
+ | Oshr, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; mk_shift Psar_rcl r r2 k
+ | Oshrimm n, a1 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Psar_ri r n :: k)
+ | Oshru, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; mk_shift Pshr_rcl r r2 k
+ | Oshruimm n, a1 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pshr_ri r n :: k)
+ | Oshrximm n, a1 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; mk_shrximm r n k
+ | Ororimm n, a1 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pror_ri r n :: k)
+ | Olea addr, _ =>
+ do am <- transl_addressing addr args; do r <- ireg_of res;
+ OK (Plea r am :: k)
+ | Onegf, a1 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- freg_of res; OK (Pnegd r :: k)
+ | Oabsf, a1 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- freg_of res; OK (Pabsd r :: k)
+ | Oaddf, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- freg_of res; do r2 <- freg_of a2; OK (Paddd_ff r r2 :: k)
+ | Osubf, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- freg_of res; do r2 <- freg_of a2; OK (Psubd_ff r r2 :: k)
+ | Omulf, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- freg_of res; do r2 <- freg_of a2; OK (Pmuld_ff r r2 :: k)
+ | Odivf, a1 :: a2 :: nil =>
+ do x <- assertion (mreg_eq a1 res);
+ do r <- freg_of res; do r2 <- freg_of a2; OK (Pdivd_ff r r2 :: k)
+ | Osingleoffloat, a1 :: nil =>
+ do r <- freg_of res; do r1 <- freg_of a1; OK (Pcvtsd2ss_ff r r1 :: k)
+ | Ointoffloat, a1 :: nil =>
+ do r <- ireg_of res; do r1 <- freg_of a1; OK (Pcvttsd2si_rf r r1 :: k)
+ | Ofloatofint, a1 :: nil =>
+ do r <- freg_of res; do r1 <- ireg_of a1; OK (Pcvtsi2sd_fr r r1 :: k)
+ | Ocmp c, args =>
+ do r <- ireg_of res;
+ transl_cond c args (Psetcc (testcond_for_condition c) r :: k)
+ | _, _ =>
+ Error(msg "Asmgen.transl_op")
+ end.
+
+(** Translation of memory loads and stores *)
+
+Definition transl_load (chunk: memory_chunk)
+ (addr: addressing) (args: list mreg) (dest: mreg)
+ (k: code) : res code :=
+ do am <- transl_addressing addr args;
+ match chunk with
+ | Mint8unsigned =>
+ do r <- ireg_of dest; OK(Pmovzb_rm r am :: k)
+ | Mint8signed =>
+ do r <- ireg_of dest; OK(Pmovsb_rm r am :: k)
+ | Mint16unsigned =>
+ do r <- ireg_of dest; OK(Pmovzw_rm r am :: k)
+ | Mint16signed =>
+ do r <- ireg_of dest; OK(Pmovsw_rm r am :: k)
+ | Mint32 =>
+ do r <- ireg_of dest; OK(Pmov_rm r am :: k)
+ | Mfloat32 =>
+ do r <- freg_of dest; OK(Pcvtss2sd_fm r am :: k)
+ | Mfloat64 =>
+ do r <- freg_of dest; OK(Pmovsd_fm r am :: k)
+ end.
+
+Definition transl_store (chunk: memory_chunk)
+ (addr: addressing) (args: list mreg) (src: mreg)
+ (k: code) : res code :=
+ do am <- transl_addressing addr args;
+ match chunk with
+ | Mint8unsigned | Mint8signed =>
+ do r <- ireg_of src; mk_smallstore Pmovb_mr am r k
+ | Mint16unsigned | Mint16signed =>
+ do r <- ireg_of src; mk_smallstore Pmovw_mr am r k
+ | Mint32 =>
+ do r <- ireg_of src; OK(Pmov_mr am r :: k)
+ | Mfloat32 =>
+ do r <- freg_of src; OK(Pcvtsd2ss_mf am r :: k)
+ | Mfloat64 =>
+ do r <- freg_of src; OK(Pmovsd_mf am r :: k)
+ end.
+
+(** Translation of a Mach instruction. *)
+
+Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) :=
+ match i with
+ | Mgetstack ofs ty dst =>
+ loadind ESP ofs ty dst k
+ | Msetstack src ofs ty =>
+ storeind src ESP ofs ty k
+ | Mgetparam ofs ty dst =>
+ do k1 <- loadind EDX ofs ty dst k;
+ loadind ESP f.(fn_link_ofs) Tint IT1 k1
+ | Mop op args res =>
+ transl_op op args res k
+ | Mload chunk addr args dst =>
+ transl_load chunk addr args dst k
+ | Mstore chunk addr args src =>
+ transl_store chunk addr args src k
+ | Mcall sig (inl reg) =>
+ do r <- ireg_of reg; OK (Pcall_r r :: k)
+ | Mcall sig (inr symb) =>
+ OK (Pcall_s symb :: k)
+ | Mtailcall sig (inl reg) =>
+ do r <- ireg_of reg;
+ OK (Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize)
+ f.(fn_retaddr_ofs) f.(fn_link_ofs) ::
+ Pjmp_r r :: k)
+ | Mtailcall sig (inr symb) =>
+ OK (Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize)
+ f.(fn_retaddr_ofs) f.(fn_link_ofs) ::
+ Pjmp_s symb :: k)
+ | Mlabel lbl =>
+ OK(Plabel lbl :: k)
+ | Mgoto lbl =>
+ OK(Pjmp_l lbl :: k)
+ | Mcond cond args lbl =>
+ transl_cond cond args (Pjcc (testcond_for_condition cond) lbl :: k)
+ | Mjumptable arg tbl =>
+ do r <- ireg_of arg; OK (Pjmptbl r tbl :: k)
+ | Mreturn =>
+ OK (Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize)
+ f.(fn_retaddr_ofs) f.(fn_link_ofs) ::
+ Pret :: k)
+ | Mbuiltin ef args res =>
+ OK (Pbuiltin ef (List.map preg_of args) (preg_of res) :: k)
+ end.
+
+Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) :=
+ match il with
+ | nil => OK nil
+ | i1 :: il' => do k <- transl_code f il'; transl_instr f i1 k
+ end.
+
+(** Translation of a whole function. Note that we must check
+ that the generated code contains less than [2^32] instructions,
+ otherwise the offset part of the [PC] code pointer could wrap
+ around, leading to incorrect executions. *)
+
+Definition transf_function (f: Mach.function) : res Asm.code :=
+ do c <- transl_code f f.(fn_code);
+ if zlt (list_length_z c) Int.max_unsigned
+ then OK (Pallocframe (- f.(fn_framesize)) f.(fn_stacksize)
+ f.(fn_retaddr_ofs) f.(fn_link_ofs) :: c)
+ else Error (msg "code size exceeded").
+
+Definition transf_fundef (f: Mach.fundef) : res Asm.fundef :=
+ transf_partial_fundef transf_function f.
+
+Definition transf_program (p: Mach.program) : res Asm.program :=
+ transform_partial_program transf_fundef p.
+
diff --git a/ia32/Asmgenproof.v b/ia32/Asmgenproof.v
new file mode 100644
index 0000000..ddf2769
--- /dev/null
+++ b/ia32/Asmgenproof.v
@@ -0,0 +1,1229 @@
+(* *********************************************************************)
+(* *)
+(* 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 PPC generation: main proof. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import Errors.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Events.
+Require Import Globalenvs.
+Require Import Smallstep.
+Require Import Op.
+Require Import Locations.
+Require Import Mach.
+Require Import Machconcr.
+Require Import Machtyping.
+Require Import Conventions.
+Require Import Asm.
+Require Import Asmgen.
+Require Import Asmgenretaddr.
+Require Import Asmgenproof1.
+
+Section PRESERVATION.
+
+Variable prog: Mach.program.
+Variable tprog: Asm.program.
+Hypothesis TRANSF: transf_program prog = Errors.OK tprog.
+
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Lemma symbols_preserved:
+ forall id, Genv.find_symbol tge id = Genv.find_symbol ge id.
+Proof.
+ intros. unfold ge, tge.
+ apply Genv.find_symbol_transf_partial with transf_fundef.
+ exact TRANSF.
+Qed.
+
+Lemma functions_translated:
+ forall b f,
+ Genv.find_funct_ptr ge b = Some f ->
+ exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = Errors.OK tf.
+Proof
+ (Genv.find_funct_ptr_transf_partial transf_fundef _ TRANSF).
+
+Lemma functions_transl:
+ forall fb f tf,
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ transf_function f = OK tf ->
+ Genv.find_funct_ptr tge fb = Some (Internal tf).
+Proof.
+ intros. exploit functions_translated; eauto. intros [tf' [A B]].
+ monadInv B. rewrite H0 in EQ; inv EQ; auto.
+Qed.
+
+Lemma varinfo_preserved:
+ forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
+Proof.
+ intros. unfold ge, tge.
+ apply Genv.find_var_info_transf_partial with transf_fundef.
+ exact TRANSF.
+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.
+Proof.
+ intros. monadInv H. destruct (zlt (list_length_z x) Int.max_unsigned); monadInv EQ0.
+ 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 ->
+ Asm.code -> Asm.code -> Prop :=
+ transl_code_at_pc_intro:
+ forall b ofs f c tf tc,
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
+ transf_function f = OK tf ->
+ transl_code f c = OK tc ->
+ code_tail (Int.unsigned ofs) tf tc ->
+ transl_code_at_pc (Vptr b ofs) b f c 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 tf tc c' rs m rs' m',
+ transl_code_at_pc (rs PC) fb f c tf tc ->
+ exec_straight tge tf tc rs m c' rs' m' ->
+ plus step tge (State rs m) E0 (State rs' m').
+Proof.
+ intros. inv H.
+ eapply exec_straight_steps_1; eauto.
+ eapply transf_function_no_overflow; eauto.
+ eapply functions_transl; eauto.
+Qed.
+
+Lemma exec_straight_at:
+ forall fb f c tf tc c' tc' rs m rs' m',
+ transl_code_at_pc (rs PC) fb f c tf tc ->
+ transl_code f c' = OK tc' ->
+ exec_straight tge tf tc rs m tc' rs' m' ->
+ transl_code_at_pc (rs' PC) fb f c' tf tc'.
+Proof.
+ 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
+ [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 tf tc ->
+ return_address_offset f c ofs' ->
+ ofs' = ofs.
+Proof.
+ intros. inv H0. inv H.
+ exploit code_tail_unique. eexact H11. eapply H1; eauto. intro.
+ 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. *)
+
+Fixpoint find_label (lbl: label) (c: code) {struct c} : option code :=
+ match c with
+ | nil => None
+ | instr :: c' =>
+ if is_label lbl instr then Some c' else find_label lbl c'
+ end.
+
+Lemma label_pos_code_tail:
+ forall lbl c pos c',
+ find_label lbl c = Some c' ->
+ exists pos',
+ label_pos lbl pos c = Some pos'
+ /\ code_tail (pos' - pos) c c'
+ /\ pos < pos' <= pos + list_length_z c.
+Proof.
+ induction c.
+ simpl; intros. discriminate.
+ simpl; intros until c'.
+ case (is_label lbl a).
+ intro EQ; injection EQ; intro; subst c'.
+ exists (pos + 1). split. auto. split.
+ replace (pos + 1 - pos) with (0 + 1) by omega. constructor. constructor.
+ 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.
+ rewrite list_length_z_cons. omega.
+Qed.
+
+(** The following lemmas show that the translation from Mach to Asm
+ preserves labels, in the sense that the following diagram commutes:
+<<
+ translation
+ Mach code ------------------------ Asm instr sequence
+ | |
+ | Mach.find_label lbl find_label lbl |
+ | |
+ v v
+ Mach code tail ------------------- Asm instr seq tail
+ translation
+>>
+ The proof demands many boring lemmas showing that Asm constructor
+ functions do not introduce new labels.
+*)
+
+Section TRANSL_LABEL.
+
+Variable lbl: label.
+
+Remark mk_mov_label:
+ forall rd rs k c, mk_mov rd rs k = OK c -> find_label lbl c = find_label lbl k.
+Proof.
+ unfold mk_mov; intros.
+ destruct rd; try discriminate; destruct rs; inv H; auto.
+Qed.
+
+Remark mk_shift_label:
+ forall f r1 r2 k c, mk_shift f r1 r2 k = OK c ->
+ (forall r, is_label lbl (f r) = false) ->
+ find_label lbl c = find_label lbl k.
+Proof.
+ unfold mk_shift; intros.
+ destruct (ireg_eq r2 ECX); monadInv H; simpl; rewrite H0; auto.
+Qed.
+
+Remark mk_div_label:
+ forall f r1 r2 k c, mk_div f r1 r2 k = OK c ->
+ (forall r, is_label lbl (f r) = false) ->
+ find_label lbl c = find_label lbl k.
+Proof.
+ unfold mk_div; intros.
+ destruct (ireg_eq r1 EAX).
+ destruct (ireg_eq r2 EDX); monadInv H; simpl; rewrite H0; auto.
+ destruct (ireg_eq r2 EAX); monadInv H; simpl; rewrite H0; auto.
+Qed.
+
+Remark mk_mod_label:
+ forall f r1 r2 k c, mk_mod f r1 r2 k = OK c ->
+ (forall r, is_label lbl (f r) = false) ->
+ find_label lbl c = find_label lbl k.
+Proof.
+ unfold mk_mod; intros.
+ destruct (ireg_eq r1 EAX).
+ destruct (ireg_eq r2 EDX); monadInv H; simpl; rewrite H0; auto.
+ destruct (ireg_eq r2 EDX); monadInv H; simpl; rewrite H0; auto.
+Qed.
+
+Remark mk_shrximm_label:
+ forall r n k c, mk_shrximm r n k = OK c -> find_label lbl c = find_label lbl k.
+Proof.
+ intros. monadInv H; auto.
+Qed.
+
+Remark mk_intconv_label:
+ forall f r1 r2 k c, mk_intconv f r1 r2 k = OK c ->
+ (forall r r', is_label lbl (f r r') = false) ->
+ find_label lbl c = find_label lbl k.
+Proof.
+ unfold mk_intconv; intros. destruct (low_ireg r2); inv H; simpl; rewrite H0; auto.
+Qed.
+
+Remark mk_smallstore_label:
+ forall f addr r k c, mk_smallstore f addr r k = OK c ->
+ (forall r addr, is_label lbl (f r addr) = false) ->
+ find_label lbl c = find_label lbl k.
+Proof.
+ unfold mk_smallstore; intros. destruct (low_ireg r); monadInv H; simpl; rewrite H0; auto.
+Qed.
+
+Remark loadind_label:
+ forall base ofs ty dst k c,
+ loadind base ofs ty dst k = OK c ->
+ find_label lbl c = find_label lbl k.
+Proof.
+ unfold loadind; intros. destruct ty.
+ monadInv H; auto.
+ destruct (preg_of dst); inv H; auto.
+Qed.
+
+Remark storeind_label:
+ forall base ofs ty src k c,
+ storeind src base ofs ty k = OK c ->
+ find_label lbl c = find_label lbl k.
+Proof.
+ unfold storeind; intros. destruct ty.
+ monadInv H; auto.
+ destruct (preg_of src); inv H; auto.
+Qed.
+
+Ltac ArgsInv :=
+ match goal with
+ | [ H: Error _ = OK _ |- _ ] => discriminate
+ | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args; ArgsInv
+ | [ H: bind _ _ = OK _ |- _ ] => monadInv H; ArgsInv
+ | _ => idtac
+ end.
+
+Remark transl_cond_label:
+ forall cond args k c,
+ transl_cond cond args k = OK c ->
+ find_label lbl c = find_label lbl k.
+Proof.
+ unfold transl_cond; intros.
+ destruct cond; ArgsInv; auto.
+ destruct (Int.eq_dec i Int.zero); auto.
+ destruct c0; auto.
+ destruct c0; auto.
+Qed.
+
+
+Remark transl_op_label:
+ forall op args r k c,
+ transl_op op args r k = OK c ->
+ find_label lbl c = find_label lbl k.
+Proof.
+ unfold transl_op; intros. destruct op; ArgsInv; auto.
+ eapply mk_mov_label; eauto.
+ eapply mk_intconv_label; eauto.
+ eapply mk_intconv_label; eauto.
+ eapply mk_intconv_label; eauto.
+ eapply mk_intconv_label; eauto.
+ eapply mk_div_label; eauto.
+ eapply mk_div_label; eauto.
+ eapply mk_mod_label; eauto.
+ eapply mk_mod_label; eauto.
+ eapply mk_shift_label; eauto.
+ eapply mk_shift_label; eauto.
+ eapply mk_shrximm_label; eauto.
+ eapply mk_shift_label; eauto.
+ eapply trans_eq. eapply transl_cond_label; eauto. auto.
+Qed.
+
+Remark transl_load_label:
+ forall chunk addr args dest k c,
+ transl_load chunk addr args dest k = OK c ->
+ find_label lbl c = find_label lbl k.
+Proof.
+ intros. monadInv H. destruct chunk; monadInv EQ0; auto.
+Qed.
+
+Remark transl_store_label:
+ forall chunk addr args src k c,
+ transl_store chunk addr args src k = OK c ->
+ find_label lbl c = find_label lbl k.
+Proof.
+ intros. monadInv H. destruct chunk; monadInv EQ0; auto; eapply mk_smallstore_label; eauto.
+Qed.
+
+Lemma transl_instr_label:
+ forall f i k c,
+ transl_instr f i 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. monadInv H. simpl. rewrite peq_true. auto.
+Opaque loadind.
+ destruct i; simpl in H.
+ eapply loadind_label; eauto.
+ eapply storeind_label; eauto.
+ monadInv H. eapply trans_eq; eapply loadind_label; eauto.
+ eapply transl_op_label; eauto.
+ eapply transl_load_label; eauto.
+ eapply transl_store_label; eauto.
+ destruct s0; monadInv H; auto.
+ destruct s0; monadInv H; auto.
+ monadInv H; auto.
+ inv H; simpl. destruct (peq lbl l). congruence. auto.
+ monadInv H; auto.
+ eapply trans_eq. eapply transl_cond_label; eauto. auto.
+ monadInv H; auto.
+ monadInv H; auto.
+Qed.
+
+Lemma transl_code_label:
+ forall f c tc,
+ transl_code f c = OK tc ->
+ match Mach.find_label lbl c with
+ | None => find_label lbl tc = None
+ | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' = OK tc'
+ end.
+Proof.
+ induction c; simpl; intros.
+ inv H. auto.
+ monadInv H. rewrite (transl_instr_label _ _ _ _ EQ0).
+ destruct (Mach.is_label lbl a). exists x; auto. apply IHc. auto.
+Qed.
+
+Lemma transl_find_label:
+ forall f tf,
+ transf_function f = OK tf ->
+ match Mach.find_label lbl f.(fn_code) with
+ | None => find_label lbl tf = None
+ | Some c => exists tc, find_label lbl tf = Some tc /\ transl_code f c = OK tc
+ end.
+Proof.
+ intros. monadInv H. destruct (zlt (list_length_z x) Int.max_unsigned); inv EQ0.
+ simpl. apply transl_code_label; auto.
+Qed.
+
+End TRANSL_LABEL.
+
+(** 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 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 tc', exists rs',
+ goto_label tf lbl rs m = Next rs' m
+ /\ transl_code_at_pc (rs' PC) b f c' tf tc'
+ /\ forall r, r <> PC -> rs'#r = rs#r.
+Proof.
+ 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 Q.
+ auto. omega.
+ generalize (transf_function_no_overflow _ _ H0). omega.
+ intros. apply Pregmap.gso; auto.
+Qed.
+
+(** * Proof of semantic preservation *)
+
+(** Semantic preservation is proved using simulation diagrams
+ of the following form.
+<<
+ st1 --------------- st2
+ | |
+ t| *|t
+ | |
+ v v
+ st1'--------------- st2'
+>>
+ The invariant is the [match_states] predicate below, which includes:
+- The PPC code pointed by the PC register is the translation of
+ the current Mach code sequence.
+- Mach register values and PPC register values agree.
+*)
+
+Inductive match_stack: list Machconcr.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 tf tc ->
+ sp <> Vundef -> ra <> Vundef ->
+ match_stack s ->
+ match_stack (Stackframe fb sp ra c :: s).
+
+Inductive match_states: Machconcr.state -> Asm.state -> Prop :=
+ | match_states_intro:
+ forall s fb sp c ms m m' rs f tf tc
+ (STACKS: match_stack s)
+ (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
+ (MEXT: Mem.extends m m')
+ (AT: transl_code_at_pc (rs PC) fb f c tf tc)
+ (AG: agree ms sp rs),
+ match_states (Machconcr.State s fb sp c ms m)
+ (Asm.State rs m')
+ | match_states_call:
+ forall s fb ms m m' rs
+ (STACKS: match_stack s)
+ (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 (Machconcr.Callstate s fb ms m)
+ (Asm.State rs m')
+ | match_states_return:
+ forall s ms m m' rs
+ (STACKS: match_stack s)
+ (MEXT: Mem.extends m m')
+ (AG: agree ms (parent_sp s) rs)
+ (ATPC: rs PC = parent_ra s),
+ match_states (Machconcr.Returnstate s ms m)
+ (Asm.State rs m').
+
+Lemma exec_straight_steps:
+ forall s fb f rs1 i c tf tc m1' m2 m2' sp ms2,
+ match_stack s ->
+ Mem.extends m2 m2' ->
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ transl_code_at_pc (rs1 PC) fb f (i :: c) tf tc ->
+ (forall k c, transl_instr f i k = OK c ->
+ exists rs2, exec_straight tge tf c rs1 m1' k rs2 m2' /\ agree ms2 sp rs2) ->
+ exists st',
+ plus step tge (State rs1 m1') E0 st' /\
+ match_states (Machconcr.State s fb sp c ms2 m2) st'.
+Proof.
+ intros. inversion H2. subst. monadInv H7.
+ exploit H3; eauto. intros [rs2 [A B]].
+ exists (State rs2 m2'); split.
+ 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.
+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 [Machconcr.Returnstate] to [Machconcr.State].
+ So, the following integer measure will suffice to rule out
+ the unwanted behaviour. *)
+
+Definition measure (s: Machconcr.state) : nat :=
+ match s with
+ | Machconcr.State _ _ _ _ _ _ => 0%nat
+ | Machconcr.Callstate _ _ _ _ => 0%nat
+ | Machconcr.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: Machconcr.state) (t: trace) (s2: Machconcr.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 (Machconcr.State s fb sp (Mlabel lbl :: c) ms m) E0
+ (Machconcr.State s fb sp c ms m).
+Proof.
+ intros; red; intros; inv MS.
+ left; eapply exec_straight_steps; eauto; intros.
+ monadInv H. econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ apply agree_nextinstr; auto.
+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 (Machconcr.State s fb sp (Mgetstack ofs ty dst :: c) ms m) E0
+ (Machconcr.State s fb sp c (Regmap.set dst v ms) m).
+Proof.
+ intros; red; intros; inv MS.
+ 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.
+ exploit loadind_correct; eauto. intros [rs' [P [Q R]]].
+ exists rs'; split. eauto. eapply agree_set_mreg; eauto. 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 (Machconcr.State s fb sp (Msetstack src ofs ty :: c) ms m) E0
+ (Machconcr.State s fb sp c ms m').
+Proof.
+ intros; red; intros; inv MS.
+ unfold store_stack in H.
+ assert (Val.lessdef (ms src) (rs (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.
+ exploit storeind_correct; eauto. intros [rs' [P Q]].
+ exists rs'; split. eauto. eapply agree_exten; eauto.
+Qed.
+
+Lemma exec_Mgetparam_prop:
+ forall (s : list stackframe) (fb : block) (f: Mach.function) (sp parent : val)
+ (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction)
+ (ms : Mach.regset) (m : mem) (v : val),
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ load_stack m sp Tint f.(fn_link_ofs) = Some parent ->
+ load_stack m parent ty ofs = Some v ->
+ exec_instr_prop (Machconcr.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0
+ (Machconcr.State s fb sp c (Regmap.set dst v (Regmap.set IT1 Vundef ms)) m).
+Proof.
+ 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]]. rewrite (sp_val _ _ _ AG) in A.
+ assert (parent' = parent). inv B. auto. simpl in H1. congruence.
+ subst parent'.
+ exploit Mem.loadv_extends. eauto. eexact H1. auto.
+ intros [v' [C D]].
+Opaque loadind.
+ left; eapply exec_straight_steps; eauto; intros. monadInv H2.
+ exploit loadind_correct. eexact EQ0. eauto. intros [rs1 [P [Q R]]]. simpl in Q.
+ exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto.
+ intros [rs2 [S [T U]]].
+ exists rs2; split. eapply exec_straight_trans; eauto.
+ eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto.
+Qed.
+
+Lemma exec_Mop_prop:
+ forall (s : list stackframe) (fb : block) (sp : val) (op : operation)
+ (args : list mreg) (res : mreg) (c : list Mach.instruction)
+ (ms : mreg -> val) (m : mem) (v : val),
+ eval_operation ge sp op ms ## args = Some v ->
+ exec_instr_prop (Machconcr.State s fb sp (Mop op args res :: c) ms m) E0
+ (Machconcr.State s fb sp c (Regmap.set res v (undef_op op ms)) m).
+Proof.
+ intros; red; intros; inv MS.
+ assert (eval_operation tge sp op ms##args = Some v).
+ rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
+ exploit eval_operation_lessdef. eapply preg_vals; eauto. eexact H0.
+ intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ left; eapply exec_straight_steps; eauto; intros. simpl in H1.
+ exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]].
+ exists rs2; split. eauto.
+ rewrite <- Q in B.
+ unfold undef_op.
+ destruct op; try (eapply agree_set_undef_mreg; eauto). eapply agree_set_mreg; eauto.
+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 (Machconcr.State s fb sp (Mload chunk addr args dst :: c) ms m)
+ E0 (Machconcr.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).
+ 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.
+ exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]].
+ exists rs2; split. eauto. eapply agree_set_undef_mreg; eauto. 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 (Machconcr.State s fb sp (Mstore chunk addr args src :: c) ms m) E0
+ (Machconcr.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).
+ 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.
+ exploit Mem.storev_extends; eauto. intros [m2' [C D]].
+ left; eapply exec_straight_steps; eauto; intros. simpl in H3.
+ exploit transl_store_correct; eauto. intros [rs2 [P Q]].
+ exists rs2; split. eauto. eapply agree_exten_temps; eauto.
+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 (Machconcr.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.
+ 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 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 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.
+
+Lemma exec_Mtailcall_prop:
+ forall (s : list stackframe) (fb stk : block) (soff : int)
+ (sig : signature) (ros : mreg + ident) (c : list Mach.instruction)
+ (ms : Mach.regset) (m : mem) (f: Mach.function) (f' : block) m',
+ find_function_ptr ge ros ms = Some f' ->
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
+ load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
+ Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' ->
+ exec_instr_prop
+ (Machconcr.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0
+ (Callstate s f' ms m').
+Proof.
+ intros; red; intros; inv MS.
+ assert (f0 = f) by congruence. subst f0.
+ 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 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.
+ 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.
+ 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.
+ 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.
+ 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.
+ 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.
+ rewrite Pregmap.gss. unfold symbol_offset. rewrite symbols_preserved. rewrite H. auto.
+Qed.
+
+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 (Machconcr.State s fb sp (Mgoto lbl :: c) ms m) E0
+ (Machconcr.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.
+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 (Machconcr.State s f sp (Mbuiltin ef args res :: b) ms m) t
+ (Machconcr.State s f sp b (Regmap.set res v (undef_temps ms)) m').
+Proof.
+ intros; red; intros; inv MS.
+ 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.
+ eapply exec_step_builtin. eauto. eauto.
+ eapply find_instr_tail; eauto.
+ eapply external_call_symbols_preserved; eauto.
+ exact symbols_preserved. exact varinfo_preserved.
+ econstructor; eauto.
+ instantiate (2 := tf); instantiate (1 := x).
+ unfold nextinstr_nf, nextinstr. rewrite Pregmap.gss.
+ simpl undef_regs. repeat rewrite Pregmap.gso; auto with ppcgen.
+ rewrite <- H0. simpl. constructor; auto.
+ 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.
+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 = Some true ->
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ Mach.find_label lbl (fn_code f) = Some c' ->
+ exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0
+ (Machconcr.State s fb sp c' (undef_temps ms) m).
+Proof.
+ intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0.
+ exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. intros EC.
+ inv AT. monadInv H5.
+ exploit transl_cond_correct; eauto. intros [rs' [A [B C]]].
+ generalize (functions_transl _ _ _ FIND H4); intro FN.
+ generalize (transf_function_no_overflow _ _ H4); intro NOOV.
+ exploit exec_straight_steps_2; eauto.
+ intros [ofs' [PC2 CT2]].
+ exploit find_label_goto_label; eauto.
+ intros [tc' [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. eauto. simpl. rewrite B. eauto. traceEq.
+ econstructor; eauto.
+ eapply agree_exten_temps; eauto. 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 = Some false ->
+ exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0
+ (Machconcr.State s fb sp c (undef_temps ms) m).
+Proof.
+ intros; red; intros; inv MS.
+ exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. intros EC.
+ left; eapply exec_straight_steps; eauto. intros. simpl in H0.
+ exploit transl_cond_correct; eauto. intros [rs' [A [B C]]].
+ econstructor; split.
+ eapply exec_straight_trans. eexact A.
+ apply exec_straight_one. simpl. rewrite B. eauto. auto.
+ apply agree_nextinstr. eapply agree_exten_temps; eauto.
+Qed.
+
+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.signed n) = Some lbl ->
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ Mach.find_label lbl (fn_code f) = Some c' ->
+ exec_instr_prop
+ (Machconcr.State s fb sp (Mjumptable arg tbl :: c) rs m) E0
+ (Machconcr.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.
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H5); 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.
+ 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.
+ econstructor; eauto.
+ eapply agree_exten_temps; eauto. intros. rewrite C; auto with ppcgen.
+ repeat rewrite Pregmap.gso; auto with ppcgen.
+Qed.
+
+Lemma exec_Mreturn_prop:
+ forall (s : list stackframe) (fb stk : block) (soff : int)
+ (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: Mach.function) m',
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
+ load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
+ Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' ->
+ exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0
+ (Returnstate s ms m').
+Proof.
+ intros; red; intros; inv MS.
+ assert (f0 = f) by congruence. subst f0.
+ 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 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.
+ 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.
+ 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 (- fn_framesize f) (fn_stacksize f) = (m1, stk) ->
+ let sp := Vptr stk (Int.repr (- fn_framesize f)) in
+ store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 ->
+ store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 ->
+ exec_instr_prop (Machconcr.Callstate s fb ms m) E0
+ (Machconcr.State s fb sp (fn_code f) ms m3).
+Proof.
+ intros; red; intros; inv MS.
+ 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]].
+ 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. rewrite Pregmap.gso; auto with ppcgen.
+ rewrite ATPC. simpl. constructor; eauto.
+ subst x. eapply code_tail_next_int. rewrite list_length_z_cons. omega.
+ constructor.
+ apply agree_nextinstr. eapply agree_change_sp; eauto. congruence.
+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' ->
+ Machconcr.extcall_arguments ms m (parent_sp s) (ef_sig ef) args ->
+ ms' = Regmap.set (loc_result (ef_sig ef)) res ms ->
+ exec_instr_prop (Machconcr.Callstate s fb ms m)
+ t0 (Machconcr.Returnstate s ms' m').
+Proof.
+ intros; red; intros; inv MS.
+ 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 [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.
+ eapply agree_set_mreg; eauto.
+ rewrite Pregmap.gso; auto with ppcgen. rewrite Pregmap.gss. auto.
+ intros. repeat rewrite Pregmap.gso; auto with ppcgen.
+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 (Machconcr.Returnstate (Stackframe fb sp ra c :: s) ms m) E0
+ (Machconcr.State s fb sp c ms m).
+Proof.
+ intros; red; intros; inv MS. inv STACKS. simpl in *.
+ right. split. omega. split. auto.
+ econstructor; eauto. rewrite ATPC; eauto.
+Qed.
+
+Theorem transf_instr_correct:
+ forall s1 t s2, Machconcr.step ge s1 t s2 ->
+ exec_instr_prop s1 t s2.
+Proof
+ (Machconcr.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_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, Machconcr.initial_state prog st1 ->
+ exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2.
+Proof.
+ intros. inversion H. unfold ge0 in *.
+ 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.
+ unfold symbol_offset.
+ rewrite (transform_partial_program_main _ _ TRANSF).
+ rewrite symbols_preserved. unfold ge; rewrite H1. auto.
+Qed.
+
+Lemma transf_final_states:
+ forall st1 st2 r,
+ match_states st1 st2 -> Machconcr.final_state st1 r -> Asm.final_state st2 r.
+Proof.
+ intros. inv H0. inv H. constructor. auto.
+ compute in H1.
+ generalize (preg_val _ _ _ AX AG). rewrite H1. intros LD; inv LD. auto.
+Qed.
+
+Theorem transf_program_correct:
+ forall (beh: program_behavior), not_wrong beh ->
+ Machconcr.exec_program prog beh -> Asm.exec_program tprog beh.
+Proof.
+ unfold Machconcr.exec_program, Asm.exec_program; intros.
+ eapply simulation_star_preservation with (measure := measure); eauto.
+ eexact transf_initial_states.
+ eexact transf_final_states.
+ exact transf_instr_correct.
+Qed.
+
+End PRESERVATION.
diff --git a/ia32/Asmgenproof1.v b/ia32/Asmgenproof1.v
new file mode 100644
index 0000000..498bb4e
--- /dev/null
+++ b/ia32/Asmgenproof1.v
@@ -0,0 +1,1436 @@
+(* *********************************************************************)
+(* *)
+(* 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 IA32 generation: auxiliary results. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Errors.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Op.
+Require Import Locations.
+Require Import Mach.
+Require Import Machconcr.
+Require Import Machtyping.
+Require Import Asm.
+Require Import Asmgen.
+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.
+
+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.
+
+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.
+
+(** 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 ->
+ (nextinstr_nf rs)#r = rs#r.
+Proof.
+ intros. unfold nextinstr_nf. rewrite nextinstr_inv.
+ simpl. repeat rewrite Pregmap.gso; auto.
+ red; intro; subst; contradiction.
+ red; intro; subst; contradiction.
+ red; intro; subst; contradiction.
+ red; intro; subst; contradiction.
+ red; intro; subst; contradiction.
+Qed.
+
+Lemma nextinstr_nf_inv1:
+ forall r rs,
+ important_preg r = true -> (nextinstr_nf rs)#r = rs#r.
+Proof.
+ intros. apply nextinstr_nf_inv. unfold important_preg in H.
+ destruct r; auto; congruence.
+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.
+Qed.
+
+Lemma nextinstr_nf_set_preg:
+ forall rs m v,
+ (nextinstr_nf (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone.
+Proof.
+ intros. unfold nextinstr_nf.
+ transitivity (nextinstr (rs#(preg_of m) <- v) PC). auto.
+ 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 ->
+ Machconcr.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,
+ Machconcr.extcall_args ms m sp ll vl ->
+ exists vl', Asm.extcall_args 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]].
+ exploit IHextcall_args; eauto. intros [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 ->
+ Machconcr.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 Machconcr.extcall_arguments, Asm.extcall_arguments; intros.
+ eapply extcall_args_match; eauto.
+Qed.
+
+(** * Execution of straight-line code *)
+
+Section STRAIGHTLINE.
+
+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
+ /\ rs2#rd = rs1#rs
+ /\ forall r, important_preg r = true -> 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.
+(* 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.
+(* getfp0 *)
+ 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. rewrite Pregmap.gso; auto.
+(* setfp0 *)
+ econstructor. split. apply exec_straight_one. simpl. eauto. auto.
+ split. auto.
+ intros. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gso. auto.
+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
+ /\ rs2#r1 = ssem rs1#r1 rs1#r2
+ /\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r.
+Proof.
+ unfold mk_shift; intros.
+ destruct (ireg_eq r2 ECX); monadInv H.
+(* fast case *)
+ econstructor. split. apply exec_straight_one. apply H0. auto.
+ split. repeat SRes.
+ intros. repeat SOther.
+(* general case *)
+ monadInv EQ.
+ 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.
+Qed.
+
+(** Smart constructor for division *)
+
+
+Lemma mk_div_correct:
+ forall mkinstr dsem msem r1 r2 k c rs1 m,
+ mk_div mkinstr r1 r2 k = OK c ->
+ (forall r c rs m,
+ exec_instr ge c (mkinstr r) rs m =
+ Next (nextinstr_nf (rs#EAX <- (dsem rs#EAX (rs#EDX <- Vundef)#r)
+ #EDX <- (msem rs#EAX (rs#EDX <- Vundef)#r))) m) ->
+ exists rs2,
+ exec_straight c rs1 m k rs2 m
+ /\ rs2#r1 = dsem rs1#r1 rs1#r2
+ /\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r.
+Proof.
+ unfold mk_div; intros.
+ destruct (ireg_eq r1 EAX). destruct (ireg_eq r2 EDX); monadInv H.
+(* r1=EAX r2=EDX *)
+ econstructor. split. eapply exec_straight_two. simpl; eauto. apply H0. auto. auto.
+ split. SRes.
+ intros. repeat SOther.
+(* r1=EAX r2<>EDX *)
+ econstructor. split. eapply exec_straight_one. apply H0. auto.
+ split. repeat SRes. decEq. apply Pregmap.gso. congruence.
+ intros. repeat SOther.
+(* r1 <> EAX *)
+ monadInv H. monadInv EQ. destruct (ireg_eq r2 EAX); monadInv EQ0.
+(* r1 <> EAX, r1 <> ECX, r2 = EAX *)
+ set (rs2 := nextinstr (rs1#ECX <- (rs1#EAX))).
+ set (rs3 := nextinstr (rs2#EAX <- (rs2#r1))).
+ set (rs4 := nextinstr_nf (rs3#EAX <- (dsem rs3#EAX (rs3#EDX <- Vundef)#ECX)
+ #EDX <- (msem rs3#EAX (rs3#EDX <- Vundef)#ECX))).
+ set (rs5 := nextinstr (rs4#r1 <- (rs4#EAX))).
+ set (rs6 := nextinstr (rs5#EAX <- (rs5#ECX))).
+ exists rs6. split. apply exec_straight_step with rs2 m; auto.
+ apply exec_straight_step with rs3 m; auto.
+ apply exec_straight_step with rs4 m; auto. apply H0.
+ apply exec_straight_step with rs5 m; auto.
+ apply exec_straight_one; auto.
+ split. unfold rs6. SRes. unfold rs5. repeat SRes.
+ unfold rs4. repeat SRes. decEq.
+ unfold rs3. repeat SRes. unfold rs2. repeat SRes.
+ intros. unfold rs6. SOther.
+ unfold Pregmap.set. destruct (PregEq.eq r EAX). subst r.
+ unfold rs5. repeat SOther.
+ unfold rs5. repeat SOther. unfold rs4. repeat SOther.
+ unfold rs3. repeat SOther. unfold rs2. repeat SOther.
+(* r1 <> EAX, r1 <> ECX, r2 <> EAX *)
+ set (rs2 := nextinstr (rs1#XMM7 <- (rs1#EAX))).
+ set (rs3 := nextinstr (rs2#ECX <- (rs2#r2))).
+ set (rs4 := nextinstr (rs3#EAX <- (rs3#r1))).
+ set (rs5 := nextinstr_nf (rs4#EAX <- (dsem rs4#EAX (rs4#EDX <- Vundef)#ECX)
+ #EDX <- (msem rs4#EAX (rs4#EDX <- Vundef)#ECX))).
+ set (rs6 := nextinstr (rs5#r2 <- (rs5#ECX))).
+ set (rs7 := nextinstr (rs6#r1 <- (rs6#EAX))).
+ set (rs8 := nextinstr (rs7#EAX <- (rs7#XMM7))).
+ exists rs8. split. apply exec_straight_step with rs2 m; auto.
+ apply exec_straight_step with rs3 m; auto.
+ apply exec_straight_step with rs4 m; auto.
+ apply exec_straight_step with rs5 m; auto. apply H0.
+ apply exec_straight_step with rs6 m; auto.
+ apply exec_straight_step with rs7 m; auto.
+ apply exec_straight_one; auto.
+ split. unfold rs8. SRes. unfold rs7. repeat SRes.
+ unfold rs6. repeat SRes. unfold rs5. repeat SRes.
+ decEq. unfold rs4. repeat SRes. unfold rs3. repeat SRes.
+ intros. unfold rs8. SOther.
+ unfold Pregmap.set. destruct (PregEq.eq r EAX). subst r. auto.
+ unfold rs7. repeat SOther. unfold rs6. SOther.
+ unfold Pregmap.set. destruct (PregEq.eq r r2). subst r. auto.
+ unfold rs5. repeat SOther. unfold rs4. repeat SOther.
+ unfold rs3. repeat SOther. unfold rs2. repeat SOther.
+Qed.
+
+(** Smart constructor for modulus *)
+
+Lemma mk_mod_correct:
+ forall mkinstr dsem msem r1 r2 k c rs1 m,
+ mk_mod mkinstr r1 r2 k = OK c ->
+ (forall r c rs m,
+ exec_instr ge c (mkinstr r) rs m =
+ Next (nextinstr_nf (rs#EAX <- (dsem rs#EAX (rs#EDX <- Vundef)#r)
+ #EDX <- (msem rs#EAX (rs#EDX <- Vundef)#r))) m) ->
+ exists rs2,
+ exec_straight c rs1 m k rs2 m
+ /\ rs2#r1 = msem rs1#r1 rs1#r2
+ /\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r.
+Proof.
+ unfold mk_mod; intros.
+ destruct (ireg_eq r1 EAX). destruct (ireg_eq r2 EDX); monadInv H.
+(* r1=EAX r2=EDX *)
+ econstructor. split. eapply exec_straight_three.
+ simpl; eauto. apply H0. simpl; eauto. auto. auto. auto.
+ split. SRes.
+ intros. repeat SOther.
+(* r1=EAX r2<>EDX *)
+ econstructor. split. eapply exec_straight_two. apply H0. simpl; eauto. auto. auto.
+ split. repeat SRes. decEq. apply Pregmap.gso. congruence.
+ intros. repeat SOther.
+(* r1 <> EAX *)
+ monadInv H. monadInv EQ. destruct (ireg_eq r2 EDX); monadInv EQ0.
+(* r1 <> EAX, r1 <> ECX, r2 = EDX *)
+ set (rs2 := nextinstr (rs1#XMM7 <- (rs1#EAX))).
+ set (rs3 := nextinstr (rs2#ECX <- (rs2#EDX))).
+ set (rs4 := nextinstr (rs3#EAX <- (rs3#r1))).
+ set (rs5 := nextinstr_nf (rs4#EAX <- (dsem rs4#EAX (rs4#EDX <- Vundef)#ECX)
+ #EDX <- (msem rs4#EAX (rs4#EDX <- Vundef)#ECX))).
+ set (rs6 := nextinstr (rs5#r1 <- (rs5#EDX))).
+ set (rs7 := nextinstr (rs6#EAX <- (rs6#XMM7))).
+ exists rs7. split. apply exec_straight_step with rs2 m; auto.
+ apply exec_straight_step with rs3 m; auto.
+ apply exec_straight_step with rs4 m; auto.
+ apply exec_straight_step with rs5 m; auto. apply H0.
+ apply exec_straight_step with rs6 m; auto.
+ apply exec_straight_one; auto.
+ split. unfold rs7. repeat SRes. unfold rs6. repeat SRes.
+ unfold rs5. repeat SRes. decEq.
+ unfold rs4. repeat SRes. unfold rs3. repeat SRes.
+ intros. unfold rs7. SOther.
+ unfold Pregmap.set. destruct (PregEq.eq r EAX). subst r.
+ unfold rs6. repeat SOther.
+ unfold rs6. repeat SOther.
+ unfold rs5. repeat SOther. unfold rs4. repeat SOther.
+ unfold rs3. repeat SOther. unfold rs2. repeat SOther.
+(* r1 <> EAX, r1 <> ECX, r2 <> EDX *)
+ set (rs2 := nextinstr (rs1#XMM7 <- (rs1#EAX))).
+ set (rs3 := nextinstr (rs2#ECX <- (rs2#r2))).
+ set (rs4 := nextinstr (rs3#EAX <- (rs3#r1))).
+ set (rs5 := nextinstr_nf (rs4#EAX <- (dsem rs4#EAX (rs4#EDX <- Vundef)#ECX)
+ #EDX <- (msem rs4#EAX (rs4#EDX <- Vundef)#ECX))).
+ set (rs6 := nextinstr (rs5#r2 <- (rs5#ECX))).
+ set (rs7 := nextinstr (rs6#r1 <- (rs6#EDX))).
+ set (rs8 := nextinstr (rs7#EAX <- (rs7#XMM7))).
+ exists rs8. split. apply exec_straight_step with rs2 m; auto.
+ apply exec_straight_step with rs3 m; auto.
+ apply exec_straight_step with rs4 m; auto.
+ apply exec_straight_step with rs5 m; auto. apply H0.
+ apply exec_straight_step with rs6 m; auto.
+ apply exec_straight_step with rs7 m; auto.
+ apply exec_straight_one; auto.
+ split. unfold rs8. SRes. unfold rs7. repeat SRes.
+ unfold rs6. repeat SRes. unfold rs5. repeat SRes.
+ decEq. unfold rs4. repeat SRes. unfold rs3. repeat SRes.
+ intros. unfold rs8. SOther.
+ unfold Pregmap.set. destruct (PregEq.eq r EAX). subst r. auto.
+ unfold rs7. repeat SOther. unfold rs6. SOther.
+ unfold Pregmap.set. destruct (PregEq.eq r r2). subst r. auto.
+ unfold rs5. repeat SOther. unfold rs4. repeat SOther.
+ unfold rs3. repeat SOther. unfold rs2. repeat SOther.
+Qed.
+
+(** Smart constructor for [shrx] *)
+
+Lemma mk_shrximm_correct:
+ forall r1 n k c (rs1: regset) x m,
+ mk_shrximm r1 n k = OK c ->
+ rs1#r1 = Vint x ->
+ Int.ltu n (Int.repr 31) = true ->
+ exists rs2,
+ exec_straight c rs1 m k rs2 m
+ /\ rs2#r1 = Vint (Int.shrx x n)
+ /\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r.
+Proof.
+ unfold mk_shrximm; intros. monadInv H. monadInv EQ.
+ rewrite Int.shrx_shr; auto.
+ set (tnm1 := Int.sub (Int.shl Int.one n) Int.one).
+ set (x' := Int.add x tnm1).
+ set (rs2 := nextinstr (compare_ints (Vint x) (Vint Int.zero) rs1)).
+ set (rs3 := nextinstr (rs2#ECX <- (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.
+ exists rs5. split.
+ apply exec_straight_step with rs2 m. simpl. rewrite H0. simpl. rewrite Int.and_idem. auto. auto.
+ apply exec_straight_step with rs3 m. simpl.
+ change (rs2 r1) with (rs1 r1). rewrite H0. simpl.
+ rewrite (Int.add_commut Int.zero tnm1). rewrite Int.add_zero. auto. auto.
+ apply exec_straight_step with rs4 m. simpl.
+ change (rs3 SOF) with (rs2 SOF). unfold rs2. rewrite nextinstr_inv; auto with ppcgen.
+ unfold compare_ints. rewrite Pregmap.gso; auto with ppcgen. rewrite Pregmap.gss.
+ simpl. unfold rs4. destruct (Int.lt x Int.zero); auto.
+ unfold rs4. destruct (Int.lt x Int.zero); auto.
+ apply exec_straight_one. auto. auto.
+ split. unfold rs5. SRes. SRes. unfold rs4. rewrite nextinstr_inv; auto with ppcgen.
+ assert (Int.ltu n Int.iwordsize = true).
+ unfold Int.ltu in *. change (Int.unsigned (Int.repr 31)) with 31 in H1.
+ destruct (zlt (Int.unsigned n) 31); try discriminate.
+ change (Int.unsigned Int.iwordsize) with 32. apply zlt_true. omega.
+ destruct (Int.lt x Int.zero). rewrite Pregmap.gss. unfold Val.shr. rewrite H2. auto.
+ rewrite H. unfold Val.shr. rewrite H2. 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.
+Qed.
+
+(** Smart constructor for integer conversions *)
+
+Lemma mk_intconv_correct:
+ forall mk sem rd rs k c rs1 m,
+ mk_intconv mk rd rs k = OK c ->
+ (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
+ /\ 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.
+ econstructor. split. eapply exec_straight_two.
+ simpl. eauto. apply H0. auto. auto.
+ split. repeat SRes.
+ intros. repeat SOther.
+Qed.
+
+(** Smart constructor for small stores *)
+
+Lemma mk_smallstore_correct:
+ forall chunk sto addr r k c rs1 m1 m2,
+ mk_smallstore sto addr r k = OK c ->
+ Mem.storev chunk m1 (eval_addrmode ge addr rs1) (rs1 r) = Some m2 ->
+ (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
+ /\ forall r, nontemp_preg r = true -> rs2#r = rs1#r.
+Proof.
+ unfold mk_smallstore; intros.
+ remember (low_ireg r) as low. destruct low; monadInv H.
+(* low reg *)
+ econstructor; split. apply exec_straight_one. rewrite H1.
+ unfold exec_store. rewrite H0. eauto. auto.
+ intros. SOther.
+(* high reg *)
+ assert (r <> ECX). red; intros; subst r; discriminate.
+ set (rs2 := nextinstr (rs1#ECX <- (eval_addrmode ge addr rs1))).
+ set (rs3 := nextinstr (rs2#EDX <- (rs1 r))).
+ 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.
+ 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).
+ replace (Val.add (eval_addrmode ge addr rs1) (Vint Int.zero))
+ with (eval_addrmode ge addr rs1).
+ rewrite H0. eauto.
+ 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.
+Qed.
+
+(** Accessing slots in the stack frame *)
+
+Lemma loadind_correct:
+ forall (base: ireg) ofs ty dst k (rs: regset) c 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 ->
+ exists rs',
+ exec_straight 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.
+Proof.
+ unfold loadind; intros.
+ set (addr := Addrmode (Some base) None (inl (ident * int) ofs)) in *.
+ assert (eval_addrmode ge addr rs = Val.add rs#base (Vint ofs)).
+ unfold addr. simpl. rewrite Int.add_commut; rewrite Int.add_zero; auto.
+ destruct ty; simpl in H0.
+ (* int *)
+ 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.
+ (* 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.
+Qed.
+
+Lemma storeind_correct:
+ forall (base: ireg) ofs ty src k (rs: regset) c 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' ->
+ exists rs',
+ exec_straight c rs m k rs' m'
+ /\ forall r, important_preg r = true -> rs'#r = rs#r.
+Proof.
+ unfold storeind; intros.
+ set (addr := Addrmode (Some base) None (inl (ident * int) ofs)) in *.
+ assert (eval_addrmode ge addr rs = Val.add rs#base (Vint ofs)).
+ unfold addr. simpl. rewrite Int.add_commut; rewrite Int.add_zero; auto.
+ destruct ty; simpl in H0.
+ (* int *)
+ monadInv H.
+ 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.
+ (* float *)
+ destruct (preg_of src); inv H.
+ econstructor; split. apply exec_straight_one.
+ simpl. unfold exec_store. rewrite H1; rewrite H0. eauto. auto.
+ intros. apply nextinstr_nf_inv1; auto.
+ econstructor; split. apply exec_straight_one.
+ simpl. unfold exec_store. rewrite H1; rewrite H0. eauto. auto.
+ intros. apply nextinstr_nf_inv1; auto.
+Qed.
+
+(** Translation of addressing modes *)
+
+Lemma transl_addressing_mode_correct:
+ forall addr args am (rs: regset) v,
+ transl_addressing addr args = OK am ->
+ eval_addressing ge (rs ESP) addr (List.map rs (List.map preg_of args)) = Some v ->
+ eval_addrmode ge am rs = v.
+Proof.
+ assert (A: forall n, Int.add Int.zero n = n).
+ intros. rewrite Int.add_commut. apply Int.add_zero.
+ assert (B: forall n i, (if Int.eq i Int.one then Vint n else Vint (Int.mul n i)) = Vint (Int.mul n i)).
+ intros. generalize (Int.eq_spec i Int.one); destruct (Int.eq i Int.one); intros.
+ subst i. rewrite Int.mul_one. auto. auto.
+ unfold transl_addressing; intros.
+ destruct addr; repeat (destruct args; try discriminate); simpl in H0.
+(* indexed *)
+ monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0. simpl.
+ destruct (rs x); inv H0; simpl. rewrite A; auto. rewrite A; auto.
+(* indexed2 *)
+ monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0; rewrite (ireg_of_eq _ _ EQ1) in H0. simpl.
+ destruct (rs x); try discriminate; destruct (rs x0); inv H0; simpl.
+ rewrite Int.add_assoc; auto.
+ repeat rewrite Int.add_assoc. decEq. decEq. apply Int.add_commut.
+ rewrite Int.add_assoc; auto.
+(* scaled *)
+ monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0. simpl.
+ destruct (rs x); inv H0; simpl.
+ rewrite B. simpl. rewrite A. auto.
+(* indexed2scaled *)
+ monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0; rewrite (ireg_of_eq _ _ EQ1) in H0. simpl.
+ destruct (rs x); try discriminate; destruct (rs x0); inv H0; simpl.
+ rewrite B. simpl. auto.
+ rewrite B. simpl. auto.
+(* global *)
+ inv H. simpl. unfold symbol_offset. destruct (Genv.find_symbol ge i); inv H0.
+ repeat rewrite Int.add_zero. auto.
+(* based *)
+ monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0. simpl.
+ destruct (rs x); inv H0; simpl.
+ unfold symbol_offset. destruct (Genv.find_symbol ge i); inv H1.
+ rewrite Int.add_zero; auto.
+(* basedscaled *)
+ monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0. simpl.
+ destruct (rs x); inv H0; simpl.
+ rewrite B. unfold symbol_offset. destruct (Genv.find_symbol ge i0); inv H1.
+ simpl. rewrite Int.add_zero. auto.
+(* instack *)
+ inv H; simpl. unfold offset_sp in H0.
+ destruct (rs ESP); inv H0. simpl. rewrite A; auto.
+Qed.
+
+(** Processor conditions and comparisons *)
+
+Lemma compare_ints_spec:
+ forall rs v1 v2,
+ let rs' := nextinstr (compare_ints v1 v2 rs) in
+ rs'#ZF = Val.cmp Ceq v1 v2
+ /\ rs'#CF = Val.cmpu Clt v1 v2
+ /\ rs'#SOF = Val.cmp Clt v1 v2
+ /\ (forall r, nontemp_preg r = true -> rs'#r = rs#r).
+Proof.
+ intros. unfold rs'; unfold compare_ints.
+ split. auto.
+ split. auto.
+ split. auto.
+ intros. repeat SOther.
+Qed.
+
+Lemma int_signed_eq:
+ forall x y, Int.eq x y = zeq (Int.signed x) (Int.signed y).
+Proof.
+ intros. unfold Int.eq. unfold proj_sumbool.
+ destruct (zeq (Int.unsigned x) (Int.unsigned y));
+ destruct (zeq (Int.signed x) (Int.signed y)); auto.
+ elim n. unfold Int.signed. rewrite e; auto.
+ elim n. apply Int.eqm_small_eq; auto with ints.
+ eapply Int.eqm_trans. apply Int.eqm_sym. apply Int.eqm_signed_unsigned.
+ rewrite e. apply Int.eqm_signed_unsigned.
+Qed.
+
+Lemma int_not_lt:
+ forall x y, negb (Int.lt y x) = (Int.lt x y || Int.eq x y).
+Proof.
+ intros. unfold Int.lt. rewrite int_signed_eq. unfold proj_sumbool.
+ destruct (zlt (Int.signed y) (Int.signed x)).
+ rewrite zlt_false. rewrite zeq_false. auto. omega. omega.
+ destruct (zeq (Int.signed x) (Int.signed y)).
+ rewrite zlt_false. auto. omega.
+ rewrite zlt_true. auto. omega.
+Qed.
+
+Lemma int_lt_not:
+ forall x y, Int.lt y x = negb (Int.lt x y) && negb (Int.eq x y).
+Proof.
+ intros. rewrite <- negb_orb. rewrite <- int_not_lt. rewrite negb_involutive. auto.
+Qed.
+
+Lemma int_not_ltu:
+ forall x y, negb (Int.ltu y x) = (Int.ltu x y || Int.eq x y).
+Proof.
+ intros. unfold Int.ltu, Int.eq.
+ destruct (zlt (Int.unsigned y) (Int.unsigned x)).
+ rewrite zlt_false. rewrite zeq_false. auto. omega. omega.
+ destruct (zeq (Int.unsigned x) (Int.unsigned y)).
+ rewrite zlt_false. auto. omega.
+ rewrite zlt_true. auto. omega.
+Qed.
+
+Lemma int_ltu_not:
+ forall x y, Int.ltu y x = negb (Int.ltu x y) && negb (Int.eq x y).
+Proof.
+ intros. rewrite <- negb_orb. rewrite <- int_not_ltu. rewrite negb_involutive. auto.
+Qed.
+
+Lemma testcond_for_signed_comparison_correct_ii:
+ forall c n1 n2 rs,
+ eval_testcond (testcond_for_signed_comparison c)
+ (nextinstr (compare_ints (Vint n1) (Vint n2) rs)) =
+ Some(Int.cmp c n1 n2).
+Proof.
+ intros. generalize (compare_ints_spec rs (Vint n1) (Vint n2)).
+ set (rs' := nextinstr (compare_ints (Vint n1) (Vint n2) rs)).
+ intros [A [B [C D]]].
+ unfold eval_testcond. rewrite A; rewrite B; rewrite C.
+ destruct c; simpl.
+ destruct (Int.eq n1 n2); auto.
+ destruct (Int.eq n1 n2); auto.
+ destruct (Int.lt n1 n2); auto.
+ rewrite int_not_lt. destruct (Int.lt n1 n2); destruct (Int.eq n1 n2); auto.
+ rewrite (int_lt_not n1 n2). destruct (Int.lt n1 n2); destruct (Int.eq n1 n2); auto.
+ destruct (Int.lt n1 n2); auto.
+Qed.
+
+Lemma testcond_for_signed_comparison_correct_pi:
+ forall c blk n1 n2 rs b,
+ eval_compare_null c n2 = Some b ->
+ eval_testcond (testcond_for_signed_comparison c)
+ (nextinstr (compare_ints (Vptr blk n1) (Vint n2) rs)) = Some b.
+Proof.
+ intros.
+ revert H. unfold eval_compare_null.
+ generalize (Int.eq_spec n2 Int.zero); destruct (Int.eq n2 Int.zero); intros; try discriminate.
+ subst n2.
+ generalize (compare_ints_spec rs (Vptr blk n1) (Vint Int.zero)).
+ set (rs' := nextinstr (compare_ints (Vptr blk n1) (Vint Int.zero) rs)).
+ intros [A [B [C D]]].
+ unfold eval_testcond. rewrite A; rewrite B; rewrite C.
+ destruct c; simpl; try discriminate.
+ rewrite <- H0; auto.
+ rewrite <- H0; auto.
+Qed.
+
+Lemma testcond_for_signed_comparison_correct_ip:
+ forall c blk n1 n2 rs b,
+ eval_compare_null c n1 = Some b ->
+ eval_testcond (testcond_for_signed_comparison c)
+ (nextinstr (compare_ints (Vint n1) (Vptr blk n2) rs)) = Some b.
+Proof.
+ intros.
+ revert H. unfold eval_compare_null.
+ generalize (Int.eq_spec n1 Int.zero); destruct (Int.eq n1 Int.zero); intros; try discriminate.
+ subst n1.
+ generalize (compare_ints_spec rs (Vint Int.zero) (Vptr blk n2)).
+ set (rs' := nextinstr (compare_ints (Vint Int.zero) (Vptr blk n2) rs)).
+ intros [A [B [C D]]].
+ unfold eval_testcond. rewrite A; rewrite B; rewrite C.
+ destruct c; simpl; try discriminate.
+ rewrite <- H0; auto.
+ rewrite <- H0; auto.
+Qed.
+
+Lemma testcond_for_signed_comparison_correct_pp:
+ forall c b1 n1 b2 n2 rs b,
+ (if eq_block b1 b2 then Some (Int.cmp c n1 n2) else eval_compare_mismatch c) = Some b ->
+ eval_testcond (testcond_for_signed_comparison c)
+ (nextinstr (compare_ints (Vptr b1 n1) (Vptr b2 n2) rs)) =
+ Some b.
+Proof.
+ intros. generalize (compare_ints_spec rs (Vptr b1 n1) (Vptr b2 n2)).
+ set (rs' := nextinstr (compare_ints (Vptr b1 n1) (Vptr b2 n2) rs)).
+ intros [A [B [C D]]]. unfold eq_block in H.
+ unfold eval_testcond. rewrite A; rewrite B; rewrite C.
+ destruct c; simpl.
+ destruct (zeq b1 b2). inversion H. destruct (Int.eq n1 n2); auto.
+ rewrite <- H; auto.
+ destruct (zeq b1 b2). inversion H. destruct (Int.eq n1 n2); auto.
+ rewrite <- H; auto.
+ destruct (zeq b1 b2). inversion H. destruct (Int.lt n1 n2); auto.
+ discriminate.
+ destruct (zeq b1 b2). inversion H.
+ rewrite int_not_lt. destruct (Int.lt n1 n2); destruct (Int.eq n1 n2); auto.
+ discriminate.
+ destruct (zeq b1 b2). inversion H.
+ rewrite (int_lt_not n1 n2). destruct (Int.lt n1 n2); destruct (Int.eq n1 n2); auto.
+ discriminate.
+ destruct (zeq b1 b2). inversion H. destruct (Int.lt n1 n2); auto.
+ discriminate.
+Qed.
+
+Lemma testcond_for_unsigned_comparison_correct:
+ forall c n1 n2 rs,
+ eval_testcond (testcond_for_unsigned_comparison c)
+ (nextinstr (compare_ints (Vint n1) (Vint n2) rs)) =
+ Some(Int.cmpu c n1 n2).
+Proof.
+ intros. generalize (compare_ints_spec rs (Vint n1) (Vint n2)).
+ set (rs' := nextinstr (compare_ints (Vint n1) (Vint n2) rs)).
+ intros [A [B [C D]]].
+ unfold eval_testcond. rewrite A; rewrite B; rewrite C.
+ destruct c; simpl.
+ destruct (Int.eq n1 n2); auto.
+ destruct (Int.eq n1 n2); auto.
+ destruct (Int.ltu n1 n2); auto.
+ rewrite int_not_ltu. destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto.
+ rewrite (int_ltu_not n1 n2). destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto.
+ destruct (Int.ltu n1 n2); auto.
+Qed.
+
+Lemma compare_floats_spec:
+ forall rs n1 n2,
+ let rs' := nextinstr (compare_floats (Vfloat n1) (Vfloat n2) rs) in
+ rs'#ZF = Val.of_bool (negb (Float.cmp Cne n1 n2))
+ /\ rs'#CF = Val.of_bool (negb (Float.cmp Cge n1 n2))
+ /\ rs'#PF = Val.of_bool (negb (Float.cmp Ceq n1 n2 || Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2))
+ /\ (forall r, nontemp_preg r = true -> rs'#r = rs#r).
+Proof.
+ intros. unfold rs'; unfold compare_floats.
+ split. auto.
+ split. auto.
+ split. auto.
+ intros. repeat SOther.
+Qed.
+
+Definition swap_floats (c: comparison) (n1 n2: float) : float :=
+ match c with
+ | Clt | Cle => n2
+ | Ceq | Cne | Cgt | Cge => n1
+ end.
+
+Lemma testcond_for_float_comparison_correct:
+ forall c n1 n2 rs,
+ eval_testcond (testcond_for_condition (Ccompf c))
+ (nextinstr (compare_floats (Vfloat (swap_floats c n1 n2))
+ (Vfloat (swap_floats c n2 n1)) rs)) =
+ Some(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_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.
+
+Lemma testcond_for_neg_float_comparison_correct:
+ forall c n1 n2 rs,
+ eval_testcond (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_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.
+
+Lemma transl_cond_correct:
+ forall cond args k c rs m b,
+ transl_cond cond args k = OK c ->
+ eval_condition cond (map rs (map preg_of args)) = Some b ->
+ exists rs',
+ exec_straight c rs m k rs' m
+ /\ eval_testcond (testcond_for_condition cond) rs' = Some b
+ /\ forall r, nontemp_preg r = true -> rs'#r = rs r.
+Proof.
+ unfold transl_cond; intros.
+ destruct cond; repeat (destruct args; try discriminate); monadInv H.
+(* comp *)
+ simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. rewrite (ireg_of_eq _ _ EQ1) in H0.
+ econstructor. split. apply exec_straight_one. simpl. eauto. auto.
+ split. simpl in H0. FuncInv.
+ subst b. apply testcond_for_signed_comparison_correct_ii.
+ apply testcond_for_signed_comparison_correct_ip; auto.
+ apply testcond_for_signed_comparison_correct_pi; auto.
+ apply testcond_for_signed_comparison_correct_pp; auto.
+ intros. unfold compare_ints. repeat SOther.
+(* compu *)
+ simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. rewrite (ireg_of_eq _ _ EQ1) in H0.
+ econstructor. split. apply exec_straight_one. simpl. eauto. auto.
+ split. simpl in H0. FuncInv.
+ subst b. apply testcond_for_unsigned_comparison_correct.
+ intros. unfold compare_ints. repeat SOther.
+(* compimm *)
+ simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0.
+ econstructor. split. apply exec_straight_one. simpl; eauto. auto.
+ split. simpl in H0. FuncInv.
+ subst b. apply testcond_for_signed_comparison_correct_ii.
+ apply testcond_for_signed_comparison_correct_pi; auto.
+ intros. unfold compare_ints. repeat SOther.
+(* compuimm *)
+ simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0.
+ exists (nextinstr (compare_ints (rs x) (Vint i) rs)).
+ split. destruct (Int.eq_dec i Int.zero).
+ apply exec_straight_one. subst i. simpl.
+ simpl in H0. FuncInv. simpl. rewrite Int.and_idem. auto. auto.
+ apply exec_straight_one; auto.
+ split. simpl in H0. FuncInv.
+ subst b. apply testcond_for_unsigned_comparison_correct.
+ intros. unfold compare_ints. repeat SOther.
+(* compf *)
+ simpl map in H0. rewrite (freg_of_eq _ _ EQ) in H0. rewrite (freg_of_eq _ _ EQ1) in H0.
+ remember (rs x) as v1; remember (rs x0) as v2. simpl in H0. FuncInv.
+ exists (nextinstr (compare_floats (Vfloat (swap_floats c0 f f0)) (Vfloat (swap_floats c0 f0 f)) rs)).
+ split. apply exec_straight_one.
+ destruct c0; unfold floatcomp, exec_instr, swap_floats; congruence.
+ auto.
+ split. subst b. apply testcond_for_float_comparison_correct.
+ intros. unfold compare_floats. repeat SOther.
+(* notcompf *)
+ simpl map in H0. rewrite (freg_of_eq _ _ EQ) in H0. rewrite (freg_of_eq _ _ EQ1) in H0.
+ remember (rs x) as v1; remember (rs x0) as v2. simpl in H0. FuncInv.
+ exists (nextinstr (compare_floats (Vfloat (swap_floats c0 f f0)) (Vfloat (swap_floats c0 f0 f)) rs)).
+ split. apply exec_straight_one.
+ destruct c0; unfold floatcomp, exec_instr, swap_floats; congruence.
+ auto.
+ split. subst b. apply testcond_for_neg_float_comparison_correct.
+ intros. unfold compare_floats. repeat SOther.
+(* maskzero *)
+ simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0.
+ econstructor. split. apply exec_straight_one. simpl; eauto. auto.
+ split. simpl in H0. FuncInv. simpl.
+ generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero).
+ intros [A B]. rewrite A. subst b. simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto.
+ intros. unfold compare_ints. repeat SOther.
+(* masknotzero *)
+ simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0.
+ econstructor. split. apply exec_straight_one. simpl; eauto. auto.
+ split. simpl in H0. FuncInv. simpl.
+ generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero).
+ intros [A B]. rewrite A. subst b. simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto.
+ intros. unfold compare_ints. repeat SOther.
+Qed.
+
+(** Translation of arithmetic operations. *)
+
+(*
+Ltac TranslOpSimpl :=
+ match goal with
+ | |- exists rs' : regset,
+ exec_straight ?c ?rs ?m ?k rs' ?m /\
+ agree (Regmap.set ?res ?v ?ms) ?sp rs' =>
+ (exists (nextinstr (rs#(ireg_of res) <- v));
+ split;
+ [ apply exec_straight_one;
+ [ repeat (rewrite (ireg_val ms sp rs); auto); reflexivity
+ | reflexivity ]
+ | auto with ppcgen ])
+ ||
+ (exists (nextinstr (rs#(freg_of res) <- v));
+ split;
+ [ apply exec_straight_one;
+ [ repeat (rewrite (freg_val ms sp rs); auto); reflexivity
+ | reflexivity ]
+ | auto with ppcgen ])
+ end.
+*)
+
+Ltac ArgsInv :=
+ match goal with
+ | [ H: Error _ = OK _ |- _ ] => discriminate
+ | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args; ArgsInv
+ | [ H: bind _ _ = OK _ |- _ ] => monadInv H; ArgsInv
+ | [ H: assertion _ = OK _ |- _ ] => monadInv H; subst; ArgsInv
+ | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *; clear H; ArgsInv
+ | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *; clear H; ArgsInv
+ | _ => idtac
+ end.
+
+Ltac TranslOp :=
+ econstructor; split;
+ [ apply exec_straight_one; [ simpl; eauto | auto ]
+ | split; [ repeat SRes | intros; repeat SOther ]].
+
+(* Move elsewhere *)
+
+Lemma transl_op_correct:
+ forall op args res k c (rs: regset) m v,
+ transl_op op args res k = OK c ->
+ eval_operation ge (rs#ESP) op (map rs (map preg_of args)) = Some v ->
+ exists rs',
+ exec_straight c rs m k rs' m
+ /\ rs'#(preg_of res) = v
+ /\ forall r,
+ match op with Omove => important_preg r = true | _ => nontemp_preg r = true end ->
+ r <> preg_of res -> rs' r = rs r.
+Proof.
+ intros until v; intros TR EV.
+ rewrite <- (eval_operation_weaken _ _ _ _ EV).
+ destruct op; simpl in TR; ArgsInv; try (TranslOp; fail).
+(* move *)
+ exploit mk_mov_correct; eauto. intros [rs2 [A [B C]]].
+ exists rs2. split. eauto. split. simpl. auto. auto.
+(* cast8signed *)
+ eapply mk_intconv_correct; eauto.
+(* cast8unsigned *)
+ eapply mk_intconv_correct; eauto.
+(* cast16signed *)
+ eapply mk_intconv_correct; eauto.
+(* cast16unsigned *)
+ eapply mk_intconv_correct; eauto.
+(* div *)
+ eapply mk_div_correct; eauto. intros. simpl. eauto.
+(* divu *)
+ eapply mk_div_correct; eauto. intros. simpl. eauto.
+(* mod *)
+ eapply mk_mod_correct; eauto. intros. simpl. eauto.
+(* modu *)
+ eapply mk_mod_correct; eauto. intros. simpl. eauto.
+(* shl *)
+ eapply mk_shift_correct; eauto.
+(* shr *)
+ eapply mk_shift_correct; eauto.
+(* shrximm *)
+ remember (rs x0) as v1. FuncInv.
+ remember (Int.ltu i (Int.repr 31)) as L. destruct L; inv EV.
+ simpl. replace (Int.ltu i Int.iwordsize) with true.
+ apply mk_shrximm_correct; auto.
+ unfold Int.ltu. rewrite zlt_true; auto.
+ generalize (Int.ltu_inv _ _ (sym_equal HeqL)).
+ assert (Int.unsigned (Int.repr 31) < Int.unsigned Int.iwordsize) by (compute; auto).
+ omega.
+(* shru *)
+ eapply mk_shift_correct; eauto.
+(* lea *)
+ exploit transl_addressing_mode_correct; eauto. intros EA.
+ rewrite (eval_addressing_weaken _ _ _ _ EV). rewrite <- EA.
+ TranslOp.
+(* condition *)
+ remember (eval_condition c0 rs ## (preg_of ## args)) as ob. destruct ob; inv EV.
+ rewrite (eval_condition_weaken _ _ (sym_equal Heqob)).
+ exploit transl_cond_correct; eauto. intros [rs2 [P [Q R]]].
+ exists (nextinstr (rs2#ECX <- Vundef #EDX <- Vundef #x <- v)).
+ split. eapply exec_straight_trans. eauto.
+ apply exec_straight_one. simpl. rewrite Q. destruct b; inv H0; auto. auto.
+ split. repeat SRes. destruct b; inv H0; auto.
+ intros. repeat SOther.
+Qed.
+
+(** Translation of memory loads. *)
+
+Lemma transl_load_correct:
+ forall chunk addr args dest k c (rs: regset) m a v,
+ transl_load chunk addr args dest k = OK c ->
+ 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
+ /\ rs'#(preg_of dest) = v
+ /\ forall r, nontemp_preg r = true -> r <> preg_of dest -> rs'#r = rs#r.
+Proof.
+ unfold transl_load; intros. monadInv H.
+ exploit transl_addressing_mode_correct; eauto. intro EA.
+ set (rs2 := nextinstr_nf (rs#(preg_of dest) <- v)).
+ assert (exec_load ge chunk m x rs (preg_of dest) = Next rs2 m).
+ unfold exec_load. rewrite EA. rewrite H1. auto.
+ 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.
+ exists rs2. split.
+ destruct chunk; ArgsInv; apply exec_straight_one; simpl; auto.
+ split. unfold rs2. rewrite nextinstr_nf_inv1. SRes. apply preg_of_important.
+ intros. unfold rs2. repeat SOther.
+Qed.
+
+Lemma transl_store_correct:
+ 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#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'
+ /\ forall r, nontemp_preg r = true -> rs'#r = rs#r.
+Proof.
+ unfold transl_store; intros. monadInv H.
+ exploit transl_addressing_mode_correct; eauto. intro EA. rewrite <- EA in H1.
+ destruct chunk; ArgsInv.
+(* int8signed *)
+ eapply mk_smallstore_correct; eauto.
+ intros. simpl. unfold exec_store.
+ destruct (eval_addrmode ge addr0 rs0); simpl; auto. rewrite Mem.store_signed_unsigned_8; auto.
+(* int8unsigned *)
+ eapply mk_smallstore_correct; eauto.
+(* int16signed *)
+ eapply mk_smallstore_correct; eauto.
+ intros. simpl. unfold exec_store.
+ destruct (eval_addrmode ge addr0 rs0); simpl; auto. rewrite Mem.store_signed_unsigned_16; auto.
+(* int16unsigned *)
+ eapply mk_smallstore_correct; eauto.
+(* int32 *)
+ econstructor; split.
+ apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
+ intros. SOther.
+(* float32 *)
+ econstructor; split.
+ apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
+ intros. SOther.
+(* float64 *)
+ econstructor; split.
+ apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
+ intros. SOther.
+Qed.
+
+End STRAIGHTLINE.
+
diff --git a/ia32/Asmgenretaddr.v b/ia32/Asmgenretaddr.v
new file mode 100644
index 0000000..048f5a2
--- /dev/null
+++ b/ia32/Asmgenretaddr.v
@@ -0,0 +1,244 @@
+(* *********************************************************************)
+(* *)
+(* 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
+ concrete semantics for Mach (module [Machconcr]) to determine the
+ return addresses that are stored in activation records. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Errors.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+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 = 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 :=
+ 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.
+*)
+Ltac IsTail :=
+ eauto with ppcretaddr;
+ match goal with
+ | [ |- is_tail _ (_ :: _) ] => constructor; IsTail
+ | [ H: Error _ = OK _ |- _ ] => discriminate
+ | [ H: OK _ = OK _ |- _ ] => inversion H; subst; 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_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.
+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.
+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.
+
+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 : 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 k c, transl_instr f i 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 tc1 tc2, transl_code f c1 = OK tc1 -> transl_code f c2 = OK tc2 ->
+ is_tail tc1 tc2.
+Proof.
+ induction 1; simpl; intros.
+ replace tc2 with tc1 by congruence. constructor.
+ IsTail. apply is_tail_trans with x. eauto. eapply transl_instr_tail; eauto.
+Qed.
+
+Lemma return_address_exists:
+ forall f c, is_tail c f.(fn_code) ->
+ exists ra, return_address_offset f c ra.
+Proof.
+ intros.
+ caseEq (transf_function f). intros tf TF.
+ caseEq (transl_code f c). intros tc TC.
+ assert (is_tail tc tf).
+ unfold transf_function in TF. monadInv TF.
+ destruct (zlt (list_length_z x) Int.max_unsigned); monadInv EQ0.
+ IsTail. eapply transl_code_tail; eauto.
+ destruct (is_tail_code_tail _ _ H0) as [ofs A].
+ exists (Int.repr ofs). constructor; intros. congruence.
+ intros. exists (Int.repr 0). constructor; intros; congruence.
+ intros. exists (Int.repr 0). constructor; intros; congruence.
+Qed.
+
+
diff --git a/ia32/CBuiltins.ml b/ia32/CBuiltins.ml
new file mode 100644
index 0000000..d077fe5
--- /dev/null
+++ b/ia32/CBuiltins.ml
@@ -0,0 +1,28 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Processor-dependent builtin C functions *)
+
+open Cparser
+open C
+
+let builtins = {
+ Builtins.typedefs = [];
+ Builtins.functions = [
+ (* Float arithmetic *)
+ "__builtin_fsqrt",
+ (TFloat(FDouble, []), [TFloat(FDouble, [])], false);
+ ]
+}
diff --git a/ia32/ConstpropOp.v b/ia32/ConstpropOp.v
new file mode 100644
index 0000000..7dfa046
--- /dev/null
+++ b/ia32/ConstpropOp.v
@@ -0,0 +1,1010 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Static analysis and strength reduction for operators
+ and conditions. This is the machine-dependent part of [Constprop]. *)
+
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Op.
+Require Import Registers.
+
+(** * Static analysis *)
+
+(** To each pseudo-register at each program point, the static analysis
+ associates a compile-time approximation taken from the following set. *)
+
+Inductive approx : Type :=
+ | Novalue: approx (** No value possible, code is unreachable. *)
+ | Unknown: approx (** All values are possible,
+ no compile-time information is available. *)
+ | I: int -> approx (** A known integer value. *)
+ | F: float -> approx (** A known floating-point value. *)
+ | S: ident -> int -> approx.
+ (** The value is the address of the given global
+ symbol plus the given integer offset. *)
+
+(** We now define the abstract interpretations of conditions and operators
+ over this set of approximations. For instance, the abstract interpretation
+ of the operator [Oaddf] applied to two expressions [a] and [b] is
+ [F(Float.add f g)] if [a] and [b] have static approximations [Vfloat f]
+ and [Vfloat g] respectively, and [Unknown] otherwise.
+
+ The static approximations are defined by large pattern-matchings over
+ the approximations of the results. We write these matchings in the
+ indirect style described in file [Cmconstr] to avoid excessive
+ duplication of cases in proofs. *)
+
+(*
+Definition eval_static_condition (cond: condition) (vl: list approx) :=
+ match cond, vl with
+ | Ccomp c, I n1 :: I n2 :: nil => Some(Int.cmp c n1 n2)
+ | Ccompu c, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 n2)
+ | Ccompimm c n, I n1 :: nil => Some(Int.cmp c n1 n)
+ | Ccompuimm c n, I n1 :: nil => Some(Int.cmpu c n1 n)
+ | Ccompf c, F n1 :: F n2 :: nil => Some(Float.cmp c n1 n2)
+ | Cnotcompf c, F n1 :: F n2 :: nil => Some(negb(Float.cmp c n1 n2))
+ | Cmaskzero n, I n1 :: nil => Some(Int.eq (Int.and n1 n) Int.zero)
+ | Cmasknotzero n, n1::nil => Some(negb(Int.eq (Int.and n1 n) Int.zero))
+ | _, _ => None
+ end.
+*)
+
+Inductive eval_static_condition_cases: forall (cond: condition) (vl: list approx), Type :=
+ | eval_static_condition_case1:
+ forall c n1 n2,
+ eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil)
+ | eval_static_condition_case2:
+ forall c n1 n2,
+ eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil)
+ | eval_static_condition_case3:
+ forall c n n1,
+ eval_static_condition_cases (Ccompimm c n) (I n1 :: nil)
+ | eval_static_condition_case4:
+ forall c n n1,
+ eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil)
+ | eval_static_condition_case5:
+ forall c n1 n2,
+ eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil)
+ | eval_static_condition_case6:
+ forall c n1 n2,
+ eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil)
+ | eval_static_condition_case7:
+ forall n n1,
+ eval_static_condition_cases (Cmaskzero n) (I n1 :: nil)
+ | eval_static_condition_case8:
+ forall n n1,
+ eval_static_condition_cases (Cmasknotzero n) (I n1 :: nil)
+ | eval_static_condition_default:
+ forall (cond: condition) (vl: list approx),
+ eval_static_condition_cases cond vl.
+
+Definition eval_static_condition_match (cond: condition) (vl: list approx) :=
+ match cond as z1, vl as z2 return eval_static_condition_cases z1 z2 with
+ | Ccomp c, I n1 :: I n2 :: nil =>
+ eval_static_condition_case1 c n1 n2
+ | Ccompu c, I n1 :: I n2 :: nil =>
+ eval_static_condition_case2 c n1 n2
+ | Ccompimm c n, I n1 :: nil =>
+ eval_static_condition_case3 c n n1
+ | Ccompuimm c n, I n1 :: nil =>
+ eval_static_condition_case4 c n n1
+ | Ccompf c, F n1 :: F n2 :: nil =>
+ eval_static_condition_case5 c n1 n2
+ | Cnotcompf c, F n1 :: F n2 :: nil =>
+ eval_static_condition_case6 c n1 n2
+ | Cmaskzero n, I n1 :: nil =>
+ eval_static_condition_case7 n n1
+ | Cmasknotzero n, I n1 :: nil =>
+ eval_static_condition_case8 n n1
+ | cond, vl =>
+ eval_static_condition_default cond vl
+ end.
+
+Definition eval_static_condition (cond: condition) (vl: list approx) :=
+ match eval_static_condition_match cond vl with
+ | eval_static_condition_case1 c n1 n2 =>
+ Some(Int.cmp c n1 n2)
+ | eval_static_condition_case2 c n1 n2 =>
+ Some(Int.cmpu c n1 n2)
+ | eval_static_condition_case3 c n n1 =>
+ Some(Int.cmp c n1 n)
+ | eval_static_condition_case4 c n n1 =>
+ Some(Int.cmpu c n1 n)
+ | eval_static_condition_case5 c n1 n2 =>
+ Some(Float.cmp c n1 n2)
+ | eval_static_condition_case6 c n1 n2 =>
+ Some(negb(Float.cmp c n1 n2))
+ | eval_static_condition_case7 n n1 =>
+ Some(Int.eq (Int.and n1 n) Int.zero)
+ | eval_static_condition_case8 n n1 =>
+ Some(negb(Int.eq (Int.and n1 n) Int.zero))
+ | eval_static_condition_default cond vl =>
+ None
+ end.
+
+(*
+Definition eval_static_addressing (addr: addressing) (vl: list approx) :=
+ match op, vl with
+ | Aindexed n, I n1::nil => I (Int.add n1 n)
+ | Aindexed n, S id ofs::nil => S id (Int.add ofs n)
+ | Aindexed2 n, I n1::I n2::nil => I (Int.add (Int.add n1 n2) n)
+ | Aindexed2 n, S id ofs::I n2::nil => S id (Int.add (Int.add ofs n2) n)
+ | Aindexed2 n, I n1::S id ofs::nil => S id (Int.add (Int.add ofs n1) n)
+ | Ascaled sc n, I n1::nil => I (Int.add (Int.mul n1 sc) n)
+ | Aindexed2scaled sc n, I n1::I n2::nil => I (Int.add n1 (Int.add (Int.mul n2 sc) n))
+ | Aindexed2scaled sc n, S id ofs::I n2::nil => S id (Int.add ofs (Int.add (Int.mul n2 sc) n))
+ | Aglobal id ofs, nil => S id ofs
+ | Abased id ofs, I n1::nil => S id (Int.add ofs n1)
+ | Abasedscaled sc id ofs, I n1::nil => S id (Int.add ofs (Int.mul sc n1))
+ | _, _ => Unknown
+ end.
+*)
+
+Inductive eval_static_addressing_cases: forall (addr: addressing) (vl: list approx), Type :=
+ | eval_static_addressing_case1:
+ forall n n1,
+ eval_static_addressing_cases (Aindexed n) (I n1::nil)
+ | eval_static_addressing_case2:
+ forall n id ofs,
+ eval_static_addressing_cases (Aindexed n) (S id ofs::nil)
+ | eval_static_addressing_case3:
+ forall n n1 n2,
+ eval_static_addressing_cases (Aindexed2 n) (I n1::I n2::nil)
+ | eval_static_addressing_case4:
+ forall n id ofs n2,
+ eval_static_addressing_cases (Aindexed2 n) (S id ofs::I n2::nil)
+ | eval_static_addressing_case5:
+ forall n n1 id ofs,
+ eval_static_addressing_cases (Aindexed2 n) (I n1::S id ofs::nil)
+ | eval_static_addressing_case6:
+ forall sc n n1,
+ eval_static_addressing_cases (Ascaled sc n) (I n1::nil)
+ | eval_static_addressing_case7:
+ forall sc n n1 n2,
+ eval_static_addressing_cases (Aindexed2scaled sc n) (I n1::I n2::nil)
+ | eval_static_addressing_case8:
+ forall sc n id ofs n2,
+ eval_static_addressing_cases (Aindexed2scaled sc n) (S id ofs::I n2::nil)
+ | eval_static_addressing_case9:
+ forall id ofs,
+ eval_static_addressing_cases (Aglobal id ofs) (nil)
+ | eval_static_addressing_case10:
+ forall id ofs n1,
+ eval_static_addressing_cases (Abased id ofs) (I n1::nil)
+ | eval_static_addressing_case11:
+ forall sc id ofs n1,
+ eval_static_addressing_cases (Abasedscaled sc id ofs) (I n1::nil)
+ | eval_static_addressing_default:
+ forall (addr: addressing) (vl: list approx),
+ eval_static_addressing_cases addr vl.
+
+Definition eval_static_addressing_match (addr: addressing) (vl: list approx) :=
+ match addr as z1, vl as z2 return eval_static_addressing_cases z1 z2 with
+ | Aindexed n, I n1::nil =>
+ eval_static_addressing_case1 n n1
+ | Aindexed n, S id ofs::nil =>
+ eval_static_addressing_case2 n id ofs
+ | Aindexed2 n, I n1::I n2::nil =>
+ eval_static_addressing_case3 n n1 n2
+ | Aindexed2 n, S id ofs::I n2::nil =>
+ eval_static_addressing_case4 n id ofs n2
+ | Aindexed2 n, I n1::S id ofs::nil =>
+ eval_static_addressing_case5 n n1 id ofs
+ | Ascaled sc n, I n1::nil =>
+ eval_static_addressing_case6 sc n n1
+ | Aindexed2scaled sc n, I n1::I n2::nil =>
+ eval_static_addressing_case7 sc n n1 n2
+ | Aindexed2scaled sc n, S id ofs::I n2::nil =>
+ eval_static_addressing_case8 sc n id ofs n2
+ | Aglobal id ofs, nil =>
+ eval_static_addressing_case9 id ofs
+ | Abased id ofs, I n1::nil =>
+ eval_static_addressing_case10 id ofs n1
+ | Abasedscaled sc id ofs, I n1::nil =>
+ eval_static_addressing_case11 sc id ofs n1
+ | addr, vl =>
+ eval_static_addressing_default addr vl
+ end.
+
+Definition eval_static_addressing (addr: addressing) (vl: list approx) :=
+ match eval_static_addressing_match addr vl with
+ | eval_static_addressing_case1 n n1 =>
+ I (Int.add n1 n)
+ | eval_static_addressing_case2 n id ofs =>
+ S id (Int.add ofs n)
+ | eval_static_addressing_case3 n n1 n2 =>
+ I (Int.add (Int.add n1 n2) n)
+ | eval_static_addressing_case4 n id ofs n2 =>
+ S id (Int.add (Int.add ofs n2) n)
+ | eval_static_addressing_case5 n n1 id ofs =>
+ S id (Int.add (Int.add ofs n1) n)
+ | eval_static_addressing_case6 sc n n1 =>
+ I (Int.add (Int.mul n1 sc) n)
+ | eval_static_addressing_case7 sc n n1 n2 =>
+ I (Int.add n1 (Int.add (Int.mul n2 sc) n))
+ | eval_static_addressing_case8 sc n id ofs n2 =>
+ S id (Int.add ofs (Int.add (Int.mul n2 sc) n))
+ | eval_static_addressing_case9 id ofs =>
+ S id ofs
+ | eval_static_addressing_case10 id ofs n1 =>
+ S id (Int.add ofs n1)
+ | eval_static_addressing_case11 sc id ofs n1 =>
+ S id (Int.add ofs (Int.mul sc n1))
+ | eval_static_addressing_default addr vl =>
+ Unknown
+ end.
+
+(*
+Definition eval_static_operation (op: operation) (vl: list approx) :=
+ match op, vl with
+ | Omove, v1::nil => v1
+ | Ointconst n, nil => I n
+ | Ofloatconst n, nil => F n
+ | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n1)
+ | Ocast8unsigned, I n1 :: nil => I(Int.zero_ext 8 n1)
+ | Ocast16signed, I n1 :: nil => I(Int.sign_ext 16 n1)
+ | Ocast16unsigned, I n1 :: nil => I(Int.zero_ext 16 n1)
+ | Oneg, I n1 :: nil => I(Int.neg n1)
+ | Osub, I n1 :: I n2 :: nil => I(Int.sub n1 n2)
+ | Osub, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 n2)
+ | Omul, I n1 :: I n2 :: nil => I(Int.mul n1 n2)
+ | Omulimm n, I n1 :: nil => I(Int.mul n1 n)
+ | Odiv, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2)
+ | Odivu, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2)
+ | Omod, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.mods n1 n2)
+ | Omodu, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.modu n1 n2)
+ | Oand, I n1 :: I n2 :: nil => I(Int.and n1 n2)
+ | Oandimm n, I n1 :: nil => I(Int.and n1 n)
+ | Oor, I n1 :: I n2 :: nil => I(Int.or n1 n2)
+ | Oorimm n, I n1 :: nil => I(Int.or n1 n)
+ | Oxor, I n1 :: I n2 :: nil => I(Int.xor n1 n2)
+ | Oxorimm n, I n1 :: nil => I(Int.xor n1 n)
+ | Oshl, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shl n1 n2) else Unknown
+ | Oshlimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shl n1 n) else Unknown
+ | Oshr, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shr n1 n2) else Unknown
+ | Oshrimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shr n1 n) else Unknown
+ | Oshrximm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shrx n1 n) else Unknown
+ | Oshru, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shru n1 n2) else Unknown
+ | Oshruimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shru n1 n) else Unknown
+ | Ororimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.ror n1 n) else Unknown
+ | Olea mode, vl => eval_static_addressing mode vl
+ | Onegf, F n1 :: nil => F(Float.neg n1)
+ | Oabsf, F n1 :: nil => F(Float.abs n1)
+ | Oaddf, F n1 :: F n2 :: nil => F(Float.add n1 n2)
+ | Osubf, F n1 :: F n2 :: nil => F(Float.sub n1 n2)
+ | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2)
+ | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2)
+ | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1)
+ | Ointoffloat, F n1 :: nil => I(Float.intoffloat n1)
+ | Ofloatofint, I n1 :: nil => F(Float.floatofint n1)
+ | Ocmp c, vl => match eval_static_condition c vl with None => Unknown | Some b => I(if b then Int.one else Int.zero) end
+ | _, _ => Unknown
+ end.
+*)
+
+Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx), Type :=
+ | eval_static_operation_case1:
+ forall v1,
+ eval_static_operation_cases (Omove) (v1::nil)
+ | eval_static_operation_case2:
+ forall n,
+ eval_static_operation_cases (Ointconst n) (nil)
+ | eval_static_operation_case3:
+ forall n,
+ eval_static_operation_cases (Ofloatconst n) (nil)
+ | eval_static_operation_case4:
+ forall n1,
+ eval_static_operation_cases (Ocast8signed) (I n1 :: nil)
+ | eval_static_operation_case5:
+ forall n1,
+ eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil)
+ | eval_static_operation_case6:
+ forall n1,
+ eval_static_operation_cases (Ocast16signed) (I n1 :: nil)
+ | eval_static_operation_case7:
+ forall n1,
+ eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil)
+ | eval_static_operation_case8:
+ forall n1,
+ eval_static_operation_cases (Oneg) (I n1 :: nil)
+ | eval_static_operation_case9:
+ forall n1 n2,
+ eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil)
+ | eval_static_operation_case10:
+ forall s1 n1 n2,
+ eval_static_operation_cases (Osub) (S s1 n1 :: I n2 :: nil)
+ | eval_static_operation_case11:
+ forall n1 n2,
+ eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil)
+ | eval_static_operation_case12:
+ forall n n1,
+ eval_static_operation_cases (Omulimm n) (I n1 :: nil)
+ | eval_static_operation_case13:
+ forall n1 n2,
+ eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil)
+ | eval_static_operation_case14:
+ forall n1 n2,
+ eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil)
+ | eval_static_operation_case15:
+ forall n1 n2,
+ eval_static_operation_cases (Omod) (I n1 :: I n2 :: nil)
+ | eval_static_operation_case16:
+ forall n1 n2,
+ eval_static_operation_cases (Omodu) (I n1 :: I n2 :: nil)
+ | eval_static_operation_case17:
+ forall n1 n2,
+ eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil)
+ | eval_static_operation_case18:
+ forall n n1,
+ eval_static_operation_cases (Oandimm n) (I n1 :: nil)
+ | eval_static_operation_case19:
+ forall n1 n2,
+ eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil)
+ | eval_static_operation_case20:
+ forall n n1,
+ eval_static_operation_cases (Oorimm n) (I n1 :: nil)
+ | eval_static_operation_case21:
+ forall n1 n2,
+ eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil)
+ | eval_static_operation_case22:
+ forall n n1,
+ eval_static_operation_cases (Oxorimm n) (I n1 :: nil)
+ | eval_static_operation_case23:
+ forall n1 n2,
+ eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil)
+ | eval_static_operation_case24:
+ forall n n1,
+ eval_static_operation_cases (Oshlimm n) (I n1 :: nil)
+ | eval_static_operation_case25:
+ forall n1 n2,
+ eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil)
+ | eval_static_operation_case26:
+ forall n n1,
+ eval_static_operation_cases (Oshrimm n) (I n1 :: nil)
+ | eval_static_operation_case27:
+ forall n n1,
+ eval_static_operation_cases (Oshrximm n) (I n1 :: nil)
+ | eval_static_operation_case28:
+ forall n1 n2,
+ eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil)
+ | eval_static_operation_case29:
+ forall n n1,
+ eval_static_operation_cases (Oshruimm n) (I n1 :: nil)
+ | eval_static_operation_case30:
+ forall n n1,
+ eval_static_operation_cases (Ororimm n) (I n1 :: nil)
+ | eval_static_operation_case31:
+ forall mode vl,
+ eval_static_operation_cases (Olea mode) (vl)
+ | eval_static_operation_case32:
+ forall n1,
+ eval_static_operation_cases (Onegf) (F n1 :: nil)
+ | eval_static_operation_case33:
+ forall n1,
+ eval_static_operation_cases (Oabsf) (F n1 :: nil)
+ | eval_static_operation_case34:
+ forall n1 n2,
+ eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil)
+ | eval_static_operation_case35:
+ forall n1 n2,
+ eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil)
+ | eval_static_operation_case36:
+ forall n1 n2,
+ eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil)
+ | eval_static_operation_case37:
+ forall n1 n2,
+ eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil)
+ | eval_static_operation_case38:
+ forall n1,
+ eval_static_operation_cases (Osingleoffloat) (F n1 :: nil)
+ | eval_static_operation_case39:
+ forall n1,
+ eval_static_operation_cases (Ointoffloat) (F n1 :: nil)
+ | eval_static_operation_case41:
+ forall n1,
+ eval_static_operation_cases (Ofloatofint) (I n1 :: nil)
+ | eval_static_operation_case43:
+ forall c vl,
+ eval_static_operation_cases (Ocmp c) vl
+ | eval_static_operation_default:
+ forall (op: operation) (vl: list approx),
+ eval_static_operation_cases op vl.
+
+Definition eval_static_operation_match (op: operation) (vl: list approx) :=
+ match op as z1, vl as z2 return eval_static_operation_cases z1 z2 with
+ | Omove, v1::nil =>
+ eval_static_operation_case1 v1
+ | Ointconst n, nil =>
+ eval_static_operation_case2 n
+ | Ofloatconst n, nil =>
+ eval_static_operation_case3 n
+ | Ocast8signed, I n1 :: nil =>
+ eval_static_operation_case4 n1
+ | Ocast8unsigned, I n1 :: nil =>
+ eval_static_operation_case5 n1
+ | Ocast16signed, I n1 :: nil =>
+ eval_static_operation_case6 n1
+ | Ocast16unsigned, I n1 :: nil =>
+ eval_static_operation_case7 n1
+ | Oneg, I n1 :: nil =>
+ eval_static_operation_case8 n1
+ | Osub, I n1 :: I n2 :: nil =>
+ eval_static_operation_case9 n1 n2
+ | Osub, S s1 n1 :: I n2 :: nil =>
+ eval_static_operation_case10 s1 n1 n2
+ | Omul, I n1 :: I n2 :: nil =>
+ eval_static_operation_case11 n1 n2
+ | Omulimm n, I n1 :: nil =>
+ eval_static_operation_case12 n n1
+ | Odiv, I n1 :: I n2 :: nil =>
+ eval_static_operation_case13 n1 n2
+ | Odivu, I n1 :: I n2 :: nil =>
+ eval_static_operation_case14 n1 n2
+ | Omod, I n1 :: I n2 :: nil =>
+ eval_static_operation_case15 n1 n2
+ | Omodu, I n1 :: I n2 :: nil =>
+ eval_static_operation_case16 n1 n2
+ | Oand, I n1 :: I n2 :: nil =>
+ eval_static_operation_case17 n1 n2
+ | Oandimm n, I n1 :: nil =>
+ eval_static_operation_case18 n n1
+ | Oor, I n1 :: I n2 :: nil =>
+ eval_static_operation_case19 n1 n2
+ | Oorimm n, I n1 :: nil =>
+ eval_static_operation_case20 n n1
+ | Oxor, I n1 :: I n2 :: nil =>
+ eval_static_operation_case21 n1 n2
+ | Oxorimm n, I n1 :: nil =>
+ eval_static_operation_case22 n n1
+ | Oshl, I n1 :: I n2 :: nil =>
+ eval_static_operation_case23 n1 n2
+ | Oshlimm n, I n1 :: nil =>
+ eval_static_operation_case24 n n1
+ | Oshr, I n1 :: I n2 :: nil =>
+ eval_static_operation_case25 n1 n2
+ | Oshrimm n, I n1 :: nil =>
+ eval_static_operation_case26 n n1
+ | Oshrximm n, I n1 :: nil =>
+ eval_static_operation_case27 n n1
+ | Oshru, I n1 :: I n2 :: nil =>
+ eval_static_operation_case28 n1 n2
+ | Oshruimm n, I n1 :: nil =>
+ eval_static_operation_case29 n n1
+ | Ororimm n, I n1 :: nil =>
+ eval_static_operation_case30 n n1
+ | Olea mode, vl =>
+ eval_static_operation_case31 mode vl
+ | Onegf, F n1 :: nil =>
+ eval_static_operation_case32 n1
+ | Oabsf, F n1 :: nil =>
+ eval_static_operation_case33 n1
+ | Oaddf, F n1 :: F n2 :: nil =>
+ eval_static_operation_case34 n1 n2
+ | Osubf, F n1 :: F n2 :: nil =>
+ eval_static_operation_case35 n1 n2
+ | Omulf, F n1 :: F n2 :: nil =>
+ eval_static_operation_case36 n1 n2
+ | Odivf, F n1 :: F n2 :: nil =>
+ eval_static_operation_case37 n1 n2
+ | Osingleoffloat, F n1 :: nil =>
+ eval_static_operation_case38 n1
+ | Ointoffloat, F n1 :: nil =>
+ eval_static_operation_case39 n1
+ | Ofloatofint, I n1 :: nil =>
+ eval_static_operation_case41 n1
+ | Ocmp c, vl =>
+ eval_static_operation_case43 c vl
+ | op, vl =>
+ eval_static_operation_default op vl
+ end.
+
+Definition eval_static_operation (op: operation) (vl: list approx) :=
+ match eval_static_operation_match op vl with
+ | eval_static_operation_case1 v1 =>
+ v1
+ | eval_static_operation_case2 n =>
+ I n
+ | eval_static_operation_case3 n =>
+ F n
+ | eval_static_operation_case4 n1 =>
+ I(Int.sign_ext 8 n1)
+ | eval_static_operation_case5 n1 =>
+ I(Int.zero_ext 8 n1)
+ | eval_static_operation_case6 n1 =>
+ I(Int.sign_ext 16 n1)
+ | eval_static_operation_case7 n1 =>
+ I(Int.zero_ext 16 n1)
+ | eval_static_operation_case8 n1 =>
+ I(Int.neg n1)
+ | eval_static_operation_case9 n1 n2 =>
+ I(Int.sub n1 n2)
+ | eval_static_operation_case10 s1 n1 n2 =>
+ S s1 (Int.sub n1 n2)
+ | eval_static_operation_case11 n1 n2 =>
+ I(Int.mul n1 n2)
+ | eval_static_operation_case12 n n1 =>
+ I(Int.mul n1 n)
+ | eval_static_operation_case13 n1 n2 =>
+ if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2)
+ | eval_static_operation_case14 n1 n2 =>
+ if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2)
+ | eval_static_operation_case15 n1 n2 =>
+ if Int.eq n2 Int.zero then Unknown else I(Int.mods n1 n2)
+ | eval_static_operation_case16 n1 n2 =>
+ if Int.eq n2 Int.zero then Unknown else I(Int.modu n1 n2)
+ | eval_static_operation_case17 n1 n2 =>
+ I(Int.and n1 n2)
+ | eval_static_operation_case18 n n1 =>
+ I(Int.and n1 n)
+ | eval_static_operation_case19 n1 n2 =>
+ I(Int.or n1 n2)
+ | eval_static_operation_case20 n n1 =>
+ I(Int.or n1 n)
+ | eval_static_operation_case21 n1 n2 =>
+ I(Int.xor n1 n2)
+ | eval_static_operation_case22 n n1 =>
+ I(Int.xor n1 n)
+ | eval_static_operation_case23 n1 n2 =>
+ if Int.ltu n2 Int.iwordsize then I(Int.shl n1 n2) else Unknown
+ | eval_static_operation_case24 n n1 =>
+ if Int.ltu n Int.iwordsize then I(Int.shl n1 n) else Unknown
+ | eval_static_operation_case25 n1 n2 =>
+ if Int.ltu n2 Int.iwordsize then I(Int.shr n1 n2) else Unknown
+ | eval_static_operation_case26 n n1 =>
+ if Int.ltu n Int.iwordsize then I(Int.shr n1 n) else Unknown
+ | eval_static_operation_case27 n n1 =>
+ if Int.ltu n (Int.repr 31) then I(Int.shrx n1 n) else Unknown
+ | eval_static_operation_case28 n1 n2 =>
+ if Int.ltu n2 Int.iwordsize then I(Int.shru n1 n2) else Unknown
+ | eval_static_operation_case29 n n1 =>
+ if Int.ltu n Int.iwordsize then I(Int.shru n1 n) else Unknown
+ | eval_static_operation_case30 n n1 =>
+ if Int.ltu n Int.iwordsize then I(Int.ror n1 n) else Unknown
+ | eval_static_operation_case31 mode vl =>
+ eval_static_addressing mode vl
+ | eval_static_operation_case32 n1 =>
+ F(Float.neg n1)
+ | eval_static_operation_case33 n1 =>
+ F(Float.abs n1)
+ | eval_static_operation_case34 n1 n2 =>
+ F(Float.add n1 n2)
+ | eval_static_operation_case35 n1 n2 =>
+ F(Float.sub n1 n2)
+ | eval_static_operation_case36 n1 n2 =>
+ F(Float.mul n1 n2)
+ | eval_static_operation_case37 n1 n2 =>
+ F(Float.div n1 n2)
+ | eval_static_operation_case38 n1 =>
+ F(Float.singleoffloat n1)
+ | eval_static_operation_case39 n1 =>
+ I(Float.intoffloat n1)
+ | eval_static_operation_case41 n1 =>
+ F(Float.floatofint n1)
+ | eval_static_operation_case43 c vl =>
+ match eval_static_condition c vl with
+ | None => Unknown
+ | Some b => I(if b then Int.one else Int.zero)
+ end
+ | eval_static_operation_default op vl =>
+ Unknown
+ end.
+
+(** * Operator strength reduction *)
+
+(** We now define auxiliary functions for strength reduction of
+ operators and addressing modes: replacing an operator with a cheaper
+ one if some of its arguments are statically known. These are again
+ large pattern-matchings expressed in indirect style. *)
+
+Section STRENGTH_REDUCTION.
+
+Variable app: reg -> approx.
+
+Definition intval (r: reg) : option int :=
+ match app r with I n => Some n | _ => None end.
+
+Inductive cond_strength_reduction_cases: condition -> list reg -> Type :=
+ | csr_case1:
+ forall c r1 r2,
+ cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil)
+ | csr_case2:
+ forall c r1 r2,
+ cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil)
+ | csr_default:
+ forall c rl,
+ cond_strength_reduction_cases c rl.
+
+Definition cond_strength_reduction_match (cond: condition) (rl: list reg) :=
+ match cond as x, rl as y return cond_strength_reduction_cases x y with
+ | Ccomp c, r1 :: r2 :: nil =>
+ csr_case1 c r1 r2
+ | Ccompu c, r1 :: r2 :: nil =>
+ csr_case2 c r1 r2
+ | cond, rl =>
+ csr_default cond rl
+ end.
+
+Definition cond_strength_reduction
+ (cond: condition) (args: list reg) : condition * list reg :=
+ match cond_strength_reduction_match cond args with
+ | csr_case1 c r1 r2 =>
+ match intval r1, intval r2 with
+ | Some n, _ =>
+ (Ccompimm (swap_comparison c) n, r2 :: nil)
+ | _, Some n =>
+ (Ccompimm c n, r1 :: nil)
+ | _, _ =>
+ (cond, args)
+ end
+ | csr_case2 c r1 r2 =>
+ match intval r1, intval r2 with
+ | Some n, _ =>
+ (Ccompuimm (swap_comparison c) n, r2 :: nil)
+ | _, Some n =>
+ (Ccompuimm c n, r1 :: nil)
+ | _, _ =>
+ (cond, args)
+ end
+ | csr_default cond args =>
+ (cond, args)
+ end.
+
+(*
+Definition addr_strength_reduction (addr: addressing) (args: list reg) :=
+ match addr, args with
+ | Aindexed ofs, r1 :: nil => (* Aindexed *)
+ | Aindexed2 ofs, r1 :: r2 :: nil => (* Aindexed2 *)
+ | Aindexed2scaled sc ofs, r1 :: r2 :: nil => (* Aindexed2scaled *)
+ | Abased id ofs, r1 :: nil => (* Abased *)
+ | Abasedscaled sc id ofs, r1 :: nil => (* Abasedscaled *)
+ | _, _ => (* default *)
+ end.
+*)
+
+Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg), Type :=
+ | addr_strength_reduction_case1:
+ forall ofs r1,
+ addr_strength_reduction_cases (Aindexed ofs) (r1 :: nil)
+ | addr_strength_reduction_case2:
+ forall ofs r1 r2,
+ addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil)
+ | addr_strength_reduction_case3:
+ forall sc ofs r1 r2,
+ addr_strength_reduction_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil)
+ | addr_strength_reduction_case4:
+ forall id ofs r1,
+ addr_strength_reduction_cases (Abased id ofs) (r1 :: nil)
+ | addr_strength_reduction_case5:
+ forall sc id ofs r1,
+ addr_strength_reduction_cases (Abasedscaled sc id ofs) (r1 :: nil)
+ | addr_strength_reduction_default:
+ forall (addr: addressing) (args: list reg),
+ addr_strength_reduction_cases addr args.
+
+Definition addr_strength_reduction_match (addr: addressing) (args: list reg) :=
+ match addr as z1, args as z2 return addr_strength_reduction_cases z1 z2 with
+ | Aindexed ofs, r1 :: nil =>
+ addr_strength_reduction_case1 ofs r1
+ | Aindexed2 ofs, r1 :: r2 :: nil =>
+ addr_strength_reduction_case2 ofs r1 r2
+ | Aindexed2scaled sc ofs, r1 :: r2 :: nil =>
+ addr_strength_reduction_case3 sc ofs r1 r2
+ | Abased id ofs, r1 :: nil =>
+ addr_strength_reduction_case4 id ofs r1
+ | Abasedscaled sc id ofs, r1 :: nil =>
+ addr_strength_reduction_case5 sc id ofs r1
+ | addr, args =>
+ addr_strength_reduction_default addr args
+ end.
+
+Definition addr_strength_reduction (addr: addressing) (args: list reg) :=
+ match addr_strength_reduction_match addr args with
+ | addr_strength_reduction_case1 ofs r1 =>
+ (* Aindexed *)
+ match app r1 with
+ | S symb n => (Aglobal symb (Int.add ofs n), nil)
+ | _ => (addr, args)
+ end
+ | addr_strength_reduction_case2 ofs r1 r2 =>
+ (* Aindexed2 *)
+ match app r1, app r2 with
+ | S symb n1, I n2 => (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil)
+ | I n1, S symb n2 => (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil)
+ | S symb n1, _ => (Abased symb (Int.add n1 ofs), r2 :: nil)
+ | _, S symb n2 => (Abased symb (Int.add n2 ofs), r1 :: nil)
+ | I n1, _ => (Aindexed (Int.add n1 ofs), r2 :: nil)
+ | _, I n2 => (Aindexed (Int.add n2 ofs), r1 :: nil)
+ | _, _ => (addr, args)
+ end
+ | addr_strength_reduction_case3 sc ofs r1 r2 =>
+ (* Aindexed2scaled *)
+ match app r1, app r2 with
+ | S symb n1, I n2 => (Aglobal symb (Int.add (Int.add n1 (Int.mul n2 sc)) ofs), nil)
+ | S symb n1, _ => (Abasedscaled sc symb (Int.add n1 ofs), r2 :: nil)
+ | _, I n2 => (Aindexed (Int.add (Int.mul n2 sc) ofs), r1 :: nil)
+ | _, _ => (addr, args)
+ end
+ | addr_strength_reduction_case4 id ofs r1 =>
+ (* Abased *)
+ match app r1 with
+ | I n1 => (Aglobal id (Int.add ofs n1), nil)
+ | _ => (addr, args)
+ end
+ | addr_strength_reduction_case5 sc id ofs r1 =>
+ (* Abasedscaled *)
+ match app r1 with
+ | I n1 => (Aglobal id (Int.add ofs (Int.mul sc n1)), nil)
+ | _ => (addr, args)
+ end
+ | addr_strength_reduction_default addr args =>
+ (addr, args)
+ end.
+
+Definition make_addimm (n: int) (r: reg) :=
+ if Int.eq n Int.zero
+ then (Omove, r :: nil)
+ else (Oaddimm n, r :: nil).
+
+Definition make_shlimm (n: int) (r: reg) :=
+ if Int.eq n Int.zero
+ then (Omove, r :: nil)
+ else (Oshlimm n, r :: nil).
+
+Definition make_shrimm (n: int) (r: reg) :=
+ if Int.eq n Int.zero
+ then (Omove, r :: nil)
+ else (Oshrimm n, r :: nil).
+
+Definition make_shruimm (n: int) (r: reg) :=
+ if Int.eq n Int.zero
+ then (Omove, r :: nil)
+ else (Oshruimm n, r :: nil).
+
+Definition make_mulimm (n: int) (r: reg) :=
+ if Int.eq n Int.zero then
+ (Ointconst Int.zero, nil)
+ else if Int.eq n Int.one then
+ (Omove, r :: nil)
+ else
+ match Int.is_power2 n with
+ | Some l => make_shlimm l r
+ | None => (Omulimm n, r :: nil)
+ end.
+
+Definition make_andimm (n: int) (r: reg) :=
+ if Int.eq n Int.zero
+ then (Ointconst Int.zero, nil)
+ else if Int.eq n Int.mone then (Omove, r :: nil)
+ else (Oandimm n, r :: nil).
+
+Definition make_orimm (n: int) (r: reg) :=
+ if Int.eq n Int.zero then (Omove, r :: nil)
+ else if Int.eq n Int.mone then (Ointconst Int.mone, nil)
+ else (Oorimm n, r :: nil).
+
+Definition make_xorimm (n: int) (r: reg) :=
+ if Int.eq n Int.zero
+ then (Omove, r :: nil)
+ else (Oxorimm n, r :: nil).
+
+(*
+Definition op_strength_reduction (op: operation) (args: list reg) :=
+ match op, args with
+ | Osub, r1 :: r2 :: nil => (* Osub *)
+ | Omul, r1 :: r2 :: nil => (* Omul *)
+ | Odiv, r1 :: r2 :: nil => (* Odiv *)
+ | Odivu, r1 :: r2 :: nil => (* Odivu *)
+ | Omodu, r1 :: r2 :: nil => (* Omodu *)
+ | Oand, r1 :: r2 :: nil => (* Oand *)
+ | Oor, r1 :: r2 :: nil => (* Oor *)
+ | Oxor, r1 :: r2 :: nil => (* Oxor *)
+ | Oshl, r1 :: r2 :: nil => (* Oshl *)
+ | Oshr, r1 :: r2 :: nil => (* Oshr *)
+ | Oshru, r1 :: r2 :: nil => (* Oshru *)
+ | Olea addr, args => (* Olea *)
+ | Ocmp c, args => (* Ocmp *)
+ | _, _ => (* default *)
+ end.
+*)
+
+Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg), Type :=
+ | op_strength_reduction_case2:
+ forall r1 r2,
+ op_strength_reduction_cases (Osub) (r1 :: r2 :: nil)
+ | op_strength_reduction_case3:
+ forall r1 r2,
+ op_strength_reduction_cases (Omul) (r1 :: r2 :: nil)
+ | op_strength_reduction_case4:
+ forall r1 r2,
+ op_strength_reduction_cases (Odiv) (r1 :: r2 :: nil)
+ | op_strength_reduction_case5:
+ forall r1 r2,
+ op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil)
+ | op_strength_reduction_case7:
+ forall r1 r2,
+ op_strength_reduction_cases (Omodu) (r1 :: r2 :: nil)
+ | op_strength_reduction_case8:
+ forall r1 r2,
+ op_strength_reduction_cases (Oand) (r1 :: r2 :: nil)
+ | op_strength_reduction_case9:
+ forall r1 r2,
+ op_strength_reduction_cases (Oor) (r1 :: r2 :: nil)
+ | op_strength_reduction_case10:
+ forall r1 r2,
+ op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil)
+ | op_strength_reduction_case11:
+ forall r1 r2,
+ op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil)
+ | op_strength_reduction_case12:
+ forall r1 r2,
+ op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil)
+ | op_strength_reduction_case13:
+ forall r1 r2,
+ op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil)
+ | op_strength_reduction_case14:
+ forall addr args,
+ op_strength_reduction_cases (Olea addr) (args)
+ | op_strength_reduction_case15:
+ forall c args,
+ op_strength_reduction_cases (Ocmp c) (args)
+ | op_strength_reduction_default:
+ forall (op: operation) (args: list reg),
+ op_strength_reduction_cases op args.
+
+Definition op_strength_reduction_match (op: operation) (args: list reg) :=
+ match op as z1, args as z2 return op_strength_reduction_cases z1 z2 with
+ | Osub, r1 :: r2 :: nil =>
+ op_strength_reduction_case2 r1 r2
+ | Omul, r1 :: r2 :: nil =>
+ op_strength_reduction_case3 r1 r2
+ | Odiv, r1 :: r2 :: nil =>
+ op_strength_reduction_case4 r1 r2
+ | Odivu, r1 :: r2 :: nil =>
+ op_strength_reduction_case5 r1 r2
+ | Omodu, r1 :: r2 :: nil =>
+ op_strength_reduction_case7 r1 r2
+ | Oand, r1 :: r2 :: nil =>
+ op_strength_reduction_case8 r1 r2
+ | Oor, r1 :: r2 :: nil =>
+ op_strength_reduction_case9 r1 r2
+ | Oxor, r1 :: r2 :: nil =>
+ op_strength_reduction_case10 r1 r2
+ | Oshl, r1 :: r2 :: nil =>
+ op_strength_reduction_case11 r1 r2
+ | Oshr, r1 :: r2 :: nil =>
+ op_strength_reduction_case12 r1 r2
+ | Oshru, r1 :: r2 :: nil =>
+ op_strength_reduction_case13 r1 r2
+ | Olea addr, args =>
+ op_strength_reduction_case14 addr args
+ | Ocmp c, args =>
+ op_strength_reduction_case15 c args
+ | op, args =>
+ op_strength_reduction_default op args
+ end.
+
+(** We must be careful to preserve 2-address constraints over the
+ RTL code, which means that commutative operations cannot
+ be specialized if their first argument is a constant. *)
+
+Definition op_strength_reduction (op: operation) (args: list reg) :=
+ match op_strength_reduction_match op args with
+ | op_strength_reduction_case2 r1 r2 =>
+ (* Osub *)
+ match intval r2 with
+ | Some n => make_addimm (Int.neg n) r1
+ | _ => (op, args)
+ end
+ | op_strength_reduction_case3 r1 r2 =>
+ (* Omul *)
+ match intval r2 with
+ | Some n => make_mulimm n r1
+ | _ => (op, args)
+ end
+ | op_strength_reduction_case4 r1 r2 =>
+ (* Odiv *)
+ match intval r2 with
+ | Some n =>
+ match Int.is_power2 n with
+ | Some l => if Int.ltu l (Int.repr 31)
+ then (Oshrximm l, r1 :: nil)
+ else (op, args)
+ | None => (op, args)
+ end
+ | None =>
+ (op, args)
+ end
+ | op_strength_reduction_case5 r1 r2 =>
+ (* Odivu *)
+ match intval r2 with
+ | Some n =>
+ match Int.is_power2 n with
+ | Some l => make_shruimm l r1
+ | None => (op, args)
+ end
+ | None =>
+ (op, args)
+ end
+ | op_strength_reduction_case7 r1 r2 =>
+ (* Omodu *)
+ match intval r2 with
+ | Some n =>
+ match Int.is_power2 n with
+ | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil)
+ | None => (op, args)
+ end
+ | None =>
+ (op, args)
+ end
+ | op_strength_reduction_case8 r1 r2 =>
+ (* Oand *)
+ match intval r2 with
+ | Some n => make_andimm n r1
+ | _ => (op, args)
+ end
+ | op_strength_reduction_case9 r1 r2 =>
+ (* Oor *)
+ match intval r2 with
+ | Some n => make_orimm n r1
+ | _ => (op, args)
+ end
+ | op_strength_reduction_case10 r1 r2 =>
+ (* Oxor *)
+ match intval r2 with
+ | Some n => make_xorimm n r1
+ | _ => (op, args)
+ end
+ | op_strength_reduction_case11 r1 r2 =>
+ (* Oshl *)
+ match intval r2 with
+ | Some n =>
+ if Int.ltu n Int.iwordsize
+ then make_shlimm n r1
+ else (op, args)
+ | _ => (op, args)
+ end
+ | op_strength_reduction_case12 r1 r2 =>
+ (* Oshr *)
+ match intval r2 with
+ | Some n =>
+ if Int.ltu n Int.iwordsize
+ then make_shrimm n r1
+ else (op, args)
+ | _ => (op, args)
+ end
+ | op_strength_reduction_case13 r1 r2 =>
+ (* Oshru *)
+ match intval r2 with
+ | Some n =>
+ if Int.ltu n Int.iwordsize
+ then make_shruimm n r1
+ else (op, args)
+ | _ => (op, args)
+ end
+ | op_strength_reduction_case14 addr args =>
+ (* Olea *)
+ let (addr', args') := addr_strength_reduction addr args in
+ (Olea addr', args')
+ | op_strength_reduction_case15 c args =>
+ (* Ocmp *)
+ let (c', args') := cond_strength_reduction c args in
+ (Ocmp c', args')
+ | op_strength_reduction_default op args =>
+ (* default *)
+ (op, args)
+ end.
+
+End STRENGTH_REDUCTION.
diff --git a/ia32/ConstpropOpproof.v b/ia32/ConstpropOpproof.v
new file mode 100644
index 0000000..ea90446
--- /dev/null
+++ b/ia32/ConstpropOpproof.v
@@ -0,0 +1,497 @@
+(* *********************************************************************)
+(* *)
+(* 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 constant propagation (processor-dependent part). *)
+
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Op.
+Require Import Registers.
+Require Import RTL.
+Require Import ConstpropOp.
+Require Import Constprop.
+
+(** * Correctness of the static analysis *)
+
+Section ANALYSIS.
+
+Variable ge: genv.
+
+(** We first show that the dataflow analysis is correct with respect
+ to the dynamic semantics: the approximations (sets of values)
+ of a register at a program point predicted by the static analysis
+ are a superset of the values actually encountered during concrete
+ executions. We formalize this correspondence between run-time values and
+ compile-time approximations by the following predicate. *)
+
+Definition val_match_approx (a: approx) (v: val) : Prop :=
+ match a with
+ | Unknown => True
+ | I p => v = Vint p
+ | F p => v = Vfloat p
+ | S symb ofs => exists b, Genv.find_symbol ge symb = Some b /\ v = Vptr b ofs
+ | _ => False
+ end.
+
+Inductive val_list_match_approx: list approx -> list val -> Prop :=
+ | vlma_nil:
+ val_list_match_approx nil nil
+ | vlma_cons:
+ forall a al v vl,
+ val_match_approx a v ->
+ val_list_match_approx al vl ->
+ val_list_match_approx (a :: al) (v :: vl).
+
+Ltac SimplVMA :=
+ match goal with
+ | H: (val_match_approx (I _) ?v) |- _ =>
+ simpl in H; (try subst v); SimplVMA
+ | H: (val_match_approx (F _) ?v) |- _ =>
+ simpl in H; (try subst v); SimplVMA
+ | H: (val_match_approx (S _ _) ?v) |- _ =>
+ simpl in H;
+ (try (elim H;
+ let b := fresh "b" in let A := fresh in let B := fresh in
+ (intros b [A B]; subst v; clear H)));
+ SimplVMA
+ | _ =>
+ idtac
+ end.
+
+Ltac InvVLMA :=
+ match goal with
+ | H: (val_list_match_approx nil ?vl) |- _ =>
+ inversion H
+ | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ =>
+ inversion H; SimplVMA; InvVLMA
+ | _ =>
+ idtac
+ end.
+
+(** We then show that [eval_static_operation] is a correct abstract
+ interpretations of [eval_operation]: if the concrete arguments match
+ the given approximations, the concrete results match the
+ approximations returned by [eval_static_operation]. *)
+
+Lemma eval_static_condition_correct:
+ forall cond al vl b,
+ val_list_match_approx al vl ->
+ eval_static_condition cond al = Some b ->
+ eval_condition cond vl = Some b.
+Proof.
+ intros until b.
+ unfold eval_static_condition.
+ case (eval_static_condition_match cond al); intros;
+ InvVLMA; simpl; congruence.
+Qed.
+
+Lemma eval_static_addressing_correct:
+ forall addr sp al vl v,
+ val_list_match_approx al vl ->
+ eval_addressing ge sp addr vl = Some v ->
+ val_match_approx (eval_static_addressing addr al) v.
+Proof.
+ intros until v. unfold eval_static_addressing.
+ case (eval_static_addressing_match addr al); intros;
+ InvVLMA; simpl in *; FuncInv; try congruence.
+ inv H4. exists b0; auto.
+ inv H4. inv H14. exists b0; auto.
+ inv H4. inv H13. exists b0; auto.
+ inv H4. inv H14. exists b0; auto.
+ destruct (Genv.find_symbol ge id); inv H0. exists b; auto.
+ inv H4. destruct (Genv.find_symbol ge id); inv H0. exists b; auto.
+ inv H4. destruct (Genv.find_symbol ge id); inv H0.
+ exists b; split; auto. rewrite Int.mul_commut; auto.
+ auto.
+Qed.
+
+Lemma eval_static_operation_correct:
+ forall op sp al vl v,
+ val_list_match_approx al vl ->
+ eval_operation ge sp op vl = Some v ->
+ val_match_approx (eval_static_operation op al) v.
+Proof.
+ intros until v.
+ unfold eval_static_operation.
+ case (eval_static_operation_match op al); intros;
+ InvVLMA; simpl in *; FuncInv; try congruence.
+
+ rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence.
+ rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence.
+
+ rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence.
+ rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence.
+
+ exists b. split. auto. congruence.
+
+ replace n2 with i0. destruct (Int.eq i0 Int.zero).
+ discriminate. injection H0; intro; subst v. simpl. congruence. congruence.
+
+ replace n2 with i0. destruct (Int.eq i0 Int.zero).
+ discriminate. injection H0; intro; subst v. simpl. congruence. congruence.
+
+ replace n2 with i0. destruct (Int.eq i0 Int.zero).
+ discriminate. injection H0; intro; subst v. simpl. congruence. congruence.
+
+ replace n2 with i0. destruct (Int.eq i0 Int.zero).
+ discriminate. injection H0; intro; subst v. simpl. congruence. congruence.
+
+ replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize).
+ injection H0; intro; subst v. simpl. congruence. discriminate. congruence.
+
+ destruct (Int.ltu n Int.iwordsize).
+ injection H0; intro; subst v. simpl. congruence. discriminate.
+
+ replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize).
+ injection H0; intro; subst v. simpl. congruence. discriminate. congruence.
+
+ destruct (Int.ltu n Int.iwordsize).
+ injection H0; intro; subst v. simpl. congruence. discriminate.
+
+ destruct (Int.ltu n (Int.repr 31)).
+ injection H0; intro; subst v. simpl. congruence. discriminate.
+
+ replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize).
+ injection H0; intro; subst v. simpl. congruence. discriminate. congruence.
+
+ destruct (Int.ltu n Int.iwordsize).
+ injection H0; intro; subst v. simpl. congruence. discriminate.
+
+ destruct (Int.ltu n Int.iwordsize).
+ injection H0; intro; subst v. simpl. congruence. discriminate.
+
+ eapply eval_static_addressing_correct; eauto.
+
+ rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence.
+
+ caseEq (eval_static_condition c vl0).
+ intros. generalize (eval_static_condition_correct _ _ _ _ H H1).
+ intro. rewrite H2 in H0.
+ destruct b; injection H0; intro; subst v; simpl; auto.
+ intros; simpl; auto.
+
+ auto.
+Qed.
+
+(** * Correctness of strength reduction *)
+
+(** We now show that strength reduction over operators and addressing
+ modes preserve semantics: the strength-reduced operations and
+ addressings evaluate to the same values as the original ones if the
+ actual arguments match the static approximations used for strength
+ reduction. *)
+
+Section STRENGTH_REDUCTION.
+
+Variable app: reg -> approx.
+Variable sp: val.
+Variable rs: regset.
+Hypothesis MATCH: forall r, val_match_approx (app r) rs#r.
+
+Lemma intval_correct:
+ forall r n,
+ intval app r = Some n -> rs#r = Vint n.
+Proof.
+ intros until n.
+ unfold intval. caseEq (app r); intros; try discriminate.
+ generalize (MATCH r). unfold val_match_approx. rewrite H.
+ congruence.
+Qed.
+
+Lemma cond_strength_reduction_correct:
+ forall cond args,
+ let (cond', args') := cond_strength_reduction app cond args in
+ eval_condition cond' rs##args' = eval_condition cond rs##args.
+Proof.
+ intros. unfold cond_strength_reduction.
+ case (cond_strength_reduction_match cond args); intros.
+ caseEq (intval app r1); intros.
+ simpl. rewrite (intval_correct _ _ H).
+ destruct (rs#r2); auto. rewrite Int.swap_cmp. auto.
+ destruct c; reflexivity.
+ caseEq (intval app r2); intros.
+ simpl. rewrite (intval_correct _ _ H0). auto.
+ auto.
+ caseEq (intval app r1); intros.
+ simpl. rewrite (intval_correct _ _ H).
+ destruct (rs#r2); auto. rewrite Int.swap_cmpu. auto.
+ caseEq (intval app r2); intros.
+ simpl. rewrite (intval_correct _ _ H0). auto.
+ auto.
+ auto.
+Qed.
+
+Ltac KnownApprox :=
+ match goal with
+ | H: ?approx ?r = ?a |- _ =>
+ generalize (MATCH r); rewrite H; intro; clear H; KnownApprox
+ | _ => idtac
+ end.
+
+Lemma addr_strength_reduction_correct:
+ forall addr args,
+ let (addr', args') := addr_strength_reduction app addr args in
+ eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args.
+Proof.
+ intros.
+
+ unfold addr_strength_reduction. destruct (addr_strength_reduction_match addr args).
+
+ generalize (MATCH r1); caseEq (app r1); intros; auto.
+ simpl in H0. destruct H0 as [b [A B]]. simpl. rewrite A; rewrite B.
+ rewrite Int.add_commut; auto.
+
+ generalize (MATCH r1) (MATCH r2); caseEq (app r1); auto; caseEq (app r2); auto;
+ simpl val_match_approx; intros; try contradiction; simpl.
+ rewrite H2. destruct (rs#r1); auto. rewrite Int.add_assoc; auto. rewrite Int.add_assoc; auto.
+ destruct H2 as [b [A B]]. rewrite A; rewrite B.
+ destruct (rs#r1); auto. repeat rewrite Int.add_assoc. decEq. decEq. decEq. apply Int.add_commut.
+ rewrite H1. destruct (rs#r2); auto.
+ rewrite Int.add_assoc; auto. rewrite Int.add_permut. auto.
+ rewrite Int.add_assoc; auto.
+ rewrite H1; rewrite H2. rewrite Int.add_permut. rewrite Int.add_assoc. auto.
+ rewrite H1; rewrite H2. auto.
+ destruct H2 as [b [A B]]. rewrite A; rewrite B. rewrite H1. do 3 decEq. apply Int.add_commut.
+ rewrite H1; auto.
+ rewrite H1; auto.
+ destruct H1 as [b [A B]]. rewrite A; rewrite B. destruct (rs#r2); auto.
+ repeat rewrite Int.add_assoc. do 3 decEq. apply Int.add_commut.
+ destruct H1 as [b [A B]]. rewrite A; rewrite B; rewrite H2. auto.
+ rewrite H2. destruct (rs#r1); auto.
+ destruct H1 as [b [A B]]. destruct H2 as [b' [A' B']].
+ rewrite A; rewrite B; rewrite B'. auto.
+
+ generalize (MATCH r1) (MATCH r2); caseEq (app r1); auto; caseEq (app r2); auto;
+ simpl val_match_approx; intros; try contradiction; simpl.
+ rewrite H2. destruct (rs#r1); auto.
+ rewrite H1; rewrite H2. auto.
+ rewrite H1. auto.
+ destruct H1 as [b [A B]]. rewrite A; rewrite B.
+ destruct (rs#r2); auto. rewrite Int.add_assoc. do 3 decEq. apply Int.add_commut.
+ destruct H1 as [b [A B]]. rewrite A; rewrite B; rewrite H2. rewrite Int.add_assoc. auto.
+ rewrite H2. destruct (rs#r1); auto.
+ destruct H1 as [b [A B]]. destruct H2 as [b' [A' B']].
+ rewrite A; rewrite B; rewrite B'. auto.
+
+ generalize (MATCH r1); caseEq (app r1); auto;
+ simpl val_match_approx; intros; try contradiction; simpl.
+ rewrite H0. auto.
+
+ generalize (MATCH r1); caseEq (app r1); auto;
+ simpl val_match_approx; intros; try contradiction; simpl.
+ rewrite H0. rewrite Int.mul_commut. auto.
+
+ auto.
+Qed.
+
+Lemma make_shlimm_correct:
+ forall n r v,
+ let (op, args) := make_shlimm n r in
+ eval_operation ge sp Oshl (rs#r :: Vint n :: nil) = Some v ->
+ eval_operation ge sp op rs##args = Some v.
+Proof.
+ intros; unfold make_shlimm.
+ generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+ subst n. simpl in *. FuncInv. rewrite Int.shl_zero in H. congruence.
+ simpl in *. auto.
+Qed.
+
+Lemma make_shrimm_correct:
+ forall n r v,
+ let (op, args) := make_shrimm n r in
+ eval_operation ge sp Oshr (rs#r :: Vint n :: nil) = Some v ->
+ eval_operation ge sp op rs##args = Some v.
+Proof.
+ intros; unfold make_shrimm.
+ generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+ subst n. simpl in *. FuncInv. rewrite Int.shr_zero in H. congruence.
+ assumption.
+Qed.
+
+Lemma make_shruimm_correct:
+ forall n r v,
+ let (op, args) := make_shruimm n r in
+ eval_operation ge sp Oshru (rs#r :: Vint n :: nil) = Some v ->
+ eval_operation ge sp op rs##args = Some v.
+Proof.
+ intros; unfold make_shruimm.
+ generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+ subst n. simpl in *. FuncInv. rewrite Int.shru_zero in H. congruence.
+ assumption.
+Qed.
+
+Lemma make_mulimm_correct:
+ forall n r v,
+ let (op, args) := make_mulimm n r in
+ eval_operation ge sp Omul (rs#r :: Vint n :: nil) = Some v ->
+ eval_operation ge sp op rs##args = Some v.
+Proof.
+ intros; unfold make_mulimm.
+ generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+ subst n. simpl in H0. FuncInv. rewrite Int.mul_zero in H. simpl. congruence.
+ generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros.
+ subst n. simpl in H1. simpl. FuncInv. rewrite Int.mul_one in H0. congruence.
+ caseEq (Int.is_power2 n); intros.
+ replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil))
+ with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil)).
+ apply make_shlimm_correct.
+ simpl. generalize (Int.is_power2_range _ _ H1).
+ change (Z_of_nat Int.wordsize) with 32. intro. rewrite H2.
+ destruct rs#r; auto. rewrite (Int.mul_pow2 i0 _ _ H1). auto.
+ exact H2.
+Qed.
+
+Lemma make_andimm_correct:
+ forall n r v,
+ let (op, args) := make_andimm n r in
+ eval_operation ge sp Oand (rs#r :: Vint n :: nil) = Some v ->
+ eval_operation ge sp op rs##args = Some v.
+Proof.
+ intros; unfold make_andimm.
+ generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+ subst n. simpl in *. FuncInv. rewrite Int.and_zero in H. congruence.
+ generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros.
+ subst n. simpl in *. FuncInv. rewrite Int.and_mone in H0. congruence.
+ exact H1.
+Qed.
+
+Lemma make_orimm_correct:
+ forall n r v,
+ let (op, args) := make_orimm n r in
+ eval_operation ge sp Oor (rs#r :: Vint n :: nil) = Some v ->
+ eval_operation ge sp op rs##args = Some v.
+Proof.
+ intros; unfold make_orimm.
+ generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+ subst n. simpl in *. FuncInv. rewrite Int.or_zero in H. congruence.
+ generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros.
+ subst n. simpl in *. FuncInv. rewrite Int.or_mone in H0. congruence.
+ exact H1.
+Qed.
+
+Lemma make_xorimm_correct:
+ forall n r v,
+ let (op, args) := make_xorimm n r in
+ eval_operation ge sp Oxor (rs#r :: Vint n :: nil) = Some v ->
+ eval_operation ge sp op rs##args = Some v.
+Proof.
+ intros; unfold make_xorimm.
+ generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+ subst n. simpl in *. FuncInv. rewrite Int.xor_zero in H. congruence.
+ exact H0.
+Qed.
+
+Lemma op_strength_reduction_correct:
+ forall op args v,
+ let (op', args') := op_strength_reduction app op args in
+ eval_operation ge sp op rs##args = Some v ->
+ eval_operation ge sp op' rs##args' = Some v.
+Proof.
+ intros; unfold op_strength_reduction;
+ case (op_strength_reduction_match op args); intros; simpl List.map.
+ (* Osub *)
+ caseEq (intval app r2); intros.
+ rewrite (intval_correct _ _ H).
+ unfold make_addimm. generalize (Int.eq_spec (Int.neg i) Int.zero).
+ destruct (Int.eq (Int.neg i) (Int.zero)); intros.
+ assert (i = Int.zero). rewrite <- (Int.neg_involutive i). rewrite H0. reflexivity.
+ subst i. simpl in *. destruct (rs#r1); inv H1; rewrite Int.sub_zero_l; auto.
+ simpl in *. destruct (rs#r1); inv H1; rewrite Int.sub_add_opp; auto.
+ auto.
+ (* Omul *)
+ caseEq (intval app r2); intros.
+ rewrite (intval_correct _ _ H). apply make_mulimm_correct.
+ assumption.
+ (* Odiv *)
+ caseEq (intval app r2); intros.
+ caseEq (Int.is_power2 i); intros.
+ caseEq (Int.ltu i0 (Int.repr 31)); intros.
+ rewrite (intval_correct _ _ H) in H2.
+ simpl in *; FuncInv. destruct (Int.eq i Int.zero). congruence.
+ rewrite H1. rewrite (Int.divs_pow2 i1 _ _ H0) in H2. auto.
+ assumption.
+ assumption.
+ assumption.
+ (* Odivu *)
+ caseEq (intval app r2); intros.
+ caseEq (Int.is_power2 i); intros.
+ rewrite (intval_correct _ _ H).
+ replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil))
+ with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil)).
+ apply make_shruimm_correct.
+ simpl. destruct rs#r1; auto.
+ rewrite (Int.is_power2_range _ _ H0).
+ generalize (Int.eq_spec i Int.zero); case (Int.eq i Int.zero); intros.
+ subst i. discriminate.
+ rewrite (Int.divu_pow2 i1 _ _ H0). auto.
+ assumption.
+ assumption.
+ (* Omodu *)
+ caseEq (intval app r2); intros.
+ caseEq (Int.is_power2 i); intros.
+ rewrite (intval_correct _ _ H) in H1.
+ simpl in *; FuncInv. destruct (Int.eq i Int.zero). congruence.
+ rewrite (Int.modu_and i1 _ _ H0) in H1. auto.
+ assumption.
+ assumption.
+
+ (* Oand *)
+ caseEq (intval app r2); intros.
+ rewrite (intval_correct _ _ H). apply make_andimm_correct.
+ assumption.
+ (* Oor *)
+ caseEq (intval app r2); intros.
+ rewrite (intval_correct _ _ H). apply make_orimm_correct.
+ assumption.
+ (* Oxor *)
+ caseEq (intval app r2); intros.
+ rewrite (intval_correct _ _ H). apply make_xorimm_correct.
+ assumption.
+ (* Oshl *)
+ caseEq (intval app r2); intros.
+ caseEq (Int.ltu i Int.iwordsize); intros.
+ rewrite (intval_correct _ _ H). apply make_shlimm_correct.
+ assumption.
+ assumption.
+ (* Oshr *)
+ caseEq (intval app r2); intros.
+ caseEq (Int.ltu i Int.iwordsize); intros.
+ rewrite (intval_correct _ _ H). apply make_shrimm_correct.
+ assumption.
+ assumption.
+ (* Oshru *)
+ caseEq (intval app r2); intros.
+ caseEq (Int.ltu i Int.iwordsize); intros.
+ rewrite (intval_correct _ _ H). apply make_shruimm_correct.
+ assumption.
+ assumption.
+ (* Olea *)
+ generalize (addr_strength_reduction_correct addr args0).
+ destruct (addr_strength_reduction app addr args0) as [addr' args'].
+ intros. simpl in *. congruence.
+ (* Ocmp *)
+ generalize (cond_strength_reduction_correct c args0).
+ destruct (cond_strength_reduction app c args0).
+ simpl. intro. rewrite H. auto.
+ (* default *)
+ assumption.
+Qed.
+
+End STRENGTH_REDUCTION.
+
+End ANALYSIS.
+
diff --git a/ia32/Machregs.v b/ia32/Machregs.v
new file mode 100644
index 0000000..9935efa
--- /dev/null
+++ b/ia32/Machregs.v
@@ -0,0 +1,76 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+
+(** ** Machine registers *)
+
+(** The following type defines the machine registers that can be referenced
+ as locations. These include:
+- Integer registers that can be allocated to RTL pseudo-registers ([Rxx]).
+- Floating-point registers that can be allocated to RTL pseudo-registers
+ ([Fxx]).
+- Two integer registers, not allocatable, reserved as temporaries for
+ spilling and reloading ([IT1, IT2]).
+- Two float registers, not allocatable, reserved as temporaries for
+ spilling and reloading ([FT1, FT2]).
+
+ The type [mreg] does not include special-purpose or reserved
+ machine registers such as the stack pointer and the condition codes. *)
+
+Inductive mreg: Type :=
+ (** Allocatable integer regs *)
+ | AX: mreg | BX: mreg | SI: mreg | DI: mreg | BP: mreg
+ (** Allocatable float regs *)
+ | X0: mreg | X1: mreg | X2: mreg | X3: mreg | X4: mreg | X5: mreg
+ (** Integer temporaries *)
+ | IT1: mreg (* DX *) | IT2: mreg (* CX *)
+ (** Float temporaries *)
+ | FT1: mreg (* X6 *) | FT2: mreg (* X7 *) | FP0: mreg (* top of FP stack *).
+
+Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}.
+Proof. decide equality. Qed.
+
+Definition mreg_type (r: mreg): typ :=
+ match r with
+ | AX => Tint | BX => Tint | SI => Tint | DI => Tint | BP => Tint
+ (** Allocatable float regs *)
+ | X0 => Tfloat | X1 => Tfloat | X2 => Tfloat
+ | X3 => Tfloat | X4 => Tfloat | X5 => Tfloat
+ (** Integer temporaries *)
+ | IT1 => Tint | IT2 => Tint
+ (** Float temporaries *)
+ | FT1 => Tfloat | FT2 => Tfloat | FP0 => Tfloat
+ end.
+
+Open Scope positive_scope.
+
+Module IndexedMreg <: INDEXED_TYPE.
+ Definition t := mreg.
+ Definition eq := mreg_eq.
+ Definition index (r: mreg): positive :=
+ match r with
+ | AX => 1 | BX => 2 | SI => 3 | DI => 4 | BP => 5
+ | X0 => 6 | X1 => 7 | X2 => 8
+ | X3 => 9 | X4 => 10 | X5 => 11
+ | IT1 => 12 | IT2 => 13
+ | FT1 => 14 | FT2 => 15 | FP0 => 16
+ end.
+ Lemma index_inj:
+ forall r1 r2, index r1 = index r2 -> r1 = r2.
+ Proof.
+ destruct r1; destruct r2; simpl; intro; discriminate || reflexivity.
+ Qed.
+End IndexedMreg.
+
diff --git a/ia32/Machregsaux.ml b/ia32/Machregsaux.ml
new file mode 100644
index 0000000..7d6df90
--- /dev/null
+++ b/ia32/Machregsaux.ml
@@ -0,0 +1,40 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Auxiliary functions on machine registers *)
+
+open Machregs
+
+let register_names = [
+ ("AX", AX); ("BX", BX); ("SI", SI); ("DI", DI); ("BP", BP);
+ ("XMM0", X0); ("XMM1", X1); ("XMM2", X2); ("XMM3", X3);
+ ("XMM4", X4); ("XMM5", X5);
+ ("DX", IT1); ("CX", IT2);
+ ("XMM6", FT1); ("XMM7", FT2); ("ST0", FP0)
+]
+
+let name_of_register r =
+ let rec rev_assoc = function
+ | [] -> None
+ | (a, b) :: rem -> if b = r then Some a else rev_assoc rem
+ in rev_assoc register_names
+
+let register_by_name s =
+ try
+ Some(List.assoc (String.uppercase s) register_names)
+ with Not_found ->
+ None
+
+let can_reserve_register r =
+ List.mem r Conventions1.int_callee_save_regs
+ || List.mem r Conventions1.float_callee_save_regs
+
diff --git a/ia32/Machregsaux.mli b/ia32/Machregsaux.mli
new file mode 100644
index 0000000..4cd7902
--- /dev/null
+++ b/ia32/Machregsaux.mli
@@ -0,0 +1,17 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Auxiliary functions on machine registers *)
+
+val name_of_register: Machregs.mreg -> string option
+val register_by_name: string -> Machregs.mreg option
+val can_reserve_register: Machregs.mreg -> bool
diff --git a/ia32/Op.v b/ia32/Op.v
new file mode 100644
index 0000000..ea28845
--- /dev/null
+++ b/ia32/Op.v
@@ -0,0 +1,974 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Operators and addressing modes. The abstract syntax and dynamic
+ semantics for the CminorSel, RTL, LTL and Mach languages depend on the
+ following types, defined in this library:
+- [condition]: boolean conditions for conditional branches;
+- [operation]: arithmetic and logical operations;
+- [addressing]: addressing modes for load and store operations.
+
+ These types are IA32-specific and correspond roughly to what the
+ processor can compute in one instruction. In other terms, these
+ types reflect the state of the program after instruction selection.
+ For a processor-independent set of operations, see the abstract
+ syntax and dynamic semantics of the Cminor language.
+*)
+
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memdata.
+Require Import Memory.
+Require Import Globalenvs.
+
+Set Implicit Arguments.
+
+(** Conditions (boolean-valued operators). *)
+
+Inductive condition : Type :=
+ | Ccomp: comparison -> condition (**r signed integer comparison *)
+ | Ccompu: comparison -> condition (**r unsigned integer comparison *)
+ | Ccompimm: comparison -> int -> condition (**r signed integer comparison with a constant *)
+ | Ccompuimm: comparison -> int -> condition (**r unsigned integer comparison with a constant *)
+ | Ccompf: comparison -> condition (**r floating-point comparison *)
+ | Cnotcompf: comparison -> condition (**r negation of a floating-point comparison *)
+ | Cmaskzero: int -> condition (**r test [(arg & constant) == 0] *)
+ | Cmasknotzero: int -> condition. (**r test [(arg & constant) != 0] *)
+
+(** Addressing modes. [r1], [r2], etc, are the arguments to the
+ addressing. *)
+
+Inductive addressing: Type :=
+ | Aindexed: int -> addressing (**r Address is [r1 + offset] *)
+ | Aindexed2: int -> addressing (**r Address is [r1 + r2 + offset] *)
+ | Ascaled: int -> int -> addressing (**r Address is [r1 * scale + offset] *)
+ | Aindexed2scaled: int -> int -> addressing
+ (**r Address is [r1 + r2 * scale + offset] *)
+ | Aglobal: ident -> int -> addressing (**r Address is [symbol + offset] *)
+ | Abased: ident -> int -> addressing (**r Address is [symbol + offset + r1] *)
+ | Abasedscaled: int -> ident -> int -> addressing (**r Address is [symbol + offset + r1 * scale] *)
+ | Ainstack: int -> addressing. (**r Address is [stack_pointer + offset] *)
+
+(** Arithmetic and logical operations. In the descriptions, [rd] is the
+ result of the operation and [r1], [r2], etc, are the arguments. *)
+
+Inductive operation : Type :=
+ | Omove: operation (**r [rd = r1] *)
+ | Ointconst: int -> operation (**r [rd] is set to the given integer constant *)
+ | Ofloatconst: float -> operation (**r [rd] is set to the given float constant *)
+(*c Integer arithmetic: *)
+ | Ocast8signed: operation (**r [rd] is 8-bit sign extension of [r1] *)
+ | Ocast8unsigned: operation (**r [rd] is 8-bit zero extension of [r1] *)
+ | Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *)
+ | Ocast16unsigned: operation (**r [rd] is 16-bit zero extension of [r1] *)
+ | Oneg: operation (**r [rd = - r1] *)
+ | Osub: operation (**r [rd = r1 - r2] *)
+ | Omul: operation (**r [rd = r1 * r2] *)
+ | Omulimm: int -> operation (**r [rd = r1 * n] *)
+ | Odiv: operation (**r [rd = r1 / r2] (signed) *)
+ | Odivu: operation (**r [rd = r1 / r2] (unsigned) *)
+ | Omod: operation (**r [rd = r1 % r2] (signed) *)
+ | Omodu: operation (**r [rd = r1 % r2] (unsigned) *)
+ | Oand: operation (**r [rd = r1 & r2] *)
+ | Oandimm: int -> operation (**r [rd = r1 & n] *)
+ | Oor: operation (**r [rd = r1 | r2] *)
+ | Oorimm: int -> operation (**r [rd = r1 | n] *)
+ | Oxor: operation (**r [rd = r1 ^ r2] *)
+ | Oxorimm: int -> operation (**r [rd = r1 ^ n] *)
+ | Oshl: operation (**r [rd = r1 << r2] *)
+ | Oshlimm: int -> operation (**r [rd = r1 << n] *)
+ | Oshr: operation (**r [rd = r1 >> r2] (signed) *)
+ | Oshrimm: int -> operation (**r [rd = r1 >> n] (signed) *)
+ | Oshrximm: int -> operation (**r [rd = r1 / 2^n] (signed) *)
+ | Oshru: operation (**r [rd = r1 >> r2] (unsigned) *)
+ | Oshruimm: int -> operation (**r [rd = r1 >> n] (unsigned) *)
+ | Ororimm: int -> operation (**r rotate right immediate *)
+ | Olea: addressing -> operation (**r effective address *)
+(*c Floating-point arithmetic: *)
+ | Onegf: operation (**r [rd = - r1] *)
+ | Oabsf: operation (**r [rd = abs(r1)] *)
+ | Oaddf: operation (**r [rd = r1 + r2] *)
+ | Osubf: operation (**r [rd = r1 - r2] *)
+ | Omulf: operation (**r [rd = r1 * r2] *)
+ | Odivf: operation (**r [rd = r1 / r2] *)
+ | Osingleoffloat: operation (**r [rd] is [r1] truncated to single-precision float *)
+(*c Conversions between int and float: *)
+ | Ointoffloat: operation (**r [rd = signed_int_of_float(r1)] *)
+ | Ofloatofint: operation (**r [rd = float_of_signed_int(r1)] *)
+(*c Boolean tests: *)
+ | Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
+
+(** Derived operators. *)
+
+Definition Oaddrsymbol (id: ident) (ofs: int) : operation := Olea (Aglobal id ofs).
+Definition Oaddimm (n: int) : operation := Olea (Aindexed n).
+
+(** Comparison functions (used in module [CSE]). *)
+
+Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}.
+Proof.
+ generalize Int.eq_dec; intro.
+ assert (forall (x y: ident), {x=y}+{x<>y}). exact peq.
+ decide equality.
+Qed.
+
+Definition eq_operation (x y: operation): {x=y} + {x<>y}.
+Proof.
+ generalize Int.eq_dec; intro.
+ generalize Float.eq_dec; intro.
+ assert (forall (x y: ident), {x=y}+{x<>y}). exact peq.
+ assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality.
+ assert (forall (x y: condition), {x=y}+{x<>y}). decide equality.
+ decide equality.
+ apply eq_addressing.
+Qed.
+
+(** Evaluation of conditions, operators and addressing modes applied
+ to lists of values. Return [None] when the computation is undefined:
+ wrong number of arguments, arguments of the wrong types, undefined
+ operations such as division by zero. [eval_condition] returns a boolean,
+ [eval_operation] and [eval_addressing] return a value. *)
+
+Definition eval_compare_mismatch (c: comparison) : option bool :=
+ match c with Ceq => Some false | Cne => Some true | _ => None end.
+
+Definition eval_compare_null (c: comparison) (n: int) : option bool :=
+ if Int.eq n Int.zero then eval_compare_mismatch c else None.
+
+Definition eval_condition (cond: condition) (vl: list val):
+ option bool :=
+ match cond, vl with
+ | Ccomp c, Vint n1 :: Vint n2 :: nil =>
+ Some (Int.cmp c n1 n2)
+ | Ccomp c, Vptr b1 n1 :: Vptr b2 n2 :: nil =>
+ if eq_block b1 b2
+ then Some (Int.cmp c n1 n2)
+ else eval_compare_mismatch c
+ | Ccomp c, Vptr b1 n1 :: Vint n2 :: nil =>
+ eval_compare_null c n2
+ | Ccomp c, Vint n1 :: Vptr b2 n2 :: nil =>
+ eval_compare_null c n1
+ | Ccompu c, Vint n1 :: Vint n2 :: nil =>
+ Some (Int.cmpu c n1 n2)
+ | Ccompimm c n, Vint n1 :: nil =>
+ Some (Int.cmp c n1 n)
+ | Ccompimm c n, Vptr b1 n1 :: nil =>
+ eval_compare_null c n
+ | Ccompuimm c n, Vint n1 :: nil =>
+ Some (Int.cmpu c n1 n)
+ | Ccompf c, Vfloat f1 :: Vfloat f2 :: nil =>
+ Some (Float.cmp c f1 f2)
+ | Cnotcompf c, Vfloat f1 :: Vfloat f2 :: nil =>
+ Some (negb (Float.cmp c f1 f2))
+ | Cmaskzero n, Vint n1 :: nil =>
+ Some (Int.eq (Int.and n1 n) Int.zero)
+ | Cmasknotzero n, Vint n1 :: nil =>
+ Some (negb (Int.eq (Int.and n1 n) Int.zero))
+ | _, _ =>
+ None
+ end.
+
+Definition offset_sp (sp: val) (delta: int) : option val :=
+ match sp with
+ | Vptr b n => Some (Vptr b (Int.add n delta))
+ | _ => None
+ end.
+
+Definition eval_addressing
+ (F V: Type) (genv: Genv.t F V) (sp: val)
+ (addr: addressing) (vl: list val) : option val :=
+ match addr, vl with
+ | Aindexed n, Vint n1 :: nil =>
+ Some (Vint (Int.add n1 n))
+ | Aindexed n, Vptr b1 n1 :: nil =>
+ Some (Vptr b1 (Int.add n1 n))
+ | Aindexed2 n, Vint n1 :: Vint n2 :: nil =>
+ Some (Vint (Int.add (Int.add n1 n2) n))
+ | Aindexed2 n, Vptr b1 n1 :: Vint n2 :: nil =>
+ Some (Vptr b1 (Int.add (Int.add n1 n2) n))
+ | Aindexed2 n, Vint n1 :: Vptr b2 n2 :: nil =>
+ Some (Vptr b2 (Int.add (Int.add n2 n1) n))
+ | Ascaled sc ofs, Vint n1 :: nil =>
+ Some (Vint (Int.add (Int.mul n1 sc) ofs))
+ | Aindexed2scaled sc ofs, Vint n1 :: Vint n2 :: nil =>
+ Some (Vint (Int.add n1 (Int.add (Int.mul n2 sc) ofs)))
+ | Aindexed2scaled sc ofs, Vptr b1 n1 :: Vint n2 :: nil =>
+ Some (Vptr b1 (Int.add n1 (Int.add (Int.mul n2 sc) ofs)))
+ | Aglobal s ofs, nil =>
+ match Genv.find_symbol genv s with
+ | None => None
+ | Some b => Some (Vptr b ofs)
+ end
+ | Abased s ofs, Vint n1 :: nil =>
+ match Genv.find_symbol genv s with
+ | None => None
+ | Some b => Some (Vptr b (Int.add ofs n1))
+ end
+ | Abasedscaled sc s ofs, Vint n1 :: nil =>
+ match Genv.find_symbol genv s with
+ | None => None
+ | Some b => Some (Vptr b (Int.add ofs (Int.mul n1 sc)))
+ end
+ | Ainstack ofs, nil =>
+ offset_sp sp ofs
+ | _, _ => None
+ end.
+
+Definition eval_operation
+ (F V: Type) (genv: Genv.t F V) (sp: val)
+ (op: operation) (vl: list val): option val :=
+ match op, vl with
+ | Omove, v1::nil => Some v1
+ | Ointconst n, nil => Some (Vint n)
+ | Ofloatconst n, nil => Some (Vfloat n)
+ | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1)
+ | Ocast8unsigned, v1 :: nil => Some (Val.zero_ext 8 v1)
+ | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1)
+ | Ocast16unsigned, v1 :: nil => Some (Val.zero_ext 16 v1)
+ | Oneg, Vint n1 :: nil => Some (Vint (Int.neg n1))
+ | Osub, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub n1 n2))
+ | Osub, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.sub n1 n2))
+ | Osub, Vptr b1 n1 :: Vptr b2 n2 :: nil =>
+ if eq_block b1 b2 then Some (Vint (Int.sub n1 n2)) else None
+ | Omul, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.mul n1 n2))
+ | Omulimm n, Vint n1 :: nil => Some (Vint (Int.mul n1 n))
+ | Odiv, Vint n1 :: Vint n2 :: nil =>
+ if Int.eq n2 Int.zero then None else Some (Vint (Int.divs n1 n2))
+ | Odivu, Vint n1 :: Vint n2 :: nil =>
+ if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2))
+ | Omod, Vint n1 :: Vint n2 :: nil =>
+ if Int.eq n2 Int.zero then None else Some (Vint (Int.mods n1 n2))
+ | Omodu, Vint n1 :: Vint n2 :: nil =>
+ if Int.eq n2 Int.zero then None else Some (Vint (Int.modu n1 n2))
+ | Oand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 n2))
+ | Oandimm n, Vint n1 :: nil => Some (Vint (Int.and n1 n))
+ | Oor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 n2))
+ | Oorimm n, Vint n1 :: nil => Some (Vint (Int.or n1 n))
+ | Oxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 n2))
+ | Oxorimm n, Vint n1 :: nil => Some (Vint (Int.xor n1 n))
+ | Oshl, Vint n1 :: Vint n2 :: nil =>
+ if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shl n1 n2)) else None
+ | Oshlimm n, Vint n1 :: nil =>
+ if Int.ltu n Int.iwordsize then Some (Vint (Int.shl n1 n)) else None
+ | Oshr, Vint n1 :: Vint n2 :: nil =>
+ if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shr n1 n2)) else None
+ | Oshrimm n, Vint n1 :: nil =>
+ if Int.ltu n Int.iwordsize then Some (Vint (Int.shr n1 n)) else None
+ | Oshrximm n, Vint n1 :: nil =>
+ if Int.ltu n (Int.repr 31) then Some (Vint (Int.shrx n1 n)) else None
+ | Oshru, Vint n1 :: Vint n2 :: nil =>
+ if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shru n1 n2)) else None
+ | Oshruimm n, Vint n1 :: nil =>
+ if Int.ltu n Int.iwordsize then Some (Vint (Int.shru n1 n)) else None
+ | Ororimm n, Vint n1 :: nil =>
+ if Int.ltu n Int.iwordsize then Some (Vint (Int.ror n1 n)) else None
+ | Olea addr, _ =>
+ eval_addressing genv sp addr vl
+ | Onegf, Vfloat f1 :: nil => Some (Vfloat (Float.neg f1))
+ | Oabsf, Vfloat f1 :: nil => Some (Vfloat (Float.abs f1))
+ | Oaddf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.add f1 f2))
+ | Osubf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.sub f1 f2))
+ | Omulf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.mul f1 f2))
+ | Odivf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.div f1 f2))
+ | Osingleoffloat, v1 :: nil =>
+ Some (Val.singleoffloat v1)
+ | Ointoffloat, Vfloat f1 :: nil =>
+ Some (Vint (Float.intoffloat f1))
+ | Ofloatofint, Vint n1 :: nil =>
+ Some (Vfloat (Float.floatofint n1))
+ | Ocmp c, _ =>
+ match eval_condition c vl with
+ | None => None
+ | Some false => Some Vfalse
+ | Some true => Some Vtrue
+ end
+ | _, _ => None
+ end.
+
+Definition negate_condition (cond: condition): condition :=
+ match cond with
+ | Ccomp c => Ccomp(negate_comparison c)
+ | Ccompu c => Ccompu(negate_comparison c)
+ | Ccompimm c n => Ccompimm (negate_comparison c) n
+ | Ccompuimm c n => Ccompuimm (negate_comparison c) n
+ | Ccompf c => Cnotcompf c
+ | Cnotcompf c => Ccompf c
+ | Cmaskzero n => Cmasknotzero n
+ | Cmasknotzero n => Cmaskzero n
+ end.
+
+Ltac FuncInv :=
+ match goal with
+ | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ =>
+ destruct x; simpl in H; try discriminate; FuncInv
+ | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ =>
+ destruct v; simpl in H; try discriminate; FuncInv
+ | H: (Some _ = Some _) |- _ =>
+ injection H; intros; clear H; FuncInv
+ | _ =>
+ idtac
+ end.
+
+Remark eval_negate_compare_mismatch:
+ forall c b,
+ eval_compare_mismatch c = Some b ->
+ eval_compare_mismatch (negate_comparison c) = Some (negb b).
+Proof.
+ intros until b. unfold eval_compare_mismatch.
+ destruct c; intro EQ; inv EQ; auto.
+Qed.
+
+Remark eval_negate_compare_null:
+ forall c i b,
+ eval_compare_null c i = Some b ->
+ eval_compare_null (negate_comparison c) i = Some (negb b).
+Proof.
+ unfold eval_compare_null; intros.
+ destruct (Int.eq i Int.zero). apply eval_negate_compare_mismatch; auto. congruence.
+Qed.
+
+Lemma eval_negate_condition:
+ forall (cond: condition) (vl: list val) (b: bool),
+ eval_condition cond vl = Some b ->
+ eval_condition (negate_condition cond) vl = Some (negb b).
+Proof.
+ intros.
+ destruct cond; simpl in H; FuncInv; try subst b; simpl.
+ rewrite Int.negate_cmp. auto.
+ apply eval_negate_compare_null; auto.
+ apply eval_negate_compare_null; auto.
+ destruct (eq_block b0 b1). rewrite Int.negate_cmp. congruence.
+ apply eval_negate_compare_mismatch; auto.
+ rewrite Int.negate_cmpu. auto.
+ rewrite Int.negate_cmp. auto.
+ apply eval_negate_compare_null; auto.
+ rewrite Int.negate_cmpu. auto.
+ auto.
+ rewrite negb_elim. auto.
+ auto.
+ rewrite negb_elim. auto.
+Qed.
+
+(** [eval_operation] and [eval_addressing] depend on a global environment
+ for resolving references to global symbols. We show that they give
+ the same results if a global environment is replaced by another that
+ assigns the same addresses to the same symbols. *)
+
+Section GENV_TRANSF.
+
+Variable F1 F2 V1 V2: Type.
+Variable ge1: Genv.t F1 V1.
+Variable ge2: Genv.t F2 V2.
+Hypothesis agree_on_symbols:
+ forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s.
+
+Lemma eval_addressing_preserved:
+ forall sp addr vl,
+ eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl.
+Proof.
+ intros.
+ unfold eval_addressing; destruct addr; try rewrite agree_on_symbols;
+ reflexivity.
+Qed.
+
+Lemma eval_operation_preserved:
+ forall sp op vl,
+ eval_operation ge2 sp op vl = eval_operation ge1 sp op vl.
+Proof.
+ intros.
+ unfold eval_operation; destruct op; try rewrite agree_on_symbols; auto.
+ apply eval_addressing_preserved.
+Qed.
+
+End GENV_TRANSF.
+
+(** Recognition of move operations. *)
+
+Definition is_move_operation
+ (A: Type) (op: operation) (args: list A) : option A :=
+ match op, args with
+ | Omove, arg :: nil => Some arg
+ | _, _ => None
+ end.
+
+Lemma is_move_operation_correct:
+ forall (A: Type) (op: operation) (args: list A) (a: A),
+ is_move_operation op args = Some a ->
+ op = Omove /\ args = a :: nil.
+Proof.
+ intros until a. unfold is_move_operation; destruct op;
+ try (intros; discriminate).
+ destruct args. intros; discriminate.
+ destruct args. intros. intuition congruence.
+ intros; discriminate.
+Qed.
+
+(** Static typing of conditions, operators and addressing modes. *)
+
+Definition type_of_condition (c: condition) : list typ :=
+ match c with
+ | Ccomp _ => Tint :: Tint :: nil
+ | Ccompu _ => Tint :: Tint :: nil
+ | Ccompimm _ _ => Tint :: nil
+ | Ccompuimm _ _ => Tint :: nil
+ | Ccompf _ => Tfloat :: Tfloat :: nil
+ | Cnotcompf _ => Tfloat :: Tfloat :: nil
+ | Cmaskzero _ => Tint :: nil
+ | Cmasknotzero _ => Tint :: nil
+ end.
+
+Definition type_of_addressing (addr: addressing) : list typ :=
+ match addr with
+ | Aindexed _ => Tint :: nil
+ | Aindexed2 _ => Tint :: Tint :: nil
+ | Ascaled _ _ => Tint :: nil
+ | Aindexed2scaled _ _ => Tint :: Tint :: nil
+ | Aglobal _ _ => nil
+ | Abased _ _ => Tint :: nil
+ | Abasedscaled _ _ _ => Tint :: nil
+ | Ainstack _ => nil
+ end.
+
+Definition type_of_operation (op: operation) : list typ * typ :=
+ match op with
+ | Omove => (nil, Tint) (* treated specially *)
+ | Ointconst _ => (nil, Tint)
+ | Ofloatconst _ => (nil, Tfloat)
+ | Ocast8signed => (Tint :: nil, Tint)
+ | Ocast8unsigned => (Tint :: nil, Tint)
+ | Ocast16signed => (Tint :: nil, Tint)
+ | Ocast16unsigned => (Tint :: nil, Tint)
+ | Oneg => (Tint :: nil, Tint)
+ | Osub => (Tint :: Tint :: nil, Tint)
+ | Omul => (Tint :: Tint :: nil, Tint)
+ | Omulimm _ => (Tint :: nil, Tint)
+ | Odiv => (Tint :: Tint :: nil, Tint)
+ | Odivu => (Tint :: Tint :: nil, Tint)
+ | Omod => (Tint :: Tint :: nil, Tint)
+ | Omodu => (Tint :: Tint :: nil, Tint)
+ | Oand => (Tint :: Tint :: nil, Tint)
+ | Oandimm _ => (Tint :: nil, Tint)
+ | Oor => (Tint :: Tint :: nil, Tint)
+ | Oorimm _ => (Tint :: nil, Tint)
+ | Oxor => (Tint :: Tint :: nil, Tint)
+ | Oxorimm _ => (Tint :: nil, Tint)
+ | Oshl => (Tint :: Tint :: nil, Tint)
+ | Oshlimm _ => (Tint :: nil, Tint)
+ | Oshr => (Tint :: Tint :: nil, Tint)
+ | Oshrimm _ => (Tint :: nil, Tint)
+ | Oshrximm _ => (Tint :: nil, Tint)
+ | Oshru => (Tint :: Tint :: nil, Tint)
+ | Oshruimm _ => (Tint :: nil, Tint)
+ | Ororimm _ => (Tint :: nil, Tint)
+ | Olea addr => (type_of_addressing addr, Tint)
+ | Onegf => (Tfloat :: nil, Tfloat)
+ | Oabsf => (Tfloat :: nil, Tfloat)
+ | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat)
+ | Osubf => (Tfloat :: Tfloat :: nil, Tfloat)
+ | Omulf => (Tfloat :: Tfloat :: nil, Tfloat)
+ | Odivf => (Tfloat :: Tfloat :: nil, Tfloat)
+ | Osingleoffloat => (Tfloat :: nil, Tfloat)
+ | Ointoffloat => (Tfloat :: nil, Tint)
+ | Ofloatofint => (Tint :: nil, Tfloat)
+ | Ocmp c => (type_of_condition c, Tint)
+ end.
+
+(** Weak type soundness results for [eval_operation]:
+ the result values, when defined, are always of the type predicted
+ by [type_of_operation]. *)
+
+Section SOUNDNESS.
+
+Variable A V: Type.
+Variable genv: Genv.t A V.
+
+Lemma type_of_addressing_sound:
+ forall addr vl sp v,
+ eval_addressing genv sp addr vl = Some v ->
+ Val.has_type v Tint.
+Proof.
+ intros. destruct addr; simpl in H; FuncInv; try subst v; try exact I.
+ destruct (Genv.find_symbol genv i); inv H; exact I.
+ destruct (Genv.find_symbol genv i); inv H; exact I.
+ destruct (Genv.find_symbol genv i0); inv H; exact I.
+ unfold offset_sp in H. destruct sp; inv H; exact I.
+Qed.
+
+Lemma type_of_operation_sound:
+ forall op vl sp v,
+ op <> Omove ->
+ eval_operation genv sp op vl = Some v ->
+ Val.has_type v (snd (type_of_operation op)).
+Proof.
+ intros.
+ destruct op; simpl in H0; FuncInv; try subst v; try exact I.
+ congruence.
+ destruct v0; exact I.
+ destruct v0; exact I.
+ destruct v0; exact I.
+ destruct v0; exact I.
+ destruct (eq_block b b0). injection H0; intro; subst v; exact I.
+ discriminate.
+ destruct (Int.eq i0 Int.zero). discriminate.
+ injection H0; intro; subst v; exact I.
+ destruct (Int.eq i0 Int.zero). discriminate.
+ injection H0; intro; subst v; exact I.
+ destruct (Int.eq i0 Int.zero). discriminate.
+ injection H0; intro; subst v; exact I.
+ destruct (Int.eq i0 Int.zero). discriminate.
+ injection H0; intro; subst v; exact I.
+ destruct (Int.ltu i0 Int.iwordsize).
+ injection H0; intro; subst v; exact I. discriminate.
+ destruct (Int.ltu i Int.iwordsize).
+ injection H0; intro; subst v; exact I. discriminate.
+ destruct (Int.ltu i0 Int.iwordsize).
+ injection H0; intro; subst v; exact I. discriminate.
+ destruct (Int.ltu i Int.iwordsize).
+ injection H0; intro; subst v; exact I. discriminate.
+ destruct (Int.ltu i (Int.repr 31)).
+ injection H0; intro; subst v; exact I. discriminate.
+ destruct (Int.ltu i0 Int.iwordsize).
+ injection H0; intro; subst v; exact I. discriminate.
+ destruct (Int.ltu i Int.iwordsize).
+ injection H0; intro; subst v; exact I. discriminate.
+ destruct (Int.ltu i Int.iwordsize).
+ injection H0; intro; subst v; exact I. discriminate.
+ simpl. eapply type_of_addressing_sound; eauto.
+ destruct v0; exact I.
+ destruct (eval_condition c vl).
+ destruct b; injection H0; intro; subst v; exact I.
+ discriminate.
+Qed.
+
+Lemma type_of_chunk_correct:
+ forall chunk m addr v,
+ Mem.loadv chunk m addr = Some v ->
+ Val.has_type v (type_of_chunk chunk).
+Proof.
+ intro chunk.
+ assert (forall v, Val.has_type (Val.load_result chunk v) (type_of_chunk chunk)).
+ destruct v; destruct chunk; exact I.
+ intros until v. unfold Mem.loadv.
+ destruct addr; intros; try discriminate.
+ eapply Mem.load_type; eauto.
+Qed.
+
+End SOUNDNESS.
+
+(** Alternate definition of [eval_condition], [eval_op], [eval_addressing]
+ as total functions that return [Vundef] when not applicable
+ (instead of [None]). Used in the proof of [PPCgen]. *)
+
+Section EVAL_OP_TOTAL.
+
+Variable F V: Type.
+Variable genv: Genv.t F V.
+
+Definition find_symbol_offset (id: ident) (ofs: int) : val :=
+ match Genv.find_symbol genv id with
+ | Some b => Vptr b ofs
+ | None => Vundef
+ end.
+
+Definition eval_condition_total (cond: condition) (vl: list val) : val :=
+ match cond, vl with
+ | Ccomp c, v1::v2::nil => Val.cmp c v1 v2
+ | Ccompu c, v1::v2::nil => Val.cmpu c v1 v2
+ | Ccompimm c n, v1::nil => Val.cmp c v1 (Vint n)
+ | Ccompuimm c n, v1::nil => Val.cmpu c v1 (Vint n)
+ | Ccompf c, v1::v2::nil => Val.cmpf c v1 v2
+ | Cnotcompf c, v1::v2::nil => Val.notbool(Val.cmpf c v1 v2)
+ | Cmaskzero n, v1::nil => Val.notbool (Val.and v1 (Vint n))
+ | Cmasknotzero n, v1::nil => Val.notbool(Val.notbool (Val.and v1 (Vint n)))
+ | _, _ => Vundef
+ end.
+
+Definition eval_addressing_total
+ (sp: val) (addr: addressing) (vl: list val) : val :=
+ match addr, vl with
+ | Aindexed n, v1::nil => Val.add v1 (Vint n)
+ | Aindexed2 n, v1::v2::nil => Val.add (Val.add v1 v2) (Vint n)
+ | Ascaled sc ofs, v1::nil => Val.add (Val.mul v1 (Vint sc)) (Vint ofs)
+ | Aindexed2scaled sc ofs, v1::v2::nil =>
+ Val.add v1 (Val.add (Val.mul v2 (Vint sc)) (Vint ofs))
+ | Aglobal s ofs, nil => find_symbol_offset s ofs
+ | Abased s ofs, v1::nil => Val.add (find_symbol_offset s ofs) v1
+ | Abasedscaled sc s ofs, v1::nil => Val.add (find_symbol_offset s ofs) (Val.mul v1 (Vint sc))
+ | Ainstack ofs, nil => Val.add sp (Vint ofs)
+ | _, _ => Vundef
+ end.
+
+Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val :=
+ match op, vl with
+ | Omove, v1::nil => v1
+ | Ointconst n, nil => Vint n
+ | Ofloatconst n, nil => Vfloat n
+ | Ocast8signed, v1::nil => Val.sign_ext 8 v1
+ | Ocast8unsigned, v1::nil => Val.zero_ext 8 v1
+ | Ocast16signed, v1::nil => Val.sign_ext 16 v1
+ | Ocast16unsigned, v1::nil => Val.zero_ext 16 v1
+ | Oneg, v1::nil => Val.neg v1
+ | Osub, v1::v2::nil => Val.sub v1 v2
+ | Omul, v1::v2::nil => Val.mul v1 v2
+ | Omulimm n, v1::nil => Val.mul v1 (Vint n)
+ | Odiv, v1::v2::nil => Val.divs v1 v2
+ | Odivu, v1::v2::nil => Val.divu v1 v2
+ | Omod, v1::v2::nil => Val.mods v1 v2
+ | Omodu, v1::v2::nil => Val.modu v1 v2
+ | Oand, v1::v2::nil => Val.and v1 v2
+ | Oandimm n, v1::nil => Val.and v1 (Vint n)
+ | Oor, v1::v2::nil => Val.or v1 v2
+ | Oorimm n, v1::nil => Val.or v1 (Vint n)
+ | Oxor, v1::v2::nil => Val.xor v1 v2
+ | Oxorimm n, v1::nil => Val.xor v1 (Vint n)
+ | Oshl, v1::v2::nil => Val.shl v1 v2
+ | Oshlimm n, v1::nil => Val.shl v1 (Vint n)
+ | Oshr, v1::v2::nil => Val.shr v1 v2
+ | Oshrimm n, v1::nil => Val.shr v1 (Vint n)
+ | Oshrximm n, v1::nil => Val.shrx v1 (Vint n)
+ | Oshru, v1::v2::nil => Val.shru v1 v2
+ | Oshruimm n, v1::nil => Val.shru v1 (Vint n)
+ | Ororimm n, v1::nil => Val.ror v1 (Vint n)
+ | Olea addr, _ => eval_addressing_total sp addr vl
+ | Onegf, v1::nil => Val.negf v1
+ | Oabsf, v1::nil => Val.absf v1
+ | Oaddf, v1::v2::nil => Val.addf v1 v2
+ | Osubf, v1::v2::nil => Val.subf v1 v2
+ | Omulf, v1::v2::nil => Val.mulf v1 v2
+ | Odivf, v1::v2::nil => Val.divf v1 v2
+ | Osingleoffloat, v1::nil => Val.singleoffloat v1
+ | Ointoffloat, v1::nil => Val.intoffloat v1
+ | Ofloatofint, v1::nil => Val.floatofint v1
+ | Ocmp c, _ => eval_condition_total c vl
+ | _, _ => Vundef
+ end.
+
+Lemma eval_compare_mismatch_weaken:
+ forall c b,
+ eval_compare_mismatch c = Some b ->
+ Val.cmp_mismatch c = Val.of_bool b.
+Proof.
+ unfold eval_compare_mismatch. intros. destruct c; inv H; auto.
+Qed.
+
+Lemma eval_compare_null_weaken:
+ forall n c b,
+ eval_compare_null c n = Some b ->
+ (if Int.eq n Int.zero then Val.cmp_mismatch c else Vundef) = Val.of_bool b.
+Proof.
+ unfold eval_compare_null.
+ intros. destruct (Int.eq n Int.zero). apply eval_compare_mismatch_weaken. auto.
+ discriminate.
+Qed.
+
+Lemma eval_condition_weaken:
+ forall c vl b,
+ eval_condition c vl = Some b ->
+ eval_condition_total c vl = Val.of_bool b.
+Proof.
+ intros.
+ unfold eval_condition in H; destruct c; FuncInv;
+ try subst b; try reflexivity; simpl;
+ try (apply eval_compare_null_weaken; auto).
+ unfold eq_block in H. destruct (zeq b0 b1).
+ congruence.
+ apply eval_compare_mismatch_weaken; auto.
+ symmetry. apply Val.notbool_negb_1.
+ symmetry. apply Val.notbool_negb_1.
+Qed.
+
+Lemma eval_addressing_weaken:
+ forall sp addr vl v,
+ eval_addressing genv sp addr vl = Some v ->
+ eval_addressing_total sp addr vl = v.
+Proof.
+ intros.
+ unfold eval_addressing in H; destruct addr; FuncInv;
+ try subst v; simpl; try reflexivity.
+ unfold find_symbol_offset. destruct (Genv.find_symbol genv i); congruence.
+ unfold find_symbol_offset. destruct (Genv.find_symbol genv i); simpl; congruence.
+ unfold find_symbol_offset. destruct (Genv.find_symbol genv i0); simpl; congruence.
+ unfold offset_sp in H. destruct sp; simpl; congruence.
+Qed.
+
+Lemma eval_operation_weaken:
+ forall sp op vl v,
+ eval_operation genv sp op vl = Some v ->
+ eval_operation_total sp op vl = v.
+Proof.
+ intros.
+ unfold eval_operation in H; destruct op; FuncInv;
+ try subst v; try reflexivity; simpl.
+ unfold eq_block in H. destruct (zeq b b0); congruence.
+ destruct (Int.eq i0 Int.zero); congruence.
+ destruct (Int.eq i0 Int.zero); congruence.
+ destruct (Int.eq i0 Int.zero); congruence.
+ destruct (Int.eq i0 Int.zero); congruence.
+ destruct (Int.ltu i0 Int.iwordsize); congruence.
+ destruct (Int.ltu i Int.iwordsize); congruence.
+ destruct (Int.ltu i0 Int.iwordsize); congruence.
+ destruct (Int.ltu i Int.iwordsize); congruence.
+ unfold Int.ltu in *. destruct (zlt (Int.unsigned i) (Int.unsigned (Int.repr 31))).
+ rewrite zlt_true. congruence. eapply Zlt_trans. eauto. compute; auto.
+ congruence.
+ destruct (Int.ltu i0 Int.iwordsize); congruence.
+ destruct (Int.ltu i Int.iwordsize); congruence.
+ destruct (Int.ltu i Int.iwordsize); congruence.
+ apply eval_addressing_weaken; auto.
+ caseEq (eval_condition c vl); intros; rewrite H0 in H.
+ replace v with (Val.of_bool b).
+ eapply eval_condition_weaken; eauto.
+ destruct b; simpl; congruence.
+ discriminate.
+Qed.
+
+Lemma eval_condition_total_is_bool:
+ forall cond vl, Val.is_bool (eval_condition_total cond vl).
+Proof.
+ intros; destruct cond;
+ destruct vl; try apply Val.undef_is_bool;
+ destruct vl; try apply Val.undef_is_bool;
+ try (destruct vl; try apply Val.undef_is_bool); simpl.
+ apply Val.cmp_is_bool.
+ apply Val.cmpu_is_bool.
+ apply Val.cmp_is_bool.
+ apply Val.cmpu_is_bool.
+ apply Val.cmpf_is_bool.
+ apply Val.notbool_is_bool.
+ apply Val.notbool_is_bool.
+ apply Val.notbool_is_bool.
+Qed.
+
+End EVAL_OP_TOTAL.
+
+(** Compatibility of the evaluation functions with the
+ ``is less defined'' relation over values. *)
+
+Section EVAL_LESSDEF.
+
+Variable F V: Type.
+Variable genv: Genv.t F V.
+
+Ltac InvLessdef :=
+ match goal with
+ | [ H: Val.lessdef (Vint _) _ |- _ ] =>
+ inv H; InvLessdef
+ | [ H: Val.lessdef (Vfloat _) _ |- _ ] =>
+ inv H; InvLessdef
+ | [ H: Val.lessdef (Vptr _ _) _ |- _ ] =>
+ inv H; InvLessdef
+ | [ H: Val.lessdef_list nil _ |- _ ] =>
+ inv H; InvLessdef
+ | [ H: Val.lessdef_list (_ :: _) _ |- _ ] =>
+ inv H; InvLessdef
+ | _ => idtac
+ end.
+
+Lemma eval_condition_lessdef:
+ forall cond vl1 vl2 b,
+ Val.lessdef_list vl1 vl2 ->
+ eval_condition cond vl1 = Some b ->
+ eval_condition cond vl2 = Some b.
+Proof.
+ intros. destruct cond; simpl in *; FuncInv; InvLessdef; auto.
+Qed.
+
+Ltac TrivialExists :=
+ match goal with
+ | [ |- exists v2, Some ?v1 = Some v2 /\ Val.lessdef ?v1 v2 ] =>
+ exists v1; split; [auto | constructor]
+ | _ => idtac
+ end.
+
+Lemma eval_addressing_lessdef:
+ forall sp addr vl1 vl2 v1,
+ Val.lessdef_list vl1 vl2 ->
+ eval_addressing genv sp addr vl1 = Some v1 ->
+ exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2.
+Proof.
+ intros. destruct addr; simpl in *; FuncInv; InvLessdef; TrivialExists.
+ destruct (Genv.find_symbol genv i); inv H0. TrivialExists.
+ destruct (Genv.find_symbol genv i); inv H0. TrivialExists.
+ destruct (Genv.find_symbol genv i0); inv H0. TrivialExists.
+ exists v1; auto.
+Qed.
+
+Lemma eval_operation_lessdef:
+ forall sp op vl1 vl2 v1,
+ Val.lessdef_list vl1 vl2 ->
+ eval_operation genv sp op vl1 = Some v1 ->
+ exists v2, eval_operation genv sp op vl2 = Some v2 /\ Val.lessdef v1 v2.
+Proof.
+ intros. destruct op; simpl in *; FuncInv; InvLessdef; TrivialExists.
+ exists v2; auto.
+ exists (Val.sign_ext 8 v2); split. auto. apply Val.sign_ext_lessdef; auto.
+ exists (Val.zero_ext 8 v2); split. auto. apply Val.zero_ext_lessdef; auto.
+ exists (Val.sign_ext 16 v2); split. auto. apply Val.sign_ext_lessdef; auto.
+ exists (Val.zero_ext 16 v2); split. auto. apply Val.zero_ext_lessdef; auto.
+ destruct (eq_block b b0); inv H0. TrivialExists.
+ destruct (Int.eq i0 Int.zero); inv H0; TrivialExists.
+ destruct (Int.eq i0 Int.zero); inv H0; TrivialExists.
+ destruct (Int.eq i0 Int.zero); inv H0; TrivialExists.
+ destruct (Int.eq i0 Int.zero); inv H0; TrivialExists.
+ destruct (Int.ltu i0 Int.iwordsize); inv H0; TrivialExists.
+ destruct (Int.ltu i Int.iwordsize); inv H0; TrivialExists.
+ destruct (Int.ltu i0 Int.iwordsize); inv H0; TrivialExists.
+ destruct (Int.ltu i Int.iwordsize); inv H0; TrivialExists.
+ destruct (Int.ltu i (Int.repr 31)); inv H0; TrivialExists.
+ destruct (Int.ltu i0 Int.iwordsize); inv H0; TrivialExists.
+ destruct (Int.ltu i Int.iwordsize); inv H0; TrivialExists.
+ destruct (Int.ltu i Int.iwordsize); inv H0; TrivialExists.
+ eapply eval_addressing_lessdef; eauto.
+ exists (Val.singleoffloat v2); split. auto. apply Val.singleoffloat_lessdef; auto.
+ caseEq (eval_condition c vl1); intros. rewrite H1 in H0.
+ rewrite (eval_condition_lessdef c H H1).
+ destruct b; inv H0; TrivialExists.
+ rewrite H1 in H0. discriminate.
+Qed.
+
+End EVAL_LESSDEF.
+
+(** Transformation of addressing modes with two operands or more
+ into an equivalent arithmetic operation. This is used in the [Reload]
+ pass when a store instruction cannot be reloaded directly because
+ it runs out of temporary registers. *)
+
+Definition op_for_binary_addressing (addr: addressing) : operation := Olea addr.
+
+Lemma eval_op_for_binary_addressing:
+ forall (F V: Type) (ge: Genv.t F V) sp addr args v,
+ (length args >= 2)%nat ->
+ eval_addressing ge sp addr args = Some v ->
+ eval_operation ge sp (op_for_binary_addressing addr) args = Some v.
+Proof.
+ intros. simpl. auto.
+Qed.
+
+Lemma type_op_for_binary_addressing:
+ forall addr,
+ (length (type_of_addressing addr) >= 2)%nat ->
+ type_of_operation (op_for_binary_addressing addr) = (type_of_addressing addr, Tint).
+Proof.
+ intros. simpl. auto.
+Qed.
+
+(** Two-address operations. Return [true] if the first argument and
+ the result must be in the same location. *)
+
+Definition two_address_op (op: operation) : bool :=
+ match op with
+ | Omove => false
+ | Ointconst _ => false
+ | Ofloatconst _ => false
+ | Ocast8signed => false
+ | Ocast8unsigned => false
+ | Ocast16signed => false
+ | Ocast16unsigned => false
+ | Oneg => true
+ | Osub => true
+ | Omul => true
+ | Omulimm _ => true
+ | Odiv => true
+ | Odivu => true
+ | Omod => true
+ | Omodu => true
+ | Oand => true
+ | Oandimm _ => true
+ | Oor => true
+ | Oorimm _ => true
+ | Oxor => true
+ | Oxorimm _ => true
+ | Oshl => true
+ | Oshlimm _ => true
+ | Oshr => true
+ | Oshrimm _ => true
+ | Oshrximm _ => true
+ | Oshru => true
+ | Oshruimm _ => true
+ | Ororimm _ => true
+ | Olea addr => false
+ | Onegf => true
+ | Oabsf => true
+ | Oaddf => true
+ | Osubf => true
+ | Omulf => true
+ | Odivf => true
+ | Osingleoffloat => false
+ | Ointoffloat => false
+ | Ofloatofint => false
+ | Ocmp c => false
+ end.
+
+(** Operations that are so cheap to recompute that CSE should not factor them out. *)
+
+Definition is_trivial_op (op: operation) : bool :=
+ match op with
+ | Omove => true
+ | Ointconst _ => true
+ | Olea (Aglobal _ _) => true
+ | Olea (Ainstack _) => true
+ | _ => false
+ end.
+
+(** Shifting stack-relative references. This is used in [Stacking]. *)
+
+Definition shift_stack_addressing (delta: int) (addr: addressing) :=
+ match addr with
+ | Ainstack ofs => Ainstack (Int.add delta ofs)
+ | _ => addr
+ end.
+
+Definition shift_stack_operation (delta: int) (op: operation) :=
+ match op with
+ | Olea addr => Olea (shift_stack_addressing delta addr)
+ | _ => op
+ end.
+
+Lemma shift_stack_eval_addressing:
+ forall (F V: Type) (ge: Genv.t F V) sp addr args delta,
+ eval_addressing ge (Val.sub sp (Vint delta)) (shift_stack_addressing delta addr) args =
+ eval_addressing ge sp addr args.
+Proof.
+ intros. destruct addr; simpl; auto.
+ destruct args; auto. unfold offset_sp. destruct sp; simpl; auto.
+ decEq. decEq. rewrite <- Int.add_assoc. decEq.
+ rewrite Int.sub_add_opp. rewrite Int.add_assoc.
+ rewrite (Int.add_commut (Int.neg delta)). rewrite <- Int.sub_add_opp.
+ rewrite Int.sub_idem. apply Int.add_zero.
+Qed.
+
+Lemma shift_stack_eval_operation:
+ forall (F V: Type) (ge: Genv.t F V) sp op args delta,
+ eval_operation ge (Val.sub sp (Vint delta)) (shift_stack_operation delta op) args =
+ eval_operation ge sp op args.
+Proof.
+ intros. destruct op; simpl; auto.
+ apply shift_stack_eval_addressing.
+Qed.
+
+Lemma type_shift_stack_addressing:
+ forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr.
+Proof.
+ intros. destruct addr; auto.
+Qed.
+
+Lemma type_shift_stack_operation:
+ forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op.
+Proof.
+ intros. destruct op; auto. simpl. decEq. apply type_shift_stack_addressing.
+Qed.
+
+
+
diff --git a/ia32/PrintAsm.ml b/ia32/PrintAsm.ml
new file mode 100644
index 0000000..e75032c
--- /dev/null
+++ b/ia32/PrintAsm.ml
@@ -0,0 +1,625 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(* Printing IA32 assembly code in asm syntax *)
+
+open Printf
+open Datatypes
+open Camlcoq
+open AST
+open Asm
+
+(* Recognition of target ABI and asm syntax *)
+
+type target = ELF | AOUT | MacOS
+
+let target =
+ match Configuration.system with
+ | "macosx" -> MacOS
+ | "linux" -> ELF
+ | "bsd" -> ELF
+ | "cygwin" -> AOUT
+ | _ -> invalid_arg ("System " ^ Configuration.system ^ " not supported")
+
+(* On-the-fly label renaming *)
+
+let next_label = ref 100
+
+let new_label() =
+ let lbl = !next_label in incr next_label; lbl
+
+let current_function_labels = (Hashtbl.create 39 : (label, int) Hashtbl.t)
+
+let transl_label lbl =
+ try
+ Hashtbl.find current_function_labels lbl
+ with Not_found ->
+ let lbl' = new_label() in
+ Hashtbl.add current_function_labels lbl lbl';
+ lbl'
+
+(* Basic printing functions *)
+
+let coqint oc n =
+ fprintf oc "%ld" (camlint_of_coqint n)
+
+let raw_symbol oc s =
+ match target with
+ | ELF -> fprintf oc "%s" s
+ | MacOS | AOUT -> fprintf oc "_%s" s
+
+let re_variadic_stub = Str.regexp "\\(.*\\)\\$[if]*$"
+
+let symbol oc symb =
+ let s = extern_atom symb in
+ if Str.string_match re_variadic_stub s 0
+ then raw_symbol oc (Str.matched_group 1 s)
+ else raw_symbol oc s
+
+let symbol_offset oc (symb, ofs) =
+ symbol oc symb;
+ if ofs <> 0l then fprintf oc " + %ld" ofs
+
+let label oc lbl =
+ match target with
+ | ELF -> fprintf oc ".L%d" lbl
+ | MacOS | AOUT -> fprintf oc "L%d" lbl
+
+let comment = "#"
+
+let int_reg_name = function
+ | EAX -> "%eax" | EBX -> "%ebx" | ECX -> "%ecx" | EDX -> "%edx"
+ | ESI -> "%esi" | EDI -> "%edi" | EBP -> "%ebp" | ESP -> "%esp"
+
+let int8_reg_name = function
+ | EAX -> "%al" | EBX -> "%bl" | ECX -> "%cl" | EDX -> "%dl"
+ | _ -> assert false
+
+let int16_reg_name = function
+ | EAX -> "%ax" | EBX -> "%bx" | ECX -> "%cx" | EDX -> "%dx"
+ | _ -> assert false
+
+let float_reg_name = function
+ | XMM0 -> "%xmm0" | XMM1 -> "%xmm1" | XMM2 -> "%xmm2" | XMM3 -> "%xmm3"
+ | XMM4 -> "%xmm4" | XMM5 -> "%xmm5" | XMM6 -> "%xmm6" | XMM7 -> "%xmm7"
+
+let ireg oc r = output_string oc (int_reg_name r)
+let ireg8 oc r = output_string oc (int8_reg_name r)
+let ireg16 oc r = output_string oc (int16_reg_name r)
+let freg oc r = output_string oc (float_reg_name r)
+
+let addressing oc (Addrmode(base, shift, cst)) =
+ begin match cst with
+ | Coq_inl n ->
+ let n = camlint_of_coqint n in
+ fprintf oc "%ld" n
+ | Coq_inr(Coq_pair(id, ofs)) ->
+ let ofs = camlint_of_coqint ofs in
+ if ofs = 0l
+ then symbol oc id
+ else fprintf oc "(%a + %ld)" symbol id ofs
+ end;
+ begin match base, shift with
+ | None, None -> ()
+ | Some r1, None -> fprintf oc "(%a)" ireg r1
+ | None, Some(Coq_pair(r2,sc)) -> fprintf oc "(,%a,%a)" ireg r2 coqint sc
+ | Some r1, Some(Coq_pair(r2,sc)) -> fprintf oc "(%a,%a,%a)" ireg r1 ireg r2 coqint sc
+ end
+
+let name_of_condition = function
+ | Cond_e -> "e" | Cond_ne -> "ne"
+ | Cond_b -> "b" | Cond_be -> "be" | Cond_ae -> "ae" | Cond_a -> "a"
+ | Cond_l -> "l" | Cond_le -> "le" | Cond_ge -> "ge" | Cond_g -> "g"
+ | Cond_p -> "p" | Cond_np -> "np"
+ | Cond_nep | Cond_enp -> assert false (* treated specially *)
+
+let section oc name =
+ fprintf oc " %s\n" name
+
+(* Names of sections *)
+
+let (text, data, const_data, float_literal, jumptable_literal) =
+ match target with
+ | ELF ->
+ (".text",
+ ".data",
+ ".section .rodata",
+ ".section .rodata.cst8,\"a\",@progbits",
+ ".text")
+ | MacOS ->
+ (".text",
+ ".data",
+ ".const",
+ ".const_data",
+ ".text")
+ | AOUT ->
+ (".text",
+ ".data",
+ ".section .rdata,\"dr\"",
+ ".section .rdata,\"dr\"",
+ ".text")
+
+(* SP adjustment to allocate or free a stack frame *)
+
+let stack_alignment =
+ match target with
+ | ELF | AOUT -> 8 (* minimum is 4, 8 is better for perfs *)
+ | MacOS -> 16 (* mandatory *)
+
+let int32_align n a =
+ if n >= 0l
+ then Int32.logand (Int32.add n (Int32.of_int (a-1))) (Int32.of_int (-a))
+ else Int32.logand n (Int32.of_int (-a))
+
+let sp_adjustment lo hi =
+ let lo = camlint_of_coqint lo and hi = camlint_of_coqint hi in
+ let sz = Int32.sub hi lo in
+(* Enforce stack alignment, noting that 4 bytes are already allocated
+ by the call *)
+ let sz = Int32.sub (int32_align (Int32.add sz 4l) stack_alignment) 4l in
+ assert (sz >= 0l);
+ sz
+
+(* Base-2 log of a Caml integer *)
+
+let rec log2 n =
+ assert (n > 0);
+ if n = 1 then 0 else 1 + log2 (n lsr 1)
+
+(* Emit a align directive *)
+
+let print_align oc n =
+ match target with
+ | ELF -> fprintf oc " .align %d\n" n
+ | AOUT | MacOS -> fprintf oc " .align %d\n" (log2 n)
+
+let need_masks = ref false
+
+(* Built-in functions *)
+
+(* Built-ins. They come in two flavors:
+ - inlined by the compiler: take their arguments in arbitrary
+ registers; preserve all registers except ECX, EDX, XMM6 and XMM7
+ - inlined while printing asm code; take their arguments in
+ locations dictated by the calling conventions; preserve
+ callee-save regs only. *)
+
+let print_builtin_inlined oc name args res =
+ fprintf oc "%s begin builtin %s\n" comment name;
+ begin match name, args, res with
+ (* Volatile reads *)
+ | "__builtin_volatile_read_int8unsigned", [IR addr], IR res ->
+ fprintf oc " movzbl 0(%a), %a\n" ireg addr ireg res
+ | "__builtin_volatile_read_int8signed", [IR addr], IR res ->
+ fprintf oc " movsbl 0(%a), %a\n" ireg addr ireg res
+ | "__builtin_volatile_read_int16unsigned", [IR addr], IR res ->
+ fprintf oc " movzwl 0(%a), %a\n" ireg addr ireg res
+ | "__builtin_volatile_read_int16signed", [IR addr], IR res ->
+ fprintf oc " movswl 0(%a), %a\n" ireg addr ireg res
+ | ("__builtin_volatile_read_int32"|"__builtin_volatile_read_pointer"), [IR addr], IR res ->
+ fprintf oc " movl 0(%a), %a\n" ireg addr ireg res
+ | "__builtin_volatile_read_float32", [IR addr], FR res ->
+ fprintf oc " cvtss2sd 0(%a), %a\n" ireg addr freg res
+ | "__builtin_volatile_read_float64", [IR addr], FR res ->
+ fprintf oc " movsd 0(%a), %a\n" ireg addr freg res
+ (* Volatile writes *)
+ | ("__builtin_volatile_write_int8unsigned"|"__builtin_volatile_write_int8signed"), [IR addr; IR src], _ ->
+ if Asmgen.low_ireg src then
+ fprintf oc " movb %a, 0(%a)\n" ireg8 src ireg addr
+ else begin
+ fprintf oc " movl %a, %%ecx\n" ireg src;
+ fprintf oc " movb %%cl, 0(%a)\n" ireg addr
+ end
+ | ("__builtin_volatile_write_int16unsigned"|"__builtin_volatile_write_int16signed"), [IR addr; IR src], _ ->
+ if Asmgen.low_ireg src then
+ fprintf oc " movw %a, 0(%a)\n" ireg16 src ireg addr
+ else begin
+ fprintf oc " movl %a, %%ecx\n" ireg src;
+ fprintf oc " movw %%cx, 0(%a)\n" ireg addr
+ end
+ | ("__builtin_volatile_write_int32"|"__builtin_volatile_write_pointer"), [IR addr; IR src], _ ->
+ fprintf oc " movl %a, 0(%a)\n" ireg src ireg addr
+ | "__builtin_volatile_write_float32", [IR addr; FR src], _ ->
+ fprintf oc " cvtsd2ss %a, %%xmm7\n" freg src;
+ fprintf oc " movss %%xmm7, 0(%a)\n" ireg addr
+ | "__builtin_volatile_write_float64", [IR addr; FR src], _ ->
+ fprintf oc " movsd %a, 0(%a)\n" freg src ireg addr
+ (* Float arithmetic *)
+ | "__builtin_fabs", [FR a1], FR res ->
+ need_masks := true;
+ if a1 <> res then
+ fprintf oc " movsd %a, %a\n" freg a1 freg res;
+ fprintf oc " andpd %a, %a\n" raw_symbol "__absd_mask" freg res
+ | "__builtin_fsqrt", [FR a1], FR res ->
+ fprintf oc " sqrtsd %a, %a\n" freg a1 freg res
+ (* Also: fmax, fmin *)
+ | _ ->
+ invalid_arg ("unrecognized builtin " ^ name)
+ end;
+ fprintf oc "%s end builtin %s\n" comment name
+
+let re_builtin_function = Str.regexp "__builtin_"
+
+let is_builtin_function s =
+ Str.string_match re_builtin_function (extern_atom s) 0
+
+let print_builtin_function oc s =
+ fprintf oc "%s begin builtin function %s\n" comment (extern_atom s);
+ (* arguments: on stack, starting at offset 0 *)
+ (* result: EAX or ST0 *)
+ begin match extern_atom s with
+ (* Block copy *)
+ | "__builtin_memcpy" ->
+ fprintf oc " movl %%esi, %%eax\n";
+ fprintf oc " movl %%edi, %%edx\n";
+ fprintf oc " movl 0(%%esp), %%edi\n";
+ fprintf oc " movl 4(%%esp), %%esi\n";
+ fprintf oc " movl 8(%%esp), %%ecx\n";
+ fprintf oc " rep movsb\n";
+ fprintf oc " movl %%eax, %%esi\n";
+ fprintf oc " movl %%edx, %%edi\n"
+ | "__builtin_memcpy_words" ->
+ fprintf oc " movl %%esi, %%eax\n";
+ fprintf oc " movl %%edi, %%edx\n";
+ fprintf oc " movl 0(%%esp), %%edi\n";
+ fprintf oc " movl 4(%%esp), %%esi\n";
+ fprintf oc " movl 8(%%esp), %%ecx\n";
+ fprintf oc " shr $2, %%ecx\n";
+ fprintf oc " rep movsl\n";
+ fprintf oc " movl %%eax, %%esi\n";
+ fprintf oc " movl %%edx, %%edi\n"
+ (* Catch-all *)
+ | s ->
+ invalid_arg ("unrecognized builtin function " ^ s)
+ end;
+ fprintf oc "%s end builtin function %s\n" comment (extern_atom s)
+
+(* Printing of instructions *)
+
+module Labelset = Set.Make(struct type t = label let compare = compare end)
+
+let float_literals : (int * int64) list ref = ref []
+let jumptables : (int * label list) list ref = ref []
+
+(* Reminder on AT&T syntax: op source, dest *)
+
+let print_instruction oc labels = function
+ (* Moves *)
+ | Pmov_rr(rd, r1) ->
+ fprintf oc " movl %a, %a\n" ireg r1 ireg rd
+ | Pmov_ri(rd, n) ->
+ let n = camlint_of_coqint n in
+ if n = 0l then
+ fprintf oc " xorl %a, %a\n" ireg rd ireg rd
+ else
+ fprintf oc " movl $%ld, %a\n" n ireg rd
+ | Pmov_rm(rd, a) ->
+ fprintf oc " movl %a, %a\n" addressing a ireg rd
+ | Pmov_mr(a, r1) ->
+ fprintf oc " movl %a, %a\n" ireg r1 addressing a
+ | Pmovd_fr(rd, r1) ->
+ fprintf oc " movd %a, %a\n" ireg r1 freg rd
+ | Pmovd_rf(rd, r1) ->
+ fprintf oc " movd %a, %a\n" freg r1 ireg rd
+ | Pmovsd_ff(rd, r1) ->
+ fprintf oc " movsd %a, %a\n" freg r1 freg rd
+ | Pmovsd_fi(rd, n) ->
+ let b = Int64.bits_of_float n in
+ if b = 0L then (* +0.0 *)
+ fprintf oc " xorpd %a, %a %s +0.0\n" freg rd freg rd comment
+ else begin
+ let lbl = new_label() in
+ fprintf oc " movsd %a, %a %s %.18g\n" label lbl freg rd comment n;
+ float_literals := (lbl, b) :: !float_literals
+ end
+ | Pmovsd_fm(rd, a) ->
+ fprintf oc " movsd %a, %a\n" addressing a freg rd
+ | Pmovsd_mf(a, r1) ->
+ fprintf oc " movsd %a, %a\n" freg r1 addressing a
+ | Pfld_f(r1) ->
+ fprintf oc " subl $8, %%esp\n";
+ fprintf oc " movsd %a, 0(%%esp)\n" freg r1;
+ fprintf oc " fldl 0(%%esp)\n";
+ fprintf oc " addl $8, %%esp\n"
+ | Pfld_m(a) ->
+ fprintf oc " fldl %a\n" addressing a
+ | Pfstp_f(rd) ->
+ fprintf oc " subl $8, %%esp\n";
+ fprintf oc " fstpl 0(%%esp)\n";
+ fprintf oc " movsd 0(%%esp), %a\n" freg rd;
+ fprintf oc " addl $8, %%esp\n"
+ | Pfstp_m(a) ->
+ fprintf oc " fstpl %a\n" addressing a
+ (** Moves with conversion *)
+ | Pmovb_mr(a, r1) ->
+ fprintf oc " movb %a, %a\n" ireg8 r1 addressing a
+ | Pmovw_mr(a, r1) ->
+ fprintf oc " movw %a, %a\n" ireg16 r1 addressing a
+ | Pmovzb_rr(rd, r1) ->
+ fprintf oc " movzbl %a, %a\n" ireg8 r1 ireg rd
+ | Pmovzb_rm(rd, a) ->
+ fprintf oc " movzbl %a, %a\n" addressing a ireg rd
+ | Pmovsb_rr(rd, r1) ->
+ fprintf oc " movsbl %a, %a\n" ireg8 r1 ireg rd
+ | Pmovsb_rm(rd, a) ->
+ fprintf oc " movsbl %a, %a\n" addressing a ireg rd
+ | Pmovzw_rr(rd, r1) ->
+ fprintf oc " movzwl %a, %a\n" ireg16 r1 ireg rd
+ | Pmovzw_rm(rd, a) ->
+ fprintf oc " movzwl %a, %a\n" addressing a ireg rd
+ | Pmovsw_rr(rd, r1) ->
+ fprintf oc " movswl %a, %a\n" ireg16 r1 ireg rd
+ | Pmovsw_rm(rd, a) ->
+ fprintf oc " movswl %a, %a\n" addressing a ireg rd
+ | Pcvtss2sd_fm(rd, a) ->
+ fprintf oc " cvtss2sd %a, %a\n" addressing a freg rd
+ | Pcvtsd2ss_ff(rd, r1) ->
+ fprintf oc " cvtsd2ss %a, %a\n" freg r1 freg rd;
+ fprintf oc " cvtss2sd %a, %a\n" freg rd freg rd
+ | Pcvtsd2ss_mf(a, r1) ->
+ fprintf oc " cvtsd2ss %a, %%xmm7\n" freg r1;
+ fprintf oc " movss %%xmm7, %a\n" addressing a
+ | Pcvttsd2si_rf(rd, r1) ->
+ fprintf oc " cvttsd2si %a, %a\n" freg r1 ireg rd
+ | Pcvtsi2sd_fr(rd, r1) ->
+ fprintf oc " cvtsi2sd %a, %a\n" ireg r1 freg rd
+ (** Arithmetic and logical operations over integers *)
+ | Plea(rd, a) ->
+ fprintf oc " leal %a, %a\n" addressing a ireg rd
+ | Pneg(rd) ->
+ fprintf oc " negl %a\n" ireg rd
+ | Psub_rr(rd, r1) ->
+ fprintf oc " subl %a, %a\n" ireg r1 ireg rd
+ | Pimul_rr(rd, r1) ->
+ fprintf oc " imull %a, %a\n" ireg r1 ireg rd
+ | Pimul_ri(rd, n) ->
+ fprintf oc " imull $%a, %a\n" coqint n ireg rd
+ | Pdiv(r1) ->
+ fprintf oc " xorl %%edx, %%edx\n";
+ fprintf oc " divl %a\n" ireg r1
+ | Pidiv(r1) ->
+ fprintf oc " cltd\n";
+ fprintf oc " idivl %a\n" ireg r1
+ | Pand_rr(rd, r1) ->
+ fprintf oc " andl %a, %a\n" ireg r1 ireg rd
+ | Pand_ri(rd, n) ->
+ fprintf oc " andl $%a, %a\n" coqint n ireg rd
+ | Por_rr(rd, r1) ->
+ fprintf oc " orl %a, %a\n" ireg r1 ireg rd
+ | Por_ri(rd, n) ->
+ fprintf oc " orl $%a, %a\n" coqint n ireg rd
+ | Pxor_rr(rd, r1) ->
+ fprintf oc " xorl %a, %a\n" ireg r1 ireg rd
+ | Pxor_ri(rd, n) ->
+ fprintf oc " xorl $%a, %a\n" coqint n ireg rd
+ | Psal_rcl(rd) ->
+ fprintf oc " sall %%cl, %a\n" ireg rd
+ | Psal_ri(rd, n) ->
+ fprintf oc " sall $%a, %a\n" coqint n ireg rd
+ | Pshr_rcl(rd) ->
+ fprintf oc " shrl %%cl, %a\n" ireg rd
+ | Pshr_ri(rd, n) ->
+ fprintf oc " shrl $%a, %a\n" coqint n ireg rd
+ | Psar_rcl(rd) ->
+ fprintf oc " sarl %%cl, %a\n" ireg rd
+ | Psar_ri(rd, n) ->
+ fprintf oc " sarl $%a, %a\n" coqint n ireg rd
+ | Pror_ri(rd, n) ->
+ fprintf oc " rorl $%a, %a\n" coqint n ireg rd
+ | Pcmp_rr(r1, r2) ->
+ fprintf oc " cmpl %a, %a\n" ireg r2 ireg r1
+ | Pcmp_ri(r1, n) ->
+ fprintf oc " cmpl $%a, %a\n" coqint n ireg r1
+ | Ptest_rr(r1, r2) ->
+ fprintf oc " testl %a, %a\n" ireg r2 ireg r1
+ | Ptest_ri(r1, n) ->
+ fprintf oc " testl $%a, %a\n" coqint n ireg r1
+ | Pcmov(c, rd, r1) ->
+ assert (c <> Cond_nep && c <> Cond_enp);
+ fprintf oc " cmov%s %a, %a\n" (name_of_condition c) ireg r1 ireg rd
+ | Psetcc(c, rd) ->
+ begin match c with
+ | Cond_nep ->
+ fprintf oc " setne %%cl\n";
+ fprintf oc " setp %%dl\n";
+ fprintf oc " orb %%dl, %%cl\n"
+ | Cond_enp ->
+ fprintf oc " sete %%cl\n";
+ fprintf oc " setnp %%dl\n";
+ fprintf oc " andb %%dl, %%cl\n"
+ | _ ->
+ fprintf oc " set%s %%cl\n" (name_of_condition c)
+ end;
+ fprintf oc " movzbl %%cl, %a\n" ireg rd
+ (** Arithmetic operations over floats *)
+ | Paddd_ff(rd, r1) ->
+ fprintf oc " addsd %a, %a\n" freg r1 freg rd
+ | Psubd_ff(rd, r1) ->
+ fprintf oc " subsd %a, %a\n" freg r1 freg rd
+ | Pmuld_ff(rd, r1) ->
+ fprintf oc " mulsd %a, %a\n" freg r1 freg rd
+ | Pdivd_ff(rd, r1) ->
+ fprintf oc " divsd %a, %a\n" freg r1 freg rd
+ | Pnegd (rd) ->
+ need_masks := true;
+ fprintf oc " xorpd %a, %a\n" raw_symbol "__negd_mask" freg rd
+ | Pabsd (rd) ->
+ need_masks := true;
+ fprintf oc " andpd %a, %a\n" raw_symbol "__absd_mask" freg rd
+ | Pcomisd_ff(r1, r2) ->
+ fprintf oc " comisd %a, %a\n" freg r2 freg r1
+ (** Branches and calls *)
+ | Pjmp_l(l) ->
+ fprintf oc " jmp %a\n" label (transl_label l)
+ | Pjmp_s(f) ->
+ if not (is_builtin_function f) then
+ fprintf oc " jmp %a\n" symbol f
+ else begin
+ print_builtin_function oc f;
+ fprintf oc " ret\n"
+ end
+ | Pjmp_r(r) ->
+ fprintf oc " jmp *%a\n" ireg r
+ | Pjcc(c, l) ->
+ let l = transl_label l in
+ begin match c with
+ | Cond_nep ->
+ fprintf oc " jp %a\n" label l;
+ fprintf oc " jne %a\n" label l
+ | Cond_enp ->
+ let l' = new_label() in
+ fprintf oc " jp %a\n" label l';
+ fprintf oc " je %a\n" label l;
+ fprintf oc "%a:\n" label l'
+ | _ ->
+ fprintf oc " j%s %a\n" (name_of_condition c) label l
+ end
+ | Pjmptbl(r, tbl) ->
+ let l = new_label() in
+ fprintf oc " jmp *%a(, %a, 4)\n" label l ireg r;
+ jumptables := (l, tbl) :: !jumptables
+ | Pcall_s(f) ->
+ if not (is_builtin_function f) then
+ fprintf oc " call %a\n" symbol f
+ else
+ print_builtin_function oc f
+ | Pcall_r(r) ->
+ fprintf oc " call *%a\n" ireg r
+ | Pret ->
+ fprintf oc " ret\n"
+ (** Pseudo-instructions *)
+ | Plabel(l) ->
+ if Labelset.mem l labels then
+ fprintf oc "%a:\n" label (transl_label l)
+ | Pallocframe(lo, hi, ofs_ra, ofs_link) ->
+ let sz = sp_adjustment lo hi in
+ let ofs_link = camlint_of_coqint ofs_link in
+ fprintf oc " subl $%ld, %%esp\n" sz;
+ fprintf oc " leal %ld(%%esp), %%edx\n" (Int32.add sz 4l);
+ fprintf oc " movl %%edx, %ld(%%esp)\n" ofs_link
+ | Pfreeframe(lo, hi, ofs_ra, ofs_link) ->
+ let sz = sp_adjustment lo hi in
+ fprintf oc " addl $%ld, %%esp\n" sz
+ | Pbuiltin(ef, args, res) ->
+ print_builtin_inlined oc (extern_atom ef.ef_id) args res
+
+let print_literal oc (lbl, n) =
+ fprintf oc "%a: .quad 0x%Lx\n" label lbl n
+
+let print_jumptable oc (lbl, tbl) =
+ fprintf oc "%a:" label lbl;
+ List.iter
+ (fun l -> fprintf oc " .long %a\n" label (transl_label l))
+ tbl
+
+let rec labels_of_code accu = function
+ | [] ->
+ accu
+ | (Pjmp_l lbl | Pjcc(_, lbl)) :: c ->
+ labels_of_code (Labelset.add lbl accu) c
+ | Pjmptbl(_, tbl) :: c ->
+ labels_of_code (List.fold_right Labelset.add tbl accu) c
+ | _ :: c ->
+ labels_of_code accu c
+
+let print_function oc name code =
+ Hashtbl.clear current_function_labels;
+ float_literals := [];
+ jumptables := [];
+ section oc text;
+ print_align oc 16;
+ if not (C2C.atom_is_static name) then
+ fprintf oc " .globl %a\n" symbol name;
+ fprintf oc "%a:\n" symbol name;
+ List.iter (print_instruction oc (labels_of_code Labelset.empty code)) code;
+ if target = ELF then begin
+ fprintf oc " .type %a, @function\n" symbol name;
+ fprintf oc " .size %a, . - %a\n" symbol name symbol name
+ end;
+ if !float_literals <> [] then begin
+ section oc float_literal;
+ print_align oc 8;
+ List.iter (print_literal oc) !float_literals;
+ float_literals := []
+ end;
+ if !jumptables <> [] then begin
+ section oc jumptable_literal;
+ print_align oc 4;
+ List.iter (print_jumptable oc) !jumptables;
+ jumptables := []
+ end
+
+let print_fundef oc (Coq_pair(name, defn)) =
+ match defn with
+ | Internal code -> print_function oc name code
+ | External ef -> ()
+
+let print_init oc = function
+ | Init_int8 n ->
+ fprintf oc " .byte %ld\n" (camlint_of_coqint n)
+ | Init_int16 n ->
+ fprintf oc " .short %ld\n" (camlint_of_coqint n)
+ | Init_int32 n ->
+ fprintf oc " .long %ld\n" (camlint_of_coqint n)
+ | Init_float32 n ->
+ fprintf oc " .long %ld %s %.18g\n" (Int32.bits_of_float n) comment n
+ | Init_float64 n ->
+ fprintf oc " .quad %Ld %s %.18g\n" (Int64.bits_of_float n) comment n
+ | Init_space n ->
+ let n = camlint_of_z n in
+ if n > 0l then fprintf oc " .space %ld\n" n
+ | Init_addrof(symb, ofs) ->
+ fprintf oc " .long %a\n"
+ symbol_offset (symb, camlint_of_coqint ofs)
+
+let print_init_data oc name id =
+ if Str.string_match PrintCsyntax.re_string_literal (extern_atom name) 0
+ && List.for_all (function Init_int8 _ -> true | _ -> false) id
+ then
+ fprintf oc " .ascii \"%s\"\n" (PrintCsyntax.string_of_init id)
+ else
+ List.iter (print_init oc) id
+
+let print_var oc (Coq_pair(name, v)) =
+ match v.gvar_init with
+ | [] -> ()
+ | _ ->
+ let sec =
+ if v.gvar_readonly then const_data else data
+ and align =
+ match C2C.atom_alignof name with
+ | Some a -> a
+ | None -> 8 (* 8-alignment is a safe default *)
+ in
+ section oc sec;
+ print_align oc align;
+ if not (C2C.atom_is_static name) then
+ fprintf oc " .globl %a\n" symbol name;
+ fprintf oc "%a:\n" symbol name;
+ print_init_data oc name v.gvar_init;
+ if target = ELF then begin
+ fprintf oc " .type %a, @object\n" symbol name;
+ fprintf oc " .size %a, . - %a\n" symbol name symbol name
+ end
+
+let print_program oc p =
+ need_masks := false;
+ List.iter (print_var oc) p.prog_vars;
+ List.iter (print_fundef oc) p.prog_funct;
+ if !need_masks then begin
+ section oc float_literal;
+ print_align oc 16;
+ fprintf oc "%a: .quad 0x8000000000000000, 0\n"
+ raw_symbol "__negd_mask";
+ fprintf oc "%a: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n"
+ raw_symbol "__absd_mask"
+ end
diff --git a/ia32/PrintAsm.mli b/ia32/PrintAsm.mli
new file mode 100644
index 0000000..aefe3a0
--- /dev/null
+++ b/ia32/PrintAsm.mli
@@ -0,0 +1,13 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+val print_program: out_channel -> Asm.program -> unit
diff --git a/ia32/PrintOp.ml b/ia32/PrintOp.ml
new file mode 100644
index 0000000..6e6ef3c
--- /dev/null
+++ b/ia32/PrintOp.ml
@@ -0,0 +1,105 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Pretty-printing of operators, conditions, addressing modes *)
+
+open Format
+open Camlcoq
+open Integers
+open Op
+
+let comparison_name = function
+ | Ceq -> "=="
+ | Cne -> "!="
+ | Clt -> "<"
+ | Cle -> "<="
+ | Cgt -> ">"
+ | Cge -> ">="
+
+let print_condition reg pp = function
+ | (Ccomp c, [r1;r2]) ->
+ fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2
+ | (Ccompu c, [r1;r2]) ->
+ fprintf pp "%a %su %a" reg r1 (comparison_name c) reg r2
+ | (Ccompimm(c, n), [r1]) ->
+ fprintf pp "%a %ss %ld" reg r1 (comparison_name c) (camlint_of_coqint n)
+ | (Ccompuimm(c, n), [r1]) ->
+ fprintf pp "%a %su %ld" reg r1 (comparison_name c) (camlint_of_coqint n)
+ | (Ccompf c, [r1;r2]) ->
+ fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2
+ | (Cnotcompf c, [r1;r2]) ->
+ fprintf pp "%a not(%sf) %a" reg r1 (comparison_name c) reg r2
+ | (Cmaskzero n, [r1]) ->
+ fprintf pp "%a & 0x%lx == 0" reg r1 (camlint_of_coqint n)
+ | (Cmasknotzero n, [r1]) ->
+ fprintf pp "%a & 0x%lx != 0" reg r1 (camlint_of_coqint n)
+ | _ ->
+ fprintf pp "<bad condition>"
+
+let print_addressing reg pp = function
+ | Aindexed n, [r1] ->
+ fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n)
+ | Aindexed2 n, [r1; r2] ->
+ fprintf pp "%a + %a + %ld" reg r1 reg r2 (camlint_of_coqint n)
+ | Ascaled(sc,n), [r1] ->
+ fprintf pp "%a * %ld + %ld" reg r1 (camlint_of_coqint sc) (camlint_of_coqint n)
+ | Aindexed2scaled(sc, n), [r1; r2] ->
+ fprintf pp "%a + %a * %ld + %ld" reg r1 reg r2 (camlint_of_coqint sc) (camlint_of_coqint n)
+ | Aglobal(id, ofs), [] -> fprintf pp "%s + %ld" (extern_atom id) (camlint_of_coqint ofs)
+ | Abased(id, ofs), [r1] -> fprintf pp "%s + %ld + %a" (extern_atom id) (camlint_of_coqint ofs) reg r1
+ | Abasedscaled(sc,id, ofs), [r1] -> fprintf pp "%s + %ld + %a * %ld" (extern_atom id) (camlint_of_coqint ofs) reg r1 (camlint_of_coqint sc)
+ | Ainstack ofs, [] -> fprintf pp "stack(%ld)" (camlint_of_coqint ofs)
+ | _ -> fprintf pp "<bad addressing>"
+
+let print_operation reg pp = function
+ | Omove, [r1] -> reg pp r1
+ | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n)
+ | Ofloatconst n, [] -> fprintf pp "%F" n
+ | Ocast8signed, [r1] -> fprintf pp "int8signed(%a)" reg r1
+ | Ocast8unsigned, [r1] -> fprintf pp "int8unsigned(%a)" reg r1
+ | Ocast16signed, [r1] -> fprintf pp "int16signed(%a)" reg r1
+ | Ocast16unsigned, [r1] -> fprintf pp "int16unsigned(%a)" reg r1
+ | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2
+ | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2
+ | Omulimm n, [r1] -> fprintf pp "%a * %ld" reg r1 (camlint_of_coqint n)
+ | Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2
+ | Odivu, [r1;r2] -> fprintf pp "%a /u %a" reg r1 reg r2
+ | Omod, [r1;r2] -> fprintf pp "%a %%s %a" reg r1 reg r2
+ | Omodu, [r1;r2] -> fprintf pp "%a %%u %a" reg r1 reg r2
+ | Oand, [r1;r2] -> fprintf pp "%a & %a" reg r1 reg r2
+ | Oandimm n, [r1] -> fprintf pp "%a & %ld" reg r1 (camlint_of_coqint n)
+ | Oor, [r1;r2] -> fprintf pp "%a | %a" reg r1 reg r2
+ | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n)
+ | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2
+ | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n)
+ | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2
+ | Oshlimm n, [r1] -> fprintf pp "%a << %ld" reg r1 (camlint_of_coqint n)
+ | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2
+ | Oshrimm n, [r1] -> fprintf pp "%a >>s %ld" reg r1 (camlint_of_coqint n)
+ | Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n)
+ | Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2
+ | Oshruimm n, [r1] -> fprintf pp "%a >>u %ld" reg r1 (camlint_of_coqint n)
+ | Ororimm n, [r1] -> fprintf pp "%a ror %ld" reg r1 (camlint_of_coqint n)
+ | Olea addr, args -> print_addressing reg pp (addr, args)
+ | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1
+ | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1
+ | Oaddf, [r1;r2] -> fprintf pp "%a +f %a" reg r1 reg r2
+ | Osubf, [r1;r2] -> fprintf pp "%a -f %a" reg r1 reg r2
+ | Omulf, [r1;r2] -> fprintf pp "%a *f %a" reg r1 reg r2
+ | Odivf, [r1;r2] -> fprintf pp "%a /f %a" reg r1 reg r2
+ | Osingleoffloat, [r1] -> fprintf pp "singleoffloat(%a)" reg r1
+ | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1
+ | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1
+ | Ocmp c, args -> print_condition reg pp (c, args)
+ | _ -> fprintf pp "<bad operator>"
+
+
diff --git a/ia32/SelectOp.v b/ia32/SelectOp.v
new file mode 100644
index 0000000..4a4d9e1
--- /dev/null
+++ b/ia32/SelectOp.v
@@ -0,0 +1,839 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Instruction selection for operators *)
+
+(** The instruction selection pass recognizes opportunities for using
+ combined arithmetic and logical operations and addressing modes
+ offered by the target processor. For instance, the expression [x + 1]
+ can take advantage of the "immediate add" instruction of the processor,
+ and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned
+ into a "rotate and mask" instruction.
+
+ This file defines functions for building CminorSel expressions and
+ statements, especially expressions consisting of operator
+ applications. These functions examine their arguments to choose
+ cheaper forms of operators whenever possible.
+
+ For instance, [add e1 e2] will return a CminorSel expression semantically
+ equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a
+ [Oaddimm] operator if one of the arguments is an integer constant,
+ or suppress the addition altogether if one of the arguments is the
+ null integer. In passing, we perform operator reassociation
+ ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount
+ of constant propagation.
+
+ On top of the "smart constructor" functions defined below,
+ module [Selection] implements the actual instruction selection pass.
+*)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Cminor.
+Require Import Op.
+Require Import CminorSel.
+
+Open Local Scope cminorsel_scope.
+
+(** ** Constants **)
+
+Definition addrsymbol (id: ident) (ofs: int) :=
+ Eop (Olea (Aglobal id ofs)) Enil.
+
+Definition addrstack (ofs: int) :=
+ Eop (Olea (Ainstack ofs)) Enil.
+
+(** ** Boolean negation *)
+
+Definition notbool_base (e: expr) :=
+ Eop (Ocmp (Ccompimm Ceq Int.zero)) (e ::: Enil).
+
+Fixpoint notbool (e: expr) {struct e} : expr :=
+ match e with
+ | Eop (Ointconst n) Enil =>
+ Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil
+ | Eop (Ocmp cond) args =>
+ Eop (Ocmp (negate_condition cond)) args
+ | Econdition e1 e2 e3 =>
+ Econdition e1 (notbool e2) (notbool e3)
+ | _ =>
+ notbool_base e
+ end.
+
+(** ** Integer addition and pointer addition *)
+
+Definition offset_addressing (a: addressing) (ofs: int) : addressing :=
+ match a with
+ | Aindexed n => Aindexed (Int.add n ofs)
+ | Aindexed2 n => Aindexed2 (Int.add n ofs)
+ | Ascaled sc n => Ascaled sc (Int.add n ofs)
+ | Aindexed2scaled sc n => Aindexed2scaled sc (Int.add n ofs)
+ | Aglobal id n => Aglobal id (Int.add n ofs)
+ | Abased id n => Abased id (Int.add n ofs)
+ | Abasedscaled sc id n => Abasedscaled sc id (Int.add n ofs)
+ | Ainstack n => Ainstack (Int.add n ofs)
+ end.
+
+(** Addition of an integer constant *)
+
+(*
+Definition addimm (n: int) (e: expr) :=
+ if Int.eq n Int.zero then e else
+ match e with
+ | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil
+ | Eop (Olea addr) args => Eop (Olea (offset_addressing addr n)) args
+ | _ => Eop (Olea (Aindexed n)) (e ::: Enil)
+ end.
+*)
+
+Inductive addimm_cases: forall (e: expr), Type :=
+ | addimm_case1:
+ forall m,
+ addimm_cases (Eop (Ointconst m) Enil)
+ | addimm_case2:
+ forall addr args,
+ addimm_cases (Eop (Olea addr) args)
+ | addimm_default:
+ forall (e: expr),
+ addimm_cases e.
+
+Definition addimm_match (e: expr) :=
+ match e as z1 return addimm_cases z1 with
+ | Eop (Ointconst m) Enil =>
+ addimm_case1 m
+ | Eop (Olea addr) args =>
+ addimm_case2 addr args
+ | e =>
+ addimm_default e
+ end.
+
+Definition addimm (n: int) (e: expr) :=
+ if Int.eq n Int.zero then e else
+ match addimm_match e with
+ | addimm_case1 m =>
+ Eop (Ointconst(Int.add n m)) Enil
+ | addimm_case2 addr args =>
+ Eop (Olea (offset_addressing addr n)) args
+ | addimm_default e =>
+ Eop (Olea (Aindexed n)) (e ::: Enil)
+ end.
+
+(** Addition of two integer or pointer expressions *)
+
+(*
+Definition add (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 => addimm n1 t2
+ | t1, Eop (Ointconst n2) Enil => addimm n2 t1
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => Eop (Olea (Aindexed2 (Int.add n1 n2))) (t1:::t2:::Enil)
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t1:::t2:::Enil)
+ | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t2:::t1:::Enil)
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil) => Eop (Olea (Abased id (Int.add ofs n1))) (t1:::Enil)
+ | Eop (Olea (Aglobal id ofs)) Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => Eop (Olea (Abased id (Int.add ofs n2))) (t2:::Enil)
+ | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil) => Eop (Olea (Abasedscaled sc id (Int.add ofs n1))) (t1:::Enil)
+ | Eop (Olea (Aglobal id ofs)) Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => Eop (Olea (Abasedscaled sc id (Int.add ofs n2))) (t2:::Enil)
+ | Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 => Eop (Olea (Aindexed2scaled sc n)) (t2:::t1:::Enil)
+ | t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) => Eop (Olea (Aindexed2scaled sc n)) (t1:::t2:::Enil)
+ | Eop (Olea (Aindexed n)) (t1:::Enil), t2 => Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil)
+ | t1, Eop (Olea (Aindexed n)) (t2:::Enil) => Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil)
+ | _, _ => Eop (Olea (Aindexed2 Int.zero)) (e1:::e2:::Enil)
+ end.
+*)
+
+Inductive add_cases: forall (e1: expr) (e2: expr), Type :=
+ | add_case1:
+ forall n1 t2,
+ add_cases (Eop (Ointconst n1) Enil) (t2)
+ | add_case2:
+ forall t1 n2,
+ add_cases (t1) (Eop (Ointconst n2) Enil)
+ | add_case3:
+ forall n1 t1 n2 t2,
+ add_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Aindexed n2)) (t2:::Enil))
+ | add_case4:
+ forall n1 t1 sc n2 t2,
+ add_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Ascaled sc n2)) (t2:::Enil))
+ | add_case5:
+ forall sc n1 t1 n2 t2,
+ add_cases (Eop (Olea (Ascaled sc n1)) (t1:::Enil)) (Eop (Olea (Aindexed n2)) (t2:::Enil))
+ | add_case6:
+ forall n1 t1 id ofs,
+ add_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Aglobal id ofs)) Enil)
+ | add_case7:
+ forall id ofs n2 t2,
+ add_cases (Eop (Olea (Aglobal id ofs)) Enil) (Eop (Olea (Aindexed n2)) (t2:::Enil))
+ | add_case8:
+ forall sc n1 t1 id ofs,
+ add_cases (Eop (Olea (Ascaled sc n1)) (t1:::Enil)) (Eop (Olea (Aglobal id ofs)) Enil)
+ | add_case9:
+ forall id ofs sc n2 t2,
+ add_cases (Eop (Olea (Aglobal id ofs)) Enil) (Eop (Olea (Ascaled sc n2)) (t2:::Enil))
+ | add_case10:
+ forall sc n t1 t2,
+ add_cases (Eop (Olea (Ascaled sc n)) (t1:::Enil)) (t2)
+ | add_case11:
+ forall t1 sc n t2,
+ add_cases (t1) (Eop (Olea (Ascaled sc n)) (t2:::Enil))
+ | add_case12:
+ forall n t1 t2,
+ add_cases (Eop (Olea (Aindexed n)) (t1:::Enil)) (t2)
+ | add_case13:
+ forall t1 n t2,
+ add_cases (t1) (Eop (Olea (Aindexed n)) (t2:::Enil))
+ | add_default:
+ forall (e1: expr) (e2: expr),
+ add_cases e1 e2.
+
+Definition add_match (e1: expr) (e2: expr) :=
+ match e1 as z1, e2 as z2 return add_cases z1 z2 with
+ | Eop (Ointconst n1) Enil, t2 =>
+ add_case1 n1 t2
+ | t1, Eop (Ointconst n2) Enil =>
+ add_case2 t1 n2
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) =>
+ add_case3 n1 t1 n2 t2
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) =>
+ add_case4 n1 t1 sc n2 t2
+ | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) =>
+ add_case5 sc n1 t1 n2 t2
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil =>
+ add_case6 n1 t1 id ofs
+ | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Aindexed n2)) (t2:::Enil) =>
+ add_case7 id ofs n2 t2
+ | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil =>
+ add_case8 sc n1 t1 id ofs
+ | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Ascaled sc n2)) (t2:::Enil) =>
+ add_case9 id ofs sc n2 t2
+ | Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 =>
+ add_case10 sc n t1 t2
+ | t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) =>
+ add_case11 t1 sc n t2
+ | Eop (Olea (Aindexed n)) (t1:::Enil), t2 =>
+ add_case12 n t1 t2
+ | t1, Eop (Olea (Aindexed n)) (t2:::Enil) =>
+ add_case13 t1 n t2
+ | e1, e2 =>
+ add_default e1 e2
+ end.
+
+Definition add (e1: expr) (e2: expr) :=
+ match add_match e1 e2 with
+ | add_case1 n1 t2 =>
+ addimm n1 t2
+ | add_case2 t1 n2 =>
+ addimm n2 t1
+ | add_case3 n1 t1 n2 t2 =>
+ Eop (Olea (Aindexed2 (Int.add n1 n2))) (t1:::t2:::Enil)
+ | add_case4 n1 t1 sc n2 t2 =>
+ Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t1:::t2:::Enil)
+ | add_case5 sc n1 t1 n2 t2 =>
+ Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t2:::t1:::Enil)
+ | add_case6 n1 t1 id ofs =>
+ Eop (Olea (Abased id (Int.add ofs n1))) (t1:::Enil)
+ | add_case7 id ofs n2 t2 =>
+ Eop (Olea (Abased id (Int.add ofs n2))) (t2:::Enil)
+ | add_case8 sc n1 t1 id ofs =>
+ Eop (Olea (Abasedscaled sc id (Int.add ofs n1))) (t1:::Enil)
+ | add_case9 id ofs sc n2 t2 =>
+ Eop (Olea (Abasedscaled sc id (Int.add ofs n2))) (t2:::Enil)
+ | add_case10 sc n t1 t2 =>
+ Eop (Olea (Aindexed2scaled sc n)) (t2:::t1:::Enil)
+ | add_case11 t1 sc n t2 =>
+ Eop (Olea (Aindexed2scaled sc n)) (t1:::t2:::Enil)
+ | add_case12 n t1 t2 =>
+ Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil)
+ | add_case13 t1 n t2 =>
+ Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil)
+ | add_default e1 e2 =>
+ Eop (Olea (Aindexed2 Int.zero)) (e1:::e2:::Enil)
+ end.
+
+(** ** Integer and pointer subtraction *)
+
+(*
+Definition sub (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil))
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 => addimm n1 (Eop Osub (t1:::t2:::Enil))
+ | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil))
+ | _, _ => Eop Osub (e1:::e2:::Enil)
+ end.
+*)
+
+Inductive sub_cases: forall (e1: expr) (e2: expr), Type :=
+ | sub_case1:
+ forall t1 n2,
+ sub_cases (t1) (Eop (Ointconst n2) Enil)
+ | sub_case2:
+ forall n1 t1 n2 t2,
+ sub_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Aindexed n2)) (t2:::Enil))
+ | sub_case3:
+ forall n1 t1 t2,
+ sub_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (t2)
+ | sub_case4:
+ forall t1 n2 t2,
+ sub_cases (t1) (Eop (Olea (Aindexed n2)) (t2:::Enil))
+ | sub_default:
+ forall (e1: expr) (e2: expr),
+ sub_cases e1 e2.
+
+Definition sub_match (e1: expr) (e2: expr) :=
+ match e1 as z1, e2 as z2 return sub_cases z1 z2 with
+ | t1, Eop (Ointconst n2) Enil =>
+ sub_case1 t1 n2
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) =>
+ sub_case2 n1 t1 n2 t2
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 =>
+ sub_case3 n1 t1 t2
+ | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) =>
+ sub_case4 t1 n2 t2
+ | e1, e2 =>
+ sub_default e1 e2
+ end.
+
+Definition sub (e1: expr) (e2: expr) :=
+ match sub_match e1 e2 with
+ | sub_case1 t1 n2 =>
+ addimm (Int.neg n2) t1
+ | sub_case2 n1 t1 n2 t2 =>
+ addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil))
+ | sub_case3 n1 t1 t2 =>
+ addimm n1 (Eop Osub (t1:::t2:::Enil))
+ | sub_case4 t1 n2 t2 =>
+ addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil))
+ | sub_default e1 e2 =>
+ Eop Osub (e1:::e2:::Enil)
+ end.
+
+(** ** Immediate shifts *)
+
+Definition shift_is_scale (n: int) : bool :=
+ Int.eq n (Int.repr 1) || Int.eq n (Int.repr 2) || Int.eq n (Int.repr 3).
+
+(*
+Definition shlimm (e1: expr) :=
+ if Int.eq n Int.zero then e1 else
+ match e1 with
+ | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shl n1 n))
+ | Eop (Oshlimm n1) (t1:::Enil) => if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil)
+ | Eop (Olea (Aindexed n1)) (t1:::Enil) => if shift_is_scale n then Eop (Olea (Ascaled (Int.shl Int.one n) (Int.shl n1 n))) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil)
+ | _ => if shift_is_scale n then Eop (Olea (Ascaled (Int.shl Int.one n) Int.zero) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil)
+ end.
+*)
+
+Inductive shlimm_cases: forall (e1: expr), Type :=
+ | shlimm_case1:
+ forall n1,
+ shlimm_cases (Eop (Ointconst n1) Enil)
+ | shlimm_case2:
+ forall n1 t1,
+ shlimm_cases (Eop (Oshlimm n1) (t1:::Enil))
+ | shlimm_case3:
+ forall n1 t1,
+ shlimm_cases (Eop (Olea (Aindexed n1)) (t1:::Enil))
+ | shlimm_default:
+ forall (e1: expr),
+ shlimm_cases e1.
+
+Definition shlimm_match (e1: expr) :=
+ match e1 as z1 return shlimm_cases z1 with
+ | Eop (Ointconst n1) Enil =>
+ shlimm_case1 n1
+ | Eop (Oshlimm n1) (t1:::Enil) =>
+ shlimm_case2 n1 t1
+ | Eop (Olea (Aindexed n1)) (t1:::Enil) =>
+ shlimm_case3 n1 t1
+ | e1 =>
+ shlimm_default e1
+ end.
+
+Definition shlimm (e1: expr) (n: int) :=
+ if Int.eq n Int.zero then e1 else
+ match shlimm_match e1 with
+ | shlimm_case1 n1 =>
+ Eop (Ointconst(Int.shl n1 n)) Enil
+ | shlimm_case2 n1 t1 =>
+ if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil)
+ | shlimm_case3 n1 t1 =>
+ if shift_is_scale n then Eop (Olea (Ascaled (Int.shl Int.one n) (Int.shl n1 n))) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil)
+ | shlimm_default e1 =>
+ if shift_is_scale n then Eop (Olea (Ascaled (Int.shl Int.one n) Int.zero)) (e1:::Enil) else Eop (Oshlimm n) (e1:::Enil)
+ end.
+
+(*
+Definition shruimm (e1: expr) :=
+ if Int.eq n Int.zero then e1 else
+ match e1 with
+ | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shru n1 n))
+ | Eop (Oshruimm n1) (t1:::Enil) => if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) else Eop (Oshruimm n) (e1:::Enil)
+ | _ => Eop (Oshruimm n) (e1:::Enil)
+ end.
+*)
+
+Inductive shruimm_cases: forall (e1: expr), Type :=
+ | shruimm_case1:
+ forall n1,
+ shruimm_cases (Eop (Ointconst n1) Enil)
+ | shruimm_case2:
+ forall n1 t1,
+ shruimm_cases (Eop (Oshruimm n1) (t1:::Enil))
+ | shruimm_default:
+ forall (e1: expr),
+ shruimm_cases e1.
+
+Definition shruimm_match (e1: expr) :=
+ match e1 as z1 return shruimm_cases z1 with
+ | Eop (Ointconst n1) Enil =>
+ shruimm_case1 n1
+ | Eop (Oshruimm n1) (t1:::Enil) =>
+ shruimm_case2 n1 t1
+ | e1 =>
+ shruimm_default e1
+ end.
+
+Definition shruimm (e1: expr) (n: int) :=
+ if Int.eq n Int.zero then e1 else
+ match shruimm_match e1 with
+ | shruimm_case1 n1 =>
+ Eop (Ointconst(Int.shru n1 n)) Enil
+ | shruimm_case2 n1 t1 =>
+ if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) else Eop (Oshruimm n) (e1:::Enil)
+ | shruimm_default e1 =>
+ Eop (Oshruimm n) (e1:::Enil)
+ end.
+
+(*
+Definition shrimm (e1: expr) :=
+ if Int.eq n Int.zero then e1 else
+ match e1 with
+ | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shr n1 n)) Enil
+ | Eop (Oshrimm n1) (t1:::Enil) => if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil)
+ | _ => Eop (Oshrimm n) (e1:::Enil)
+ end.
+*)
+
+Inductive shrimm_cases: forall (e1: expr), Type :=
+ | shrimm_case1:
+ forall n1,
+ shrimm_cases (Eop (Ointconst n1) Enil)
+ | shrimm_case2:
+ forall n1 t1,
+ shrimm_cases (Eop (Oshrimm n1) (t1:::Enil))
+ | shrimm_default:
+ forall (e1: expr),
+ shrimm_cases e1.
+
+Definition shrimm_match (e1: expr) :=
+ match e1 as z1 return shrimm_cases z1 with
+ | Eop (Ointconst n1) Enil =>
+ shrimm_case1 n1
+ | Eop (Oshrimm n1) (t1:::Enil) =>
+ shrimm_case2 n1 t1
+ | e1 =>
+ shrimm_default e1
+ end.
+
+Definition shrimm (e1: expr) (n: int) :=
+ if Int.eq n Int.zero then e1 else
+ match shrimm_match e1 with
+ | shrimm_case1 n1 =>
+ Eop (Ointconst(Int.shr n1 n)) Enil
+ | shrimm_case2 n1 t1 =>
+ if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil)
+ | shrimm_default e1 =>
+ Eop (Oshrimm n) (e1:::Enil)
+ end.
+
+(** ** Integer multiply *)
+
+Definition mulimm_base (n1: int) (e2: expr) :=
+ match Int.one_bits n1 with
+ | i :: nil =>
+ shlimm e2 i
+ | i :: j :: nil =>
+ Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j))
+ | _ =>
+ Eop (Omulimm n1) (e2:::Enil)
+ end.
+
+(*
+Definition mulimm (n1: int) (e2: expr) :=
+ if Int.eq n1 Int.zero then
+ Eop (Ointconst Int.zero) Enil
+ else if Int.eq n1 Int.one then
+ e2
+ else match e2 with
+ | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil
+ | Eop (Olea (Aindexed n2)) (t2:::Enil) => if mul_is_scale n1 then Eop (Olea (Ascaled n1 (Int.mul n1 n2))) (t2:::Enil) else addimm (Int.mul n1 n2) (mulimm_base n1 t2)
+ | _ => mulimm_base n1 e2
+ end.
+
+Definition mulimm (e2: expr) :=
+ match e2 with
+ | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil
+ | Eop (Olea (Aindexed n2)) (t2:::Enil) => if mul_is_scale n1 then Eop (Olea (Ascaled n1 (Int.mul n1 n2))) (t2:::Enil) else addimm (Int.mul n1 n2) (mulimm_base n1 t2)
+ | _ => mulimm_base n1 e2
+ end.
+*)
+
+Inductive mulimm_cases: forall (e2: expr), Type :=
+ | mulimm_case1:
+ forall n2,
+ mulimm_cases (Eop (Ointconst n2) Enil)
+ | mulimm_case2:
+ forall n2 t2,
+ mulimm_cases (Eop (Olea (Aindexed n2)) (t2:::Enil))
+ | mulimm_default:
+ forall (e2: expr),
+ mulimm_cases e2.
+
+Definition mulimm_match (e2: expr) :=
+ match e2 as z1 return mulimm_cases z1 with
+ | Eop (Ointconst n2) Enil =>
+ mulimm_case1 n2
+ | Eop (Olea (Aindexed n2)) (t2:::Enil) =>
+ mulimm_case2 n2 t2
+ | e2 =>
+ mulimm_default e2
+ end.
+
+Definition mulimm (n1: int) (e2: expr) :=
+ if Int.eq n1 Int.zero then
+ Eop (Ointconst Int.zero) Enil
+ else if Int.eq n1 Int.one then
+ e2
+ else match mulimm_match e2 with
+ | mulimm_case1 n2 =>
+ Eop (Ointconst(Int.mul n1 n2)) Enil
+ | mulimm_case2 n2 t2 =>
+ addimm (Int.mul n1 n2) (mulimm_base n1 t2)
+ | mulimm_default e2 =>
+ mulimm_base n1 e2
+ end.
+
+(*
+Definition mul (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2
+ | t1, Eop (Ointconst n2) Enil => mulimm n2 t1
+ | _, _ => Eop Omul (e1:::e2:::Enil)
+ end.
+*)
+
+Inductive mul_cases: forall (e1: expr) (e2: expr), Type :=
+ | mul_case1:
+ forall (n1: int) (t2: expr),
+ mul_cases (Eop (Ointconst n1) Enil) (t2)
+ | mul_case2:
+ forall (t1: expr) (n2: int),
+ mul_cases (t1) (Eop (Ointconst n2) Enil)
+ | mul_default:
+ forall (e1: expr) (e2: expr),
+ mul_cases e1 e2.
+
+Definition mul_match_aux (e1: expr) (e2: expr) :=
+ match e2 as z2 return mul_cases e1 z2 with
+ | Eop (Ointconst n2) Enil =>
+ mul_case2 e1 n2
+ | e2 =>
+ mul_default e1 e2
+ end.
+
+Definition mul_match (e1: expr) (e2: expr) :=
+ match e1 as z1 return mul_cases z1 e2 with
+ | Eop (Ointconst n1) Enil =>
+ mul_case1 n1 e2
+ | e1 =>
+ mul_match_aux e1 e2
+ end.
+
+Definition mul (e1: expr) (e2: expr) :=
+ match mul_match e1 e2 with
+ | mul_case1 n1 t2 =>
+ mulimm n1 t2
+ | mul_case2 t1 n2 =>
+ mulimm n2 t1
+ | mul_default e1 e2 =>
+ Eop Omul (e1:::e2:::Enil)
+ end.
+
+(** ** Bitwise and, or, xor *)
+
+Definition orimm (n: int) (e: expr) :=
+ if Int.eq n Int.zero then e
+ else if Int.eq n Int.mone then Eop (Ointconst Int.mone) Enil
+ else Eop (Oorimm n) (e:::Enil).
+
+Definition same_expr_pure (e1 e2: expr) :=
+ match e1, e2 with
+ | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false
+ | _, _ => false
+ end.
+
+(*
+Definition or (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 => orimm n1 t2
+ | t1, Eop (Ointconst n2) Enil => orimm n2 t1
+ | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil)) => ...
+ | Eop (Oshruimm n2) (t2:::Enil)), Eop (Oshlimm n1) (t1:::Enil) => ...
+ | _, _ => Eop Oor (e1:::e2:::Enil)
+ end.
+*)
+
+Inductive or_cases: forall (e1: expr) (e2: expr), Type :=
+ | or_case1:
+ forall n1 t2,
+ or_cases (Eop (Ointconst n1) Enil) (t2)
+ | or_case2:
+ forall t1 n2,
+ or_cases (t1) (Eop (Ointconst n2) Enil)
+ | or_case3:
+ forall n1 t1 n2 t2,
+ or_cases (Eop (Oshlimm n1) (t1:::Enil)) (Eop (Oshruimm n2) (t2:::Enil))
+ | or_case4:
+ forall n2 t2 n1 t1,
+ or_cases (Eop (Oshruimm n2) (t2:::Enil)) (Eop (Oshlimm n1) (t1:::Enil))
+ | or_default:
+ forall (e1: expr) (e2: expr),
+ or_cases e1 e2.
+
+Definition or_match (e1: expr) (e2: expr) :=
+ match e1 as z1, e2 as z2 return or_cases z1 z2 with
+ | Eop (Ointconst n1) Enil, t2 =>
+ or_case1 n1 t2
+ | t1, Eop (Ointconst n2) Enil =>
+ or_case2 t1 n2
+ | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) =>
+ or_case3 n1 t1 n2 t2
+ | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) =>
+ or_case4 n2 t2 n1 t1
+ | e1, e2 =>
+ or_default e1 e2
+ end.
+
+Definition or (e1: expr) (e2: expr) :=
+ match or_match e1 e2 with
+ | or_case1 n1 t2 =>
+ orimm n1 t2
+ | or_case2 t1 n2 =>
+ orimm n2 t1
+ | or_case3 n1 t1 n2 t2 =>
+ if Int.eq (Int.add n1 n2) Int.iwordsize
+ && same_expr_pure t1 t2
+ then Eop (Ororimm n2) (t1:::Enil)
+ else Eop Oor (e1:::e2:::Enil)
+ | or_case4 n2 t2 n1 t1 =>
+ if Int.eq (Int.add n1 n2) Int.iwordsize
+ && same_expr_pure t1 t2
+ then Eop (Ororimm n2) (t1:::Enil)
+ else Eop Oor (e1:::e2:::Enil)
+ | or_default e1 e2 =>
+ Eop Oor (e1:::e2:::Enil)
+ end.
+
+Definition andimm (n: int) (e: expr) :=
+ if Int.eq n Int.zero then Eop (Ointconst Int.zero) Enil
+ else if Int.eq n Int.mone then e
+ else Eop (Oandimm n) (e:::Enil).
+
+Definition and (e1: expr) (e2: expr) :=
+ match mul_match e1 e2 with
+ | mul_case1 n1 t2 =>
+ andimm n1 t2
+ | mul_case2 t1 n2 =>
+ andimm n2 t1
+ | mul_default e1 e2 =>
+ Eop Oand (e1:::e2:::Enil)
+ end.
+
+Definition xorimm (n: int) (e: expr) :=
+ if Int.eq n Int.zero then e
+ else Eop (Oxorimm n) (e:::Enil).
+
+Definition xor (e1: expr) (e2: expr) :=
+ match mul_match e1 e2 with
+ | mul_case1 n1 t2 =>
+ xorimm n1 t2
+ | mul_case2 t1 n2 =>
+ xorimm n2 t1
+ | mul_default e1 e2 =>
+ Eop Oxor (e1:::e2:::Enil)
+ end.
+
+(** ** General shifts *)
+
+Inductive shift_cases: forall (e1: expr), Type :=
+ | shift_case1:
+ forall (n2: int),
+ shift_cases (Eop (Ointconst n2) Enil)
+ | shift_default:
+ forall (e1: expr),
+ shift_cases e1.
+
+Definition shift_match (e1: expr) :=
+ match e1 as z1 return shift_cases z1 with
+ | Eop (Ointconst n2) Enil =>
+ shift_case1 n2
+ | e1 =>
+ shift_default e1
+ end.
+
+Definition shl (e1: expr) (e2: expr) :=
+ match shift_match e2 with
+ | shift_case1 n2 =>
+ shlimm e1 n2
+ | shift_default e2 =>
+ Eop Oshl (e1:::e2:::Enil)
+ end.
+
+Definition shru (e1: expr) (e2: expr) :=
+ match shift_match e2 with
+ | shift_case1 n2 =>
+ shruimm e1 n2
+ | shift_default e2 =>
+ Eop Oshru (e1:::e2:::Enil)
+ end.
+
+Definition shr (e1: expr) (e2: expr) :=
+ match shift_match e2 with
+ | shift_case1 n2 =>
+ shrimm e1 n2
+ | shift_default e2 =>
+ Eop Oshr (e1:::e2:::Enil)
+ end.
+
+(** ** Comparisons *)
+
+Inductive comp_cases: forall (e1: expr) (e2: expr), Type :=
+ | comp_case1:
+ forall n1 t2,
+ comp_cases (Eop (Ointconst n1) Enil) (t2)
+ | comp_case2:
+ forall t1 n2,
+ comp_cases (t1) (Eop (Ointconst n2) Enil)
+ | comp_default:
+ forall (e1: expr) (e2: expr),
+ comp_cases e1 e2.
+
+Definition comp_match (e1: expr) (e2: expr) :=
+ match e1 as z1, e2 as z2 return comp_cases z1 z2 with
+ | Eop (Ointconst n1) Enil, t2 =>
+ comp_case1 n1 t2
+ | t1, Eop (Ointconst n2) Enil =>
+ comp_case2 t1 n2
+ | e1, e2 =>
+ comp_default e1 e2
+ end.
+
+Definition comp (c: comparison) (e1: expr) (e2: expr) :=
+ match comp_match e1 e2 with
+ | comp_case1 n1 t2 =>
+ Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2 ::: Enil)
+ | comp_case2 t1 n2 =>
+ Eop (Ocmp (Ccompimm c n2)) (t1 ::: Enil)
+ | comp_default e1 e2 =>
+ Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil)
+ end.
+
+Definition compu (c: comparison) (e1: expr) (e2: expr) :=
+ match comp_match e1 e2 with
+ | comp_case1 n1 t2 =>
+ Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2 ::: Enil)
+ | comp_case2 t1 n2 =>
+ Eop (Ocmp (Ccompuimm c n2)) (t1 ::: Enil)
+ | comp_default e1 e2 =>
+ Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil)
+ end.
+
+Definition compf (c: comparison) (e1: expr) (e2: expr) :=
+ Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil).
+
+(** ** Other operators, not optimized. *)
+
+Definition cast8unsigned (e: expr) := Eop Ocast8unsigned (e ::: Enil).
+Definition cast8signed (e: expr) := Eop Ocast8signed (e ::: Enil).
+Definition cast16unsigned (e: expr) := Eop Ocast16unsigned (e ::: Enil).
+Definition cast16signed (e: expr) := Eop Ocast16signed (e ::: Enil).
+Definition divu (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil).
+Definition modu (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil).
+Definition divs (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil).
+Definition mods (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil).
+Definition negint (e: expr) := Eop Oneg (e ::: Enil).
+Definition notint (e: expr) := Eop (Oxorimm Int.mone) (e ::: Enil).
+Definition negf (e: expr) := Eop Onegf (e ::: Enil).
+Definition absf (e: expr) := Eop Oabsf (e ::: Enil).
+Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil).
+Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil).
+Definition floatofint (e: expr) := Eop Ofloatofint (e ::: Enil).
+Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil).
+Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil).
+Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil).
+Definition divf (e1 e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil).
+
+(** ** Conversions between unsigned ints and floats *)
+
+Definition intuoffloat (e: expr) :=
+ let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in
+ Elet e
+ (Econdition (CEcond (Ccompf Clt) (Eletvar O ::: f ::: Enil))
+ (intoffloat (Eletvar O))
+ (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar O) f)))).
+
+Definition floatofintu (e: expr) :=
+ let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in
+ Elet e
+ (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil))
+ (floatofint (Eletvar O))
+ (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f)).
+
+(** ** Addressing modes *)
+
+(*
+Definition addressing (e: expr) :=
+ match e with
+ | Eop (Olea addr) args => (addr, args)
+ | _ => (Aindexed Int.zero, e:::Enil)
+ end.
+*)
+
+Inductive addressing_cases: forall (e: expr), Type :=
+ | addressing_case1:
+ forall addr args,
+ addressing_cases (Eop (Olea addr) args)
+ | addressing_default:
+ forall (e: expr),
+ addressing_cases e.
+
+Definition addressing_match (e: expr) :=
+ match e as z1 return addressing_cases z1 with
+ | Eop (Olea addr) args =>
+ addressing_case1 addr args
+ | e =>
+ addressing_default e
+ end.
+
+Definition addressing (chunk: memory_chunk) (e: expr) :=
+ match addressing_match e with
+ | addressing_case1 addr args =>
+ (addr, args)
+ | addressing_default e =>
+ (Aindexed Int.zero, e:::Enil)
+ end.
+
diff --git a/ia32/SelectOpproof.v b/ia32/SelectOpproof.v
new file mode 100644
index 0000000..59fed01
--- /dev/null
+++ b/ia32/SelectOpproof.v
@@ -0,0 +1,935 @@
+(* *********************************************************************)
+(* *)
+(* 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 of instruction selection for operators *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Events.
+Require Import Globalenvs.
+Require Import Smallstep.
+Require Import Cminor.
+Require Import Op.
+Require Import CminorSel.
+Require Import SelectOp.
+
+Open Local Scope cminorsel_scope.
+
+Section CMCONSTR.
+
+Variable ge: genv.
+Variable sp: val.
+Variable e: env.
+Variable m: mem.
+
+(** * Useful lemmas and tactics *)
+
+(** The following are trivial lemmas and custom tactics that help
+ perform backward (inversion) and forward reasoning over the evaluation
+ of operator applications. *)
+
+Ltac EvalOp := eapply eval_Eop; eauto with evalexpr.
+
+Ltac TrivialOp cstr := unfold cstr; intros; EvalOp.
+
+Ltac InvEval1 :=
+ match goal with
+ | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] =>
+ inv H; InvEval1
+ | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: Enil)) _) |- _ ] =>
+ inv H; InvEval1
+ | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: _ ::: Enil)) _) |- _ ] =>
+ inv H; InvEval1
+ | [ H: (eval_exprlist _ _ _ _ _ Enil _) |- _ ] =>
+ inv H; InvEval1
+ | [ H: (eval_exprlist _ _ _ _ _ (_ ::: _) _) |- _ ] =>
+ inv H; InvEval1
+ | _ =>
+ idtac
+ end.
+
+Ltac InvEval2 :=
+ match goal with
+ | [ H: (eval_operation _ _ _ nil = Some _) |- _ ] =>
+ simpl in H; inv H
+ | [ H: (eval_operation _ _ _ (_ :: nil) = Some _) |- _ ] =>
+ simpl in H; FuncInv
+ | [ H: (eval_operation _ _ _ (_ :: _ :: nil) = Some _) |- _ ] =>
+ simpl in H; FuncInv
+ | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) = Some _) |- _ ] =>
+ simpl in H; FuncInv
+ | _ =>
+ idtac
+ end.
+
+Ltac InvEval := InvEval1; InvEval2; InvEval2.
+
+(** * Correctness of the smart constructors *)
+
+(** We now show that the code generated by "smart constructor" functions
+ such as [SelectOp.notint] behaves as expected. Continuing the
+ [notint] example, we show that if the expression [e]
+ evaluates to some integer value [Vint n], then [SelectOp.notint e]
+ evaluates to a value [Vint (Int.not n)] which is indeed the integer
+ negation of the value of [e].
+
+ All proofs follow a common pattern:
+- Reasoning by case over the result of the classification functions
+ (such as [add_match] for integer addition), gathering additional
+ information on the shape of the argument expressions in the non-default
+ cases.
+- Inversion of the evaluations of the arguments, exploiting the additional
+ information thus gathered.
+- Equational reasoning over the arithmetic operations performed,
+ using the lemmas from the [Int] and [Float] modules.
+- Construction of an evaluation derivation for the expression returned
+ by the smart constructor.
+*)
+
+Theorem eval_addrsymbol:
+ forall le id ofs b,
+ Genv.find_symbol ge id = Some b ->
+ eval_expr ge sp e m le (addrsymbol id ofs) (Vptr b ofs).
+Proof.
+ intros. unfold addrsymbol. econstructor. constructor.
+ simpl. rewrite H. auto.
+Qed.
+
+Theorem eval_addrstack:
+ forall le ofs b n,
+ sp = Vptr b n ->
+ eval_expr ge sp e m le (addrstack ofs) (Vptr b (Int.add n ofs)).
+Proof.
+ intros. unfold addrstack. econstructor. constructor.
+ simpl. unfold offset_sp. rewrite H. auto.
+Qed.
+
+Lemma eval_notbool_base:
+ forall le a v b,
+ eval_expr ge sp e m le a v ->
+ Val.bool_of_val v b ->
+ eval_expr ge sp e m le (notbool_base a) (Val.of_bool (negb b)).
+Proof.
+ TrivialOp notbool_base. simpl.
+ inv H0.
+ rewrite Int.eq_false; auto.
+ rewrite Int.eq_true; auto.
+ reflexivity.
+Qed.
+
+Hint Resolve Val.bool_of_true_val Val.bool_of_false_val
+ Val.bool_of_true_val_inv Val.bool_of_false_val_inv: valboolof.
+
+Theorem eval_notbool:
+ forall le a v b,
+ eval_expr ge sp e m le a v ->
+ Val.bool_of_val v b ->
+ eval_expr ge sp e m le (notbool a) (Val.of_bool (negb b)).
+Proof.
+ induction a; simpl; intros; try (eapply eval_notbool_base; eauto).
+ destruct o; try (eapply eval_notbool_base; eauto).
+
+ destruct e0. InvEval.
+ inv H0. rewrite Int.eq_false; auto.
+ simpl; eauto with evalexpr.
+ rewrite Int.eq_true; simpl; eauto with evalexpr.
+ eapply eval_notbool_base; eauto.
+
+ inv H. eapply eval_Eop; eauto.
+ simpl. assert (eval_condition c vl = Some b).
+ generalize H6. simpl.
+ case (eval_condition c vl); intros.
+ destruct b0; inv H1; inversion H0; auto; congruence.
+ congruence.
+ rewrite (Op.eval_negate_condition _ _ H).
+ destruct b; reflexivity.
+
+ inv H. eapply eval_Econdition; eauto.
+ destruct v1; eauto.
+Qed.
+
+Lemma eval_offset_addressing:
+ forall addr n args v,
+ eval_addressing ge sp addr args = Some v ->
+ eval_addressing ge sp (offset_addressing addr n) args = Some (Val.add v (Vint n)).
+Proof.
+ intros. destruct addr; simpl in *; FuncInv; subst; simpl.
+ rewrite Int.add_assoc. auto.
+ rewrite Int.add_assoc. auto.
+ rewrite <- Int.add_assoc. auto.
+ rewrite <- Int.add_assoc. auto.
+ rewrite <- Int.add_assoc. auto.
+ rewrite <- Int.add_assoc. auto.
+ rewrite <- Int.add_assoc. decEq. decEq. repeat rewrite Int.add_assoc. auto.
+ decEq. decEq. repeat rewrite Int.add_assoc. auto.
+ destruct (Genv.find_symbol ge i); inv H. auto.
+ destruct (Genv.find_symbol ge i); inv H. simpl.
+ repeat rewrite Int.add_assoc. decEq. decEq. decEq. apply Int.add_commut.
+ destruct (Genv.find_symbol ge i0); inv H. simpl.
+ repeat rewrite Int.add_assoc. decEq. decEq. decEq. apply Int.add_commut.
+ unfold offset_sp in *. destruct sp; inv H. simpl. rewrite Int.add_assoc. auto.
+Qed.
+
+Theorem eval_addimm:
+ forall le n a x,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le (addimm n a) (Vint (Int.add x n)).
+Proof.
+ unfold addimm; intros until x.
+ generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro.
+ subst n. rewrite Int.add_zero. auto.
+ case (addimm_match a); intros; InvEval.
+ EvalOp. simpl. rewrite Int.add_commut. auto.
+ inv H0. EvalOp. simpl. rewrite (eval_offset_addressing _ _ _ _ H6). auto.
+ EvalOp.
+Qed.
+
+Theorem eval_addimm_ptr:
+ forall le n a b ofs,
+ eval_expr ge sp e m le a (Vptr b ofs) ->
+ eval_expr ge sp e m le (addimm n a) (Vptr b (Int.add ofs n)).
+Proof.
+ unfold addimm; intros until ofs.
+ generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro.
+ subst n. rewrite Int.add_zero. auto.
+ case (addimm_match a); intros; InvEval.
+ inv H0. EvalOp. simpl. rewrite (eval_offset_addressing _ _ _ _ H6). auto.
+ EvalOp.
+Qed.
+
+Theorem eval_add:
+ forall le a b x y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ eval_expr ge sp e m le (add a b) (Vint (Int.add x y)).
+Proof.
+ intros until y.
+ unfold add; case (add_match a b); intros; InvEval.
+ rewrite Int.add_commut. apply eval_addimm. auto.
+ apply eval_addimm. auto.
+ subst. EvalOp. simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_permut.
+ subst. EvalOp. simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_permut.
+ subst. EvalOp. simpl. decEq. decEq.
+ rewrite Int.add_permut. rewrite Int.add_assoc. decEq. apply Int.add_permut.
+ destruct (Genv.find_symbol ge id); inv H0.
+ destruct (Genv.find_symbol ge id); inv H0.
+ destruct (Genv.find_symbol ge id); inv H0.
+ destruct (Genv.find_symbol ge id); inv H0.
+ subst. EvalOp. simpl. rewrite Int.add_commut. auto.
+ subst. EvalOp.
+ subst. EvalOp. simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut.
+ subst. EvalOp. simpl. decEq. decEq. apply Int.add_assoc.
+ EvalOp. simpl. rewrite Int.add_zero. auto.
+Qed.
+
+Theorem eval_add_ptr:
+ forall le a b p x y,
+ eval_expr ge sp e m le a (Vptr p x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ eval_expr ge sp e m le (add a b) (Vptr p (Int.add x y)).
+Proof.
+ intros until y. unfold add; case (add_match a b); intros; InvEval.
+ apply eval_addimm_ptr; auto.
+ subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_permut.
+ subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_permut.
+ destruct (Genv.find_symbol ge id); inv H0.
+ subst. EvalOp; simpl. destruct (Genv.find_symbol ge id); inv H0.
+ decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut.
+ subst. EvalOp; simpl. destruct (Genv.find_symbol ge id); inv H0.
+ decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut.
+ subst. EvalOp.
+ subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut.
+ subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. auto.
+ EvalOp; simpl. rewrite Int.add_zero. auto.
+Qed.
+
+Theorem eval_add_ptr_2:
+ forall le a b x p y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vptr p y) ->
+ eval_expr ge sp e m le (add a b) (Vptr p (Int.add y x)).
+Proof.
+ intros until y. unfold add; case (add_match a b); intros; InvEval.
+ apply eval_addimm_ptr; auto.
+ subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq.
+ rewrite (Int.add_commut n1 n2). apply Int.add_permut.
+ subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq.
+ rewrite (Int.add_commut n1 n2). apply Int.add_permut.
+ subst. EvalOp; simpl. destruct (Genv.find_symbol ge id); inv H0.
+ decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut.
+ destruct (Genv.find_symbol ge id); inv H0.
+ subst. EvalOp; simpl. destruct (Genv.find_symbol ge id); inv H0.
+ decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut.
+ subst. EvalOp.
+ subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. auto.
+ subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut.
+ EvalOp; simpl. rewrite Int.add_zero. auto.
+Qed.
+
+Theorem eval_sub:
+ forall le a b x y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)).
+Proof.
+ intros until y.
+ unfold sub; case (sub_match a b); intros; InvEval.
+ rewrite Int.sub_add_opp.
+ apply eval_addimm. assumption.
+ replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)).
+ apply eval_addimm. EvalOp.
+ subst x; subst y.
+ repeat rewrite Int.sub_add_opp.
+ repeat rewrite Int.add_assoc. decEq.
+ rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr.
+ replace (Int.sub x y) with (Int.add (Int.sub i y) n1).
+ apply eval_addimm. EvalOp.
+ subst x. rewrite Int.sub_add_l. auto.
+ replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)).
+ apply eval_addimm. EvalOp.
+ subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r.
+ EvalOp.
+Qed.
+
+Theorem eval_sub_ptr_int:
+ forall le a b p x y,
+ eval_expr ge sp e m le a (Vptr p x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ eval_expr ge sp e m le (sub a b) (Vptr p (Int.sub x y)).
+Proof.
+ intros until y.
+ unfold sub; case (sub_match a b); intros; InvEval.
+ rewrite Int.sub_add_opp.
+ apply eval_addimm_ptr. assumption.
+ subst b0. replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)).
+ apply eval_addimm_ptr. EvalOp.
+ subst x; subst y.
+ repeat rewrite Int.sub_add_opp.
+ repeat rewrite Int.add_assoc. decEq.
+ rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr.
+ subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1).
+ apply eval_addimm_ptr. EvalOp.
+ subst x. rewrite Int.sub_add_l. auto.
+ replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)).
+ apply eval_addimm_ptr. EvalOp.
+ subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r.
+ EvalOp.
+Qed.
+
+Theorem eval_sub_ptr_ptr:
+ forall le a b p x y,
+ eval_expr ge sp e m le a (Vptr p x) ->
+ eval_expr ge sp e m le b (Vptr p y) ->
+ eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)).
+Proof.
+ intros until y.
+ unfold sub; case (sub_match a b); intros; InvEval.
+ replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)).
+ apply eval_addimm. EvalOp.
+ simpl; unfold eq_block. subst b0; subst b1; rewrite zeq_true. auto.
+ subst x; subst y.
+ repeat rewrite Int.sub_add_opp.
+ repeat rewrite Int.add_assoc. decEq.
+ rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr.
+ subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1).
+ apply eval_addimm. EvalOp.
+ simpl. unfold eq_block. rewrite zeq_true. auto.
+ subst x. rewrite Int.sub_add_l. auto.
+ subst b0. replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)).
+ apply eval_addimm. EvalOp.
+ simpl. unfold eq_block. rewrite zeq_true. auto.
+ subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r.
+ EvalOp. simpl. unfold eq_block. rewrite zeq_true. auto.
+Qed.
+
+Theorem eval_shlimm:
+ forall le a n x,
+ eval_expr ge sp e m le a (Vint x) ->
+ Int.ltu n Int.iwordsize = true ->
+ eval_expr ge sp e m le (shlimm a n) (Vint (Int.shl x n)).
+Proof.
+ intros until x; unfold shlimm.
+ generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero).
+ intros. subst n. rewrite Int.shl_zero. auto.
+ case (shlimm_match a); intros.
+ InvEval. EvalOp.
+ case_eq (Int.ltu (Int.add n n1) Int.iwordsize); intros.
+ InvEval. revert H8. case_eq (Int.ltu n1 Int.iwordsize); intros; inv H8.
+ EvalOp. simpl. rewrite H2. rewrite Int.shl_shl; auto; rewrite Int.add_commut; auto.
+ EvalOp. simpl. rewrite H1; auto.
+ InvEval. subst.
+ destruct (shift_is_scale n).
+ EvalOp. simpl. decEq. decEq.
+ rewrite (Int.shl_mul (Int.add i n1)); auto. rewrite (Int.shl_mul n1); auto.
+ rewrite Int.mul_add_distr_l. auto.
+ EvalOp. constructor. EvalOp. simpl. eauto. constructor. simpl. rewrite H1. auto.
+ destruct (shift_is_scale n).
+ EvalOp. simpl. decEq. decEq.
+ rewrite Int.add_zero. symmetry. apply Int.shl_mul.
+ EvalOp. simpl. rewrite H1; auto.
+Qed.
+
+Theorem eval_shruimm:
+ forall le a n x,
+ eval_expr ge sp e m le a (Vint x) ->
+ Int.ltu n Int.iwordsize = true ->
+ eval_expr ge sp e m le (shruimm a n) (Vint (Int.shru x n)).
+Proof.
+ intros until x; unfold shruimm.
+ generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero).
+ intros. subst n. rewrite Int.shru_zero. auto.
+ case (shruimm_match a); intros.
+ InvEval. EvalOp.
+ case_eq (Int.ltu (Int.add n n1) Int.iwordsize); intros.
+ InvEval. revert H8. case_eq (Int.ltu n1 Int.iwordsize); intros; inv H8.
+ EvalOp. simpl. rewrite H2. rewrite Int.shru_shru; auto; rewrite Int.add_commut; auto.
+ EvalOp. simpl. rewrite H1; auto.
+ EvalOp. simpl. rewrite H1; auto.
+Qed.
+
+Theorem eval_shrimm:
+ forall le a n x,
+ eval_expr ge sp e m le a (Vint x) ->
+ Int.ltu n Int.iwordsize = true ->
+ eval_expr ge sp e m le (shrimm a n) (Vint (Int.shr x n)).
+Proof.
+ intros until x; unfold shrimm.
+ generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero).
+ intros. subst n. rewrite Int.shr_zero. auto.
+ case (shrimm_match a); intros.
+ InvEval. EvalOp.
+ case_eq (Int.ltu (Int.add n n1) Int.iwordsize); intros.
+ InvEval. revert H8. case_eq (Int.ltu n1 Int.iwordsize); intros; inv H8.
+ EvalOp. simpl. rewrite H2. rewrite Int.shr_shr; auto; rewrite Int.add_commut; auto.
+ EvalOp. simpl. rewrite H1; auto.
+ EvalOp. simpl. rewrite H1; auto.
+Qed.
+
+Lemma eval_mulimm_base:
+ forall le a n x,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le (mulimm_base n a) (Vint (Int.mul x n)).
+Proof.
+ intros; unfold mulimm_base.
+ generalize (Int.one_bits_decomp n).
+ generalize (Int.one_bits_range n).
+ destruct (Int.one_bits n).
+ intros. EvalOp.
+ destruct l.
+ intros. rewrite H1. simpl.
+ rewrite Int.add_zero. rewrite <- Int.shl_mul.
+ apply eval_shlimm. auto. auto with coqlib.
+ destruct l.
+ intros. apply eval_Elet with (Vint x). auto.
+ rewrite H1. simpl. rewrite Int.add_zero.
+ rewrite Int.mul_add_distr_r.
+ apply eval_add.
+ rewrite <- Int.shl_mul. apply eval_shlimm. constructor. auto. auto with coqlib.
+ rewrite <- Int.shl_mul. apply eval_shlimm. constructor. auto. auto with coqlib.
+ intros. EvalOp.
+Qed.
+
+Theorem eval_mulimm:
+ forall le a n x,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le (mulimm n a) (Vint (Int.mul x n)).
+Proof.
+ intros until x; unfold mulimm.
+ generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro.
+ subst n. rewrite Int.mul_zero. intros. EvalOp.
+ generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intro.
+ subst n. rewrite Int.mul_one. auto.
+ case (mulimm_match a); intros; InvEval.
+ EvalOp. rewrite Int.mul_commut. reflexivity.
+ subst. rewrite Int.mul_add_distr_l.
+ rewrite (Int.mul_commut n n2). apply eval_addimm. apply eval_mulimm_base. auto.
+ apply eval_mulimm_base. assumption.
+Qed.
+
+Theorem eval_mul:
+ forall le a b x y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ eval_expr ge sp e m le (mul a b) (Vint (Int.mul x y)).
+Proof.
+ intros until y.
+ unfold mul; case (mul_match a b); intros; InvEval.
+ rewrite Int.mul_commut. apply eval_mulimm. auto.
+ apply eval_mulimm. auto.
+ EvalOp.
+Qed.
+
+Lemma eval_orimm:
+ forall le n a x,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le (orimm n a) (Vint (Int.or x n)).
+Proof.
+ intros. unfold orimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ subst n. rewrite Int.or_zero. auto.
+ predSpec Int.eq Int.eq_spec n Int.mone.
+ subst n. rewrite Int.or_mone. EvalOp.
+ EvalOp.
+Qed.
+
+Remark eval_same_expr:
+ forall a1 a2 le v1 v2,
+ same_expr_pure a1 a2 = true ->
+ eval_expr ge sp e m le a1 v1 ->
+ eval_expr ge sp e m le a2 v2 ->
+ a1 = a2 /\ v1 = v2.
+Proof.
+ intros until v2.
+ destruct a1; simpl; try (intros; discriminate).
+ destruct a2; simpl; try (intros; discriminate).
+ case (ident_eq i i0); intros.
+ subst i0. inversion H0. inversion H1. split. auto. congruence.
+ discriminate.
+Qed.
+
+Theorem eval_or:
+ forall le a x b y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ eval_expr ge sp e m le (or a b) (Vint (Int.or x y)).
+Proof.
+ intros until y; unfold or; case (or_match a b); intros; InvEval.
+
+ rewrite Int.or_commut. apply eval_orimm; auto.
+ apply eval_orimm; auto.
+
+ revert H7; case_eq (Int.ltu n1 Int.iwordsize); intros; inv H7.
+ revert H6; case_eq (Int.ltu n2 Int.iwordsize); intros; inv H6.
+ caseEq (Int.eq (Int.add n1 n2) Int.iwordsize
+ && same_expr_pure t1 t2); intro.
+ destruct (andb_prop _ _ H1).
+ generalize (Int.eq_spec (Int.add n1 n2) Int.iwordsize); rewrite H4; intros.
+ exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2.
+ EvalOp. simpl. rewrite H0. rewrite <- Int.or_ror; auto.
+ EvalOp. econstructor. EvalOp. simpl. rewrite H; eauto.
+ econstructor. EvalOp. simpl. rewrite H0; eauto. constructor.
+ simpl. auto.
+
+ revert H7; case_eq (Int.ltu n2 Int.iwordsize); intros; inv H7.
+ revert H6; case_eq (Int.ltu n1 Int.iwordsize); intros; inv H6.
+ caseEq (Int.eq (Int.add n1 n2) Int.iwordsize
+ && same_expr_pure t1 t2); intro.
+ destruct (andb_prop _ _ H1).
+ generalize (Int.eq_spec (Int.add n1 n2) Int.iwordsize); rewrite H4; intros.
+ exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2.
+ EvalOp. simpl. rewrite H. rewrite Int.or_commut. rewrite <- Int.or_ror; auto.
+ EvalOp. econstructor. EvalOp. simpl. rewrite H; eauto.
+ econstructor. EvalOp. simpl. rewrite H0; eauto. constructor.
+ simpl. auto.
+
+ EvalOp.
+Qed.
+
+Lemma eval_andimm:
+ forall le n a x,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le (andimm n a) (Vint (Int.and x n)).
+Proof.
+ intros. unfold andimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ subst n. rewrite Int.and_zero. EvalOp.
+ predSpec Int.eq Int.eq_spec n Int.mone.
+ subst n. rewrite Int.and_mone. auto.
+ EvalOp.
+Qed.
+
+Theorem eval_and:
+ forall le a x b y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ eval_expr ge sp e m le (and a b) (Vint (Int.and x y)).
+Proof.
+ intros until y; unfold and. case (mul_match a b); intros.
+ InvEval. rewrite Int.and_commut. apply eval_andimm; auto.
+ InvEval. apply eval_andimm; auto.
+ EvalOp.
+Qed.
+
+Lemma eval_xorimm:
+ forall le n a x,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le (xorimm n a) (Vint (Int.xor x n)).
+Proof.
+ intros. unfold xorimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ subst n. rewrite Int.xor_zero. auto.
+ EvalOp.
+Qed.
+
+Theorem eval_xor:
+ forall le a x b y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ eval_expr ge sp e m le (xor a b) (Vint (Int.xor x y)).
+Proof.
+ intros until y; unfold xor. case (mul_match a b); intros.
+ InvEval. rewrite Int.xor_commut. apply eval_xorimm; auto.
+ InvEval. apply eval_xorimm; auto.
+ EvalOp.
+Qed.
+
+Theorem eval_divu:
+ forall le a x b y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ y <> Int.zero ->
+ eval_expr ge sp e m le (divu a b) (Vint (Int.divu x y)).
+Proof.
+ intros; unfold divu; EvalOp.
+ simpl. rewrite Int.eq_false; auto.
+Qed.
+
+Theorem eval_modu:
+ forall le a x b y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ y <> Int.zero ->
+ eval_expr ge sp e m le (modu a b) (Vint (Int.modu x y)).
+Proof.
+ intros; unfold modu; EvalOp.
+ simpl. rewrite Int.eq_false; auto.
+Qed.
+
+Theorem eval_divs:
+ forall le a b x y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ y <> Int.zero ->
+ eval_expr ge sp e m le (divs a b) (Vint (Int.divs x y)).
+Proof.
+ TrivialOp divs. simpl.
+ predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto.
+Qed.
+
+Theorem eval_mods:
+ forall le a b x y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ y <> Int.zero ->
+ eval_expr ge sp e m le (mods a b) (Vint (Int.mods x y)).
+Proof.
+ TrivialOp mods. simpl.
+ predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto.
+Qed.
+
+Theorem eval_shl:
+ forall le a x b y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ Int.ltu y Int.iwordsize = true ->
+ eval_expr ge sp e m le (shl a b) (Vint (Int.shl x y)).
+Proof.
+ intros until y; unfold shl; case (shift_match b); intros.
+ InvEval. apply eval_shlimm; auto.
+ EvalOp. simpl. rewrite H1. auto.
+Qed.
+
+Theorem eval_shru:
+ forall le a x b y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ Int.ltu y Int.iwordsize = true ->
+ eval_expr ge sp e m le (shru a b) (Vint (Int.shru x y)).
+Proof.
+ intros until y; unfold shru; case (shift_match b); intros.
+ InvEval. apply eval_shruimm; auto.
+ EvalOp. simpl. rewrite H1. auto.
+Qed.
+
+Theorem eval_shr:
+ forall le a x b y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ Int.ltu y Int.iwordsize = true ->
+ eval_expr ge sp e m le (shr a b) (Vint (Int.shr x y)).
+Proof.
+ intros until y; unfold shr; case (shift_match b); intros.
+ InvEval. apply eval_shrimm; auto.
+ EvalOp. simpl. rewrite H1. auto.
+Qed.
+
+Theorem eval_comp_int:
+ forall le c a x b y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x y)).
+Proof.
+ intros until y.
+ unfold comp; case (comp_match a b); intros; InvEval.
+ EvalOp. simpl. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity.
+ EvalOp. simpl. destruct (Int.cmp c x y); reflexivity.
+ EvalOp. simpl. destruct (Int.cmp c x y); reflexivity.
+Qed.
+
+Remark eval_compare_null_transf:
+ forall c x v,
+ Cminor.eval_compare_null c x = Some v ->
+ match eval_compare_null c x with
+ | Some true => Some Vtrue
+ | Some false => Some Vfalse
+ | None => None (A:=val)
+ end = Some v.
+Proof.
+ unfold Cminor.eval_compare_null, eval_compare_null; intros.
+ destruct (Int.eq x Int.zero); try discriminate.
+ destruct c; try discriminate; auto.
+Qed.
+
+Theorem eval_comp_ptr_int:
+ forall le c a x1 x2 b y v,
+ eval_expr ge sp e m le a (Vptr x1 x2) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ Cminor.eval_compare_null c y = Some v ->
+ eval_expr ge sp e m le (comp c a b) v.
+Proof.
+ intros until v.
+ unfold comp; case (comp_match a b); intros; InvEval.
+ EvalOp. simpl. apply eval_compare_null_transf; auto.
+ EvalOp. simpl. apply eval_compare_null_transf; auto.
+Qed.
+
+Remark eval_compare_null_swap:
+ forall c x,
+ Cminor.eval_compare_null (swap_comparison c) x =
+ Cminor.eval_compare_null c x.
+Proof.
+ intros. unfold Cminor.eval_compare_null.
+ destruct (Int.eq x Int.zero). destruct c; auto. auto.
+Qed.
+
+Theorem eval_comp_int_ptr:
+ forall le c a x b y1 y2 v,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vptr y1 y2) ->
+ Cminor.eval_compare_null c x = Some v ->
+ eval_expr ge sp e m le (comp c a b) v.
+Proof.
+ intros until v.
+ unfold comp; case (comp_match a b); intros; InvEval.
+ EvalOp. simpl. apply eval_compare_null_transf.
+ rewrite eval_compare_null_swap; auto.
+ EvalOp. simpl. apply eval_compare_null_transf. auto.
+Qed.
+
+Theorem eval_comp_ptr_ptr:
+ forall le c a x1 x2 b y1 y2,
+ eval_expr ge sp e m le a (Vptr x1 x2) ->
+ eval_expr ge sp e m le b (Vptr y1 y2) ->
+ x1 = y1 ->
+ eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x2 y2)).
+Proof.
+ intros until y2.
+ unfold comp; case (comp_match a b); intros; InvEval.
+ EvalOp. simpl. subst y1. rewrite dec_eq_true.
+ destruct (Int.cmp c x2 y2); reflexivity.
+Qed.
+
+Theorem eval_comp_ptr_ptr_2:
+ forall le c a x1 x2 b y1 y2 v,
+ eval_expr ge sp e m le a (Vptr x1 x2) ->
+ eval_expr ge sp e m le b (Vptr y1 y2) ->
+ x1 <> y1 ->
+ Cminor.eval_compare_mismatch c = Some v ->
+ eval_expr ge sp e m le (comp c a b) v.
+Proof.
+ intros until y2.
+ unfold comp; case (comp_match a b); intros; InvEval.
+ EvalOp. simpl. rewrite dec_eq_false; auto.
+ destruct c; simpl in H2; inv H2; auto.
+Qed.
+
+Theorem eval_compu:
+ forall le c a x b y,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le b (Vint y) ->
+ eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)).
+Proof.
+ intros until y.
+ unfold compu; case (comp_match a b); intros; InvEval.
+ EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity.
+ EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity.
+ EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity.
+Qed.
+
+Theorem eval_compf:
+ forall le c a x b y,
+ eval_expr ge sp e m le a (Vfloat x) ->
+ eval_expr ge sp e m le b (Vfloat y) ->
+ eval_expr ge sp e m le (compf c a b) (Val.of_bool(Float.cmp c x y)).
+Proof.
+ intros. unfold compf. EvalOp. simpl.
+ destruct (Float.cmp c x y); reflexivity.
+Qed.
+
+Theorem eval_cast8signed:
+ forall le a v,
+ eval_expr ge sp e m le a v ->
+ eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v).
+Proof. intros; unfold cast8signed; EvalOp. Qed.
+
+Theorem eval_cast8unsigned:
+ forall le a v,
+ eval_expr ge sp e m le a v ->
+ eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v).
+Proof. intros; unfold cast8unsigned; EvalOp. Qed.
+
+Theorem eval_cast16signed:
+ forall le a v,
+ eval_expr ge sp e m le a v ->
+ eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v).
+Proof. intros; unfold cast16signed; EvalOp. Qed.
+
+Theorem eval_cast16unsigned:
+ forall le a v,
+ eval_expr ge sp e m le a v ->
+ eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v).
+Proof. intros; unfold cast16unsigned; EvalOp. Qed.
+
+Theorem eval_singleoffloat:
+ forall le a v,
+ eval_expr ge sp e m le a v ->
+ eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v).
+Proof. intros; unfold singleoffloat; EvalOp. Qed.
+
+Theorem eval_notint:
+ forall le a x,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le (notint a) (Vint (Int.xor x Int.mone)).
+Proof. intros; unfold notint; EvalOp. Qed.
+
+Theorem eval_negint:
+ forall le a x,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le (negint a) (Vint (Int.neg x)).
+Proof. intros; unfold negint; EvalOp. Qed.
+
+Theorem eval_negf:
+ forall le a x,
+ eval_expr ge sp e m le a (Vfloat x) ->
+ eval_expr ge sp e m le (negf a) (Vfloat (Float.neg x)).
+Proof. intros; unfold negf; EvalOp. Qed.
+
+Theorem eval_absf:
+ forall le a x,
+ eval_expr ge sp e m le a (Vfloat x) ->
+ eval_expr ge sp e m le (absf a) (Vfloat (Float.abs x)).
+Proof. intros; unfold absf; EvalOp. Qed.
+
+Theorem eval_intoffloat:
+ forall le a x,
+ eval_expr ge sp e m le a (Vfloat x) ->
+ eval_expr ge sp e m le (intoffloat a) (Vint (Float.intoffloat x)).
+Proof. intros; unfold intoffloat; EvalOp. Qed.
+
+Theorem eval_floatofint:
+ forall le a x,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le (floatofint a) (Vfloat (Float.floatofint x)).
+Proof. intros; unfold floatofint; EvalOp. Qed.
+
+Theorem eval_addf:
+ forall le a x b y,
+ eval_expr ge sp e m le a (Vfloat x) ->
+ eval_expr ge sp e m le b (Vfloat y) ->
+ eval_expr ge sp e m le (addf a b) (Vfloat (Float.add x y)).
+Proof. intros; unfold addf; EvalOp. Qed.
+
+Theorem eval_subf:
+ forall le a x b y,
+ eval_expr ge sp e m le a (Vfloat x) ->
+ eval_expr ge sp e m le b (Vfloat y) ->
+ eval_expr ge sp e m le (subf a b) (Vfloat (Float.sub x y)).
+Proof. intros; unfold subf; EvalOp. Qed.
+
+Theorem eval_mulf:
+ forall le a x b y,
+ eval_expr ge sp e m le a (Vfloat x) ->
+ eval_expr ge sp e m le b (Vfloat y) ->
+ eval_expr ge sp e m le (mulf a b) (Vfloat (Float.mul x y)).
+Proof. intros; unfold mulf; EvalOp. Qed.
+
+Theorem eval_divf:
+ forall le a x b y,
+ eval_expr ge sp e m le a (Vfloat x) ->
+ eval_expr ge sp e m le b (Vfloat y) ->
+ eval_expr ge sp e m le (divf a b) (Vfloat (Float.div x y)).
+Proof. intros; unfold divf; EvalOp. Qed.
+
+Theorem eval_intuoffloat:
+ forall le a x,
+ eval_expr ge sp e m le a (Vfloat x) ->
+ eval_expr ge sp e m le (intuoffloat a) (Vint (Float.intuoffloat x)).
+Proof.
+ intros. unfold intuoffloat.
+ econstructor. eauto.
+ set (im := Int.repr Int.half_modulus).
+ set (fm := Float.floatofintu im).
+ assert (eval_expr ge sp e m (Vfloat x :: le) (Eletvar O) (Vfloat x)).
+ constructor. auto.
+ apply eval_Econdition with (v1 := Float.cmp Clt x fm).
+ econstructor. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
+ simpl. auto.
+ caseEq (Float.cmp Clt x fm); intros.
+ rewrite Float.intuoffloat_intoffloat_1; auto.
+ EvalOp.
+ rewrite Float.intuoffloat_intoffloat_2; auto.
+ fold im. apply eval_addimm. apply eval_intoffloat. apply eval_subf; auto. EvalOp.
+Qed.
+
+Theorem eval_floatofintu:
+ forall le a x,
+ eval_expr ge sp e m le a (Vint x) ->
+ eval_expr ge sp e m le (floatofintu a) (Vfloat (Float.floatofintu x)).
+Proof.
+ intros. unfold floatofintu.
+ econstructor. eauto.
+ set (fm := Float.floatofintu Float.ox8000_0000).
+ assert (eval_expr ge sp e m (Vint x :: le) (Eletvar O) (Vint x)).
+ constructor. auto.
+ apply eval_Econdition with (v1 := Int.ltu x Float.ox8000_0000).
+ econstructor. constructor. eauto. constructor.
+ simpl. auto.
+ caseEq (Int.ltu x Float.ox8000_0000); intros.
+ rewrite Float.floatofintu_floatofint_1; auto.
+ apply eval_floatofint; auto.
+ rewrite Float.floatofintu_floatofint_2; auto.
+ fold fm. apply eval_addf. apply eval_floatofint.
+ rewrite Int.sub_add_opp. apply eval_addimm; auto.
+ EvalOp.
+Qed.
+
+Theorem eval_addressing:
+ forall le chunk a v b ofs,
+ eval_expr ge sp e m le a v ->
+ v = Vptr b ofs ->
+ match addressing chunk a with (mode, args) =>
+ exists vl,
+ eval_exprlist ge sp e m le args vl /\
+ eval_addressing ge sp mode vl = Some v
+ end.
+Proof.
+ intros until v. unfold addressing; case (addressing_match a); intros; InvEval.
+ inv H. exists vl; auto.
+ exists (v :: nil); split. constructor; auto. constructor. subst; simpl. rewrite Int.add_zero; auto.
+Qed.
+
+End CMCONSTR.
diff --git a/ia32/extractionMachdep.v b/ia32/extractionMachdep.v
new file mode 100644
index 0000000..435dce2
--- /dev/null
+++ b/ia32/extractionMachdep.v
@@ -0,0 +1,14 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(* Additional extraction directives specific to the IA32 port *)
+
diff --git a/ia32/standard/CPragmas.ml b/ia32/standard/CPragmas.ml
new file mode 100644
index 0000000..f48064c
--- /dev/null
+++ b/ia32/standard/CPragmas.ml
@@ -0,0 +1,28 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Platform-dependent handling of pragmas *)
+
+(* No pragmas supported on PowerPC/MacOS *)
+
+let initialize () = ()
+
+(* PowerPC-specific: say if an atom is in a small data area *)
+
+let atom_is_small_data a ofs = false
+
+(* PowerPC-specific: determine section to use for a particular symbol *)
+
+let section_for_atom a init = None
diff --git a/ia32/standard/Conventions1.v b/ia32/standard/Conventions1.v
new file mode 100644
index 0000000..a2d7aba
--- /dev/null
+++ b/ia32/standard/Conventions1.v
@@ -0,0 +1,455 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Function calling conventions and other conventions regarding the use of
+ machine registers and stack slots. *)
+
+Require Import Coqlib.
+Require Import AST.
+Require Import Locations.
+
+(** * Classification of machine registers *)
+
+(** Machine registers (type [mreg] in module [Locations]) are divided in
+ the following groups:
+- Temporaries used for spilling, reloading, and parallel move operations.
+- Allocatable registers, that can be assigned to RTL pseudo-registers.
+ These are further divided into:
+-- Callee-save registers, whose value is preserved across a function call.
+-- Caller-save registers that can be modified during a function call.
+
+ We follow the x86-32 application binary interface (ABI) in our choice
+ of callee- and caller-save registers.
+*)
+
+Definition int_caller_save_regs := AX :: nil.
+
+Definition float_caller_save_regs := X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: nil.
+
+Definition int_callee_save_regs := BX :: SI :: DI :: BP :: nil.
+
+Definition float_callee_save_regs : list mreg := nil.
+
+Definition destroyed_at_call_regs :=
+ int_caller_save_regs ++ float_caller_save_regs.
+
+Definition destroyed_at_call :=
+ List.map R destroyed_at_call_regs.
+
+Definition int_temporaries := IT1 :: IT2 :: nil.
+
+Definition float_temporaries := FT1 :: FT2 :: FP0 :: nil.
+
+Definition temporaries :=
+ R IT1 :: R IT2 :: R FT1 :: R FT2 :: R FP0 :: nil.
+
+Definition dummy_int_reg := AX. (**r Used in [Coloring]. *)
+Definition dummy_float_reg := X0. (**r Used in [Coloring]. *)
+
+(** The [index_int_callee_save] and [index_float_callee_save] associate
+ a unique positive integer to callee-save registers. This integer is
+ used in [Stacking] to determine where to save these registers in
+ the activation record if they are used by the current function. *)
+
+Definition index_int_callee_save (r: mreg) :=
+ match r with
+ | BX => 1 | SI => 2 | DI => 3 | BP => 4 | _ => -1
+ end.
+
+Definition index_float_callee_save (r: mreg) := -1.
+
+Ltac ElimOrEq :=
+ match goal with
+ | |- (?x = ?y) \/ _ -> _ =>
+ let H := fresh in
+ (intro H; elim H; clear H;
+ [intro H; rewrite <- H; clear H | ElimOrEq])
+ | |- False -> _ =>
+ let H := fresh in (intro H; contradiction)
+ end.
+
+Ltac OrEq :=
+ match goal with
+ | |- (?x = ?x) \/ _ => left; reflexivity
+ | |- (?x = ?y) \/ _ => right; OrEq
+ | |- False => fail
+ end.
+
+Ltac NotOrEq :=
+ match goal with
+ | |- (?x = ?y) \/ _ -> False =>
+ let H := fresh in (
+ intro H; elim H; clear H; [intro; discriminate | NotOrEq])
+ | |- False -> False =>
+ contradiction
+ end.
+
+Lemma index_int_callee_save_pos:
+ forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0.
+Proof.
+ intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega.
+Qed.
+
+Lemma index_float_callee_save_pos:
+ forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0.
+Proof.
+ intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega.
+Qed.
+
+Lemma index_int_callee_save_pos2:
+ forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs.
+Proof.
+ destruct r; simpl; intro; omegaContradiction || OrEq.
+Qed.
+
+Lemma index_float_callee_save_pos2:
+ forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs.
+Proof.
+ unfold index_float_callee_save; intros. omegaContradiction.
+Qed.
+
+Lemma index_int_callee_save_inj:
+ forall r1 r2,
+ In r1 int_callee_save_regs ->
+ In r2 int_callee_save_regs ->
+ r1 <> r2 ->
+ index_int_callee_save r1 <> index_int_callee_save r2.
+Proof.
+ intros r1 r2.
+ simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save;
+ intros; congruence.
+Qed.
+
+Lemma index_float_callee_save_inj:
+ forall r1 r2,
+ In r1 float_callee_save_regs ->
+ In r2 float_callee_save_regs ->
+ r1 <> r2 ->
+ index_float_callee_save r1 <> index_float_callee_save r2.
+Proof.
+ simpl; intros. contradiction.
+Qed.
+
+(** The following lemmas show that
+ (temporaries, destroyed at call, integer callee-save, float callee-save)
+ is a partition of the set of machine registers. *)
+
+Lemma int_float_callee_save_disjoint:
+ list_disjoint int_callee_save_regs float_callee_save_regs.
+Proof.
+ red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate.
+Qed.
+
+Lemma register_classification:
+ forall r,
+ (In (R r) temporaries \/ In (R r) destroyed_at_call) \/
+ (In r int_callee_save_regs \/ In r float_callee_save_regs).
+Proof.
+ destruct r;
+ try (left; left; simpl; OrEq);
+ try (left; right; simpl; OrEq);
+ try (right; left; simpl; OrEq);
+ try (right; right; simpl; OrEq).
+Qed.
+
+Lemma int_callee_save_not_destroyed:
+ forall r,
+ In (R r) temporaries \/ In (R r) destroyed_at_call ->
+ ~(In r int_callee_save_regs).
+Proof.
+ intros; red; intros. elim H.
+ generalize H0. simpl; ElimOrEq; NotOrEq.
+ generalize H0. simpl; ElimOrEq; NotOrEq.
+Qed.
+
+Lemma float_callee_save_not_destroyed:
+ forall r,
+ In (R r) temporaries \/ In (R r) destroyed_at_call ->
+ ~(In r float_callee_save_regs).
+Proof.
+ intros; red; intros. elim H.
+ generalize H0. simpl; ElimOrEq; NotOrEq.
+ generalize H0. simpl; ElimOrEq; NotOrEq.
+Qed.
+
+Lemma int_callee_save_type:
+ forall r, In r int_callee_save_regs -> mreg_type r = Tint.
+Proof.
+ intro. simpl; ElimOrEq; reflexivity.
+Qed.
+
+Lemma float_callee_save_type:
+ forall r, In r float_callee_save_regs -> mreg_type r = Tfloat.
+Proof.
+ intro. simpl; ElimOrEq; reflexivity.
+Qed.
+
+Ltac NoRepet :=
+ match goal with
+ | |- list_norepet nil =>
+ apply list_norepet_nil
+ | |- list_norepet (?a :: ?b) =>
+ apply list_norepet_cons; [simpl; intuition discriminate | NoRepet]
+ end.
+
+Lemma int_callee_save_norepet:
+ list_norepet int_callee_save_regs.
+Proof.
+ unfold int_callee_save_regs; NoRepet.
+Qed.
+
+Lemma float_callee_save_norepet:
+ list_norepet float_callee_save_regs.
+Proof.
+ unfold float_callee_save_regs; NoRepet.
+Qed.
+
+(** * Function calling conventions *)
+
+(** The functions in this section determine the locations (machine registers
+ and stack slots) used to communicate arguments and results between the
+ caller and the callee during function calls. These locations are functions
+ of the signature of the function and of the call instruction.
+ Agreement between the caller and the callee on the locations to use
+ is guaranteed by our dynamic semantics for Cminor and RTL, which demand
+ that the signature of the call instruction is identical to that of the
+ called function.
+
+ Calling conventions are largely arbitrary: they must respect the properties
+ proved in this section (such as no overlapping between the locations
+ of function arguments), but this leaves much liberty in choosing actual
+ locations. To ensure binary interoperability of code generated by our
+ compiler with libraries compiled by another compiler, we
+ implement the standard x86 conventions. *)
+
+(** ** Location of function result *)
+
+(** The result value of a function is passed back to the caller in
+ registers [AX] or [FP0], depending on the type of the returned value.
+ We treat a function without result as a function with one integer result. *)
+
+Definition loc_result (s: signature) : mreg :=
+ match s.(sig_res) with
+ | None => AX
+ | Some Tint => AX
+ | Some Tfloat => FP0
+ end.
+
+(** The result location has the type stated in the signature. *)
+
+Lemma loc_result_type:
+ forall sig,
+ mreg_type (loc_result sig) =
+ match sig.(sig_res) with None => Tint | Some ty => ty end.
+Proof.
+ intros; unfold loc_result.
+ destruct (sig_res sig).
+ destruct t; reflexivity.
+ reflexivity.
+Qed.
+
+(** The result location is a caller-save register or a temporary *)
+
+Lemma loc_result_caller_save:
+ forall (s: signature),
+ In (R (loc_result s)) destroyed_at_call \/ In (R (loc_result s)) temporaries.
+Proof.
+ intros; unfold loc_result.
+ destruct (sig_res s).
+ destruct t. left; simpl; OrEq. right; simpl; OrEq.
+ left; simpl; OrEq.
+Qed.
+
+(** ** Location of function arguments *)
+
+(** All arguments are passed on stack. (Snif.) *)
+
+Fixpoint loc_arguments_rec
+ (tyl: list typ) (ofs: Z) {struct tyl} : list loc :=
+ match tyl with
+ | nil => nil
+ | Tint :: tys => S (Outgoing ofs Tint) :: loc_arguments_rec tys (ofs + 1)
+ | Tfloat :: tys => S (Outgoing ofs Tfloat) :: loc_arguments_rec tys (ofs + 2)
+ end.
+
+(** [loc_arguments s] returns the list of locations where to store arguments
+ when calling a function with signature [s]. *)
+
+Definition loc_arguments (s: signature) : list loc :=
+ loc_arguments_rec s.(sig_args) 0.
+
+(** [size_arguments s] returns the number of [Outgoing] slots used
+ to call a function with signature [s]. *)
+
+Fixpoint size_arguments_rec
+ (tyl: list typ) (ofs: Z) {struct tyl} : Z :=
+ match tyl with
+ | nil => ofs
+ | Tint :: tys => size_arguments_rec tys (ofs + 1)
+ | Tfloat :: tys => size_arguments_rec tys (ofs + 2)
+ end.
+
+Definition size_arguments (s: signature) : Z :=
+ size_arguments_rec s.(sig_args) 0.
+
+(** A tail-call is possible for a signature if the corresponding
+ arguments are all passed in registers. *)
+
+Definition tailcall_possible (s: signature) : Prop :=
+ forall l, In l (loc_arguments s) ->
+ match l with R _ => True | S _ => False end.
+
+(** Argument locations are either non-temporary registers or [Outgoing]
+ stack slots at nonnegative offsets. *)
+
+Definition loc_argument_acceptable (l: loc) : Prop :=
+ match l with
+ | R r => ~(In l temporaries)
+ | S (Outgoing ofs ty) => ofs >= 0
+ | _ => False
+ end.
+
+Remark loc_arguments_rec_charact:
+ forall tyl ofs l,
+ In l (loc_arguments_rec tyl ofs) ->
+ match l with
+ | S (Outgoing ofs' ty) => ofs' >= ofs
+ | _ => False
+ end.
+Proof.
+ induction tyl; simpl loc_arguments_rec; intros.
+ elim H.
+ destruct a; simpl in H; destruct H.
+ subst l. omega.
+ generalize (IHtyl _ _ H). destruct l; auto. destruct s; auto. omega.
+ subst l. omega.
+ generalize (IHtyl _ _ H). destruct l; auto. destruct s; auto. omega.
+Qed.
+
+Lemma loc_arguments_acceptable:
+ forall (s: signature) (r: loc),
+ In r (loc_arguments s) -> loc_argument_acceptable r.
+Proof.
+ unfold loc_arguments; intros.
+ generalize (loc_arguments_rec_charact _ _ _ H).
+ destruct r; tauto.
+Qed.
+Hint Resolve loc_arguments_acceptable: locs.
+
+(** Arguments are parwise disjoint (in the sense of [Loc.norepet]). *)
+
+Remark loc_arguments_rec_notin_local:
+ forall tyl ofs ofs0 ty0,
+ Loc.notin (S (Local ofs0 ty0)) (loc_arguments_rec tyl ofs).
+Proof.
+ induction tyl; simpl; intros.
+ auto.
+ destruct a; simpl; auto.
+Qed.
+
+Remark loc_arguments_rec_notin_outgoing:
+ forall tyl ofs ofs0 ty0,
+ ofs0 + typesize ty0 <= ofs ->
+ Loc.notin (S (Outgoing ofs0 ty0)) (loc_arguments_rec tyl ofs).
+Proof.
+ induction tyl; simpl; intros.
+ auto.
+ destruct a.
+ split. simpl. omega. apply IHtyl. omega.
+ split. simpl. omega. apply IHtyl. omega.
+Qed.
+
+Lemma loc_arguments_norepet:
+ forall (s: signature), Loc.norepet (loc_arguments s).
+Proof.
+ intros. unfold loc_arguments. generalize (sig_args s) 0.
+ induction l; simpl; intros.
+ constructor.
+ destruct a; constructor.
+ apply loc_arguments_rec_notin_outgoing. simpl; omega. auto.
+ apply loc_arguments_rec_notin_outgoing. simpl; omega. auto.
+Qed.
+
+(** The offsets of [Outgoing] arguments are below [size_arguments s]. *)
+
+Remark size_arguments_rec_above:
+ forall tyl ofs0, ofs0 <= size_arguments_rec tyl ofs0.
+Proof.
+ induction tyl; simpl; intros.
+ omega.
+ destruct a.
+ apply Zle_trans with (ofs0 + 1); auto; omega.
+ apply Zle_trans with (ofs0 + 2); auto; omega.
+Qed.
+
+Lemma size_arguments_above:
+ forall s, size_arguments s >= 0.
+Proof.
+ intros; unfold size_arguments. apply Zle_ge.
+ apply size_arguments_rec_above.
+Qed.
+
+Lemma loc_arguments_bounded:
+ forall (s: signature) (ofs: Z) (ty: typ),
+ In (S (Outgoing ofs ty)) (loc_arguments s) ->
+ ofs + typesize ty <= size_arguments s.
+Proof.
+ intros until ty. unfold loc_arguments, size_arguments. generalize (sig_args s) 0.
+ induction l; simpl; intros.
+ elim H.
+ destruct a; simpl in H; destruct H.
+ inv H. apply size_arguments_rec_above.
+ auto.
+ inv H. apply size_arguments_rec_above.
+ auto.
+Qed.
+
+(** Temporary registers do not overlap with argument locations. *)
+
+Lemma loc_arguments_not_temporaries:
+ forall sig, Loc.disjoint (loc_arguments sig) temporaries.
+Proof.
+ intros; red; intros x1 x2 H.
+ generalize (loc_arguments_rec_charact _ _ _ H).
+ destruct x1. tauto. destruct s; intuition.
+ revert H1. simpl; ElimOrEq; auto.
+Qed.
+Hint Resolve loc_arguments_not_temporaries: locs.
+
+(** Argument registers are caller-save. *)
+
+Lemma arguments_caller_save:
+ forall sig r,
+ In (R r) (loc_arguments sig) -> In (R r) destroyed_at_call.
+Proof.
+ unfold loc_arguments; intros.
+ elim (loc_arguments_rec_charact _ _ _ H); simpl.
+Qed.
+
+(** Argument locations agree in number with the function signature. *)
+
+Lemma loc_arguments_length:
+ forall sig,
+ List.length (loc_arguments sig) = List.length sig.(sig_args).
+Proof.
+ intros. unfold loc_arguments. generalize (sig_args sig) 0.
+ induction l; simpl; intros. auto. destruct a; simpl; decEq; auto.
+Qed.
+
+(** Argument locations agree in types with the function signature. *)
+
+Lemma loc_arguments_type:
+ forall sig, List.map Loc.type (loc_arguments sig) = sig.(sig_args).
+Proof.
+ intros. unfold loc_arguments. generalize (sig_args sig) 0.
+ induction l; simpl; intros. auto. destruct a; simpl; decEq; auto.
+Qed.
diff --git a/ia32/standard/Stacklayout.v b/ia32/standard/Stacklayout.v
new file mode 100644
index 0000000..135aba1
--- /dev/null
+++ b/ia32/standard/Stacklayout.v
@@ -0,0 +1,76 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Machine- and ABI-dependent layout information for activation records. *)
+
+Require Import Coqlib.
+Require Import Bounds.
+
+(** The general shape of activation records is as follows,
+ from bottom (lowest offsets) to top:
+- Space for outgoing arguments to function calls.
+- Back link to parent frame
+- Return address (formally; it's actually pushed elsewhere)
+- Local stack slots of integer type.
+- Saved values of integer callee-save registers used by the function.
+- Local stack slots of float type.
+- Saved values of float callee-save registers used by the function.
+- Space for the stack-allocated data declared in Cminor.
+
+To facilitate some of the proofs, the Cminor stack-allocated data
+starts at offset 0; the preceding areas in the activation record
+therefore have negative offsets. This part (with negative offsets)
+is called the ``frame'', by opposition with the ``Cminor stack data''
+which is the part with positive offsets.
+
+The [frame_env] compilation environment records the positions of
+the boundaries between areas in the frame part.
+*)
+
+Definition fe_ofs_arg := 0.
+
+Record frame_env : Type := mk_frame_env {
+ fe_size: Z;
+ fe_ofs_link: Z;
+ fe_ofs_retaddr: Z;
+ fe_ofs_int_local: Z;
+ fe_ofs_int_callee_save: Z;
+ fe_num_int_callee_save: Z;
+ fe_ofs_float_local: Z;
+ fe_ofs_float_callee_save: Z;
+ fe_num_float_callee_save: Z
+}.
+
+(** Computation of the frame environment from the bounds of the current
+ function. *)
+
+Definition make_env (b: bounds) :=
+ let olink := 4 * b.(bound_outgoing) in (* back link *)
+ let oretaddr := olink + 4 in (* return address *)
+ let oil := oretaddr + 4 in (* integer locals *)
+ let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *)
+ let oendi := oics + 4 * b.(bound_int_callee_save) in
+ let ofl := align oendi 8 in (* float locals *)
+ let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *)
+ let sz := ofcs + 8 * b.(bound_float_callee_save) in (* total frame size *)
+ mk_frame_env sz olink oretaddr
+ oil oics b.(bound_int_callee_save)
+ ofl ofcs b.(bound_float_callee_save).
+
+
+Remark align_float_part:
+ forall b,
+ 4 * bound_outgoing b + 4 + 4 + 4 * bound_int_local b + 4 * bound_int_callee_save b <=
+ align (4 * bound_outgoing b + 4 + 4 + 4 * bound_int_local b + 4 * bound_int_callee_save b) 8.
+Proof.
+ intros. apply align_le. omega.
+Qed.
diff --git a/lib/Floats.v b/lib/Floats.v
index c9dda09..6257bcc 100644
--- a/lib/Floats.v
+++ b/lib/Floats.v
@@ -23,29 +23,33 @@
Require Import Coqlib.
Require Import Integers.
-Parameter float: Type.
+Parameter float: Type. (**r the type of IEE754 doubles *)
Module Float.
-Parameter zero: float.
-Parameter one: float.
+Parameter zero: float. (**r the float [+0.0] *)
-Parameter neg: float -> float.
-Parameter abs: float -> float.
-Parameter singleoffloat: float -> float.
-Parameter intoffloat: float -> int.
-Parameter intuoffloat: float -> int.
-Parameter floatofint: int -> float.
-Parameter floatofintu: int -> float.
+Axiom eq_dec: forall (f1 f2: float), {f1 = f2} + {f1 <> f2}.
-Parameter add: float -> float -> float.
-Parameter sub: float -> float -> float.
-Parameter mul: float -> float -> float.
-Parameter div: float -> float -> float.
+(** Arithmetic operations *)
-Parameter cmp: comparison -> float -> float -> bool.
+Parameter neg: float -> float. (**r opposite (change sign) *)
+Parameter abs: float -> float. (**r absolute value (set sign to [+]) *)
+Parameter singleoffloat: float -> float. (**r conversion to single precision *)
+Parameter intoffloat: float -> int. (**r conversion to signed 32-bit int *)
+Parameter intuoffloat: float -> int. (**r conversion to unsigned 32-bit int *)
+Parameter floatofint: int -> float. (**r conversion from signed 32-bit int *)
+Parameter floatofintu: int -> float. (**r conversion from unsigned 32-bit int *)
-Axiom eq_dec: forall (f1 f2: float), {f1 = f2} + {f1 <> f2}.
+Parameter add: float -> float -> float. (**r addition *)
+Parameter sub: float -> float -> float. (**r subtraction *)
+Parameter mul: float -> float -> float. (**r multiplication *)
+Parameter div: float -> float -> float. (**r division *)
+
+Parameter cmp: comparison -> float -> float -> bool. (**r comparison *)
+
+(** Conversions between floats and their concrete in-memory representation
+ as a sequence of 64 bits (double precision) or 32 bits (single precision). *)
Parameter bits_of_double: float -> int64.
Parameter double_of_bits: int64 -> float.
@@ -53,6 +57,11 @@ Parameter double_of_bits: int64 -> float.
Parameter bits_of_single: float -> int.
Parameter single_of_bits: int -> float.
+Definition from_words (hi lo: int) : float :=
+ double_of_bits
+ (Int64.or (Int64.shl (Int64.repr (Int.unsigned hi)) (Int64.repr 32))
+ (Int64.repr (Int.unsigned lo))).
+
(** Below are the only properties of floating-point arithmetic that we
rely on in the compiler proof. *)
@@ -63,12 +72,39 @@ Axiom subf_addf_opp: forall f1 f2, sub f1 f2 = add f1 (neg f2).
Axiom singleoffloat_idem:
forall f, singleoffloat (singleoffloat f) = singleoffloat f.
+(** Properties of comparisons. *)
+
+Axiom cmp_swap:
+ forall c x y, Float.cmp (swap_comparison c) x y = Float.cmp c y x.
Axiom cmp_ne_eq:
forall f1 f2, cmp Cne f1 f2 = negb (cmp Ceq f1 f2).
+Axiom cmp_lt_eq_false:
+ forall x y, cmp Clt x y = true -> cmp Ceq x y = true -> False.
Axiom cmp_le_lt_eq:
forall f1 f2, cmp Cle f1 f2 = cmp Clt f1 f2 || cmp Ceq f1 f2.
-Axiom cmp_ge_gt_eq:
+
+Corollary cmp_gt_eq_false:
+ forall x y, cmp Cgt x y = true -> cmp Ceq x y = true -> False.
+Proof.
+ intros. rewrite <- cmp_swap in H. rewrite <- cmp_swap in H0.
+ eapply cmp_lt_eq_false; eauto.
+Qed.
+
+Corollary cmp_ge_gt_eq:
forall f1 f2, cmp Cge f1 f2 = cmp Cgt f1 f2 || cmp Ceq f1 f2.
+Proof.
+ intros.
+ change Cge with (swap_comparison Cle).
+ change Cgt with (swap_comparison Clt).
+ change Ceq with (swap_comparison Ceq).
+ repeat rewrite cmp_swap.
+ apply cmp_le_lt_eq.
+Qed.
+
+(** Properties of conversions to/from in-memory representation.
+ The double-precision conversions are bijective (one-to-one).
+ The single-precision conversions lose precision exactly
+ as described by [singleoffloat] rounding. *)
Axiom double_of_bits_of_double:
forall f, double_of_bits (bits_of_double f) = f.
@@ -80,4 +116,52 @@ Axiom bits_of_singleoffloat:
Axiom singleoffloat_of_bits:
forall b, singleoffloat (single_of_bits b) = single_of_bits b.
+(** Conversions between floats and unsigned ints can be defined
+ in terms of conversions between floats and signed ints.
+ (Most processors provide only the latter, forcing the compiler
+ to emulate the former.) *)
+
+Definition ox8000_0000 := Int.repr Int.half_modulus. (**r [0x8000_0000] *)
+
+Axiom floatofintu_floatofint_1:
+ forall x,
+ Int.ltu x ox8000_0000 = true ->
+ floatofintu x = floatofint x.
+
+Axiom floatofintu_floatofint_2:
+ forall x,
+ Int.ltu x ox8000_0000 = false ->
+ floatofintu x = add (floatofint (Int.sub x ox8000_0000))
+ (floatofintu ox8000_0000).
+
+Axiom intuoffloat_intoffloat_1:
+ forall x,
+ cmp Clt x (floatofintu ox8000_0000) = true ->
+ intuoffloat x = intoffloat x.
+
+Axiom intuoffloat_intoffloat_2:
+ forall x,
+ cmp Clt x (floatofintu ox8000_0000) = false ->
+ intuoffloat x =
+ Int.add (intoffloat (sub x (floatofintu ox8000_0000)))
+ ox8000_0000.
+
+(** Conversions from ints to floats can be defined as bitwise manipulations
+ over the in-memory representation. This is what the PowerPC port does.
+ The trick is that [from_words 0x4330_0000 x] is the float
+ [2^52 + floatofintu x]. *)
+
+Definition ox4330_0000 := Int.repr 1127219200. (**r [0x4330_0000] *)
+
+Axiom floatofintu_from_words:
+ forall x,
+ floatofintu x =
+ sub (from_words ox4330_0000 x) (from_words ox4330_0000 Int.zero).
+
+Axiom floatofint_from_words:
+ forall x,
+ floatofint x =
+ sub (from_words ox4330_0000 (Int.add x ox8000_0000))
+ (from_words ox4330_0000 ox8000_0000).
+
End Float.
diff --git a/powerpc/Asm.v b/powerpc/Asm.v
index 9da5871..e49986f 100644
--- a/powerpc/Asm.v
+++ b/powerpc/Asm.v
@@ -159,17 +159,15 @@ Inductive instruction : Type :=
| Pfadd: freg -> freg -> freg -> instruction (**r float addition *)
| Pfcmpu: freg -> freg -> instruction (**r float comparison *)
| Pfcti: ireg -> freg -> instruction (**r float-to-signed-int conversion *)
- | Pfctiu: ireg -> freg -> instruction (**r float-to-unsigned-int conversion *)
| Pfdiv: freg -> freg -> freg -> instruction (**r float division *)
| Pfmadd: freg -> freg -> freg -> freg -> instruction (**r float multiply-add *)
+ | Pfmake: freg -> ireg -> ireg -> instruction (**r build a float from 2 ints *)
| Pfmr: freg -> freg -> instruction (**r float move *)
| Pfmsub: freg -> freg -> freg -> freg -> instruction (**r float multiply-sub *)
| Pfmul: freg -> freg -> freg -> instruction (**r float multiply *)
| Pfneg: freg -> freg -> instruction (**r float negation *)
| Pfrsp: freg -> freg -> instruction (**r float round to single precision *)
| Pfsub: freg -> freg -> freg -> instruction (**r float subtraction *)
- | Pictf: freg -> ireg -> instruction (**r int-to-float conversion *)
- | Piuctf: freg -> ireg -> instruction (**r unsigned int-to-float conversion *)
| Plbz: ireg -> constant -> ireg -> instruction (**r load 8-bit unsigned int *)
| Plbzx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *)
| Plfd: freg -> constant -> ireg -> instruction (**r load 64-bit float *)
@@ -235,72 +233,21 @@ lbl: .double floatcst
Initialized data in the constant data section are not modeled here,
which is why we use a pseudo-instruction for this purpose.
- [Pfcti]: convert a float to a signed integer. This requires a transfer
- via memory of a 32-bit integer from a float register to an int register,
- which our memory model cannot express. Expands to:
+ via memory of a 32-bit integer from a float register to an int register.
+ Expands to:
<<
fctiwz f13, rsrc
stfdu f13, -8(r1)
lwz rdst, 4(r1)
addi r1, r1, 8
>>
-- [Pfctiu]: convert a float to an unsigned integer. The PowerPC way
- to do this is to compare the argument against the floating-point
- constant [2^31], subtract [2^31] if bigger, then convert to a signed
- integer as above, then add back [2^31] if needed. Expands to:
+- [Pfmake]: build a double float from two 32-bit integers. This also
+ requires a transfer via memory. Expands to:
<<
- addis r12, 0, ha16(lbl1)
- lfd f13, lo16(lbl1)(r12)
- fcmpu cr7, rsrc, f13
- cror 30, 29, 30
- beq cr7, lbl2
- fctiwz f13, rsrc
- stfdu f13, -8(r1)
- lwz rdst, 4(r1)
- b lbl3
-lbl2: fsub f13, rsrc, f13
- fctiwz f13, f13
- stfdu f13, -8(r1)
- lwz rdst, 4(r1)
- addis rdst, rdst, 0x8000
-lbl3: addi r1, r1, 8
- .const_data
-lbl1: .long 0x41e00000, 0x00000000 # 2^31 in double precision
- .text
->>
-- [Pictf]: convert a signed integer to a float. This requires complicated
- bit-level manipulations of IEEE floats through mixed float and integer
- arithmetic over a memory word, which our memory model and axiomatization
- of floats cannot express. Expands to:
-<<
- addis r12, 0, 0x4330
- stwu r12, -8(r1)
- addis r12, rsrc, 0x8000
- stw r12, 4(r1)
- addis r12, 0, ha16(lbl)
- lfd f13, lo16(lbl)(r12)
+ stwu rsrc1, -8(r1)
+ stw rsrc2, 4(r1)
lfd rdst, 0(r1)
addi r1, r1, 8
- fsub rdst, rdst, f13
- .const_data
-lbl: .long 0x43300000, 0x80000000
- .text
->>
- (Don't worry if you do not understand this instruction sequence: intimate
- knowledge of IEEE float arithmetic is necessary.)
-- [Piuctf]: convert an unsigned integer to a float. The expansion is close
- to that [Pictf], and equally obscure.
-<<
- addis r12, 0, 0x4330
- stwu r12, -8(r1)
- stw rsrc, 4(r1)
- addis r12, 0, ha16(lbl)
- lfd f13, lo16(lbl)(r12)
- lfd rdst, 0(r1)
- addi r1, r1, 8
- fsub rdst, rdst, f13
- .const_data
-lbl: .long 0x43300000, 0x00000000
- .text
>>
- [Pallocframe lo hi ofs]: in the formal semantics, this pseudo-instruction
allocates a memory block with bounds [lo] and [hi], stores the value
@@ -585,7 +532,7 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
let sp := Vptr stk (Int.repr lo) in
match Mem.storev Mint32 m1 (Val.add sp (Vint ofs)) rs#GPR1 with
| None => Error
- | Some m2 => OK (nextinstr (rs#GPR1 <- sp #GPR12 <- Vundef)) m2
+ | Some m2 => OK (nextinstr (rs#GPR1 <- sp #GPR0 <- Vundef)) m2
end
| Pand_ rd r1 r2 =>
let v := Val.and rs#r1 rs#r2 in
@@ -621,7 +568,7 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
| _ => Error
end
| Pbtbl r tbl =>
- match rs#r with
+ match gpr_or_zero rs r with
| Vint n =>
let pos := Int.signed n in
if zeq (Zmod pos 4) 0 then
@@ -672,13 +619,13 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
| Pfcmpu r1 r2 =>
OK (nextinstr (compare_float rs rs#r1 rs#r2)) m
| Pfcti rd r1 =>
- OK (nextinstr (rs#rd <- (Val.intoffloat rs#r1) #FPR13 <- Vundef)) m
- | Pfctiu rd r1 =>
- OK (nextinstr (rs#rd <- (Val.intuoffloat rs#r1) #FPR13 <- Vundef)) m
+ OK (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.intoffloat rs#r1))) m
| Pfdiv rd r1 r2 =>
OK (nextinstr (rs#rd <- (Val.divf rs#r1 rs#r2))) m
| Pfmadd rd r1 r2 r3 =>
OK (nextinstr (rs#rd <- (Val.addf (Val.mulf rs#r1 rs#r2) rs#r3))) m
+ | Pfmake rd r1 r2 =>
+ OK (nextinstr (rs#rd <- (Val.floatofwords rs#r1 rs#r2))) m
| Pfmr rd r1 =>
OK (nextinstr (rs#rd <- (rs#r1))) m
| Pfmsub rd r1 r2 r3 =>
@@ -691,10 +638,6 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
OK (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m
| Pfsub rd r1 r2 =>
OK (nextinstr (rs#rd <- (Val.subf rs#r1 rs#r2))) m
- | Pictf rd r1 =>
- OK (nextinstr (rs#rd <- (Val.floatofint rs#r1) #GPR12 <- Vundef #FPR13 <- Vundef)) m
- | Piuctf rd r1 =>
- OK (nextinstr (rs#rd <- (Val.floatofintu rs#r1) #GPR12 <- Vundef #FPR13 <- Vundef)) m
| Plbz rd cst r1 =>
load1 Mint8unsigned rd cst r1 rs m
| Plbzx rd r1 r2 =>
@@ -716,7 +659,7 @@ 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#rd <- (Vfloat f) #GPR12 <- Vundef)) m
+ OK (nextinstr (rs #GPR12 <- Vundef #rd <- (Vfloat f))) m
| Plwz rd cst r1 =>
load1 Mint32 rd cst r1 rs m
| Plwzx rd r1 r2 =>
@@ -766,9 +709,15 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
| Pstfdx rd r1 r2 =>
store2 Mfloat64 rd r1 r2 rs m
| Pstfs rd cst r1 =>
- store1 Mfloat32 rd cst r1 (rs#FPR13 <- Vundef) m
+ match store1 Mfloat32 rd cst r1 rs m with
+ | OK rs' m' => OK (rs'#FPR13 <- Vundef) m'
+ | Error => Error
+ end
| Pstfsx rd r1 r2 =>
- store2 Mfloat32 rd r1 r2 (rs#FPR13 <- Vundef) m
+ match store2 Mfloat32 rd r1 r2 rs m with
+ | OK rs' m' => OK (rs'#FPR13 <- Vundef) m'
+ | Error => Error
+ end
| Psth rd cst r1 =>
store1 Mint16unsigned rd cst r1 rs m
| Psthx rd r1 r2 =>
@@ -801,8 +750,8 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome
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 [GPR12] nor [FPR13].
- These two registers are reserved as temporaries, to be used
+ 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 :=
@@ -814,20 +763,21 @@ Definition ireg_of (r: mreg) : ireg :=
| R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24
| R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28
| R29 => GPR29 | R30 => GPR30 | R31 => GPR31
- | IT1 => GPR11 | IT2 => GPR0
- | _ => GPR0 (* should not happen *)
+ | 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 | F14 => FPR14 | F15 => FPR15
+ | F9 => FPR9 | F10 => FPR10 | F11 => FPR11
+ | F14 => FPR14 | F15 => FPR15
| F16 => FPR16 | F17 => FPR17 | F18 => FPR18 | F19 => FPR19
| F20 => FPR20 | F21 => FPR21 | F22 => FPR22 | F23 => FPR23
| F24 => FPR24 | F25 => FPR25 | F26 => FPR26 | F27 => FPR27
| F28 => FPR28 | F29 => FPR29 | F30 => FPR30 | F31 => FPR31
- | FT1 => FPR0 | FT2 => FPR11 | FT3 => FPR12
+ | FT1 => FPR0 | FT2 => FPR12 | FT3 => FPR13
| _ => FPR0 (* should not happen *)
end.
@@ -886,7 +836,11 @@ Inductive step: state -> trace -> state -> Prop :=
Genv.find_funct_ptr ge b = Some (Internal c) ->
find_instr (Int.unsigned ofs) c = Some (Pbuiltin ef args res) ->
external_call ef ge (map rs args) m t v m' ->
- step (State rs m) t (State (nextinstr(rs # res <- v)) m')
+ step (State rs m) t
+ (State (nextinstr(rs #GPR11 <- Vundef #GPR12 <- Vundef
+ #FPR12 <- Vundef #FPR13 <- Vundef
+ #FPR0 <- Vundef #CTR <- Vundef
+ #res <- v)) m')
| exec_step_external:
forall b ef args res rs m t rs' m',
rs PC = Vptr b Int.zero ->
diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v
index b1b1245..9c37c42 100644
--- a/powerpc/Asmgen.v
+++ b/powerpc/Asmgen.v
@@ -60,7 +60,7 @@ Definition loadimm (r: ireg) (n: int) (k: code) :=
Paddis r GPR0 (Cint (high_u n)) ::
Pori r r (Cint (low_u n)) :: k.
-Definition addimm_1 (r1 r2: ireg) (n: int) (k: code) :=
+Definition addimm (r1 r2: ireg) (n: int) (k: code) :=
if Int.eq (high_s n) Int.zero then
Paddi r1 r2 (Cint n) :: k
else if Int.eq (low_s n) Int.zero then
@@ -69,24 +69,13 @@ Definition addimm_1 (r1 r2: ireg) (n: int) (k: code) :=
Paddis r1 r2 (Cint (high_s n)) ::
Paddi r1 r1 (Cint (low_s n)) :: k.
-Definition addimm_2 (r1 r2: ireg) (n: int) (k: code) :=
- loadimm GPR12 n (Padd r1 r2 GPR12 :: k).
-
-Definition addimm (r1 r2: ireg) (n: int) (k: code) :=
- if ireg_eq r1 GPR0 then
- addimm_2 r1 r2 n k
- else if ireg_eq r2 GPR0 then
- addimm_2 r1 r2 n k
- else
- addimm_1 r1 r2 n k.
-
Definition andimm (r1 r2: ireg) (n: int) (k: code) :=
if Int.eq (high_u n) Int.zero then
Pandi_ r1 r2 (Cint n) :: k
else if Int.eq (low_u n) Int.zero then
Pandis_ r1 r2 (Cint (high_u n)) :: k
else
- loadimm GPR12 n (Pand_ r1 r2 GPR12 :: k).
+ loadimm GPR0 n (Pand_ r1 r2 GPR0 :: k).
Definition orimm (r1 r2: ireg) (n: int) (k: code) :=
if Int.eq (high_u n) Int.zero then
@@ -106,36 +95,34 @@ Definition xorimm (r1 r2: ireg) (n: int) (k: code) :=
Pxoris r1 r2 (Cint (high_u n)) ::
Pxori r1 r1 (Cint (low_u n)) :: k.
-(** Smart constructors for indexed loads and stores,
- where the address is the contents of a register plus
- an integer literal. *)
-
-Definition loadind_aux (base: ireg) (ofs: int) (ty: typ) (dst: mreg) :=
- match ty with
- | Tint => Plwz (ireg_of dst) (Cint ofs) base
- | Tfloat => Plfd (freg_of dst) (Cint ofs) base
- end.
+(** 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
- loadind_aux base ofs ty dst :: k
+ match ty with
+ | Tint => Plwz (ireg_of dst) (Cint ofs) base :: k
+ | Tfloat => Plfd (freg_of dst) (Cint ofs) base :: k
+ end
else
- Paddis GPR12 base (Cint (high_s ofs)) ::
- loadind_aux GPR12 (low_s ofs) ty dst :: k.
-
-Definition storeind_aux (src: mreg) (base: ireg) (ofs: int) (ty: typ) :=
- match ty with
- | Tint => Pstw (ireg_of src) (Cint ofs) base
- | Tfloat => Pstfd (freg_of src) (Cint ofs) base
- end.
+ loadimm GPR0 ofs
+ (match ty with
+ | Tint => Plwzx (ireg_of dst) base GPR0 :: k
+ | Tfloat => Plfdx (freg_of dst) 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
- storeind_aux src base ofs ty :: k
+ match ty with
+ | Tint => Pstw (ireg_of src) (Cint ofs) base :: k
+ | Tfloat => Pstfd (freg_of src) (Cint ofs) base :: k
+ end
else
- Paddis GPR12 base (Cint (high_s ofs)) ::
- storeind_aux src GPR12 (low_s ofs) ty :: k.
-
+ loadimm GPR0 ofs
+ (match ty with
+ | Tint => Pstwx (ireg_of src) base GPR0 :: k
+ | Tfloat => Pstfdx (freg_of src) base GPR0 :: k
+ end).
+
(** Constructor for a floating-point comparison. The PowerPC has
a single [fcmpu] instruction to compare floats, which sets
bits 0, 1 and 2 of the condition register to reflect ``less'',
@@ -168,20 +155,20 @@ Definition transl_cond
if Int.eq (high_s n) Int.zero then
Pcmpwi (ireg_of a1) (Cint n) :: k
else
- loadimm GPR12 n (Pcmpw (ireg_of a1) GPR12 :: k)
+ loadimm GPR0 n (Pcmpw (ireg_of a1) GPR0 :: k)
| Ccompuimm c n, a1 :: nil =>
if Int.eq (high_u n) Int.zero then
Pcmplwi (ireg_of a1) (Cint n) :: k
else
- loadimm GPR12 n (Pcmplw (ireg_of a1) GPR12 :: k)
+ loadimm GPR0 n (Pcmplw (ireg_of a1) GPR0 :: k)
| Ccompf cmp, a1 :: a2 :: nil =>
floatcomp cmp (freg_of a1) (freg_of a2) k
| Cnotcompf cmp, a1 :: a2 :: nil =>
floatcomp cmp (freg_of a1) (freg_of a2) k
| Cmaskzero n, a1 :: nil =>
- andimm GPR12 (ireg_of a1) n k
+ andimm GPR0 (ireg_of a1) n k
| Cmasknotzero n, a1 :: nil =>
- andimm GPR12 (ireg_of a1) n k
+ andimm GPR0 (ireg_of a1) n k
| _, _ =>
k (**r never happens for well-typed code *)
end.
@@ -287,14 +274,14 @@ Definition transl_op
if Int.eq (high_s n) Int.zero then
Psubfic (ireg_of r) (ireg_of a1) (Cint n) :: k
else
- loadimm GPR12 n (Psubfc (ireg_of r) (ireg_of a1) GPR12 :: k)
+ loadimm GPR0 n (Psubfc (ireg_of r) (ireg_of a1) GPR0 :: k)
| Omul, a1 :: a2 :: nil =>
Pmullw (ireg_of r) (ireg_of a1) (ireg_of a2) :: 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 GPR12 n (Pmullw (ireg_of r) (ireg_of a1) GPR12 :: k)
+ loadimm GPR0 n (Pmullw (ireg_of r) (ireg_of a1) GPR0 :: k)
| Odiv, a1 :: a2 :: nil =>
Pdivw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
| Odivu, a1 :: a2 :: nil =>
@@ -350,12 +337,8 @@ Definition transl_op
Pfrsp (freg_of r) (freg_of a1) :: k
| Ointoffloat, a1 :: nil =>
Pfcti (ireg_of r) (freg_of a1) :: k
- | Ointuoffloat, a1 :: nil =>
- Pfctiu (ireg_of r) (freg_of a1) :: k
- | Ofloatofint, a1 :: nil =>
- Pictf (freg_of r) (ireg_of a1) :: k
- | Ofloatofintu, a1 :: nil =>
- Piuctf (freg_of r) (ireg_of a1) :: k
+ | Ofloatofwords, a1 :: a2 :: nil =>
+ Pfmake (freg_of r) (ireg_of a1) (ireg_of a2) :: k
| Ocmp cmp, _ =>
match classify_condition cmp args with
| condition_ge0 _ a _ =>
@@ -377,43 +360,38 @@ Definition transl_op
(** Common code to translate [Mload] and [Mstore] instructions. *)
+Definition int_temp_for (r: mreg) :=
+ if mreg_eq r IT2 then GPR11 else GPR12.
+
Definition transl_load_store
(mk1: constant -> ireg -> instruction)
(mk2: ireg -> ireg -> instruction)
- (addr: addressing) (args: list mreg) (k: code) :=
+ (addr: addressing) (args: list mreg)
+ (temp: ireg) (k: code) :=
match addr, args with
| Aindexed ofs, a1 :: nil =>
- if ireg_eq (ireg_of a1) GPR0 then
- Pmr GPR12 (ireg_of a1) ::
- Paddis GPR12 GPR12 (Cint (high_s ofs)) ::
- mk1 (Cint (low_s ofs)) GPR12 :: k
- else if Int.eq (high_s ofs) Int.zero then
+ if Int.eq (high_s ofs) Int.zero then
mk1 (Cint ofs) (ireg_of a1) :: k
else
- Paddis GPR12 (ireg_of a1) (Cint (high_s ofs)) ::
- mk1 (Cint (low_s ofs)) GPR12 :: k
+ Paddis temp (ireg_of a1) (Cint (high_s ofs)) ::
+ mk1 (Cint (low_s ofs)) temp :: k
| Aindexed2, a1 :: a2 :: nil =>
mk2 (ireg_of a1) (ireg_of a2) :: k
| Aglobal symb ofs, nil =>
if symbol_is_small_data symb ofs then
mk1 (Csymbol_sda symb ofs) GPR0 :: k
else
- Paddis GPR12 GPR0 (Csymbol_high symb ofs) ::
- mk1 (Csymbol_low symb ofs) GPR12 :: k
+ Paddis temp GPR0 (Csymbol_high symb ofs) ::
+ mk1 (Csymbol_low symb ofs) temp :: k
| Abased symb ofs, a1 :: nil =>
- if ireg_eq (ireg_of a1) GPR0 then
- Pmr GPR12 (ireg_of a1) ::
- Paddis GPR12 GPR12 (Csymbol_high symb ofs) ::
- mk1 (Csymbol_low symb ofs) GPR12 :: k
- else
- Paddis GPR12 (ireg_of a1) (Csymbol_high symb ofs) ::
- mk1 (Csymbol_low symb ofs) GPR12 :: k
+ Paddis temp (ireg_of a1) (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 GPR12 GPR1 (Cint (high_s ofs)) ::
- mk1 (Cint (low_s ofs)) GPR12 :: k
+ Paddis temp GPR1 (Cint (high_s ofs)) ::
+ mk1 (Cint (low_s ofs)) temp :: k
| _, _ =>
(* should not happen *) k
end.
@@ -427,57 +405,58 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) :=
| Msetstack src ofs ty =>
storeind src GPR1 ofs ty k
| Mgetparam ofs ty dst =>
- Plwz GPR12 (Cint f.(fn_link_ofs)) GPR1 :: loadind GPR12 ofs ty dst k
+ Plwz GPR11 (Cint f.(fn_link_ofs)) GPR1 :: loadind GPR11 ofs ty dst k
| 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
+ (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 k
+ (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 k
+ (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 k
+ (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 k
+ (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 k
+ (Plfs (freg_of dst)) (Plfsx (freg_of dst)) addr args GPR12 k
| Mfloat64 =>
transl_load_store
- (Plfd (freg_of dst)) (Plfdx (freg_of dst)) addr args k
+ (Plfd (freg_of dst)) (Plfdx (freg_of dst)) addr args GPR12 k
end
| 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 k
+ (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 k
+ (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 k
+ (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 k
+ (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 k
+ (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 k
+ (Pstfs (freg_of src)) (Pstfsx (freg_of src)) addr args temp k
| Mfloat64 =>
transl_load_store
- (Pstfd (freg_of src)) (Pstfdx (freg_of src)) addr args k
+ (Pstfd (freg_of src)) (Pstfdx (freg_of src)) addr args temp k
end
| Mcall sig (inl r) =>
Pmtctr (ireg_of r) :: Pbctrl :: k
@@ -485,13 +464,13 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) :=
Pbl symb :: k
| Mtailcall sig (inl r) =>
Pmtctr (ireg_of r) ::
- Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 ::
- Pmtlr GPR12 ::
+ Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 ::
+ Pmtlr GPR0 ::
Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) ::
Pbctr :: k
| Mtailcall sig (inr symb) =>
- Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 ::
- Pmtlr GPR12 ::
+ Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 ::
+ Pmtlr GPR0 ::
Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) ::
Pbs symb :: k
| Mbuiltin ef args res =>
@@ -508,8 +487,8 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) :=
Prlwinm GPR12 (ireg_of arg) (Int.repr 2) (Int.repr (-4)) ::
Pbtbl GPR12 tbl :: k
| Mreturn =>
- Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 ::
- Pmtlr GPR12 ::
+ Plwz GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 ::
+ Pmtlr GPR0 ::
Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) ::
Pblr :: k
end.
@@ -524,8 +503,8 @@ Definition transl_code (f: Mach.function) (il: list Mach.instruction) :=
Definition transl_function (f: Mach.function) :=
Pallocframe (- f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) ::
- Pmflr GPR12 ::
- Pstw GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 ::
+ Pmflr GPR0 ::
+ Pstw GPR0 (Cint f.(fn_retaddr_ofs)) GPR1 ::
transl_code f f.(fn_code).
Open Local Scope string_scope.
diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v
index fc14830..65c831e 100644
--- a/powerpc/Asmgenproof.v
+++ b/powerpc/Asmgenproof.v
@@ -342,25 +342,12 @@ Proof.
Qed.
Hint Rewrite loadimm_label: labels.
-Remark addimm_1_label:
- forall r1 r2 n k, find_label lbl (addimm_1 r1 r2 n k) = find_label lbl k.
-Proof.
- intros; unfold addimm_1.
- case (Int.eq (high_s n) Int.zero). reflexivity.
- case (Int.eq (low_s n) Int.zero). reflexivity. reflexivity.
-Qed.
-Remark addimm_2_label:
- forall r1 r2 n k, find_label lbl (addimm_2 r1 r2 n k) = find_label lbl k.
-Proof.
- intros; unfold addimm_2. autorewrite with labels. reflexivity.
-Qed.
Remark addimm_label:
forall r1 r2 n k, find_label lbl (addimm r1 r2 n k) = find_label lbl k.
Proof.
intros; unfold addimm.
- case (ireg_eq r1 GPR0); intro. apply addimm_2_label.
- case (ireg_eq r2 GPR0); intro. apply addimm_2_label.
- apply addimm_1_label.
+ case (Int.eq (high_s n) Int.zero). reflexivity.
+ case (Int.eq (low_s n) Int.zero). reflexivity. reflexivity.
Qed.
Hint Rewrite addimm_label: labels.
@@ -392,36 +379,22 @@ Proof.
Qed.
Hint Rewrite xorimm_label: labels.
-Remark loadind_aux_label:
- forall base ofs ty dst k, find_label lbl (loadind_aux base ofs ty dst :: k) = find_label lbl k.
-Proof.
- intros; unfold loadind_aux.
- case ty; reflexivity.
-Qed.
Remark loadind_label:
forall base ofs ty dst k, find_label lbl (loadind base ofs ty dst k) = find_label lbl k.
Proof.
intros; unfold loadind.
- case (Int.eq (high_s ofs) Int.zero). apply loadind_aux_label.
- transitivity (find_label lbl (loadind_aux GPR12 (low_s ofs) ty dst :: k)).
- reflexivity. apply loadind_aux_label.
+ destruct (Int.eq (high_s ofs) Int.zero); destruct ty; autorewrite with labels; auto.
Qed.
Hint Rewrite loadind_label: labels.
-Remark storeind_aux_label:
- forall base ofs ty dst k, find_label lbl (storeind_aux base ofs ty dst :: k) = find_label lbl k.
-Proof.
- intros; unfold storeind_aux.
- case dst; reflexivity.
-Qed.
+
Remark storeind_label:
forall base ofs ty src k, find_label lbl (storeind base src ofs ty k) = find_label lbl k.
Proof.
- intros; unfold storeind.
- case (Int.eq (high_s ofs) Int.zero). apply storeind_aux_label.
- transitivity (find_label lbl (storeind_aux base GPR12 (low_s ofs) ty :: k)).
- reflexivity. apply storeind_aux_label.
+ intros; unfold storeind.
+ destruct (Int.eq (high_s ofs) Int.zero); destruct ty; 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.
@@ -481,22 +454,19 @@ Hint Rewrite transl_op_label: labels.
Remark transl_load_store_label:
forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction)
- addr args k,
+ addr args temp k,
(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 k) = find_label lbl k.
+ 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.
- case (ireg_eq (ireg_of m) GPR0); intro.
- simpl. rewrite H. auto.
- case (Int.eq (high_s i) Int.zero). simpl; rewrite H; auto.
- simpl; rewrite H; auto.
+ destruct (Int.eq (high_s i) Int.zero); simpl; rewrite H; auto.
simpl; rewrite H0; auto.
destruct (symbol_is_small_data i i0); simpl; rewrite H; auto.
- case (ireg_eq (ireg_of m) GPR0); intro; simpl; rewrite H; auto.
- case (Int.eq (high_s i) Int.zero); simpl; rewrite H; auto.
+ simpl; rewrite H; auto.
+ destruct (Int.eq (high_s i) Int.zero); simpl; rewrite H; auto.
Qed.
Hint Rewrite transl_load_store_label: labels.
@@ -593,56 +563,102 @@ Inductive match_stack: list Machconcr.stackframe -> Prop :=
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: Machconcr.state -> Asm.state -> Prop :=
| match_states_intro:
- forall s fb sp c ms m rs f
+ 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),
+ (AG: agree ms sp rs)
+ (MEXT: Mem.extends m m'),
match_states (Machconcr.State s fb sp c ms m)
- (Asm.State rs m)
+ (Asm.State rs m')
| match_states_call:
- forall s fb ms m rs
+ forall s fb ms m rs m'
(STACKS: match_stack s)
(AG: agree ms (parent_sp s) rs)
+ (MEXT: Mem.extends m m')
(ATPC: rs PC = Vptr fb Int.zero)
(ATLR: rs LR = parent_ra s),
match_states (Machconcr.Callstate s fb ms m)
- (Asm.State rs m)
+ (Asm.State rs m')
| match_states_return:
- forall s ms m rs
+ forall s ms m rs m'
(STACKS: match_stack s)
(AG: agree ms (parent_sp s) rs)
+ (MEXT: Mem.extends m m')
(ATPC: rs PC = parent_ra s),
match_states (Machconcr.Returnstate s ms m)
- (Asm.State rs m).
+ (Asm.State rs m').
Lemma exec_straight_steps:
- forall s fb sp m1 f c1 rs1 c2 m2 ms2,
+ 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
+ exec_straight tge (transl_function f) (transl_code f c1) rs1 m1' (transl_code f c2) rs2 m2'
/\ agree ms2 sp rs2) ->
+ Mem.extends m2 m2' ->
exists st',
- plus step tge (State rs1 m1) E0 st' /\
+ plus step tge (State rs1 m1') E0 st' /\
match_states (Machconcr.State s fb sp c2 ms2 m2) st'.
Proof.
intros. destruct H4 as [rs2 [A B]].
- exists (State rs2 m2); split.
+ exists (State rs2 m2'); split.
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) ->
+ exists st',
+ plus step tge (State rs1 m1') E0 st' /\
+ match_states (Machconcr.State s fb sp c2 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.
+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
@@ -694,18 +710,18 @@ Proof.
unfold load_stack in H.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
intro WTI. inversion WTI.
- rewrite (sp_val _ _ _ AG) in H.
- assert (NOTE: GPR1 <> GPR0). congruence.
- generalize (loadind_correct tge (transl_function f) GPR1 ofs ty
- dst (transl_code f c) rs m v H H1 NOTE).
+ 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_exten_2 with (rs#(preg_of dst) <- v).
+ apply agree_exten_2 with (rs#(preg_of dst) <- v').
auto with ppcgen.
- intros. case (preg_eq r0 (preg_of dst)); intro.
- subst r0. rewrite Pregmap.gss. auto.
- rewrite Pregmap.gso; auto.
+ intros. unfold Pregmap.set. destruct (PregEq.eq r0 (preg_of dst)).
+ subst r0. auto.
+ apply OTH; auto.
Qed.
Lemma exec_Msetstack_prop:
@@ -719,12 +735,14 @@ Proof.
intros; red; intros; inv MS.
unfold store_stack in H.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inversion WTI.
- rewrite (sp_val _ _ _ AG) in H.
- rewrite (preg_val ms sp rs) in H; auto.
- assert (NOTE: GPR1 <> GPR0). congruence.
- generalize (storeind_correct tge (transl_function f) GPR1 ofs ty
- src (transl_code f c) rs m m' H H1 NOTE).
+ intro WTI. inv WTI.
+ generalize (preg_val ms sp rs src AG). intro.
+ exploit Mem.storev_extends; eauto.
+ intros [m2' [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.
@@ -739,34 +757,35 @@ Lemma exec_Mgetparam_prop:
load_stack m sp Tint f.(fn_link_ofs) = Some parent ->
load_stack m parent ty ofs = Some v ->
exec_instr_prop (Machconcr.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0
- (Machconcr.State s fb sp c (Regmap.set dst v ms) m).
+ (Machconcr.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.
- set (rs2 := nextinstr (rs#GPR12 <- parent)).
- assert (EX1: exec_straight tge (transl_function f)
- (transl_code f (Mgetparam ofs ty dst :: c)) rs m
- (loadind GPR12 ofs ty dst (transl_code f c)) rs2 m).
- simpl. apply exec_straight_one.
- simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto with ppcgen.
- unfold const_low. rewrite <- (sp_val ms sp rs); auto.
- unfold load_stack in H0. simpl chunk_of_type in H0.
- rewrite H0. reflexivity. reflexivity.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI. inversion WTI.
- unfold load_stack in H1. change parent with rs2#GPR12 in H1.
- assert (NOTE: GPR12 <> GPR0). congruence.
- generalize (loadind_correct tge (transl_function f) GPR12 ofs ty
- dst (transl_code f c) rs2 m v H1 H3 NOTE).
- intros [rs3 [EX2 [RES OTH]]].
- left; eapply exec_straight_steps; eauto with coqlib.
- exists rs3; split; simpl.
- eapply exec_straight_trans; eauto.
- apply agree_exten_2 with (rs2#(preg_of dst) <- v).
- unfold rs2; auto with ppcgen.
- intros. case (preg_eq r0 (preg_of dst)); intro.
- subst r0. rewrite Pregmap.gss. auto.
- rewrite Pregmap.gso; auto.
+ intro WTI. inv WTI.
+ unfold load_stack in *. simpl in H0.
+ 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.
+ assert (agree (Regmap.set IT1 Vundef ms) sp rs1).
+ unfold rs1. eauto with ppcgen.
+ apply agree_exten_2 with (rs1#(preg_of dst) <- v').
+ auto with ppcgen.
+ intros. unfold Pregmap.set. destruct (PregEq.eq r (preg_of dst)).
+ congruence. auto.
Qed.
Lemma exec_Mop_prop:
@@ -775,7 +794,7 @@ Lemma exec_Mop_prop:
(ms : mreg -> val) (m : mem) (v : val),
eval_operation ge sp op ms ## args = Some v ->
exec_instr_prop (Machconcr.State s fb sp (Mop op args res :: c) ms m) E0
- (Machconcr.State s fb sp c (Regmap.set res v ms) m).
+ (Machconcr.State s fb sp c (Regmap.set res v (undef_op op ms)) m).
Proof.
intros; red; intros; inv MS.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
@@ -805,7 +824,7 @@ Lemma exec_Mload_prop:
eval_addressing ge sp addr ms ## args = Some a ->
Mem.loadv chunk m a = Some v ->
exec_instr_prop (Machconcr.State s fb sp (Mload chunk addr args dst :: c) ms m)
- E0 (Machconcr.State s fb sp c (Regmap.set dst v ms) m).
+ E0 (Machconcr.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 _ _))).
@@ -820,26 +839,22 @@ Proof.
(* 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).
+ 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.
- generalize (transl_load_correct tge (transl_function f)
- (Plbz (ireg_of dst)) (Plbzx (ireg_of dst))
- Mint8unsigned addr args
- (Pextsb (ireg_of dst) (ireg_of dst) :: transl_code f c)
- ms sp rs m dst a v'
- X1 X2 AG H3 H7 LOAD).
+ 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]].
- exists (nextinstr (rs2#(ireg_of dst) <- v)).
- split. eapply exec_straight_trans. eexact EX1.
- apply exec_straight_one. simpl.
- rewrite <- (ireg_val _ _ _ dst AG1);auto. rewrite Regmap.gss.
- rewrite EQ. reflexivity. reflexivity.
- eauto with ppcgen.
+ 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.
Qed.
Lemma storev_8_signed_unsigned:
@@ -866,20 +881,20 @@ Lemma exec_Mstore_prop:
eval_addressing ge sp addr ms ## args = Some a ->
Mem.storev chunk m a (ms src) = Some m' ->
exec_instr_prop (Machconcr.State s fb sp (Mstore chunk addr args src :: c) ms m) E0
- (Machconcr.State s fb sp c ms m').
+ (Machconcr.State s fb sp c (undef_temps ms) m').
Proof.
intros; red; intros; inv MS.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
- intro WTI; inversion WTI.
+ intro WTI; inv WTI.
rewrite <- (eval_addressing_preserved _ _ symbols_preserved) in H.
- left; eapply exec_straight_steps; eauto with coqlib.
+ left; eapply exec_straight_steps_bis; eauto with coqlib.
destruct chunk; simpl; simpl in H6;
try (rewrite storev_8_signed_unsigned in H0);
try (rewrite storev_16_signed_unsigned in H0);
simpl; eapply transl_store_correct; eauto;
- intros; (econstructor; split; [unfold preg_of; rewrite H6; reflexivity | auto]).
- intros. apply Pregmap.gso; auto.
- intros. apply Pregmap.gso; auto.
+ (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.
Lemma exec_Mcall_prop:
@@ -904,12 +919,15 @@ Proof.
(* Indirect call *)
generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1.
generalize (code_tail_next_int _ _ _ _ NOOV CT1). intro CT2.
- set (rs2 := nextinstr (rs#CTR <- (ms m0))).
- set (rs3 := rs2 #LR <- (Val.add rs2#PC Vone) #PC <- (ms m0)).
- assert (ATPC: rs3 PC = Vptr f' Int.zero).
- change (rs3 PC) with (ms m0).
- destruct (ms m0); try discriminate.
+ 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).
@@ -918,11 +936,11 @@ Proof.
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.
+ 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 <- (ireg_val ms sp rs); auto.
+ simpl. rewrite P2. auto.
apply star_one. econstructor.
change (rs2 PC) with (Val.add (rs PC) Vone). rewrite <- H5.
simpl. auto.
@@ -933,6 +951,8 @@ Proof.
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)).
@@ -947,7 +967,7 @@ Proof.
rewrite <- H5. reflexivity.
assert (AG2: agree ms sp rs2).
unfold rs2; auto 8 with ppcgen.
- left; exists (State rs2 m); split.
+ left; exists (State rs2 m'); split.
apply plus_one. econstructor.
eauto.
apply functions_transl. eexact H0.
@@ -956,6 +976,7 @@ Proof.
econstructor; eauto with coqlib.
econstructor; eauto with coqlib.
rewrite RA_EQ. econstructor; eauto.
+ eapply agree_sp_def; eauto. congruence.
Qed.
Lemma exec_Mtailcall_prop:
@@ -978,30 +999,43 @@ Proof.
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 *)
- set (rs2 := nextinstr (rs#CTR <- (ms m0))).
- set (rs3 := nextinstr (rs2#GPR12 <- (parent_ra s))).
+ 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))).
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
- (Pbctr :: transl_code f c) rs5 m').
- simpl. apply exec_straight_step with rs2 m.
- simpl. rewrite <- (ireg_val _ _ _ _ AG H7). reflexivity. reflexivity.
- apply exec_straight_step with rs3 m.
+ (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.
+ 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. unfold load_stack in H2. simpl in H2. rewrite H2.
- reflexivity. discriminate. reflexivity.
- apply exec_straight_step with rs4 m.
+ simpl. rewrite LOAD2. 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).
- unfold load_stack in H1; simpl in H1.
- simpl. rewrite H1. rewrite H3. reflexivity. reflexivity.
- left; exists (State rs6 m'); split.
+ simpl. rewrite LOAD1. rewrite FREE'. reflexivity. reflexivity.
+ left; exists (State rs6 m2'); split.
(* execution *)
eapply plus_right'. eapply exec_straight_exec; eauto.
econstructor.
@@ -1017,32 +1051,27 @@ Proof.
unfold rs4, rs3, rs2; auto 10 with ppcgen.
assert (AG5: agree ms (parent_sp s) rs5).
unfold rs5. apply agree_nextinstr.
- split. reflexivity. intros. inv AG4. rewrite H13.
- rewrite Pregmap.gso; auto with ppcgen.
+ split. reflexivity. apply parent_sp_def; auto.
+ intros. inv AG4. rewrite Pregmap.gso; auto with ppcgen.
unfold rs6; auto with ppcgen.
- change (rs6 PC) with (ms m0).
- generalize H. destruct (ms m0); try congruence.
- predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence.
(* direct call *)
- set (rs2 := nextinstr (rs#GPR12 <- (parent_ra s))).
+ set (rs2 := nextinstr (rs#GPR0 <- (parent_ra s))).
set (rs3 := nextinstr (rs2#LR <- (parent_ra s))).
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
- (Pbs i :: transl_code f c) rs4 m').
- simpl. apply exec_straight_step with rs2 m.
+ (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.
simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low.
rewrite <- (sp_val _ _ _ AG).
- simpl. unfold load_stack in H2. simpl in H2. rewrite H2.
- reflexivity. discriminate. reflexivity.
- apply exec_straight_step with rs3 m.
+ simpl. rewrite LOAD2. auto. discriminate. 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).
- unfold load_stack in H1; simpl in H1.
- simpl. rewrite H1. rewrite H3. reflexivity. reflexivity.
- left; exists (State rs5 m'); split.
+ simpl. rewrite LOAD1. rewrite FREE'. reflexivity. reflexivity.
+ left; exists (State rs5 m2'); split.
(* execution *)
eapply plus_right'. eapply exec_straight_exec; eauto.
econstructor.
@@ -1059,8 +1088,9 @@ Proof.
unfold rs3, rs2; auto 10 with ppcgen.
assert (AG4: agree ms (parent_sp s) rs4).
unfold rs4. apply agree_nextinstr.
- split. reflexivity. intros. inv AG3. rewrite H13.
- rewrite Pregmap.gso; auto with ppcgen.
+ split. reflexivity.
+ apply parent_sp_def; auto.
+ intros. inv AG3. rewrite Pregmap.gso; auto with ppcgen.
unfold rs5; auto with ppcgen.
Qed.
@@ -1071,7 +1101,7 @@ Lemma exec_Mbuiltin_prop:
(t : trace) (v : val) (m' : mem),
external_call ef ge ms ## args m t v m' ->
exec_instr_prop (Machconcr.State s f sp (Mbuiltin ef args res :: b) ms m) t
- (Machconcr.State s f sp b (Regmap.set res v ms) m').
+ (Machconcr.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 _ _))).
@@ -1079,20 +1109,21 @@ Proof.
inv AT. simpl in H3.
generalize (functions_transl _ _ FIND); intro FN.
generalize (functions_transl_no_overflow _ _ FIND); 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.
eapply exec_step_builtin. eauto. eauto.
- eapply find_instr_tail; eauto.
- replace (rs##(preg_of##args)) with (ms##args).
+ eapply find_instr_tail; eauto.
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
- rewrite list_map_compose. apply list_map_exten. intros.
- symmetry. eapply preg_val; eauto.
econstructor; eauto with coqlib.
- unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso.
+ 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.
- auto with ppcgen.
+ apply sym_not_equal. auto with ppcgen.
+ apply agree_nextinstr. apply agree_set_mreg; auto.
+ eapply agree_undef_temps; eauto.
+ intros. repeat rewrite Pregmap.gso; auto.
Qed.
Lemma exec_Mgoto_prop:
@@ -1107,9 +1138,9 @@ 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).
+ 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.
+ left; exists (State rs2 m'); split.
apply plus_one. econstructor; eauto.
apply functions_transl; eauto.
eapply find_instr_tail; eauto.
@@ -1128,7 +1159,7 @@ Lemma exec_Mcond_true_prop:
Genv.find_funct_ptr ge fb = Some (Internal f) ->
Mach.find_label lbl (fn_code f) = Some c' ->
exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0
- (Machconcr.State s fb sp c' ms m).
+ (Machconcr.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 _ _))).
@@ -1138,16 +1169,16 @@ Proof.
then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c
else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c).
generalize (transl_cond_correct tge (transl_function f)
- cond args k1 ms sp rs m true H3 AG H).
+ cond args k1 ms sp rs m' true H3 AG H).
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).
+ generalize (find_label_goto_label f lbl rs2 m' _ _ _ FIND PC2 H1).
intros [rs3 [GOTO [AT3 INV3]]].
- left; exists (State rs3 m); split.
+ 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.
@@ -1160,7 +1191,7 @@ Proof.
traceEq.
econstructor; eauto.
eapply Mach.find_label_incl; eauto.
- apply agree_exten_2 with rs2; auto.
+ apply agree_exten_2 with rs2; auto with ppcgen.
Qed.
Lemma exec_Mcond_false_prop:
@@ -1169,7 +1200,7 @@ Lemma exec_Mcond_false_prop:
(c : list Mach.instruction) (ms : mreg -> val) (m : mem),
eval_condition cond ms ## args = Some false ->
exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0
- (Machconcr.State s fb sp c ms m).
+ (Machconcr.State s fb sp c (undef_temps ms) m).
Proof.
intros; red; intros; inv MS.
generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
@@ -1179,7 +1210,7 @@ Proof.
then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c
else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c).
generalize (transl_cond_correct tge (transl_function f)
- cond args k1 ms sp rs m false H1 AG H).
+ cond args k1 ms sp rs m' false H1 AG H).
simpl. intros [rs2 [EX [RES AG2]]].
left; eapply exec_straight_steps; eauto with coqlib.
exists (nextinstr rs2); split.
@@ -1205,7 +1236,7 @@ Lemma exec_Mjumptable_prop:
Mach.find_label lbl (fn_code f) = Some c' ->
exec_instr_prop
(Machconcr.State s fb sp (Mjumptable arg tbl :: c) rs m) E0
- (Machconcr.State s fb sp c' rs m).
+ (Machconcr.State s fb sp c' (undef_temps rs) m).
Proof.
intros; red; intros; inv MS.
assert (f0 = f) by congruence. subst f0.
@@ -1227,17 +1258,18 @@ Proof.
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).
+ (Prlwinm GPR12 (ireg_of arg) (Int.repr 2) (Int.repr (-4)) :: k1) rs0 m'
+ k1 rs1 m').
apply exec_straight_one.
- simpl. rewrite <- (ireg_val _ _ _ _ AG H5). rewrite H. reflexivity. reflexivity.
+ 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).
+ generalize (find_label_goto_label f lbl rs2 m' _ _ _ FIND PC2 H2).
intros [rs3 [GOTO [AT3 INV3]]].
- left; exists (State rs3 m); split.
+ left; exists (State rs3 m'); split.
eapply plus_right'.
eapply exec_straight_steps_1; eauto.
econstructor; eauto.
@@ -1251,7 +1283,10 @@ Opaque Zmod. Opaque Zdiv.
econstructor; eauto.
eapply Mach.find_label_incl; eauto.
apply agree_exten_2 with rs2; auto.
- unfold rs2, rs1. repeat apply agree_set_other; auto with ppcgen.
+ unfold rs2, rs1. apply agree_set_other; auto with ppcgen.
+ apply agree_undef_temps with rs0; auto.
+ intros. rewrite Pregmap.gso; auto. rewrite nextinstr_inv; auto.
+ rewrite Pregmap.gso; auto.
Qed.
Lemma exec_Mreturn_prop:
@@ -1266,27 +1301,33 @@ Lemma exec_Mreturn_prop:
Proof.
intros; red; intros; inv MS.
assert (f0 = f) by congruence. subst f0.
- set (rs2 := nextinstr (rs#GPR12 <- (parent_ra s))).
+ 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))).
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
- (Pblr :: transl_code f c) rs4 m').
- simpl. apply exec_straight_three with rs2 m rs3 m.
+ (transl_code f (Mreturn :: c)) rs m'0
+ (Pblr :: transl_code f c) 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.
- unfold load_stack in H1. simpl in H1.
- rewrite <- (sp_val _ _ _ AG). simpl. rewrite H1.
+ rewrite <- (sp_val _ _ _ AG). simpl. rewrite LOAD2.
reflexivity. discriminate.
- unfold rs3. change (parent_ra s) with rs2#GPR12. reflexivity.
+ unfold rs3. reflexivity.
simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG).
- simpl.
- unfold load_stack in H0. simpl in H0.
- rewrite H0. rewrite H2. reflexivity.
+ simpl. rewrite LOAD1. rewrite FREE'. reflexivity.
reflexivity. reflexivity. reflexivity.
- left; exists (State rs5 m'); split.
+ left; exists (State rs5 m2'); split.
(* execution *)
- apply plus_right' with E0 (State rs4 m') E0.
+ 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).
@@ -1303,7 +1344,7 @@ Proof.
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. intros. unfold 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.
@@ -1328,23 +1369,29 @@ Proof.
inversion TY; auto.
exploit functions_transl; eauto. intro TFIND.
generalize (functions_transl_no_overflow _ _ H); intro NOOV.
- set (rs2 := nextinstr (rs#GPR1 <- sp #GPR12 <- Vundef)).
- set (rs3 := nextinstr (rs2#GPR12 <- (parent_ra s))).
+ 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).
(* Execution of function prologue *)
assert (EXEC_PROLOGUE:
exec_straight tge (transl_function f)
- (transl_function f) rs m
- (transl_code f (fn_code f)) rs4 m3).
+ (transl_function f) rs m'
+ (transl_code f (fn_code f)) rs4 m3').
unfold transl_function at 2.
- apply exec_straight_three with rs2 m2 rs3 m2.
- unfold exec_instr. rewrite H0. fold sp.
- unfold store_stack in H1. simpl chunk_of_type in H1.
- rewrite <- (sp_val _ _ _ AG). rewrite H1. reflexivity.
+ 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.
simpl. unfold store1. rewrite gpr_or_zero_not_zero.
- unfold const_low. change (rs3 GPR1) with sp. change (rs3 GPR12) with (parent_ra s).
- unfold store_stack in H2. simpl chunk_of_type in H2. rewrite H2. reflexivity.
+ 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)).
@@ -1356,13 +1403,13 @@ Proof.
change (Int.unsigned Int.zero) with 0.
unfold transl_function. constructor.
assert (AG2: agree ms sp rs2).
- split. reflexivity.
+ split. reflexivity. unfold sp. congruence.
intros. unfold rs2. rewrite nextinstr_inv.
repeat (rewrite Pregmap.gso). elim AG; auto.
auto with ppcgen. auto with ppcgen. auto with ppcgen.
assert (AG4: agree ms sp rs4).
unfold rs4, rs3; auto with ppcgen.
- left; exists (State rs4 m3); split.
+ left; exists (State rs4 m3'); split.
(* execution *)
eapply exec_straight_steps_1; eauto.
change (Int.unsigned Int.zero) with 0. constructor.
@@ -1384,12 +1431,15 @@ Proof.
intros; red; intros; inv MS.
exploit functions_translated; eauto.
intros [tf [A B]]. simpl in B. inv B.
- left; exists (State (rs#(loc_external_result (ef_sig ef)) <- res #PC <- (rs LR))
- m'); split.
+ exploit extcall_arguments_match; eauto.
+ intros [args' [C D]].
+ 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.
apply plus_one. eapply exec_step_external; eauto.
eapply external_call_symbols_preserved; eauto.
exact symbols_preserved. exact varinfo_preserved.
- eapply extcall_arguments_match; eauto.
econstructor; eauto.
unfold loc_external_result. auto with ppcgen.
Qed.
@@ -1440,7 +1490,9 @@ Proof.
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.
+ split. auto. simpl. congruence.
+ intros. repeat rewrite Pregmap.gso; auto with ppcgen.
+ apply Mem.extends_refl.
unfold symbol_offset.
rewrite (transform_partial_program_main _ _ TRANSF).
rewrite symbols_preserved. unfold ge; rewrite H1. auto.
@@ -1451,8 +1503,8 @@ Lemma transf_final_states:
match_states st1 st2 -> Machconcr.final_state st1 r -> Asm.final_state st2 r.
Proof.
intros. inv H0. inv H. constructor. auto.
- compute in H1.
- rewrite (ireg_val _ _ _ R3 AG) in H1. auto. auto.
+ compute in H1.
+ exploit (ireg_val _ _ _ R3 AG). auto. rewrite H1; intro. inv H. auto.
Qed.
Theorem transf_program_correct:
diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v
index 0b146da..d428543 100644
--- a/powerpc/Asmgenproof1.v
+++ b/powerpc/Asmgenproof1.v
@@ -117,8 +117,7 @@ Qed.
Definition is_data_reg (r: preg) : Prop :=
match r with
- | IR GPR12 => False
- | FR FPR13 => False
+ | IR GPR0 => False
| PC => False | LR => False | CTR => False
| CR0_0 => False | CR0_1 => False | CR0_2 => False | CR0_3 => False
| CARRY => False
@@ -148,17 +147,12 @@ Lemma ireg_of_not_GPR1:
Proof.
intro. case r; discriminate.
Qed.
-Lemma ireg_of_not_GPR12:
- forall r, ireg_of r <> GPR12.
+Lemma ireg_of_not_GPR0:
+ forall r, ireg_of r <> GPR0.
Proof.
intro. case r; discriminate.
Qed.
-Lemma freg_of_not_FPR13:
- forall r, freg_of r <> FPR13.
-Proof.
- intro. case r; discriminate.
-Qed.
-Hint Resolve ireg_of_not_GPR1 ireg_of_not_GPR12 freg_of_not_FPR13: ppcgen.
+Hint Resolve ireg_of_not_GPR1 ireg_of_not_GPR0: ppcgen.
Lemma preg_of_not:
forall r1 r2, ~(is_data_reg r2) -> preg_of r1 <> r2.
@@ -174,36 +168,57 @@ Proof.
Qed.
Hint Resolve 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. *)
-Definition agree (ms: Mach.regset) (sp: val) (rs: Asm.regset) :=
- rs#GPR1 = sp /\ forall r: mreg, ms r = rs#(preg_of r).
+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 -> ms r = rs#(preg_of r).
+ agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r).
Proof.
- intros. elim H. auto.
+ 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 ->
- ms r = rs#(ireg_of r).
+ Val.lessdef (ms r) rs#(ireg_of r).
Proof.
- intros. elim H; intros.
- generalize (H2 r). unfold preg_of. rewrite H0. auto.
+ 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 ->
- ms r = rs#(freg_of r).
+ Val.lessdef (ms r) rs#(freg_of r).
Proof.
- intros. elim H; intros.
- generalize (H2 r). unfold preg_of. rewrite H0. auto.
+ intros. replace (FR (freg_of r)) with (preg_of r). eapply preg_val; eauto.
+ unfold preg_of. rewrite H0. auto.
Qed.
Lemma sp_val:
@@ -220,8 +235,9 @@ Lemma agree_exten_1:
(forall r, is_data_reg r -> rs'#r = rs#r) ->
agree ms sp rs'.
Proof.
- unfold agree; intros. elim H; intros.
- split. rewrite H0. auto. exact I.
+ intros. inv H. constructor.
+ apply H0. exact I.
+ auto.
intros. rewrite H0. auto. apply preg_of_is_data_reg.
Qed.
@@ -229,7 +245,7 @@ Lemma agree_exten_2:
forall ms sp rs rs',
agree ms sp rs ->
(forall r,
- r <> IR GPR12 -> r <> FR FPR13 ->
+ r <> IR GPR0 ->
r <> PC -> r <> LR -> r <> CTR ->
r <> CR0_0 -> r <> CR0_1 -> r <> CR0_2 -> r <> CR0_3 ->
r <> CARRY ->
@@ -243,12 +259,14 @@ Qed.
(** Preservation of register agreement under various assignments. *)
Lemma agree_set_mreg:
- forall ms sp rs r v,
+ forall ms sp rs r v v',
agree ms sp rs ->
- agree (Regmap.set r v ms) sp (rs#(preg_of r) <- v).
+ Val.lessdef v v' ->
+ agree (Regmap.set r v ms) sp (rs#(preg_of r) <- v').
Proof.
- unfold agree; intros. elim H; intros; clear H.
- split. rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_GPR1.
+ intros. inv H. constructor.
+ rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_GPR1.
+ auto.
intros. unfold Regmap.set. case (RegEq.eq r0 r); intro.
subst r0. rewrite Pregmap.gss. auto.
rewrite Pregmap.gso. auto. red; intro.
@@ -296,13 +314,14 @@ Qed.
Hint Resolve agree_nextinstr: ppcgen.
Lemma agree_set_mireg_twice:
- forall ms sp rs r v v',
+ forall ms sp rs r v v' v1,
agree ms sp rs ->
mreg_type r = Tint ->
- agree (Regmap.set r v ms) sp (rs #(ireg_of r) <- v' #(ireg_of r) <- v).
+ Val.lessdef v v' ->
+ agree (Regmap.set r v ms) sp (rs #(ireg_of r) <- v1 #(ireg_of r) <- v').
Proof.
- intros. replace (IR (ireg_of r)) with (preg_of r). elim H; intros.
- split. repeat (rewrite Pregmap.gso; auto with ppcgen).
+ intros. replace (IR (ireg_of r)) with (preg_of r). inv H.
+ split. repeat (rewrite Pregmap.gso; auto with ppcgen). auto.
intros. case (mreg_eq r r0); intro.
subst r0. rewrite Regmap.gss. rewrite Pregmap.gss. auto.
assert (preg_of r <> preg_of r0).
@@ -314,15 +333,17 @@ Qed.
Hint Resolve agree_set_mireg_twice: ppcgen.
Lemma agree_set_twice_mireg:
- forall ms sp rs r v v',
- agree (Regmap.set r v' ms) sp rs ->
+ forall ms sp rs r v v1 v',
+ agree (Regmap.set r v1 ms) sp rs ->
mreg_type r = Tint ->
- agree (Regmap.set r v ms) sp (rs#(ireg_of r) <- v).
+ Val.lessdef v v' ->
+ agree (Regmap.set r v ms) sp (rs#(ireg_of r) <- v').
Proof.
- intros. elim H; intros.
+ intros. inv H.
split. rewrite Pregmap.gso. auto.
generalize (ireg_of_not_GPR1 r); congruence.
- intros. generalize (H2 r0).
+ 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.
@@ -367,20 +388,66 @@ Lemma agree_set_mireg_exten:
forall ms sp rs r v (rs': regset),
agree ms sp rs ->
mreg_type r = Tint ->
- rs'#(ireg_of r) = v ->
+ Val.lessdef v rs'#(ireg_of r) ->
(forall r',
- r' <> IR GPR12 -> r' <> FR FPR13 ->
+ r' <> IR GPR0 ->
r' <> PC -> r' <> LR -> r' <> CTR ->
r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 ->
r' <> CARRY ->
r' <> IR (ireg_of r) -> rs'#r' = rs#r') ->
agree (Regmap.set r v ms) sp rs'.
Proof.
- intros. apply agree_exten_2 with (rs#(ireg_of r) <- v).
+ intros. set (v' := rs'#(ireg_of r)).
+ apply agree_exten_2 with (rs#(ireg_of r) <- v').
auto with ppcgen.
intros. unfold Pregmap.set. case (PregEq.eq r0 (ireg_of r)); intro.
subst r0. auto. apply H2; auto.
Qed.
+Hint Resolve agree_set_mireg_exten: ppcgen.
+
+Lemma agree_undef_regs:
+ forall rl ms sp rs rs',
+ agree ms sp rs ->
+ (forall r, is_data_reg r -> ~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_1 with rs; auto.
+ apply IHrl with (rs#(preg_of a) <- (rs'#(preg_of a))).
+ apply agree_set_mreg; 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,
+ r <> IR GPR0 ->
+ r <> PC -> r <> LR -> r <> CTR ->
+ r <> CR0_0 -> r <> CR0_1 -> r <> CR0_2 -> r <> CR0_3 ->
+ r <> CARRY ->
+ r <> IR GPR11 -> r <> IR GPR12 ->
+ r <> FR FPR0 -> r <> FR FPR12 -> r <> FR FPR13 ->
+ 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.
+ apply H0; (red; intro; subst; simpl in H1; intuition congruence).
+Qed.
+Hint Resolve agree_undef_temps: ppcgen.
+
+Lemma agree_undef_temps_2:
+ forall ms sp rs,
+ agree ms sp rs ->
+ agree (undef_temps ms) sp rs.
+Proof.
+ intros. apply agree_undef_temps with rs; auto.
+Qed.
+Hint Resolve agree_undef_temps_2: ppcgen.
(** Useful properties of the PC and GPR0 registers. *)
@@ -416,33 +483,41 @@ Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: ppcgen.
functions. *)
Lemma extcall_arg_match:
- forall ms sp rs m l v,
+ forall ms sp rs m m' l v,
agree ms sp rs ->
+ Mem.extends m m' ->
Machconcr.extcall_arg ms m sp l v ->
- Asm.extcall_arg rs m l v.
+ exists v', Asm.extcall_arg rs m' l v' /\ Val.lessdef v v'.
Proof.
- intros. inv H0.
- rewrite (preg_val _ _ _ r H). constructor.
- rewrite (sp_val _ _ _ H) in H1.
- destruct ty; unfold load_stack in H1.
- econstructor. reflexivity. assumption.
- econstructor. reflexivity. assumption.
+ 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, agree ms sp rs ->
+ forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' ->
forall ll vl,
Machconcr.extcall_args ms m sp ll vl ->
- Asm.extcall_args rs m ll vl.
+ exists vl', Asm.extcall_args rs m' ll vl' /\ Val.lessdef_list vl vl'.
Proof.
- induction 2; constructor; auto. eapply extcall_arg_match; eauto.
+ induction 3; intros.
+ exists (@nil val); split. constructor. constructor.
+ exploit extcall_arg_match; eauto. intros [v1' [A B]].
+ exploit IHextcall_args; eauto. intros [vl' [C D]].
+ exists (v1' :: vl'); split; constructor; auto.
Qed.
Lemma extcall_arguments_match:
- forall ms m sp rs sg args,
- agree ms sp rs ->
+ forall ms m m' sp rs sg args,
+ agree ms sp rs -> Mem.extends m m' ->
Machconcr.extcall_arguments ms m sp sg args ->
- Asm.extcall_arguments rs m sg args.
+ exists args', Asm.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'.
Proof.
unfold Machconcr.extcall_arguments, Asm.extcall_arguments; intros.
eapply extcall_args_match; eauto.
@@ -611,16 +686,16 @@ Qed.
(** Add integer immediate. *)
-Lemma addimm_1_correct:
+Lemma addimm_correct:
forall r1 r2 n k rs m,
r1 <> GPR0 ->
r2 <> GPR0 ->
exists rs',
- exec_straight (addimm_1 r1 r2 n k) rs m k rs' m
+ exec_straight (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_1.
+ intros. unfold addimm.
(* addi *)
case (Int.eq (high_s n) Int.zero).
exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))).
@@ -653,55 +728,18 @@ Proof.
unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
Qed.
-Lemma addimm_2_correct:
- forall r1 r2 n k rs m,
- r2 <> GPR12 ->
- exists rs',
- exec_straight (addimm_2 r1 r2 n k) rs m k rs' m
- /\ rs'#r1 = Val.add rs#r2 (Vint n)
- /\ forall r': preg, r' <> r1 -> r' <> GPR12 -> r' <> PC -> rs'#r' = rs#r'.
-Proof.
- intros. unfold addimm_2.
- generalize (loadimm_correct GPR12 n (Padd r1 r2 GPR12 :: k) rs m).
- intros [rs1 [EX [RES OTHER]]].
- exists (nextinstr (rs1#r1 <- (Val.add rs#r2 (Vint n)))).
- split. eapply exec_straight_trans. eexact EX.
- apply exec_straight_one. simpl. rewrite RES. rewrite OTHER.
- auto. congruence. discriminate.
- reflexivity.
- split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
- intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
-Qed.
-
-Lemma addimm_correct:
- forall r1 r2 n k rs m,
- r2 <> GPR12 ->
- exists rs',
- exec_straight (addimm r1 r2 n k) rs m k rs' m
- /\ rs'#r1 = Val.add rs#r2 (Vint n)
- /\ forall r': preg, r' <> r1 -> r' <> GPR12 -> r' <> PC -> rs'#r' = rs#r'.
-Proof.
- intros. unfold addimm.
- case (ireg_eq r1 GPR0); intro.
- apply addimm_2_correct; auto.
- case (ireg_eq r2 GPR0); intro.
- apply addimm_2_correct; auto.
- generalize (addimm_1_correct r1 r2 n k rs m n0 n1).
- intros [rs' [EX [RES OTH]]]. exists rs'. intuition.
-Qed.
-
(** And integer immediate. *)
Lemma andimm_correct:
forall r1 r2 n k (rs : regset) m,
- r2 <> GPR12 ->
+ r2 <> GPR0 ->
let v := Val.and rs#r2 (Vint n) in
exists rs',
exec_straight (andimm r1 r2 n k) rs m k rs' m
/\ rs'#r1 = v
/\ rs'#CR0_2 = Val.cmp Ceq v Vzero
/\ forall r': preg,
- r' <> r1 -> r' <> GPR12 -> r' <> PC ->
+ r' <> r1 -> r' <> GPR0 -> r' <> PC ->
r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 ->
rs'#r' = rs#r'.
Proof.
@@ -728,7 +766,7 @@ Proof.
split. auto.
intros. rewrite D; auto. apply Pregmap.gso; auto.
(* loadimm + and *)
- generalize (loadimm_correct GPR12 n (Pand_ r1 r2 GPR12 :: k) rs m).
+ generalize (loadimm_correct GPR0 n (Pand_ r1 r2 GPR0 :: k) rs m).
intros [rs1 [EX1 [RES1 OTHER1]]].
exists (nextinstr (compare_sint (rs1#r1 <- v) v Vzero)).
generalize (compare_sint_spec (rs1#r1 <- v) v Vzero).
@@ -823,21 +861,6 @@ Qed.
(** Indexed memory loads. *)
-Lemma loadind_aux_correct:
- forall (base: ireg) ofs ty dst (rs: regset) m v,
- Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v ->
- mreg_type dst = ty ->
- base <> GPR0 ->
- exec_instr ge fn (loadind_aux base ofs ty dst) rs m =
- OK (nextinstr (rs#(preg_of dst) <- v)) m.
-Proof.
- intros. unfold loadind_aux. unfold preg_of. rewrite H0. destruct ty.
- simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto.
- unfold const_low. simpl in H. rewrite H. auto.
- simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto.
- unfold const_low. simpl in H. rewrite H. auto.
-Qed.
-
Lemma loadind_correct:
forall (base: ireg) ofs ty dst k (rs: regset) m v,
Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v ->
@@ -846,50 +869,33 @@ Lemma loadind_correct:
exists rs',
exec_straight (loadind base ofs ty dst k) rs m k rs' m
/\ rs'#(preg_of dst) = v
- /\ forall r, r <> PC -> r <> GPR12 -> r <> preg_of dst -> rs'#r = rs#r.
+ /\ forall r, r <> PC -> r <> preg_of dst -> r <> GPR0 -> rs'#r = rs#r.
Proof.
- intros. unfold loadind.
- assert (preg_of dst <> PC).
- unfold preg_of. case (mreg_type dst); discriminate.
- (* short offset *)
- case (Int.eq (high_s ofs) Int.zero).
- exists (nextinstr (rs#(preg_of dst) <- v)).
- split. apply exec_straight_one. apply loadind_aux_correct; auto.
- unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. auto. auto.
- split. rewrite nextinstr_inv; auto. apply Pregmap.gss.
+ intros. unfold loadind. destruct (Int.eq (high_s ofs) Int.zero).
+(* one load *)
+ exists (nextinstr (rs#(preg_of dst) <- v)); split.
+ destruct ty; apply exec_straight_one; auto with ppcgen; simpl.
+ unfold load1. rewrite gpr_or_zero_not_zero; auto.
+ simpl in *. rewrite H. unfold preg_of; rewrite H0. auto.
+ unfold load1. rewrite gpr_or_zero_not_zero; auto.
+ simpl in *. rewrite H. unfold preg_of; rewrite H0. auto.
+ split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
- (* long offset *)
- pose (rs1 := nextinstr (rs#GPR12 <- (Val.add rs#base (Vint (Int.shl (high_s ofs) (Int.repr 16)))))).
- exists (nextinstr (rs1#(preg_of dst) <- v)).
- split. apply exec_straight_two with rs1 m.
- simpl. rewrite gpr_or_zero_not_zero; auto.
- apply loadind_aux_correct.
- unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
- rewrite Val.add_assoc. simpl. rewrite low_high_s. assumption.
- auto. discriminate. reflexivity.
- unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. auto. auto.
- split. rewrite nextinstr_inv; auto. apply Pregmap.gss.
+(* loadimm + one 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.
+ destruct ty; apply exec_straight_one; auto with ppcgen; simpl.
+ unfold load2. rewrite B. rewrite C; auto with ppcgen. simpl in H. rewrite H.
+ unfold preg_of; rewrite H0. auto. congruence.
+ unfold load2. rewrite B. rewrite C; auto with ppcgen. simpl in H. rewrite H.
+ unfold preg_of; rewrite H0. auto. congruence.
+ split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
- unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
Qed.
(** Indexed memory stores. *)
-Lemma storeind_aux_correct:
- forall (base: ireg) ofs ty src (rs: regset) m m',
- 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 ->
- exec_instr ge fn (storeind_aux src base ofs ty) rs m =
- OK (nextinstr rs) m'.
-Proof.
- intros. unfold storeind_aux. unfold preg_of in H. rewrite H0 in H. destruct ty.
- simpl. unfold store1. rewrite gpr_or_zero_not_zero; auto.
- unfold const_low. simpl in H. rewrite H. auto.
- simpl. unfold store1. rewrite gpr_or_zero_not_zero; auto.
- unfold const_low. simpl in H. rewrite H. auto.
-Qed.
-
Lemma storeind_correct:
forall (base: ireg) ofs ty src k (rs: regset) m m',
Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' ->
@@ -897,28 +903,31 @@ Lemma storeind_correct:
base <> GPR0 ->
exists rs',
exec_straight (storeind src base ofs ty k) rs m k rs' m'
- /\ forall r, r <> PC -> r <> GPR12 -> rs'#r = rs#r.
+ /\ forall r, r <> PC -> r <> GPR0 -> rs'#r = rs#r.
Proof.
- intros. unfold storeind.
- (* short offset *)
- case (Int.eq (high_s ofs) Int.zero).
- exists (nextinstr rs).
- split. apply exec_straight_one. apply storeind_aux_correct; auto.
- reflexivity.
+ 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 *)
+ exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
+ assert (rs' base = rs base). apply C; auto with ppcgen. congruence.
+ 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.
- (* long offset *)
- pose (rs1 := nextinstr (rs#GPR12 <- (Val.add rs#base (Vint (Int.shl (high_s ofs) (Int.repr 16)))))).
- exists (nextinstr rs1).
- split. apply exec_straight_two with rs1 m.
- simpl. rewrite gpr_or_zero_not_zero; auto.
- apply storeind_aux_correct; auto with ppcgen.
- unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
- rewrite nextinstr_inv; auto with ppcgen.
- rewrite Pregmap.gso; auto with ppcgen.
- rewrite Val.add_assoc. simpl. rewrite low_high_s. assumption.
- reflexivity. reflexivity.
- intros. rewrite nextinstr_inv; auto.
- unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
Qed.
(** Float comparisons. *)
@@ -979,6 +988,19 @@ Ltac 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. *)
Lemma transl_cond_correct_aux:
@@ -989,116 +1011,101 @@ Lemma transl_cond_correct_aux:
exec_straight (transl_cond cond args k) rs m k rs' m
/\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
(if snd (crbit_for_cond cond)
- then eval_condition_total cond (map ms args)
- else Val.notbool (eval_condition_total cond (map ms args)))
+ then eval_condition_total cond (map rs (map preg_of args))
+ else Val.notbool (eval_condition_total cond (map rs (map preg_of args))))
/\ agree ms sp rs'.
Proof.
- intros. destruct cond; simpl in H; TypeInv.
+ intros.
+ destruct cond; simpl in H; TypeInv; simpl; UseTypeInfo.
(* Ccomp *)
- simpl.
- generalize (compare_sint_spec rs ms#m0 ms#m1).
- intros [A [B [C D]]].
- exists (nextinstr (compare_sint rs ms#m0 ms#m1)).
- split. apply exec_straight_one. simpl.
- repeat (rewrite <- (ireg_val ms sp rs); auto).
- reflexivity.
+ destruct (compare_sint_spec rs (rs (ireg_of m0)) (rs (ireg_of m1)))
+ 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.
apply agree_exten_2 with rs; auto.
(* Ccompu *)
- simpl.
- generalize (compare_uint_spec rs ms#m0 ms#m1).
- intros [A [B [C D]]].
- exists (nextinstr (compare_uint rs ms#m0 ms#m1)).
- split. apply exec_straight_one. simpl.
- repeat (rewrite <- (ireg_val ms sp rs); auto).
- reflexivity.
+ destruct (compare_uint_spec rs (rs (ireg_of m0)) (rs (ireg_of m1)))
+ 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.
apply agree_exten_2 with rs; auto.
(* Ccompimm *)
- simpl.
case (Int.eq (high_s i) Int.zero).
- generalize (compare_sint_spec rs ms#m0 (Vint i)).
- intros [A [B [C D]]].
- exists (nextinstr (compare_sint rs ms#m0 (Vint i))).
- split. apply exec_straight_one. simpl.
- repeat (rewrite <- (ireg_val ms sp rs); auto).
- reflexivity.
+ destruct (compare_sint_spec rs (rs (ireg_of m0)) (Vint i))
+ as [A [B [C D]]].
+ econstructor; split.
+ apply exec_straight_one. simpl. eauto. reflexivity.
split.
case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
apply agree_exten_2 with rs; auto.
- generalize (loadimm_correct GPR12 i (Pcmpw (ireg_of m0) GPR12 :: k) rs m).
+ generalize (loadimm_correct GPR0 i (Pcmpw (ireg_of m0) GPR0 :: k) rs m).
intros [rs1 [EX1 [RES1 OTH1]]].
- assert (agree ms sp rs1). apply agree_exten_2 with rs; auto.
- generalize (compare_sint_spec rs1 ms#m0 (Vint i)).
- intros [A [B [C D]]].
- exists (nextinstr (compare_sint rs1 ms#m0 (Vint i))).
+ 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. decEq. auto with ppcgen.
+ exists (nextinstr (compare_sint rs1 (rs1 (ireg_of m0)) (Vint i))).
split. eapply exec_straight_trans. eexact EX1.
- apply exec_straight_one. simpl.
- repeat (rewrite <- (ireg_val ms sp rs1); auto). rewrite RES1.
- reflexivity. reflexivity.
- split.
+ apply exec_straight_one. simpl. rewrite RES1; rewrite H; auto.
+ reflexivity.
+ split. rewrite H.
case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
- apply agree_exten_2 with rs1; auto.
+ apply agree_exten_2 with rs; auto.
+ intros. rewrite H; rewrite D; auto.
(* Ccompuimm *)
- simpl.
case (Int.eq (high_u i) Int.zero).
- generalize (compare_uint_spec rs ms#m0 (Vint i)).
- intros [A [B [C D]]].
- exists (nextinstr (compare_uint rs ms#m0 (Vint i))).
- split. apply exec_straight_one. simpl.
- repeat (rewrite <- (ireg_val ms sp rs); auto).
- reflexivity.
+ destruct (compare_uint_spec rs (rs (ireg_of m0)) (Vint i))
+ as [A [B [C D]]].
+ econstructor; split.
+ apply exec_straight_one. simpl. eauto. reflexivity.
split.
case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
apply agree_exten_2 with rs; auto.
- generalize (loadimm_correct GPR12 i (Pcmplw (ireg_of m0) GPR12 :: k) rs m).
+ generalize (loadimm_correct GPR0 i (Pcmplw (ireg_of m0) GPR0 :: k) rs m).
intros [rs1 [EX1 [RES1 OTH1]]].
- assert (agree ms sp rs1). apply agree_exten_2 with rs; auto.
- generalize (compare_uint_spec rs1 ms#m0 (Vint i)).
- intros [A [B [C D]]].
- exists (nextinstr (compare_uint rs1 ms#m0 (Vint i))).
+ destruct (compare_uint_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. decEq. auto with ppcgen.
+ exists (nextinstr (compare_uint rs1 (rs1 (ireg_of m0)) (Vint i))).
split. eapply exec_straight_trans. eexact EX1.
- apply exec_straight_one. simpl.
- repeat (rewrite <- (ireg_val ms sp rs1); auto). rewrite RES1.
- reflexivity. reflexivity.
- split.
+ apply exec_straight_one. simpl. rewrite RES1; rewrite H; auto.
+ reflexivity.
+ split. rewrite H.
case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
- apply agree_exten_2 with rs1; auto.
+ apply agree_exten_2 with rs; auto.
+ intros. rewrite H; rewrite D; auto.
(* Ccompf *)
- simpl.
- generalize (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m).
- intros [rs' [EX [RES OTH]]].
+ destruct (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m)
+ as [rs' [EX [RES OTH]]].
exists rs'. split. auto.
- split. rewrite RES. repeat (rewrite <- (freg_val ms sp rs); auto).
+ split. apply RES.
apply agree_exten_2 with rs; auto.
(* Cnotcompf *)
- simpl.
- generalize (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m).
- intros [rs' [EX [RES OTH]]].
+ destruct (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m)
+ as [rs' [EX [RES OTH]]].
exists rs'. split. auto.
- split. rewrite RES. repeat (rewrite <- (freg_val ms sp rs); auto).
+ split. rewrite RES.
assert (forall v1 v2, Val.notbool (Val.notbool (Val.cmpf c v1 v2)) = Val.cmpf c v1 v2).
intros v1 v2; unfold Val.cmpf; destruct v1; destruct v2; auto.
apply Val.notbool_idem2.
- rewrite H.
- generalize RES. case (snd (crbit_for_fcmp c)); simpl; auto.
+ rewrite H. case (snd (crbit_for_fcmp c)); simpl; auto.
apply agree_exten_2 with rs; auto.
(* Cmaskzero *)
- simpl.
- generalize (andimm_correct GPR12 (ireg_of m0) i k rs m (ireg_of_not_GPR12 m0)).
- intros [rs' [A [B [C D]]]].
+ destruct (andimm_correct GPR0 (ireg_of m0) i k rs m (ireg_of_not_GPR0 m0))
+ as [rs' [A [B [C D]]]].
exists rs'. split. assumption.
- split. rewrite C. rewrite <- (ireg_val ms sp rs); auto.
+ split. rewrite C. auto.
apply agree_exten_2 with rs; auto.
(* Cmasknotzero *)
- simpl.
- generalize (andimm_correct GPR12 (ireg_of m0) i k rs m (ireg_of_not_GPR12 m0)).
- intros [rs' [A [B [C D]]]].
+ destruct (andimm_correct GPR0 (ireg_of m0) i k rs m (ireg_of_not_GPR0 m0))
+ as [rs' [A [B [C D]]]].
exists rs'. split. assumption.
- split. rewrite C. rewrite <- (ireg_val ms sp rs); auto.
- rewrite Val.notbool_idem3. reflexivity.
+ split. rewrite C. rewrite Val.notbool_idem3. reflexivity.
apply agree_exten_2 with rs; auto.
Qed.
@@ -1115,31 +1122,37 @@ Lemma transl_cond_correct:
else Val.notbool (Val.of_bool b))
/\ agree ms sp rs'.
Proof.
- intros. rewrite <- (eval_condition_weaken _ _ H1).
- apply transl_cond_correct_aux; auto.
+ intros.
+ assert (eval_condition_total cond rs ## (preg_of ## args) = Val.of_bool b).
+ apply eval_condition_weaken. eapply eval_condition_lessdef; eauto.
+ eapply preg_vals; eauto.
+ rewrite <- H2. eapply transl_cond_correct_aux; eauto.
Qed.
(** Translation of arithmetic operations. *)
Ltac TranslOpSimpl :=
+ econstructor; split;
+ [ apply exec_straight_one; [simpl; eauto | reflexivity]
+ | auto 7 with ppcgen; fail ].
+(*
match goal with
- | |- exists rs' : regset,
+ | H: (Val.lessdef ?v ?v') |-
+ exists rs' : regset,
exec_straight ?c ?rs ?m ?k rs' ?m /\
agree (Regmap.set ?res ?v ?ms) ?sp rs' =>
- (exists (nextinstr (rs#(ireg_of res) <- v));
+
+ (exists (nextinstr (rs#(ireg_of res) <- v'));
split;
- [ apply exec_straight_one;
- [ repeat (rewrite (ireg_val ms sp rs); auto); reflexivity
- | reflexivity ]
+ [ apply exec_straight_one; auto; fail
| auto with ppcgen ])
||
- (exists (nextinstr (rs#(freg_of res) <- v));
+ (exists (nextinstr (rs#(freg_of res) <- v'));
split;
- [ apply exec_straight_one;
- [ repeat (rewrite (freg_val ms sp rs); auto); reflexivity
- | reflexivity ]
+ [ apply exec_straight_one; auto; fail
| auto with ppcgen ])
end.
+*)
Lemma transl_op_correct:
forall op args res k ms sp rs m v,
@@ -1147,41 +1160,44 @@ Lemma transl_op_correct:
agree ms sp rs ->
eval_operation ge sp op (map ms args) = Some v ->
exists rs',
- exec_straight (transl_op op args res k) rs m k rs' m
- /\ agree (Regmap.set res v ms) sp 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'.
Proof.
- intros. rewrite <- (eval_operation_weaken _ _ _ _ H1). clear H1; clear v.
- inversion H.
+ intros.
+ assert (exists v', Val.lessdef v v' /\
+ eval_operation_total ge sp op (map rs (map preg_of args)) = v').
+ exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto.
+ intros [v' [A B]]. exists v'; split; auto.
+ apply eval_operation_weaken; eauto.
+ destruct H2 as [v' [LD EQ]]. clear H1.
+ inv H.
(* Omove *)
- simpl. exists (nextinstr (rs#(preg_of res) <- (ms r1))).
- split. caseEq (mreg_type r1); intro.
- apply exec_straight_one. simpl. rewrite (ireg_val ms sp rs); auto.
- simpl. unfold preg_of. rewrite <- H2. rewrite H5. reflexivity.
- auto with ppcgen.
- apply exec_straight_one. simpl. rewrite (freg_val ms sp rs); auto.
- simpl. unfold preg_of. rewrite <- H2. rewrite H5. reflexivity.
- auto with ppcgen.
- auto with ppcgen.
+ simpl in *.
+ exists (nextinstr (rs#(preg_of res) <- (rs#(preg_of r1)))).
+ split. unfold preg_of. rewrite <- H2.
+ destruct (mreg_type r1); apply exec_straight_one; auto.
+ auto with ppcgen.
(* Other instructions *)
- clear H1; clear H2; clear H4.
- destruct op; simpl in H5; injection H5; clear H5; intros;
- TypeInv; simpl; try (TranslOpSimpl).
+ destruct op; simpl; simpl in H5; injection H5; clear H5; intros;
+ TypeInv; simpl in *; UseTypeInfo; try (TranslOpSimpl).
(* Omove again *)
congruence.
(* Ointconst *)
- generalize (loadimm_correct (ireg_of res) i k rs m).
- intros [rs' [A [B C]]].
+ destruct (loadimm_correct (ireg_of res) i k rs m)
+ as [rs' [A [B C]]].
exists rs'. split. auto.
- apply agree_set_mireg_exten with rs; auto.
+ rewrite <- B in LD. eauto with ppcgen.
(* Ofloatconst *)
- exists (nextinstr (rs#(freg_of res) <- (Vfloat f) #GPR12 <- Vundef)).
+ exists (nextinstr (rs #GPR12 <- Vundef #(freg_of res) <- (Vfloat f))).
split. apply exec_straight_one. reflexivity. reflexivity.
- auto with ppcgen.
+ apply agree_nextinstr. apply agree_set_mfreg; auto. apply agree_set_mreg; auto.
+ eapply agree_undef_temps; eauto.
+ intros. apply Pregmap.gso; auto.
(* Oaddrsymbol *)
- change (find_symbol_offset ge i i0) with (symbol_offset ge i i0).
- set (v := symbol_offset ge i i0).
- pose (rs1 := nextinstr (rs#GPR12 <- (high_half v))).
- exists (nextinstr (rs1#(ireg_of res) <- v)).
+ change (find_symbol_offset ge i i0) with (symbol_offset ge i i0) in LD.
+ set (v' := symbol_offset ge i i0) in *.
+ pose (rs1 := nextinstr (rs#GPR12 <- (high_half v'))).
+ exists (nextinstr (rs1#(ireg_of res) <- v')).
split. apply exec_straight_two with rs1 m.
unfold exec_instr. rewrite gpr_or_zero_zero.
unfold const_high. rewrite Val.add_commut.
@@ -1189,173 +1205,127 @@ Proof.
simpl. rewrite gpr_or_zero_not_zero. 2: congruence.
unfold rs1 at 1. rewrite nextinstr_inv; auto with ppcgen.
rewrite Pregmap.gss.
- fold v. rewrite Val.add_commut. unfold v. rewrite low_high_half.
+ fold v'. rewrite Val.add_commut. unfold v'. rewrite low_high_half.
reflexivity. reflexivity. reflexivity.
unfold rs1. apply agree_nextinstr. apply agree_set_mireg; auto.
- apply agree_set_mreg. apply agree_nextinstr.
- apply agree_set_other. auto. simpl. tauto.
+ apply agree_set_mreg; auto. apply agree_nextinstr.
+ eapply agree_undef_temps; eauto.
+ intros. apply Pregmap.gso; auto.
(* Oaddrstack *)
- assert (GPR1 <> GPR12). discriminate.
- generalize (addimm_correct (ireg_of res) GPR1 i k rs m H2).
+ assert (GPR1 <> GPR0). discriminate.
+ generalize (addimm_correct (ireg_of res) GPR1 i k rs m (ireg_of_not_GPR0 res) H1).
intros [rs' [EX [RES OTH]]].
exists rs'. split. auto.
- apply agree_set_mireg_exten with rs; auto.
- rewrite (sp_val ms sp rs). auto. auto.
+ apply agree_set_mireg_exten with rs; auto with ppcgen.
+ rewrite (sp_val ms sp rs) in LD; auto. rewrite RES; auto.
(* Ocast8unsigned *)
- exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 255)))).
- split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity.
- replace (Val.zero_ext 8 (ms m0))
- with (Val.rolm (ms m0) Int.zero (Int.repr 255)).
+ econstructor; split.
+ apply exec_straight_one. simpl; reflexivity. reflexivity.
+ replace (Val.zero_ext 8 (rs (ireg_of m0)))
+ with (Val.rolm (rs (ireg_of m0)) Int.zero (Int.repr 255)) in LD.
auto with ppcgen.
- unfold Val.rolm, Val.zero_ext. destruct (ms m0); auto.
+ unfold Val.rolm, Val.zero_ext. destruct (rs (ireg_of m0)); auto.
rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto.
(* Ocast16unsigned *)
- exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 65535)))).
- split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity.
- replace (Val.zero_ext 16 (ms m0))
- with (Val.rolm (ms m0) Int.zero (Int.repr 65535)).
+ econstructor; split.
+ apply exec_straight_one. simpl; reflexivity. reflexivity.
+ replace (Val.zero_ext 16 (rs (ireg_of m0)))
+ with (Val.rolm (rs (ireg_of m0)) Int.zero (Int.repr 65535)) in LD.
auto with ppcgen.
- unfold Val.rolm, Val.zero_ext. destruct (ms m0); auto.
+ unfold Val.rolm, Val.zero_ext. destruct (rs (ireg_of m0)); auto.
rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto.
(* Oaddimm *)
generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m
- (ireg_of_not_GPR12 m0)).
+ (ireg_of_not_GPR0 res) (ireg_of_not_GPR0 m0)).
intros [rs' [A [B C]]].
exists rs'. split. auto.
- apply agree_set_mireg_exten with rs; auto.
- rewrite (ireg_val ms sp rs); auto.
- (* Osub *)
- exists (nextinstr (rs#(ireg_of res) <- (Val.sub (ms m0) (ms m1)) #CARRY <- Vundef)).
- split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto).
- simpl. reflexivity. auto with ppcgen.
+ rewrite <- B in LD. eauto with ppcgen.
(* Osubimm *)
case (Int.eq (high_s i) Int.zero).
- exists (nextinstr (rs#(ireg_of res) <- (Val.sub (Vint i) (ms m0)) #CARRY <- Vundef)).
- split. apply exec_straight_one. rewrite (ireg_val ms sp rs); auto.
- reflexivity. simpl. auto with ppcgen.
- generalize (loadimm_correct GPR12 i (Psubfc (ireg_of res) (ireg_of m0) GPR12 :: k) rs m).
+ econstructor; split.
+ apply exec_straight_one. simpl; eauto. auto.
+ auto 7 with ppcgen.
+ generalize (loadimm_correct GPR0 i (Psubfc (ireg_of res) (ireg_of m0) GPR0 :: k) rs m).
intros [rs1 [EX [RES OTH]]].
- assert (agree ms sp rs1). apply agree_exten_2 with rs; auto.
- exists (nextinstr (rs1#(ireg_of res) <- (Val.sub (Vint i) (ms m0)) #CARRY <- Vundef)).
- split. eapply exec_straight_trans. eexact EX.
- apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto).
- simpl. rewrite RES. rewrite OTH. reflexivity.
- generalize (ireg_of_not_GPR12 m0); congruence.
- discriminate.
- reflexivity. simpl; auto with ppcgen.
+ econstructor; split.
+ eapply exec_straight_trans. eexact EX.
+ apply exec_straight_one. simpl; eauto. auto.
+ rewrite RES. rewrite OTH; auto with ppcgen.
+ assert (agree (undef_temps ms) sp rs1). eauto with ppcgen.
+ auto with ppcgen. decEq; auto with ppcgen.
(* Omulimm *)
case (Int.eq (high_s i) Int.zero).
- exists (nextinstr (rs#(ireg_of res) <- (Val.mul (ms m0) (Vint i)))).
- split. apply exec_straight_one. rewrite (ireg_val ms sp rs); auto.
- reflexivity. auto with ppcgen.
- generalize (loadimm_correct GPR12 i (Pmullw (ireg_of res) (ireg_of m0) GPR12 :: k) rs m).
+ econstructor; split.
+ apply exec_straight_one. simpl; eauto. auto.
+ auto with ppcgen.
+ generalize (loadimm_correct GPR0 i (Pmullw (ireg_of res) (ireg_of m0) GPR0 :: k) rs m).
intros [rs1 [EX [RES OTH]]].
- assert (agree ms sp rs1). apply agree_exten_2 with rs; auto.
- exists (nextinstr (rs1#(ireg_of res) <- (Val.mul (ms m0) (Vint i)))).
- split. eapply exec_straight_trans. eexact EX.
- apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto).
- simpl. rewrite RES. rewrite OTH. reflexivity.
- generalize (ireg_of_not_GPR12 m0); congruence.
- discriminate.
- reflexivity. simpl; auto with ppcgen.
+ assert (agree (undef_temps ms) sp rs1). eauto with ppcgen.
+ econstructor; split.
+ eapply exec_straight_trans. eexact EX.
+ apply exec_straight_one. simpl; eauto. auto.
+ rewrite RES. rewrite OTH; auto with ppcgen. decEq; auto with ppcgen.
(* Oand *)
- pose (v := Val.and (ms m0) (ms m1)).
- pose (rs1 := rs#(ireg_of res) <- v).
- generalize (compare_sint_spec rs1 v Vzero).
+ 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]]].
- exists (nextinstr (compare_sint rs1 v Vzero)).
- split. apply exec_straight_one.
- unfold rs1, v. repeat (rewrite (ireg_val ms sp rs); auto).
- reflexivity.
- apply agree_exten_2 with rs1. unfold rs1, v; auto with ppcgen.
+ exists (nextinstr (compare_sint rs1 v' Vzero)).
+ split. apply exec_straight_one. auto. auto.
+ apply agree_exten_2 with rs1. unfold rs1; auto with ppcgen.
auto.
(* Oandimm *)
generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m
- (ireg_of_not_GPR12 m0)).
+ (ireg_of_not_GPR0 m0)).
intros [rs' [A [B [C D]]]].
- exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto.
- rewrite (ireg_val ms sp rs); auto.
+ exists rs'. split. auto. rewrite <- B in LD. eauto with ppcgen.
(* Oorimm *)
generalize (orimm_correct (ireg_of res) (ireg_of m0) i k rs m).
intros [rs' [A [B C]]].
- exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto.
- rewrite (ireg_val ms sp rs); auto.
+ exists rs'. split. auto. rewrite <- B in LD. eauto with ppcgen.
(* Oxorimm *)
generalize (xorimm_correct (ireg_of res) (ireg_of m0) i k rs m).
intros [rs' [A [B C]]].
- exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto.
- rewrite (ireg_val ms sp rs); auto.
- (* Oshr *)
- exists (nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (ms m1)) #CARRY <- (Val.shr_carry (ms m0) (ms m1)))).
- split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto).
- reflexivity. auto with ppcgen.
- (* Oshrimm *)
- exists (nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (Vint i)) #CARRY <- (Val.shr_carry (ms m0) (Vint i)))).
- split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto).
- reflexivity. auto with ppcgen.
+ exists rs'. split. auto. rewrite <- B in LD. eauto with ppcgen.
(* Oxhrximm *)
- pose (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (Vint i)) #CARRY <- (Val.shr_carry (ms m0) (Vint i)))).
- exists (nextinstr (rs1#(ireg_of res) <- (Val.shrx (ms m0) (Vint i)))).
+ pose (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shr (rs (ireg_of m0)) (Vint i)) #CARRY <- (Val.shr_carry (rs (ireg_of m0)) (Vint i)))).
+ exists (nextinstr (rs1#(ireg_of res) <- (Val.shrx (rs (ireg_of m0)) (Vint i)))).
split. apply exec_straight_two with rs1 m.
- unfold rs1; rewrite (ireg_val ms sp rs); auto.
- simpl; unfold rs1; repeat rewrite <- (ireg_val ms sp rs); auto.
- repeat (rewrite nextinstr_inv; try discriminate).
- repeat rewrite Pregmap.gss. decEq. decEq.
- apply (f_equal3 (@Pregmap.set val)); auto.
- rewrite Pregmap.gso. rewrite Pregmap.gss. apply Val.shrx_carry.
- discriminate. reflexivity. reflexivity.
- apply agree_exten_2 with (rs#(ireg_of res) <- (Val.shrx (ms m0) (Vint i))).
- auto with ppcgen.
- intros. rewrite nextinstr_inv; auto.
- case (preg_eq (ireg_of res) r); intro.
- subst r. repeat rewrite Pregmap.gss. auto.
- repeat rewrite Pregmap.gso; auto.
- unfold rs1. rewrite nextinstr_inv; auto.
- repeat rewrite Pregmap.gso; auto.
+ auto. simpl. decEq. decEq. decEq.
+ unfold rs1. repeat (rewrite nextinstr_inv; try discriminate).
+ rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss.
+ apply Val.shrx_carry. auto with ppcgen. auto. auto.
+ apply agree_nextinstr. unfold rs1. apply agree_nextinstr_commut.
+ apply agree_set_commut. auto with ppcgen.
+ apply agree_set_other. apply agree_set_mireg_twice; auto with ppcgen.
+ compute; auto. auto with ppcgen.
(* Ointoffloat *)
- exists (nextinstr (rs#(ireg_of res) <- (Val.intoffloat (ms m0)) #FPR13 <- Vundef)).
- split. apply exec_straight_one.
- repeat (rewrite (freg_val ms sp rs); auto).
- reflexivity. auto with ppcgen.
- (* Ointuoffloat *)
- exists (nextinstr (rs#(ireg_of res) <- (Val.intuoffloat (ms m0)) #FPR13 <- Vundef)).
- split. apply exec_straight_one.
- repeat (rewrite (freg_val ms sp rs); auto).
- reflexivity. auto with ppcgen.
- (* Ofloatofint *)
- exists (nextinstr (rs#(freg_of res) <- (Val.floatofint (ms m0)) #GPR12 <- Vundef #FPR13 <- Vundef)).
- split. apply exec_straight_one.
- repeat (rewrite (ireg_val ms sp rs); auto).
- reflexivity. auto 10 with ppcgen.
- (* Ofloatofintu *)
- exists (nextinstr (rs#(freg_of res) <- (Val.floatofintu (ms m0)) #GPR12 <- Vundef #FPR13 <- Vundef)).
- split. apply exec_straight_one.
- repeat (rewrite (ireg_val ms sp rs); auto).
- reflexivity. auto 10 with ppcgen.
+ econstructor; split.
+ apply exec_straight_one. simpl; eauto. auto.
+ apply agree_nextinstr. apply agree_set_mireg; auto. apply agree_set_mreg; auto.
+ apply agree_undef_temps with rs; auto. intros.
+ repeat rewrite Pregmap.gso; auto.
(* Ocmp *)
- generalize H2; case (classify_condition c args); intros.
+ revert H1 LD; case (classify_condition c args); intros.
(* Optimization: compimm Cge 0 *)
- subst n. simpl in H4. simpl.
- set (rs1 := nextinstr (rs#(ireg_of res) <- (Val.rolm (ms r) Int.one Int.one))).
+ subst n. simpl in *. inv H1. UseTypeInfo.
+ set (rs1 := nextinstr (rs#(ireg_of res) <- (Val.rolm (rs (ireg_of r)) Int.one Int.one))).
set (rs2 := nextinstr (rs1#(ireg_of res) <- (Val.xor (rs1#(ireg_of res)) (Vint Int.one)))).
exists rs2.
- split. apply exec_straight_two with rs1 m.
- simpl. unfold rs1. rewrite (ireg_val ms sp rs); auto. congruence.
- auto. auto. auto.
- rewrite <- Val.rolm_ge_zero.
+ split. apply exec_straight_two with rs1 m; auto.
+ rewrite <- Val.rolm_ge_zero in LD.
unfold rs2. apply agree_nextinstr.
unfold rs1. apply agree_nextinstr_commut. fold rs1.
- replace (rs1 (ireg_of res)) with (Val.rolm (ms r) Int.one Int.one).
- apply agree_set_mireg_twice; auto.
+ replace (rs1 (ireg_of res)) with (Val.rolm (rs (ireg_of r)) Int.one Int.one).
+ apply agree_set_mireg_twice; auto with ppcgen.
unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. auto.
auto with ppcgen. auto with ppcgen.
(* Optimization: compimm Clt 0 *)
- subst n. simpl in H4. simpl.
- exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms r) Int.one Int.one))).
- split. apply exec_straight_one. simpl. rewrite (ireg_val ms sp rs); auto. congruence.
- auto.
- apply agree_nextinstr. apply agree_set_mireg.
- rewrite Val.rolm_lt_zero. apply agree_set_mreg. auto. congruence.
+ subst n. simpl in *. inv H1. UseTypeInfo.
+ exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (rs (ireg_of r)) Int.one Int.one))).
+ split. apply exec_straight_one; auto.
+ rewrite <- Val.rolm_lt_zero in LD.
+ auto with ppcgen.
(* General case *)
set (bit := fst (crbit_for_cond c0)).
set (isset := snd (crbit_for_cond c0)).
@@ -1364,7 +1334,7 @@ Proof.
(if isset
then k
else Pxori (ireg_of res) (ireg_of res) (Cint Int.one) :: k)).
- generalize (transl_cond_correct_aux c0 rl k1 ms sp rs m H4 H0).
+ generalize (transl_cond_correct_aux c0 rl k1 ms sp rs m H1 H0).
fold bit; fold isset.
intros [rs1 [EX1 [RES1 AG1]]].
set (rs2 := nextinstr (rs1#(ireg_of res) <- (rs1#(reg_of_crbit bit)))).
@@ -1374,89 +1344,63 @@ Proof.
unfold k1. apply exec_straight_one.
reflexivity. reflexivity.
unfold rs2. rewrite RES1. auto with ppcgen.
- exists (nextinstr (rs2#(ireg_of res) <- (eval_condition_total c0 ms##rl))).
+ econstructor.
split. apply exec_straight_trans with k1 rs1 m. assumption.
unfold k1. apply exec_straight_two with rs2 m.
- reflexivity. simpl.
- replace (Val.xor (rs2 (ireg_of res)) (Vint Int.one))
- with (eval_condition_total c0 ms##rl).
- reflexivity.
- unfold rs2. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
- rewrite RES1. apply Val.notbool_xor. apply eval_condition_total_is_bool.
- reflexivity. reflexivity.
- unfold rs2. auto with ppcgen.
+ reflexivity. simpl. eauto. auto. auto.
+ apply agree_nextinstr.
+ unfold rs2 at 1. rewrite nextinstr_inv. rewrite Pregmap.gss.
+ rewrite RES1. rewrite <- Val.notbool_xor.
+ unfold rs2. auto 7 with ppcgen.
+ apply eval_condition_total_is_bool.
+ auto with ppcgen.
Qed.
Lemma transl_load_store_correct:
forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction)
- addr args k ms sp rs m ms' m',
+ addr args (temp: ireg) k ms sp rs m ms' m',
(forall cst (r1: ireg) (rs1: regset) k,
- eval_addressing_total ge sp addr (map ms args) =
+ eval_addressing_total ge sp addr (map rs (map preg_of args)) =
Val.add (gpr_or_zero rs1 r1) (const_low ge cst) ->
- agree ms sp rs1 ->
+ (forall (r: preg), r <> PC -> r <> temp -> rs1 r = rs r) ->
exists rs',
exec_straight (mk1 cst r1 :: k) rs1 m k rs' m' /\
agree ms' sp rs') ->
- (forall (r1 r2: ireg) (rs1: regset) k,
- eval_addressing_total ge sp addr (map ms args) = Val.add rs1#r1 rs1#r2 ->
- agree ms sp rs1 ->
+ (forall (r1 r2: ireg) k,
+ eval_addressing_total ge sp addr (map rs (map preg_of args)) = Val.add rs#r1 rs#r2 ->
exists rs',
- exec_straight (mk2 r1 r2 :: k) rs1 m k rs' m' /\
+ 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 ->
exists rs',
- exec_straight (transl_load_store mk1 mk2 addr args k) rs m
+ exec_straight (transl_load_store mk1 mk2 addr args temp k) rs m
k rs' m'
/\ agree ms' sp rs'.
Proof.
intros. destruct addr; simpl in H2; TypeInv; simpl.
(* Aindexed *)
- case (ireg_eq (ireg_of t) GPR0); intro.
- (* Aindexed from GPR0 *)
- set (rs1 := nextinstr (rs#GPR12 <- (ms t))).
- set (rs2 := nextinstr (rs1#GPR12 <- (Val.add (ms t) (Vint (Int.shl (high_s i) (Int.repr 16)))))).
- assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) =
- Val.add (gpr_or_zero rs2 GPR12) (const_low ge (Cint (low_s i)))).
- simpl. rewrite gpr_or_zero_not_zero; auto with ppcgen.
- unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss.
- rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
- discriminate.
- assert (AG: agree ms sp rs2). unfold rs2, rs1; auto 6 with ppcgen.
- destruct (H _ _ _ k ADDR AG) as [rs' [EX' AG']].
- exists rs'. split.
- apply exec_straight_trans with (mk1 (Cint (low_s i)) GPR12 :: k) rs2 m.
- apply exec_straight_two with rs1 m.
- unfold rs1. rewrite (ireg_val ms sp rs); auto.
- unfold rs2. replace (ms t) with (rs1#GPR12). auto.
- unfold rs1. rewrite nextinstr_inv. apply Pregmap.gss. discriminate.
- reflexivity. reflexivity.
- assumption. assumption.
- (* Aindexed short *)
case (Int.eq (high_s i) Int.zero).
- assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) =
- Val.add (gpr_or_zero rs (ireg_of t)) (const_low ge (Cint i))).
- simpl. rewrite gpr_or_zero_not_zero; auto with ppcgen.
- rewrite (ireg_val ms sp rs); auto.
- destruct (H _ _ _ k ADDR H1) as [rs' [EX' AG']].
- exists rs'. split. auto. auto.
+ (* Aindexed short *)
+ apply H.
+ simpl. UseTypeInfo. rewrite gpr_or_zero_not_zero; auto with ppcgen.
+ auto.
(* Aindexed long *)
- set (rs1 := nextinstr (rs#GPR12 <- (Val.add (ms t) (Vint (Int.shl (high_s i) (Int.repr 16)))))).
- assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) =
- Val.add (gpr_or_zero rs1 GPR12) (const_low ge (Cint (low_s i)))).
- simpl. rewrite gpr_or_zero_not_zero; auto with ppcgen.
- unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss.
+ 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. rewrite nextinstr_inv. rewrite Pregmap.gss.
rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
discriminate.
- assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen.
- destruct (H _ _ _ k ADDR AG) as [rs' [EX' AG']].
+ 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.
- simpl. rewrite gpr_or_zero_not_zero; auto.
- rewrite <- (ireg_val ms sp rs); auto. reflexivity.
- assumption. assumption.
+ simpl. rewrite gpr_or_zero_not_zero; auto with ppcgen. auto.
+ auto. auto.
(* Aindexed2 *)
apply H0.
- simpl. repeat (rewrite (ireg_val ms sp rs); auto). auto.
+ simpl. UseTypeInfo; auto.
(* Aglobal *)
case_eq (symbol_is_small_data i i0); intro SISD.
(* Aglobal from small data *)
@@ -1466,17 +1410,16 @@ Proof.
destruct (Genv.find_symbol ge i); auto. rewrite Int.add_zero. auto.
auto.
(* Aglobal general case *)
- set (rs1 := nextinstr (rs#GPR12 <- (const_high ge (Csymbol_high i i0)))).
- assert (ADDR: eval_addressing_total ge sp (Aglobal i i0) ms##nil =
- Val.add (gpr_or_zero rs1 GPR12) (const_low ge (Csymbol_low i i0))).
+ 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. apply low_high_half.
- discriminate. discriminate.
- assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen.
- destruct (H _ _ _ k ADDR AG) as [rs' [EX' AG']].
+ discriminate.
+ 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_zero.
rewrite Val.add_commut. unfold const_high.
@@ -1484,153 +1427,142 @@ Proof.
reflexivity. reflexivity.
assumption. assumption.
(* Abased *)
- assert (COMMON:
- forall (rs1: regset) r,
- r <> GPR0 ->
- ms t = rs1#r ->
- agree ms sp rs1 ->
- exists rs',
- exec_straight
- (Paddis GPR12 r (Csymbol_high i i0)
- :: mk1 (Csymbol_low i i0) GPR12 :: k) rs1 m k rs' m'
- /\ agree ms' sp rs').
- intros.
- set (rs2 := nextinstr (rs1#GPR12 <- (Val.add (ms t) (const_high ge (Csymbol_high i i0))))).
- assert (ADDR: eval_addressing_total ge sp (Abased i i0) ms##(t::nil) =
- Val.add (gpr_or_zero rs2 GPR12) (const_low ge (Csymbol_low i i0))).
- simpl. rewrite gpr_or_zero_not_zero; auto with ppcgen.
- unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss.
- unfold const_high.
- set (v := symbol_offset ge i i0).
+ 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.
rewrite Val.add_assoc.
- rewrite (Val.add_commut (high_half v)).
- unfold v. rewrite low_high_half. apply Val.add_commut.
- discriminate.
- assert (AG: agree ms sp rs2). unfold rs2; auto with ppcgen.
- destruct (H _ _ _ k ADDR AG) as [rs' [EX' AG']].
- exists rs'. split. apply exec_straight_step with rs2 m.
- unfold exec_instr. rewrite gpr_or_zero_not_zero; auto.
- rewrite <- H3. reflexivity. reflexivity.
- assumption. assumption.
- case (ireg_eq (ireg_of t) GPR0); intro.
- set (rs1 := nextinstr (rs#GPR12 <- (ms t))).
- assert (R1: GPR12 <> GPR0). discriminate.
- assert (R2: ms t = rs1 GPR12).
- unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss; auto.
- discriminate.
- assert (R3: agree ms sp rs1). unfold rs1; auto with ppcgen.
- generalize (COMMON rs1 GPR12 R1 R2 R3). intros [rs' [EX' AG']].
- exists rs'. split.
- apply exec_straight_step with rs1 m.
- unfold rs1. rewrite (ireg_val ms sp rs); auto. reflexivity.
+ unfold const_high, const_low.
+ set (v := symbol_offset ge i i0).
+ symmetry. rewrite Val.add_commut. decEq.
+ unfold v. rewrite Val.add_commut. apply low_high_half.
+ UseTypeInfo. auto. discriminate.
+ 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. auto.
assumption. assumption.
- apply COMMON; auto. eapply ireg_val; eauto.
(* 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#GPR12 <- (Val.add sp (Vint (Int.shl (high_s i) (Int.repr 16)))))).
- assert (ADDR: eval_addressing_total ge sp (Ainstack i) ms##nil =
- Val.add (gpr_or_zero rs1 GPR12) (const_low ge (Cint (low_s i)))).
- simpl. rewrite gpr_or_zero_not_zero; auto with ppcgen.
+ 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).
+ simpl. rewrite gpr_or_zero_not_zero; auto.
unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss.
- rewrite Val.add_assoc. decEq. simpl. rewrite low_high_s. auto.
- discriminate.
- assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen.
- destruct (H _ _ _ k ADDR AG) as [rs' [EX' AG']].
+ rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
+ congruence.
+ 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.
- simpl. rewrite gpr_or_zero_not_zero.
- unfold rs1. rewrite (sp_val ms sp rs). reflexivity.
- auto. discriminate. reflexivity. assumption. assumption.
+ unfold exec_instr. rewrite gpr_or_zero_not_zero; auto with ppcgen.
+ rewrite <- (sp_val ms sp rs); auto. auto.
+ assumption. assumption.
Qed.
(** Translation of memory loads. *)
Lemma transl_load_correct:
forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction)
- chunk addr args k ms sp rs m dst a v,
+ 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) ->
+ 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) ->
+ 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 ->
Mem.loadv chunk m a = Some v ->
+ Mem.extends m m' ->
exists rs',
- exec_straight (transl_load_store mk1 mk2 addr args k) rs m
- k rs' m
- /\ agree (Regmap.set dst v ms) sp 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'.
Proof.
- intros. apply transl_load_store_correct with ms.
- intros. exists (nextinstr (rs1#(preg_of dst) <- v)).
- split. apply exec_straight_one. rewrite H.
- unfold load1. rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4.
- rewrite H5 in H4. rewrite H4. auto.
- auto with ppcgen. auto with ppcgen.
- intros. exists (nextinstr (rs1#(preg_of dst) <- v)).
+ intros.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto.
+ intros [a' [A B]].
+ exploit Mem.loadv_extends; eauto. intros [v' [C D]].
+ exploit eval_addressing_weaken. eexact A. intro E. rewrite <- E in C.
+ apply transl_load_store_correct with ms; auto.
+(* mk1 *)
+ intros. exists (nextinstr (rs1#(preg_of dst) <- v')).
+ split. apply exec_straight_one. rewrite H.
+ unfold load1. rewrite <- H6. rewrite C. auto.
+ auto with ppcgen.
+ eauto with ppcgen.
+(* mk2 *)
+ intros. exists (nextinstr (rs#(preg_of dst) <- v')).
split. apply exec_straight_one. rewrite H0.
- unfold load2.
- rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4.
- rewrite H5 in H4. rewrite H4. auto.
- auto with ppcgen. auto with ppcgen.
- auto. auto.
+ unfold load2. rewrite <- H6. rewrite C. auto.
+ auto with ppcgen.
+ eauto with ppcgen.
+(* not GPR0 *)
+ congruence.
Qed.
(** Translation of memory 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',
- (forall cst (r1: ireg) (rs1: regset),
- exists rs2,
- exec_instr ge fn (mk1 cst r1) rs1 m =
- store1 ge chunk (preg_of src) cst r1 rs2 m
- /\ (forall (r: preg), r <> FPR13 -> rs2 r = rs1 r)) ->
- (forall (r1 r2: ireg) (rs1: regset),
- exists rs2,
- exec_instr ge fn (mk2 r1 r2) rs1 m =
- store2 chunk (preg_of src) r1 r2 rs2 m
- /\ (forall (r: preg), r <> FPR13 -> rs2 r = rs1 r)) ->
+ 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' ->
- exists rs',
- exec_straight (transl_load_store mk1 mk2 addr args k) rs m
- k rs' m'
- /\ agree ms sp rs'.
+ 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'.
Proof.
- intros. apply transl_load_store_correct with ms.
- intros. destruct (H cst r1 rs1) as [rs2 [A B]].
- exists (nextinstr rs2).
- split. apply exec_straight_one. rewrite A.
- unfold store1. rewrite B. replace (gpr_or_zero rs2 r1) with (gpr_or_zero rs1 r1).
- rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4.
- rewrite H5 in H4. elim H6; intros. rewrite H8 in H4.
- rewrite H4. auto.
- unfold gpr_or_zero. destruct (ireg_eq r1 GPR0); auto. symmetry. apply B. discriminate.
- apply preg_of_not. simpl. tauto.
- rewrite <- B. auto. discriminate.
- apply agree_nextinstr. eapply agree_exten_2; eauto.
-
- intros. destruct (H0 r1 r2 rs1) as [rs2 [A B]].
- exists (nextinstr rs2).
- split. apply exec_straight_one. rewrite A.
- unfold store2. repeat rewrite B.
- rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4.
- rewrite H5 in H4. elim H6; intros. rewrite H8 in H4.
- rewrite H4. auto.
- apply preg_of_not. simpl. tauto.
- discriminate. discriminate.
- rewrite <- B. auto. discriminate.
- apply agree_nextinstr. eapply agree_exten_2; eauto.
-
- auto. auto.
+ intros.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eauto.
+ intros [a' [A B]].
+ assert (Z: Val.lessdef (ms src) (rs (preg_of src))). eapply preg_val; eauto.
+ exploit Mem.storev_extends; eauto. intros [m1' [C D]].
+ exploit eval_addressing_weaken. eexact A. intro E. rewrite <- E in C.
+ exists m1'; split; auto.
+ apply transl_load_store_correct with ms; auto.
+(* mk1 *)
+ intros.
+ exploit (H cst r1 rs1 (nextinstr rs1) m1').
+ unfold store1. rewrite <- H6.
+ 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.
+ eapply agree_undef_temps; eauto. intros.
+ rewrite V; auto. rewrite nextinstr_inv; auto. apply H7; auto.
+ unfold int_temp_for. destruct (mreg_eq src IT2); auto.
+(* mk2 *)
+ intros.
+ exploit (H0 r1 r2 rs (nextinstr rs) m1').
+ unfold store2. rewrite <- 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. rewrite nextinstr_inv; auto.
+ unfold int_temp_for. destruct (mreg_eq src IT2); congruence.
Qed.
-
End STRAIGHTLINE.
diff --git a/powerpc/Asmgenretaddr.v b/powerpc/Asmgenretaddr.v
index d55635b..ae3c2bd 100644
--- a/powerpc/Asmgenretaddr.v
+++ b/powerpc/Asmgenretaddr.v
@@ -109,7 +109,7 @@ Hint Resolve loadimm_tail: ppcretaddr.
Lemma addimm_tail:
forall r1 r2 n k, is_tail k (addimm r1 r2 n k).
-Proof. unfold addimm, addimm_1, addimm_2; intros; IsTail. Qed.
+Proof. unfold addimm; intros; IsTail. Qed.
Hint Resolve addimm_tail: ppcretaddr.
Lemma andimm_tail:
@@ -129,12 +129,12 @@ Hint Resolve xorimm_tail: ppcretaddr.
Lemma loadind_tail:
forall base ofs ty dst k, is_tail k (loadind base ofs ty dst k).
-Proof. unfold loadind; intros; IsTail. Qed.
+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; IsTail. Qed.
+Proof. unfold storeind; intros. destruct ty; IsTail. Qed.
Hint Resolve storeind_tail: ppcretaddr.
Lemma floatcomp_tail:
@@ -156,8 +156,8 @@ Qed.
Hint Resolve transl_op_tail: ppcretaddr.
Lemma transl_load_store_tail:
- forall mk1 mk2 addr args k,
- is_tail k (transl_load_store mk1 mk2 addr args k).
+ 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.
diff --git a/powerpc/ConstpropOp.v b/powerpc/ConstpropOp.v
index ededce0..b6eecc7 100644
--- a/powerpc/ConstpropOp.v
+++ b/powerpc/ConstpropOp.v
@@ -182,9 +182,7 @@ Definition eval_static_operation (op: operation) (vl: list approx) :=
| Omulsubf, F n1 :: F n2 :: F n3 :: nil => F(Float.sub (Float.mul n1 n2) n3)
| Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1)
| Ointoffloat, F n1 :: nil => I(Float.intoffloat n1)
- | Ointuoffloat, F n1 :: nil => I(Float.intuoffloat n1)
- | Ofloatofint, I n1 :: nil => F(Float.floatofint n1)
- | Ofloatofintu, I n1 :: nil => F(Float.floatofintu n1)
+ | Ofloatofwords, I n1 :: I n2 :: nil => F(Float.from_words n1 n2)
| Ocmp c, vl =>
match eval_static_condition c vl with
| None => Unknown
@@ -322,11 +320,8 @@ Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx),
forall n1,
eval_static_operation_cases (Ointoffloat) (F n1 :: nil)
| eval_static_operation_case45:
- forall n1,
- eval_static_operation_cases (Ofloatofint) (I n1 :: nil)
- | eval_static_operation_case46:
- forall n1,
- eval_static_operation_cases (Ofloatofintu) (I n1 :: nil)
+ forall n1 n2,
+ eval_static_operation_cases (Ofloatofwords) (I n1 :: I n2 :: nil)
| eval_static_operation_case47:
forall c vl,
eval_static_operation_cases (Ocmp c) (vl)
@@ -336,9 +331,6 @@ Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx),
| eval_static_operation_case49:
forall n1,
eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil)
- | eval_static_operation_case50:
- forall n1,
- eval_static_operation_cases (Ointuoffloat) (F n1 :: nil)
| eval_static_operation_default:
forall (op: operation) (vl: list approx),
eval_static_operation_cases op vl.
@@ -429,18 +421,14 @@ Definition eval_static_operation_match (op: operation) (vl: list approx) :=
eval_static_operation_case43 n1
| Ointoffloat, F n1 :: nil =>
eval_static_operation_case44 n1
- | Ofloatofint, I n1 :: nil =>
- eval_static_operation_case45 n1
- | Ofloatofintu, I n1 :: nil =>
- eval_static_operation_case46 n1
+ | Ofloatofwords, I n1 :: I n2 :: nil =>
+ eval_static_operation_case45 n1 n2
| Ocmp c, vl =>
eval_static_operation_case47 c vl
| Ocast8unsigned, I n1 :: nil =>
eval_static_operation_case48 n1
| Ocast16unsigned, I n1 :: nil =>
eval_static_operation_case49 n1
- | Ointuoffloat, F n1 :: nil =>
- eval_static_operation_case50 n1
| op, vl =>
eval_static_operation_default op vl
end.
@@ -531,10 +519,8 @@ Definition eval_static_operation (op: operation) (vl: list approx) :=
F(Float.singleoffloat n1)
| eval_static_operation_case44 n1 =>
I(Float.intoffloat n1)
- | eval_static_operation_case45 n1 =>
- F(Float.floatofint n1)
- | eval_static_operation_case46 n1 =>
- F(Float.floatofintu n1)
+ | eval_static_operation_case45 n1 n2 =>
+ F(Float.from_words n1 n2)
| eval_static_operation_case47 c vl =>
match eval_static_condition c vl with
| None => Unknown
@@ -544,8 +530,6 @@ Definition eval_static_operation (op: operation) (vl: list approx) :=
I(Int.zero_ext 8 n1)
| eval_static_operation_case49 n1 =>
I(Int.zero_ext 16 n1)
- | eval_static_operation_case50 n1 =>
- I(Float.intuoffloat n1)
| eval_static_operation_default op vl =>
Unknown
end.
diff --git a/powerpc/Machregs.v b/powerpc/Machregs.v
index 88b70c1..632a55d 100644
--- a/powerpc/Machregs.v
+++ b/powerpc/Machregs.v
@@ -41,18 +41,19 @@ Inductive mreg: Type :=
(** Allocatable float regs *)
| F1: mreg | F2: mreg | F3: mreg | F4: mreg
| F5: mreg | F6: mreg | F7: mreg | F8: mreg
- | F9: mreg | F10: mreg | F14: mreg | F15: mreg
+ | F9: mreg | F10: mreg | F11: mreg
+ | F14: mreg | F15: mreg
| F16: mreg | F17: mreg | F18: mreg | F19: mreg
| F20: mreg | F21: mreg | F22: mreg | F23: mreg
| F24: mreg | F25: mreg | F26: mreg | F27: mreg
| F28: mreg | F29: mreg | F30: mreg | F31: mreg
(** Integer temporaries *)
- | IT1: mreg (* R11 *) | IT2: mreg (* R0 *)
+ | IT1: mreg (* R11 *) | IT2: mreg (* R12 *)
(** Float temporaries *)
- | FT1: mreg (* F11 *) | FT2: mreg (* F12 *) | FT3: mreg (* F0 *).
+ | FT1: mreg (* F0 *) | FT2: mreg (* F12 *) | FT3: mreg (* F13 *).
Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}.
-Proof. decide equality. Qed.
+Proof. decide equality. Defined.
Definition mreg_type (r: mreg): typ :=
match r with
@@ -65,7 +66,8 @@ Definition mreg_type (r: mreg): typ :=
| R29 => Tint | R30 => Tint | R31 => Tint
| F1 => Tfloat | F2 => Tfloat | F3 => Tfloat | F4 => Tfloat
| F5 => Tfloat | F6 => Tfloat | F7 => Tfloat | F8 => Tfloat
- | F9 => Tfloat | F10 => Tfloat | F14 => Tfloat | F15 => Tfloat
+ | F9 => Tfloat | F10 => Tfloat | F11 => Tfloat
+ | F14 => Tfloat | F15 => Tfloat
| F16 => Tfloat | F17 => Tfloat | F18 => Tfloat | F19 => Tfloat
| F20 => Tfloat | F21 => Tfloat | F22 => Tfloat | F23 => Tfloat
| F24 => Tfloat | F25 => Tfloat | F26 => Tfloat | F27 => Tfloat
@@ -90,13 +92,14 @@ Module IndexedMreg <: INDEXED_TYPE.
| R29 => 24 | R30 => 25 | R31 => 26
| F1 => 28 | F2 => 29 | F3 => 30 | F4 => 31
| F5 => 32 | F6 => 33 | F7 => 34 | F8 => 35
- | F9 => 36 | F10 => 37 | F14 => 38 | F15 => 39
- | F16 => 40 | F17 => 41 | F18 => 42 | F19 => 43
- | F20 => 44 | F21 => 45 | F22 => 46 | F23 => 47
- | F24 => 48 | F25 => 49 | F26 => 50 | F27 => 51
- | F28 => 52 | F29 => 53 | F30 => 54 | F31 => 55
- | IT1 => 56 | IT2 => 57
- | FT1 => 58 | FT2 => 59 | FT3 => 60
+ | F9 => 36 | F10 => 37 | F11 => 38
+ | F14 => 39 | F15 => 40
+ | F16 => 41 | F17 => 42 | F18 => 43 | F19 => 44
+ | F20 => 45 | F21 => 46 | F22 => 47 | F23 => 48
+ | F24 => 49 | F25 => 50 | F26 => 51 | F27 => 52
+ | F28 => 53 | F29 => 54 | F30 => 55 | F31 => 56
+ | IT1 => 57 | IT2 => 58
+ | FT1 => 59 | FT2 => 60 | FT3 => 61
end.
Lemma index_inj:
forall r1 r2, index r1 = index r2 -> r1 = r2.
diff --git a/powerpc/Machregsaux.ml b/powerpc/Machregsaux.ml
index 87800be..713e14d 100644
--- a/powerpc/Machregsaux.ml
+++ b/powerpc/Machregsaux.ml
@@ -24,13 +24,14 @@ let register_names = [
("R29", R29); ("R30", R30); ("R31", R31);
("F1", F1); ("F2", F2); ("F3", F3); ("F4", F4);
("F5", F5); ("F6", F6); ("F7", F7); ("F8", F8);
- ("F9", F9); ("F10", F10); ("F14", F14); ("F15", F15);
+ ("F9", F9); ("F10", F10); ("F11", F11);
+ ("F14", F14); ("F15", F15);
("F16", F16); ("F17", F17); ("F18", F18); ("F19", F19);
("F20", F20); ("F21", F21); ("F22", F22); ("F23", F23);
("F24", F24); ("F25", F25); ("F26", F26); ("F27", F27);
("F28", F28); ("F29", F29); ("F30", F30); ("F31", F31);
- ("R11", IT1); ("R0", IT2);
- ("F11", FT1); ("F12", FT2); ("F0", FT3)
+ ("R11", IT1); ("R12", IT2);
+ ("F0", FT1); ("F12", FT2); ("F13", FT3)
]
let name_of_register r =
diff --git a/powerpc/Op.v b/powerpc/Op.v
index 7a9aa50..902fc02 100644
--- a/powerpc/Op.v
+++ b/powerpc/Op.v
@@ -96,9 +96,7 @@ Inductive operation : Type :=
| Osingleoffloat: operation (**r [rd] is [r1] truncated to single-precision float *)
(*c Conversions between int and float: *)
| Ointoffloat: operation (**r [rd = signed_int_of_float(r1)] *)
- | Ointuoffloat: operation (**r [rd = unsigned_int_of_float(r1)] *)
- | Ofloatofint: operation (**r [rd = float_of_signed_int(r1)] *)
- | Ofloatofintu: operation (**r [rd = float_of_unsigned_int(r1)] *)
+ | Ofloatofwords: operation (**r [rd = float_of_words(r1,r2)] *)
(*c Boolean tests: *)
| Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
@@ -250,12 +248,8 @@ Definition eval_operation
Some (Val.singleoffloat v1)
| Ointoffloat, Vfloat f1 :: nil =>
Some (Vint (Float.intoffloat f1))
- | Ointuoffloat, Vfloat f1 :: nil =>
- Some (Vint (Float.intuoffloat f1))
- | Ofloatofint, Vint n1 :: nil =>
- Some (Vfloat (Float.floatofint n1))
- | Ofloatofintu, Vint n1 :: nil =>
- Some (Vfloat (Float.floatofintu n1))
+ | Ofloatofwords, Vint i1 :: Vint i2 :: nil =>
+ Some (Vfloat (Float.from_words i1 i2))
| Ocmp c, _ =>
match eval_condition c vl with
| None => None
@@ -466,9 +460,7 @@ Definition type_of_operation (op: operation) : list typ * typ :=
| Omulsubf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat)
| Osingleoffloat => (Tfloat :: nil, Tfloat)
| Ointoffloat => (Tfloat :: nil, Tint)
- | Ointuoffloat => (Tfloat :: nil, Tint)
- | Ofloatofint => (Tint :: nil, Tfloat)
- | Ofloatofintu => (Tint :: nil, Tfloat)
+ | Ofloatofwords => (Tint :: Tint :: nil, Tfloat)
| Ocmp c => (type_of_condition c, Tint)
end.
@@ -615,9 +607,7 @@ Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val :
| Omulsubf, v1::v2::v3::nil => Val.subf (Val.mulf v1 v2) v3
| Osingleoffloat, v1::nil => Val.singleoffloat v1
| Ointoffloat, v1::nil => Val.intoffloat v1
- | Ointuoffloat, v1::nil => Val.intuoffloat v1
- | Ofloatofint, v1::nil => Val.floatofint v1
- | Ofloatofintu, v1::nil => Val.floatofintu v1
+ | Ofloatofwords, v1::v2::nil => Val.floatofwords v1 v2
| Ocmp c, _ => eval_condition_total c vl
| _, _ => Vundef
end.
@@ -840,3 +830,73 @@ Lemma type_op_for_binary_addressing:
Proof.
intros. destruct addr; simpl in H; reflexivity || omegaContradiction.
Qed.
+
+(** Two-address operations. There are none in the PowerPC architecture. *)
+
+Definition two_address_op (op: operation) : bool := false.
+
+(** Operations that are so cheap to recompute that CSE should not factor them out. *)
+
+Definition is_trivial_op (op: operation) : bool :=
+ match op with
+ | Omove => true
+ | Ointconst _ => true
+ | Oaddrsymbol _ _ => true
+ | Oaddrstack _ => true
+ | _ => false
+ end.
+
+(** Shifting stack-relative references. This is used in [Stacking]. *)
+
+Definition shift_stack_addressing (delta: int) (addr: addressing) :=
+ match addr with
+ | Ainstack ofs => Ainstack (Int.add delta ofs)
+ | _ => addr
+ end.
+
+Definition shift_stack_operation (delta: int) (op: operation) :=
+ match op with
+ | Oaddrstack ofs => Oaddrstack (Int.add delta ofs)
+ | _ => op
+ end.
+
+Lemma shift_stack_eval_addressing:
+ forall (F V: Type) (ge: Genv.t F V) sp addr args delta,
+ eval_addressing ge (Val.sub sp (Vint delta)) (shift_stack_addressing delta addr) args =
+ eval_addressing ge sp addr args.
+Proof.
+ intros. destruct addr; simpl; auto.
+ destruct args; auto. unfold offset_sp. destruct sp; simpl; auto.
+ decEq. decEq. rewrite <- Int.add_assoc. decEq.
+ rewrite Int.sub_add_opp. rewrite Int.add_assoc.
+ rewrite (Int.add_commut (Int.neg delta)). rewrite <- Int.sub_add_opp.
+ rewrite Int.sub_idem. apply Int.add_zero.
+Qed.
+
+Lemma shift_stack_eval_operation:
+ forall (F V: Type) (ge: Genv.t F V) sp op args delta,
+ eval_operation ge (Val.sub sp (Vint delta)) (shift_stack_operation delta op) args =
+ eval_operation ge sp op args.
+Proof.
+ intros. destruct op; simpl; auto.
+ destruct args; auto. unfold offset_sp. destruct sp; simpl; auto.
+ decEq. decEq. rewrite <- Int.add_assoc. decEq.
+ rewrite Int.sub_add_opp. rewrite Int.add_assoc.
+ rewrite (Int.add_commut (Int.neg delta)). rewrite <- Int.sub_add_opp.
+ rewrite Int.sub_idem. apply Int.add_zero.
+Qed.
+
+Lemma type_shift_stack_addressing:
+ forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr.
+Proof.
+ intros. destruct addr; auto.
+Qed.
+
+Lemma type_shift_stack_operation:
+ forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op.
+Proof.
+ intros. destruct op; auto.
+Qed.
+
+
+
diff --git a/powerpc/PrintAsm.ml b/powerpc/PrintAsm.ml
index 9df9cc0..ef50795 100644
--- a/powerpc/PrintAsm.ml
+++ b/powerpc/PrintAsm.ml
@@ -263,14 +263,15 @@ let rec log2 n =
(* Built-ins. They come in two flavors:
- inlined by the compiler: take their arguments in arbitrary
- registers; preserve all registers except GPR12 and FPR13
+ registers; preserve all registers except the temporaries
+ (GPR0, GPR11, GPR12, FPR0, FPR12, FPR13);
- inlined while printing asm code; take their arguments in
locations dictated by the calling conventions; preserve
callee-save regs only. *)
let print_builtin_inlined oc name args res =
fprintf oc "%s begin builtin %s\n" comment name;
- (* Can use as temporaries: GPR12, FPR13 *)
+ (* Can use as temporaries: GPR0, GPR11, GPR12, FPR0, FPR12, FPR13 *)
begin match name, args, res with
(* Volatile reads *)
| "__builtin_volatile_read_int8unsigned", [IR addr], IR res ->
@@ -524,32 +525,18 @@ let print_instruction oc labels = function
fprintf oc " lwz %a, 4(%a)\n" ireg r1 ireg GPR1;
fprintf oc " addi %a, %a, 8\n" ireg GPR1 ireg GPR1;
fprintf oc "%s end pseudoinstr fcti\n" comment
- | Pfctiu(r1, r2) ->
- let lbl1 = new_label() in
- let lbl2 = new_label() in
- let lbl3 = new_label() in
- fprintf oc "%s begin pseudoinstr %a = fctiu(%a)\n" comment ireg r1 freg r2;
- fprintf oc " addis %a, 0, %a\n" ireg GPR12 label_high lbl1;
- fprintf oc " lfd %a, %a(%a)\n" freg FPR13 label_low lbl1 ireg GPR12;
- fprintf oc " fcmpu %a, %a, %a\n" creg 7 freg r2 freg FPR13;
- fprintf oc " cror 30, 29, 30\n";
- fprintf oc " beq %a, %a\n" creg 7 label lbl2;
- fprintf oc " fctiwz %a, %a\n" freg FPR13 freg r2;
- fprintf oc " stfdu %a, -8(%a)\n" freg FPR13 ireg GPR1;
- fprintf oc " lwz %a, 4(%a)\n" ireg r1 ireg GPR1;
- fprintf oc " b %a\n" label lbl3;
- fprintf oc "%a: fsub %a, %a, %a\n" label lbl2 freg FPR13 freg r2 freg FPR13;
- fprintf oc " fctiwz %a, %a\n" freg FPR13 freg FPR13;
- fprintf oc " stfdu %a, -8(%a)\n" freg FPR13 ireg GPR1;
- fprintf oc " lwz %a, 4(%a)\n" ireg r1 ireg GPR1;
- fprintf oc " addis %a, %a, 0x8000\n" ireg r1 ireg r1;
- fprintf oc "%a: addi %a, %a, 8\n" label lbl3 ireg GPR1 ireg GPR1;
- float_literals := (lbl1, 0x41e0_0000_0000_0000L) :: !float_literals;
- fprintf oc "%s end pseudoinstr fctiu\n" comment
| Pfdiv(r1, r2, r3) ->
fprintf oc " fdiv %a, %a, %a\n" freg r1 freg r2 freg r3
| Pfmadd(r1, r2, r3, r4) ->
fprintf oc " fmadd %a, %a, %a, %a\n" freg r1 freg r2 freg r3 freg r4
+ | Pfmake(rd, r1, r2) ->
+ fprintf oc "%s begin pseudoinstr %a = fmake(%a, %a)\n"
+ comment freg rd ireg r1 ireg r2;
+ fprintf oc " stwu %a, -8(%a)\n" ireg r1 ireg GPR1;
+ fprintf oc " stw %a, 4(%a)\n" ireg r2 ireg GPR1;
+ fprintf oc " lfd %a, 0(%a)\n" freg rd ireg GPR1;
+ fprintf oc " addi %a, %a, 8\n" ireg GPR1 ireg GPR1;
+ fprintf oc "%s end pseudoinstr fmake\n" comment
| Pfmr(r1, r2) ->
fprintf oc " fmr %a, %a\n" freg r1 freg r2
| Pfmsub(r1, r2, r3, r4) ->
@@ -562,33 +549,6 @@ let print_instruction oc labels = function
fprintf oc " frsp %a, %a\n" freg r1 freg r2
| Pfsub(r1, r2, r3) ->
fprintf oc " fsub %a, %a, %a\n" freg r1 freg r2 freg r3
- | Pictf(r1, r2) ->
- let lbl = new_label() in
- fprintf oc "%s begin pseudoinstr %a = ictf(%a)\n" comment freg r1 ireg r2;
- fprintf oc " addis %a, 0, 0x4330\n" ireg GPR12;
- fprintf oc " stwu %a, -8(%a)\n" ireg GPR12 ireg GPR1;
- fprintf oc " addis %a, %a, 0x8000\n" ireg GPR12 ireg r2;
- fprintf oc " stw %a, 4(%a)\n" ireg GPR12 ireg GPR1;
- fprintf oc " addis %a, 0, %a\n" ireg GPR12 label_high lbl;
- fprintf oc " lfd %a, %a(%a)\n" freg FPR13 label_low lbl ireg GPR12;
- fprintf oc " lfd %a, 0(%a)\n" freg r1 ireg GPR1;
- fprintf oc " addi %a, %a, 8\n" ireg GPR1 ireg GPR1;
- fprintf oc " fsub %a, %a, %a\n" freg r1 freg r1 freg FPR13;
- float_literals := (lbl, 0x4330_0000_8000_0000L) :: !float_literals;
- fprintf oc "%s end pseudoinstr ictf\n" comment
- | Piuctf(r1, r2) ->
- let lbl = new_label() in
- fprintf oc "%s begin pseudoinstr %a = iuctf(%a)\n" comment freg r1 ireg r2;
- fprintf oc " addis %a, 0, 0x4330\n" ireg GPR12;
- fprintf oc " stwu %a, -8(%a)\n" ireg GPR12 ireg GPR1;
- fprintf oc " stw %a, 4(%a)\n" ireg r2 ireg GPR1;
- fprintf oc " addis %a, 0, %a\n" ireg GPR12 label_high lbl;
- fprintf oc " lfd %a, %a(%a)\n" freg FPR13 label_low lbl ireg GPR12;
- fprintf oc " lfd %a, 0(%a)\n" freg r1 ireg GPR1;
- fprintf oc " addi %a, %a, 8\n" ireg GPR1 ireg GPR1;
- fprintf oc " fsub %a, %a, %a\n" freg r1 freg r1 freg FPR13;
- float_literals := (lbl, 0x4330_0000_0000_0000L) :: !float_literals;
- fprintf oc "%s end pseudoinstr ictf\n" comment
| Plbz(r1, c, r2) ->
fprintf oc " lbz %a, %a(%a)\n" ireg r1 constant c ireg r2
| Plbzx(r1, r2, r3) ->
diff --git a/powerpc/PrintOp.ml b/powerpc/PrintOp.ml
index 31de8d1..4eb95bf 100644
--- a/powerpc/PrintOp.ml
+++ b/powerpc/PrintOp.ml
@@ -92,9 +92,7 @@ let print_operation reg pp = function
| Omulsubf, [r1;r2;r3] -> fprintf pp "%a *f %a -f %a" reg r1 reg r2 reg r3
| Osingleoffloat, [r1] -> fprintf pp "singleoffloat(%a)" reg r1
| Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1
- | Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1
- | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1
- | Ofloatofintu, [r1] -> fprintf pp "floatofintu(%a)" reg r1
+ | Ofloatofwords, [r1;r2] -> fprintf pp "floatofwords(%a,%a)" reg r1 reg r2
| Ocmp c, args -> print_condition reg pp (c, args)
| _ -> fprintf pp "<bad operator>"
@@ -105,5 +103,3 @@ let print_addressing reg pp = function
| Abased(id, ofs), [r1] -> fprintf pp "%s + %ld + %a" (extern_atom id) (camlint_of_coqint ofs) reg r1
| Ainstack ofs, [] -> fprintf pp "stack(%ld)" (camlint_of_coqint ofs)
| _ -> fprintf pp "<bad addressing>"
-
-
diff --git a/powerpc/SelectOp.v b/powerpc/SelectOp.v
index e6a281b..c421cdc 100644
--- a/powerpc/SelectOp.v
+++ b/powerpc/SelectOp.v
@@ -50,6 +50,14 @@ Require Import CminorSel.
Open Local Scope cminorsel_scope.
+(** ** Constants **)
+
+Definition addrsymbol (id: ident) (ofs: int) :=
+ Eop (Oaddrsymbol id ofs) Enil.
+
+Definition addrstack (ofs: int) :=
+ Eop (Oaddrstack ofs) Enil.
+
(** ** Integer logical negation *)
(** The natural way to write smart constructors is by pattern-matching
@@ -846,148 +854,6 @@ Definition subf (e1: expr) (e2: expr) :=
end
else Eop Osubf (e1:::e2:::Enil).
-(** ** Truncations and sign extensions *)
-
-Inductive cast8signed_cases: forall (e1: expr), Type :=
- | cast8signed_case1:
- forall (e2: expr),
- cast8signed_cases (Eop Ocast8signed (e2 ::: Enil))
- | cast8signed_case2:
- forall mode args,
- cast8signed_cases (Eload Mint8signed mode args)
- | cast8signed_default:
- forall (e1: expr),
- cast8signed_cases e1.
-
-Definition cast8signed_match (e1: expr) :=
- match e1 as z1 return cast8signed_cases z1 with
- | Eop Ocast8signed (e2 ::: Enil) =>
- cast8signed_case1 e2
- | Eload Mint8signed mode args =>
- cast8signed_case2 mode args
- | e1 =>
- cast8signed_default e1
- end.
-
-Definition cast8signed (e: expr) :=
- match cast8signed_match e with
- | cast8signed_case1 e1 => e
- | cast8signed_case2 mode args => e
- | cast8signed_default e1 => Eop Ocast8signed (e1 ::: Enil)
- end.
-
-Inductive cast8unsigned_cases: forall (e1: expr), Type :=
- | cast8unsigned_case1:
- forall (e2: expr),
- cast8unsigned_cases (Eop Ocast8unsigned (e2 ::: Enil))
- | cast8unsigned_case2:
- forall mode args,
- cast8unsigned_cases (Eload Mint8unsigned mode args)
- | cast8unsigned_default:
- forall (e1: expr),
- cast8unsigned_cases e1.
-
-Definition cast8unsigned_match (e1: expr) :=
- match e1 as z1 return cast8unsigned_cases z1 with
- | Eop Ocast8unsigned (e2 ::: Enil) =>
- cast8unsigned_case1 e2
- | Eload Mint8unsigned mode args =>
- cast8unsigned_case2 mode args
- | e1 =>
- cast8unsigned_default e1
- end.
-
-Definition cast8unsigned (e: expr) :=
- match cast8unsigned_match e with
- | cast8unsigned_case1 e1 => e
- | cast8unsigned_case2 mode args => e
- | cast8unsigned_default e1 => Eop Ocast8unsigned (e1 ::: Enil)
- end.
-
-Inductive cast16signed_cases: forall (e1: expr), Type :=
- | cast16signed_case1:
- forall (e2: expr),
- cast16signed_cases (Eop Ocast16signed (e2 ::: Enil))
- | cast16signed_case2:
- forall mode args,
- cast16signed_cases (Eload Mint16signed mode args)
- | cast16signed_default:
- forall (e1: expr),
- cast16signed_cases e1.
-
-Definition cast16signed_match (e1: expr) :=
- match e1 as z1 return cast16signed_cases z1 with
- | Eop Ocast16signed (e2 ::: Enil) =>
- cast16signed_case1 e2
- | Eload Mint16signed mode args =>
- cast16signed_case2 mode args
- | e1 =>
- cast16signed_default e1
- end.
-
-Definition cast16signed (e: expr) :=
- match cast16signed_match e with
- | cast16signed_case1 e1 => e
- | cast16signed_case2 mode args => e
- | cast16signed_default e1 => Eop Ocast16signed (e1 ::: Enil)
- end.
-
-Inductive cast16unsigned_cases: forall (e1: expr), Type :=
- | cast16unsigned_case1:
- forall (e2: expr),
- cast16unsigned_cases (Eop Ocast16unsigned (e2 ::: Enil))
- | cast16unsigned_case2:
- forall mode args,
- cast16unsigned_cases (Eload Mint16unsigned mode args)
- | cast16unsigned_default:
- forall (e1: expr),
- cast16unsigned_cases e1.
-
-Definition cast16unsigned_match (e1: expr) :=
- match e1 as z1 return cast16unsigned_cases z1 with
- | Eop Ocast16unsigned (e2 ::: Enil) =>
- cast16unsigned_case1 e2
- | Eload Mint16unsigned mode args =>
- cast16unsigned_case2 mode args
- | e1 =>
- cast16unsigned_default e1
- end.
-
-Definition cast16unsigned (e: expr) :=
- match cast16unsigned_match e with
- | cast16unsigned_case1 e1 => e
- | cast16unsigned_case2 mode args => e
- | cast16unsigned_default e1 => Eop Ocast16unsigned (e1 ::: Enil)
- end.
-
-Inductive singleoffloat_cases: forall (e1: expr), Type :=
- | singleoffloat_case1:
- forall (e2: expr),
- singleoffloat_cases (Eop Osingleoffloat (e2 ::: Enil))
- | singleoffloat_case2:
- forall mode args,
- singleoffloat_cases (Eload Mfloat32 mode args)
- | singleoffloat_default:
- forall (e1: expr),
- singleoffloat_cases e1.
-
-Definition singleoffloat_match (e1: expr) :=
- match e1 as z1 return singleoffloat_cases z1 with
- | Eop Osingleoffloat (e2 ::: Enil) =>
- singleoffloat_case1 e2
- | Eload Mfloat32 mode args =>
- singleoffloat_case2 mode args
- | e1 =>
- singleoffloat_default e1
- end.
-
-Definition singleoffloat (e: expr) :=
- match singleoffloat_match e with
- | singleoffloat_case1 e1 => e
- | singleoffloat_case2 mode args => e
- | singleoffloat_default e1 => Eop Osingleoffloat (e1 ::: Enil)
- end.
-
(** ** Comparisons *)
Inductive comp_cases: forall (e1: expr) (e2: expr), Type :=
@@ -1034,15 +900,36 @@ Definition compu (c: comparison) (e1: expr) (e2: expr) :=
Definition compf (c: comparison) (e1: expr) (e2: expr) :=
Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil).
+(** ** Floating-point conversions *)
+
+Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil).
+
+Definition intuoffloat (e: expr) :=
+ let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in
+ Elet e
+ (Econdition (CEcond (Ccompf Clt) (Eletvar O ::: f ::: Enil))
+ (intoffloat (Eletvar O))
+ (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar O) f)))).
+
+Definition floatofintu (e: expr) :=
+ subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: e ::: Enil))
+ (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Int.zero)) Enil).
+
+Definition floatofint (e: expr) :=
+ subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil
+ ::: addimm Float.ox8000_0000 e ::: Enil))
+ (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Float.ox8000_0000)) Enil).
+
(** ** Other operators, not optimized. *)
+Definition cast8unsigned (e: expr) := Eop Ocast8unsigned (e ::: Enil).
+Definition cast8signed (e: expr) := Eop Ocast8signed (e ::: Enil).
+Definition cast16unsigned (e: expr) := Eop Ocast16unsigned (e ::: Enil).
+Definition cast16signed (e: expr) := Eop Ocast16signed (e ::: Enil).
+Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil).
Definition negint (e: expr) := Eop (Osubimm Int.zero) (e ::: Enil).
Definition negf (e: expr) := Eop Onegf (e ::: Enil).
Definition absf (e: expr) := Eop Oabsf (e ::: Enil).
-Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil).
-Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil).
-Definition floatofint (e: expr) := Eop Ofloatofint (e ::: Enil).
-Definition floatofintu (e: expr) := Eop Ofloatofintu (e ::: Enil).
Definition xor (e1 e2: expr) := Eop Oxor (e1 ::: e2 ::: Enil).
Definition shr (e1 e2: expr) := Eop Oshr (e1 ::: e2 ::: Enil).
Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil).
diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v
index 2fc1327..8a06433 100644
--- a/powerpc/SelectOpproof.v
+++ b/powerpc/SelectOpproof.v
@@ -100,6 +100,24 @@ Ltac InvEval := InvEval1; InvEval2; InvEval2.
by the smart constructor.
*)
+Theorem eval_addrsymbol:
+ forall le id ofs b,
+ Genv.find_symbol ge id = Some b ->
+ eval_expr ge sp e m le (addrsymbol id ofs) (Vptr b ofs).
+Proof.
+ intros. unfold addrsymbol. econstructor. constructor.
+ simpl. rewrite H. auto.
+Qed.
+
+Theorem eval_addrstack:
+ forall le ofs b n,
+ sp = Vptr b n ->
+ eval_expr ge sp e m le (addrstack ofs) (Vptr b (Int.add n ofs)).
+Proof.
+ intros. unfold addrstack. econstructor. constructor.
+ simpl. unfold offset_sp. rewrite H. auto.
+Qed.
+
Theorem eval_notint:
forall le a x,
eval_expr ge sp e m le a (Vint x) ->
@@ -667,80 +685,35 @@ Proof.
intros. EvalOp.
Qed.
-Lemma loadv_cast:
- forall chunk addr v,
- Mem.loadv chunk m addr = Some v ->
- match chunk with
- | Mint8signed => v = Val.sign_ext 8 v
- | Mint8unsigned => v = Val.zero_ext 8 v
- | Mint16signed => v = Val.sign_ext 16 v
- | Mint16unsigned => v = Val.zero_ext 16 v
- | Mfloat32 => v = Val.singleoffloat v
- | _ => True
- end.
-Proof.
- intros. destruct addr; simpl in H; try discriminate.
- eapply Mem.load_cast. eauto.
-Qed.
-
Theorem eval_cast8signed:
forall le a v,
eval_expr ge sp e m le a v ->
eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v).
-Proof.
- intros until v; unfold cast8signed; case (cast8signed_match a); intros; InvEval.
- EvalOp. simpl. subst v. destruct v1; simpl; auto.
- rewrite Int.sign_ext_idem. reflexivity. compute; auto.
- inv H. econstructor; eauto. rewrite H7. decEq. apply (loadv_cast _ _ _ H7).
- EvalOp.
-Qed.
+Proof. TrivialOp cast8signed. Qed.
Theorem eval_cast8unsigned:
forall le a v,
eval_expr ge sp e m le a v ->
eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v).
-Proof.
- intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros; InvEval.
- EvalOp. simpl. subst v. destruct v1; simpl; auto.
- rewrite Int.zero_ext_idem. reflexivity. compute; auto.
- inv H. econstructor; eauto. rewrite H7. decEq. apply (loadv_cast _ _ _ H7).
- EvalOp.
-Qed.
+Proof. TrivialOp cast8unsigned. Qed.
Theorem eval_cast16signed:
forall le a v,
eval_expr ge sp e m le a v ->
eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v).
-Proof.
- intros until v; unfold cast16signed; case (cast16signed_match a); intros; InvEval.
- EvalOp. simpl. subst v. destruct v1; simpl; auto.
- rewrite Int.sign_ext_idem. reflexivity. compute; auto.
- inv H. econstructor; eauto. rewrite H7. decEq. apply (loadv_cast _ _ _ H7).
- EvalOp.
-Qed.
+Proof. TrivialOp cast16signed. Qed.
Theorem eval_cast16unsigned:
forall le a v,
eval_expr ge sp e m le a v ->
eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v).
-Proof.
- intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros; InvEval.
- EvalOp. simpl. subst v. destruct v1; simpl; auto.
- rewrite Int.zero_ext_idem. reflexivity. compute; auto.
- inv H. econstructor; eauto. rewrite H7. decEq. apply (loadv_cast _ _ _ H7).
- EvalOp.
-Qed.
+Proof. TrivialOp cast16unsigned. Qed.
Theorem eval_singleoffloat:
forall le a v,
eval_expr ge sp e m le a v ->
eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v).
-Proof.
- intros until v; unfold singleoffloat; case (singleoffloat_match a); intros; InvEval.
- EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity.
- inv H. econstructor; eauto. rewrite H7. decEq. apply (loadv_cast _ _ _ H7).
- EvalOp.
-Qed.
+Proof. TrivialOp singleoffloat. Qed.
Theorem eval_comp_int:
forall le c a x b y,
@@ -883,19 +856,46 @@ Theorem eval_intuoffloat:
forall le a x,
eval_expr ge sp e m le a (Vfloat x) ->
eval_expr ge sp e m le (intuoffloat a) (Vint (Float.intuoffloat x)).
-Proof. intros; unfold intuoffloat; EvalOp. Qed.
+Proof.
+ intros. unfold intuoffloat.
+ econstructor. eauto.
+ set (fm := Float.floatofintu Float.ox8000_0000).
+ assert (eval_expr ge sp e m (Vfloat x :: le) (Eletvar O) (Vfloat x)). constructor. auto.
+ apply eval_Econdition with (v1 := Float.cmp Clt x fm).
+ econstructor. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
+ simpl. auto.
+ caseEq (Float.cmp Clt x fm); intros.
+ rewrite Float.intuoffloat_intoffloat_1; auto.
+ EvalOp.
+ rewrite Float.intuoffloat_intoffloat_2; auto.
+ apply eval_addimm. apply eval_intoffloat. apply eval_subf; auto. EvalOp.
+Qed.
Theorem eval_floatofint:
forall le a x,
eval_expr ge sp e m le a (Vint x) ->
eval_expr ge sp e m le (floatofint a) (Vfloat (Float.floatofint x)).
-Proof. intros; unfold floatofint; EvalOp. Qed.
+Proof.
+ intros. unfold floatofint. rewrite Float.floatofint_from_words.
+ apply eval_subf.
+ EvalOp. constructor. EvalOp. simpl; eauto.
+ constructor. apply eval_addimm. eauto. constructor.
+ simpl. auto.
+ EvalOp.
+Qed.
Theorem eval_floatofintu:
forall le a x,
eval_expr ge sp e m le a (Vint x) ->
eval_expr ge sp e m le (floatofintu a) (Vfloat (Float.floatofintu x)).
-Proof. intros; unfold floatofintu; EvalOp. Qed.
+Proof.
+ intros. unfold floatofintu. rewrite Float.floatofintu_from_words.
+ apply eval_subf.
+ EvalOp. constructor. EvalOp. simpl; eauto.
+ constructor. eauto. constructor.
+ simpl. auto.
+ EvalOp.
+Qed.
Theorem eval_xor:
forall le a x b y,
diff --git a/powerpc/eabi/Conventions1.v b/powerpc/eabi/Conventions1.v
index 60eaaa5..b25f2a5 100644
--- a/powerpc/eabi/Conventions1.v
+++ b/powerpc/eabi/Conventions1.v
@@ -35,7 +35,7 @@ Definition int_caller_save_regs :=
R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil.
Definition float_caller_save_regs :=
- F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil.
+ F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: F11 :: nil.
Definition int_callee_save_regs :=
R31 :: R30 :: R29 :: R28 :: R27 :: R26 :: R25 :: R24 :: R23 ::
@@ -58,6 +58,9 @@ Definition float_temporaries := FT1 :: FT2 :: FT3 :: nil.
Definition temporaries :=
R IT1 :: R IT2 :: R FT1 :: R FT2 :: R FT3 :: nil.
+Definition dummy_int_reg := R3. (**r Used in [Coloring]. *)
+Definition dummy_float_reg := F1. (**r Used in [Coloring]. *)
+
(** The [index_int_callee_save] and [index_float_callee_save] associate
a unique positive integer to callee-save registers. This integer is
used in [Stacking] to determine where to save these registers in
diff --git a/powerpc/macosx/Conventions1.v b/powerpc/macosx/Conventions1.v
index a5741e1..2a0f233 100644
--- a/powerpc/macosx/Conventions1.v
+++ b/powerpc/macosx/Conventions1.v
@@ -35,7 +35,7 @@ Definition int_caller_save_regs :=
R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil.
Definition float_caller_save_regs :=
- F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil.
+ F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: F11 :: nil.
Definition int_callee_save_regs :=
R14 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 ::
@@ -58,6 +58,9 @@ Definition float_temporaries := FT1 :: FT2 :: FT3 :: nil.
Definition temporaries :=
R IT1 :: R IT2 :: R FT1 :: R FT2 :: R FT3 :: nil.
+Definition dummy_int_reg := R3. (**r Used in [Coloring]. *)
+Definition dummy_float_reg := F1. (**r Used in [Coloring]. *)
+
(** The [index_int_callee_save] and [index_float_callee_save] associate
a unique positive integer to callee-save registers. This integer is
used in [Stacking] to determine where to save these registers in
@@ -291,7 +294,7 @@ Qed.
(** The PowerPC ABI states the following convention for passing arguments
to a function:
- The first 8 integer arguments are passed in registers [R3] to [R10].
-- The first 10 float arguments are passed in registers [F1] to [F10].
+- The first 11 float arguments are passed in registers [F1] to [F11].
- Each float argument passed in a float register ``consumes'' two
integer arguments.
- Extra arguments are passed on the stack, in [Outgoing] slots, consecutively
@@ -327,7 +330,7 @@ Fixpoint loc_arguments_rec
Definition int_param_regs :=
R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil.
Definition float_param_regs :=
- F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil.
+ F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: F11 :: nil.
(** [loc_arguments s] returns the list of locations where to store arguments
when calling a function with signature [s]. *)
@@ -589,4 +592,3 @@ Proof.
intro; simpl. ElimOrEq; reflexivity.
intro; simpl. ElimOrEq; reflexivity.
Qed.
-
diff --git a/test/c/Makefile b/test/c/Makefile
index b4fd1fd..7b6d63c 100644
--- a/test/c/Makefile
+++ b/test/c/Makefile
@@ -1,7 +1,7 @@
include ../../Makefile.config
CCOMP=../../ccomp
-CCOMPFLAGS=-stdlib ../../runtime -fmadd -dcmedium -dclight -dasm
+CCOMPFLAGS=-stdlib ../../runtime -fmadd -dc -dclight -dasm
CFLAGS=-O1 -Wall
@@ -58,4 +58,4 @@ time_compcert:
clean:
rm -f *.compcert *.gcc
- rm -f *.light.c *.medium.c *.s *.o *~
+ rm -f *.light.c *.compcert.c *.s *.o *~
diff --git a/test/raytracer/Makefile b/test/raytracer/Makefile
index dea57af..8ba9ede 100644
--- a/test/raytracer/Makefile
+++ b/test/raytracer/Makefile
@@ -1,6 +1,8 @@
+include ../../Makefile.config
+
CC=../../ccomp
CFLAGS=-stdlib ../../runtime -dparse -dclight -dasm -fstruct-passing -fstruct-assign
-LIBS=
+LIBS=$(LIBMATH)
TIME=xtime -mintime 2.0
OBJS=memory.o gmllexer.o gmlparser.o eval.o \
diff --git a/test/regression/Makefile b/test/regression/Makefile
index 55b07f5..7d456df 100644
--- a/test/regression/Makefile
+++ b/test/regression/Makefile
@@ -1,12 +1,13 @@
include ../../Makefile.config
CCOMP=../../ccomp
-CCOMPFLAGS=-stdlib ../../runtime -dparse -dcmedium -dclight -dasm \
+CCOMPFLAGS=-stdlib ../../runtime -dparse -dc -dclight -dasm \
-fstruct-passing -fstruct-assign -fbitfields
LIBS=$(LIBMATH)
# Can run and have reference output in Results
+
TESTS=bitfields1 bitfields2 bitfields3 bitfields4 \
bitfields5 bitfields6 \
expr1 initializers volatile2 \
@@ -32,7 +33,7 @@ all: $(TESTS:%=%.compcert) $(EXTRAS:%=%.s)
clean:
rm -f *.compcert
- rm -f *.parsed.c *.light.c *.s *.o *~
+ rm -f *.parsed.c *.compcert.c *.light.c *.s *.o *~
test:
@for i in $(TESTS); do \
diff --git a/test/regression/Results/casts3 b/test/regression/Results/casts3
new file mode 100644
index 0000000..78ee28a
--- /dev/null
+++ b/test/regression/Results/casts3
@@ -0,0 +1 @@
+........................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................
diff --git a/test/regression/Results/expr1 b/test/regression/Results/expr1
index dc49203..f5a6864 100644
--- a/test/regression/Results/expr1
+++ b/test/regression/Results/expr1
@@ -1 +1 @@
-Result: 0x0
+Result: 0
diff --git a/test/regression/casts3.c b/test/regression/casts3.c
new file mode 100644
index 0000000..f6e35c2
--- /dev/null
+++ b/test/regression/casts3.c
@@ -0,0 +1,60 @@
+/* Testing int <-> float conversions */
+
+#include <stdio.h>
+
+unsigned int urand(void)
+{
+ static unsigned int seed = 0;
+ seed = seed * 25173 + 8453;
+ return seed;
+}
+
+signed int srand(void)
+{
+ return (signed int) urand();
+}
+
+double fuzzing[] = { 0.0, 0.01, 0.25, 0.4, 0.5, 0.6, 0.75, 0.99 };
+
+double fuzz(void)
+{
+ static unsigned int n = 0;
+ n = n + 1;
+ if (n >= sizeof(fuzzing) / sizeof(double)) n = 0;
+ return fuzzing[n];
+}
+
+void test_signed_conv(void)
+{
+ int n = srand();
+ double f = fuzz();
+ double d = (double) n;
+ double e = n < 0 ? d - f : d + f;
+ int m = (int) e;
+ if (m != n)
+ printf("\nError: signed: %d, %g, %g, %d\n", n, f, e, m);
+}
+
+void test_unsigned_conv(void)
+{
+ unsigned int n = srand();
+ double f = fuzz();
+ double d = (double) n;
+ double e = f + d;
+ unsigned int m = (unsigned int) e;
+ if (m != n)
+ printf("\nError: unsigned: %u, %g, %g, %u\n", n, f, e, m);
+}
+
+int main()
+{
+ int i;
+ for (i = 0; i < 1000000; i++) {
+ if ((i % 1000) == 0) { printf("."); fflush(stdout); }
+ test_signed_conv();
+ test_unsigned_conv();
+ }
+ printf("\n");
+ return 0;
+}
+
diff --git a/test/regression/expr1.c b/test/regression/expr1.c
index 0cc7b54..132ce44 100644
--- a/test/regression/expr1.c
+++ b/test/regression/expr1.c
@@ -12,6 +12,6 @@ int main(int argc, char ** argv)
struct list l;
l.tl = &l;
f(&(l.tl));
- printf("Result: %p\n", l.tl);
+ printf("Result: %d\n", (int) l.tl);
return 0;
}
diff --git a/test/spass/Makefile b/test/spass/Makefile
index b964770..30832f8 100644
--- a/test/spass/Makefile
+++ b/test/spass/Makefile
@@ -1,3 +1,5 @@
+include ../../Makefile.config
+
CC=../../ccomp
CFLAGS=-stdlib ../../runtime -dparse -dclight -dasm -fstruct-passing -fstruct-assign
@@ -13,7 +15,7 @@ SRCS=analyze.c clause.c clock.c closure.c cnf.c component.c \
all: spass
spass: $(SRCS:.c=.o)
- $(CC) $(CFLAGS) -o spass $(SRCS:.c=.o)
+ $(CC) $(CFLAGS) -o spass $(SRCS:.c=.o) $(LIBMATH)
clean:
rm -f spass
diff --git a/test/spass/dfgparser.c b/test/spass/dfgparser.c
index 3691271..b2bfa5d 100644
--- a/test/spass/dfgparser.c
+++ b/test/spass/dfgparser.c
@@ -359,20 +359,6 @@ typedef struct yyltype
/* The parser invokes alloca or malloc; define the necessary symbols. */
-# if YYSTACK_USE_ALLOCA
-# define YYSTACK_ALLOC alloca
-# else
-# ifndef YYSTACK_USE_ALLOCA
-# if defined (alloca) || defined (_ALLOCA_H)
-# define YYSTACK_ALLOC alloca
-# else
-# ifdef __GNUC__
-# define YYSTACK_ALLOC __builtin_alloca
-# endif
-# endif
-# endif
-# endif
-
# ifdef YYSTACK_ALLOC
/* Pacify GCC's `empty if-body' warning. */
# define YYSTACK_FREE(Ptr) do { /* empty */; } while (0)
diff --git a/test/spass/iaparser.c b/test/spass/iaparser.c
index 4fa8697..96274df 100644
--- a/test/spass/iaparser.c
+++ b/test/spass/iaparser.c
@@ -210,20 +210,6 @@ typedef struct yyltype
/* The parser invokes alloca or malloc; define the necessary symbols. */
-# if YYSTACK_USE_ALLOCA
-# define YYSTACK_ALLOC alloca
-# else
-# ifndef YYSTACK_USE_ALLOCA
-# if defined (alloca) || defined (_ALLOCA_H)
-# define YYSTACK_ALLOC alloca
-# else
-# ifdef __GNUC__
-# define YYSTACK_ALLOC __builtin_alloca
-# endif
-# endif
-# endif
-# endif
-
# ifdef YYSTACK_ALLOC
/* Pacify GCC's `empty if-body' warning. */
# define YYSTACK_FREE(Ptr) do { /* empty */; } while (0)