diff options
| author |  xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e> | 2010-09-02 12:42:19 +0000 |
|---|---|---|
| committer | xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e> | 2010-09-02 12:42:19 +0000 |
| commit | 265fa07b34a813ba9d8249ddad82d71e6002c10d (patch) | |
| tree | 45831b1793c7920b10969fc7cf6316c202d78e91 | |
| parent | 94470fb6a652cb993982269fcb7a0e8319b54488 (diff) | |
Merge of the reuse-temps branch:
- Reload temporaries are marked as destroyed (set to Vundef) across
operations in the semantics of LTL, LTLin, Linear and Mach,
allowing Asmgen to reuse them.
- Added IA32 port.
- Cleaned up float conversions and axiomatization of floats.
git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1499 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e
89 files changed, 12842 insertions, 2579 deletions
@@ -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 @@ -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 @@ -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) @@ -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) |