From 9bd7dcfb9918930c7cbeadf03c455ed0a0d43259 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Tue, 2 Mar 2021 14:37:20 +0100 Subject: Asmcondexp branche useful to benchmark expansions --- riscV/Asmgen.v | 247 ++++++++++++++++ riscV/Asmgenproof.v | 164 +++++++++-- riscV/Asmgenproof1.v | 773 +++++++++++++++++++++++++++++++++++++++++++++------ 3 files changed, 1088 insertions(+), 96 deletions(-) (limited to 'riscV') diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index 957166b6..4f9d008b 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -105,6 +105,8 @@ Definition addimm32 := opimm32 Paddw Paddiw. Definition andimm32 := opimm32 Pandw Pandiw. Definition orimm32 := opimm32 Porw Poriw. Definition xorimm32 := opimm32 Pxorw Pxoriw. +Definition sltimm32 := opimm32 Psltw Psltiw. +Definition sltuimm32 := opimm32 Psltuw Psltiuw. Definition load_hilo64 (r: ireg) (hi lo: int64) k := if Int64.eq lo Int64.zero then Pluil r hi :: k @@ -130,6 +132,8 @@ Definition addimm64 := opimm64 Paddl Paddil. Definition andimm64 := opimm64 Pandl Pandil. Definition orimm64 := opimm64 Porl Poril. Definition xorimm64 := opimm64 Pxorl Pxoril. +Definition sltimm64 := opimm64 Psltl Psltil. +Definition sltuimm64 := opimm64 Psltul Psltiul. Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := if Ptrofs.eq_dec n Ptrofs.zero then @@ -141,6 +145,66 @@ Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := (** Translation of conditional branches. *) +Definition transl_cbranch_int32s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeqw r1 r2 lbl + | Cne => Pbnew r1 r2 lbl + | Clt => Pbltw r1 r2 lbl + | Cle => Pbgew r2 r1 lbl + | Cgt => Pbltw r2 r1 lbl + | Cge => Pbgew r1 r2 lbl + end. + +Definition transl_cbranch_int32u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeqw r1 r2 lbl + | Cne => Pbnew r1 r2 lbl + | Clt => Pbltuw r1 r2 lbl + | Cle => Pbgeuw r2 r1 lbl + | Cgt => Pbltuw r2 r1 lbl + | Cge => Pbgeuw r1 r2 lbl + end. + +Definition transl_cbranch_int64s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeql r1 r2 lbl + | Cne => Pbnel r1 r2 lbl + | Clt => Pbltl r1 r2 lbl + | Cle => Pbgel r2 r1 lbl + | Cgt => Pbltl r2 r1 lbl + | Cge => Pbgel r1 r2 lbl + end. + +Definition transl_cbranch_int64u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeql r1 r2 lbl + | Cne => Pbnel r1 r2 lbl + | Clt => Pbltul r1 r2 lbl + | Cle => Pbgeul r2 r1 lbl + | Cgt => Pbltul r2 r1 lbl + | Cge => Pbgeul r1 r2 lbl + end. + +Definition transl_cond_float (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := + match cmp with + | Ceq => (Pfeqd rd fs1 fs2, true) + | Cne => (Pfeqd rd fs1 fs2, false) + | Clt => (Pfltd rd fs1 fs2, true) + | Cle => (Pfled rd fs1 fs2, true) + | Cgt => (Pfltd rd fs2 fs1, true) + | Cge => (Pfled rd fs2 fs1, true) + end. + +Definition transl_cond_single (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := + match cmp with + | Ceq => (Pfeqs rd fs1 fs2, true) + | Cne => (Pfeqs rd fs1 fs2, false) + | Clt => (Pflts rd fs1 fs2, true) + | Cle => (Pfles rd fs1 fs2, true) + | Cgt => (Pflts rd fs2 fs1, true) + | Cge => (Pfles rd fs2 fs1, true) + end. + Definition apply_bin_r0_r0r0lbl (optR0: option bool) (sem: ireg0 -> ireg0 -> label -> instruction) (r1 r2: ireg0) (lbl: label) := match optR0 with | None => sem r1 r2 lbl @@ -158,6 +222,59 @@ Definition apply_bin_r0_r0r0 (optR0: option bool) (sem: ireg0 -> ireg0 -> instru Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) := match cond, args with + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cbranch_int32s c r1 r2 lbl :: k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cbranch_int32u c r1 r2 lbl :: k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int.eq n Int.zero then + transl_cbranch_int32s c r1 X0 lbl :: k + else + loadimm32 X31 n (transl_cbranch_int32s c r1 X31 lbl :: k)) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int.eq n Int.zero then + transl_cbranch_int32u c r1 X0 lbl :: k + else + loadimm32 X31 n (transl_cbranch_int32u c r1 X31 lbl :: k)) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cbranch_int64s c r1 r2 lbl :: k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cbranch_int64u c r1 r2 lbl :: k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int64.eq n Int64.zero then + transl_cbranch_int64s c r1 X0 lbl :: k + else + loadimm64 X31 n (transl_cbranch_int64s c r1 X31 lbl :: k)) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int64.eq n Int64.zero then + transl_cbranch_int64u c r1 X0 lbl :: k + else + loadimm64 X31 n (transl_cbranch_int64u c r1 X31 lbl :: k)) + | Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c X31 r1 r2 in + OK (insn :: (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c X31 r1 r2 in + OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c X31 r1 r2 in + OK (insn :: (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c X31 r1 r2 in + OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) + | CEbeqw optR0, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (apply_bin_r0_r0r0lbl optR0 Pbeqw r1 r2 lbl :: k) @@ -210,6 +327,133 @@ Definition transl_cbranch Error(msg "Asmgen.transl_cond_branch") end. +(** Translation of a condition operator. The generated code sets the + [rd] target register to 0 or 1 depending on the truth value of the + condition. *) + +Definition transl_cond_int32s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseqw rd r1 r2 :: k + | Cne => Psnew rd r1 r2 :: k + | Clt => Psltw rd r1 r2 :: k + | Cle => Psltw rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltw rd r2 r1 :: k + | Cge => Psltw rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_cond_int32u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseqw rd r1 r2 :: k + | Cne => Psnew rd r1 r2 :: k + | Clt => Psltuw rd r1 r2 :: k + | Cle => Psltuw rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltuw rd r2 r1 :: k + | Cge => Psltuw rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_cond_int64s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseql rd r1 r2 :: k + | Cne => Psnel rd r1 r2 :: k + | Clt => Psltl rd r1 r2 :: k + | Cle => Psltl rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltl rd r2 r1 :: k + | Cge => Psltl rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_cond_int64u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseql rd r1 r2 :: k + | Cne => Psnel rd r1 r2 :: k + | Clt => Psltul rd r1 r2 :: k + | Cle => Psltul rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltul rd r2 r1 :: k + | Cge => Psltul rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_condimm_int32s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := + if Int.eq n Int.zero then transl_cond_int32s cmp rd r1 X0 k else + match cmp with + | Ceq | Cne => xorimm32 rd r1 n (transl_cond_int32s cmp rd rd X0 k) + | Clt => sltimm32 rd r1 n k + | Cle => if Int.eq n (Int.repr Int.max_signed) + then loadimm32 rd Int.one k + else sltimm32 rd r1 (Int.add n Int.one) k + | _ => loadimm32 X31 n (transl_cond_int32s cmp rd r1 X31 k) + end. + +Definition transl_condimm_int32u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := + if Int.eq n Int.zero then transl_cond_int32u cmp rd r1 X0 k else + match cmp with + | Clt => sltuimm32 rd r1 n k + | _ => loadimm32 X31 n (transl_cond_int32u cmp rd r1 X31 k) + end. + +Definition transl_condimm_int64s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := + if Int64.eq n Int64.zero then transl_cond_int64s cmp rd r1 X0 k else + match cmp with + | Ceq | Cne => xorimm64 rd r1 n (transl_cond_int64s cmp rd rd X0 k) + | Clt => sltimm64 rd r1 n k + | Cle => if Int64.eq n (Int64.repr Int64.max_signed) + then loadimm32 rd Int.one k + else sltimm64 rd r1 (Int64.add n Int64.one) k + | _ => loadimm64 X31 n (transl_cond_int64s cmp rd r1 X31 k) + end. + +Definition transl_condimm_int64u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := + if Int64.eq n Int64.zero then transl_cond_int64u cmp rd r1 X0 k else + match cmp with + | Clt => sltuimm64 rd r1 n k + | _ => loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k) + end. + +Definition transl_cond_op + (cond: condition) (rd: ireg) (args: list mreg) (k: code) := + match cond, args with + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32s c rd r1 r2 k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32u c rd r1 r2 k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32s c rd r1 n k) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32u c rd r1 n k) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64s c rd r1 r2 k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64u c rd r1 r2 k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64s c rd r1 n k) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64u c rd r1 n k) + | Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | _, _ => + Error(msg "Asmgen.transl_cond_op") + end. + (** Translation of the arithmetic operation [r <- op(args)]. The corresponding instructions are prepended to [k]. *) @@ -523,6 +767,9 @@ Definition transl_op | Osingleoflongu, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfcvtslu rd rs :: k) + | Ocmp cmp, _ => + do rd <- ireg_of res; + transl_cond_op cmp rd args k | OEseqw optR0, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 6abad4ed..82c1917d 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -161,37 +161,165 @@ Proof. Qed. Hint Resolve addptrofs_label: labels. +Remark transl_cond_float_nolabel: + forall c r1 r2 r3 insn normal, + transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn. +Proof. + unfold transl_cond_float; intros. destruct c; inv H; exact I. +Qed. + +Remark transl_cond_single_nolabel: + forall c r1 r2 r3 insn normal, + transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn. +Proof. + unfold transl_cond_single; intros. destruct c; inv H; exact I. + Qed. + Remark transl_cbranch_label: forall cond args lbl k c, transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. Proof. intros. unfold transl_cbranch in H; destruct cond; TailNoLabel. - all: destruct optR0 as [[]|]; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct (Int.eq n Int.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int32s c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (Int.eq n Int.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int32u c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int64s c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int64u c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. Qed. +Remark transl_cond_op_label: + forall cond args r k c, + transl_cond_op cond r args k = OK c -> tail_nolabel k c. +Proof. + intros. unfold transl_cond_op in H; destruct cond; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int32s. + destruct (Int.eq n Int.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl. +* eapply tail_nolabel_trans; [apply opimm32_label; intros; exact I | TailNoLabel]. +* eapply tail_nolabel_trans; [apply opimm32_label; intros; exact I | TailNoLabel]. +* apply opimm32_label; intros; exact I. +* destruct (Int.eq n (Int.repr Int.max_signed)). apply loadimm32_label. apply opimm32_label; intros; exact I. +* eapply tail_nolabel_trans. apply loadimm32_label. TailNoLabel. +* eapply tail_nolabel_trans. apply loadimm32_label. TailNoLabel. +- unfold transl_condimm_int32u. + destruct (Int.eq n Int.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl; + try (eapply tail_nolabel_trans; [apply loadimm32_label | TailNoLabel]). + apply opimm32_label; intros; exact I. +- destruct c0; simpl; TailNoLabel. + - destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int64s. + destruct (Int64.eq n Int64.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl. +* eapply tail_nolabel_trans; [apply opimm64_label; intros; exact I | TailNoLabel]. +* eapply tail_nolabel_trans; [apply opimm64_label; intros; exact I | TailNoLabel]. +* apply opimm64_label; intros; exact I. +* destruct (Int64.eq n (Int64.repr Int64.max_signed)). apply loadimm32_label. apply opimm64_label; intros; exact I. +* eapply tail_nolabel_trans. apply loadimm64_label. TailNoLabel. +* eapply tail_nolabel_trans. apply loadimm64_label. TailNoLabel. +- unfold transl_condimm_int64u. + destruct (Int64.eq n Int64.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl; + try (eapply tail_nolabel_trans; [apply loadimm64_label | TailNoLabel]). + apply opimm64_label; intros; exact I. +- destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. + Qed. + Remark transl_op_label: forall op args r k c, transl_op op args r k = OK c -> tail_nolabel k c. Proof. Opaque Int.eq. unfold transl_op; intros; destruct op; TailNoLabel. - { destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. } - { destruct (Float.eq_dec n Float.zero); TailNoLabel. } - { destruct (Float32.eq_dec n Float32.zero); TailNoLabel. } - { destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). - + eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel. - + TailNoLabel. } - { apply opimm32_label; intros; exact I. } - { apply opimm32_label; intros; exact I. } - { apply opimm32_label; intros; exact I. } - { apply opimm32_label; intros; exact I. } - { destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. } - { apply opimm64_label; intros; exact I. } - { apply opimm64_label; intros; exact I. } - { apply opimm64_label; intros; exact I. } - { apply opimm64_label; intros; exact I. } - { destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. } - all: destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. +- destruct (Float.eq_dec n Float.zero); TailNoLabel. +- destruct (Float32.eq_dec n Float32.zero); TailNoLabel. +- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). ++ eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel. ++ TailNoLabel. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. +- eapply transl_cond_op_label; eauto. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. Qed. Remark indexed_memory_access_label: diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index f0def29b..6d83cf5a 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -290,6 +290,102 @@ Proof. rewrite H0 in B. inv B. auto. Qed. +(** Translation of conditional branches *) + +Lemma transl_cbranch_int32s_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmp_bool cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (transl_cbranch_int32s cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H. +- destruct rs##r1; simpl in H; try discriminate. destruct rs##r2; inv H. + simpl; auto. +- destruct rs##r1; simpl in H; try discriminate. destruct rs##r2; inv H. + simpl; auto. +- auto. +- rewrite <- Val.swap_cmp_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmp_bool. simpl. rewrite H; auto. +- auto. +Qed. + +Lemma transl_cbranch_int32u_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (transl_cbranch_int32u cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H; auto. +- rewrite <- Val.swap_cmpu_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmpu_bool. simpl. rewrite H; auto. +Qed. + +Lemma transl_cbranch_int64s_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmpl_bool cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (transl_cbranch_int64s cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H. +- destruct rs###r1; simpl in H; try discriminate. destruct rs###r2; inv H. + simpl; auto. +- destruct rs###r1; simpl in H; try discriminate. destruct rs###r2; inv H. + simpl; auto. +- auto. +- rewrite <- Val.swap_cmpl_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmpl_bool. simpl. rewrite H; auto. +- auto. +Qed. + +Lemma transl_cbranch_int64u_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (transl_cbranch_int64u cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H; auto. +- rewrite <- Val.swap_cmplu_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmplu_bool. simpl. rewrite H; auto. +Qed. + +Lemma transl_cond_float_correct: + forall (rs: regset) m cmp rd r1 r2 insn normal v, + transl_cond_float cmp rd r1 r2 = (insn, normal) -> + v = (if normal then Val.cmpf cmp rs#r1 rs#r2 else Val.notbool (Val.cmpf cmp rs#r1 rs#r2)) -> + exec_instr ge fn insn rs m = Next (nextinstr (rs#rd <- v)) m. +Proof. + intros. destruct cmp; simpl in H; inv H; auto. +- rewrite Val.negate_cmpf_eq. auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpf, Val.cmpf_bool. + rewrite <- Float.cmp_swap. auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpf, Val.cmpf_bool. + rewrite <- Float.cmp_swap. auto. +Qed. + +Lemma transl_cond_single_correct: + forall (rs: regset) m cmp rd r1 r2 insn normal v, + transl_cond_single cmp rd r1 r2 = (insn, normal) -> + v = (if normal then Val.cmpfs cmp rs#r1 rs#r2 else Val.notbool (Val.cmpfs cmp rs#r1 rs#r2)) -> + exec_instr ge fn insn rs m = Next (nextinstr (rs#rd <- v)) m. +Proof. + intros. destruct cmp; simpl in H; inv H; auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. + rewrite Float32.cmp_ne_eq. destruct (Float32.cmp Ceq f0 f); auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. + rewrite <- Float32.cmp_swap. auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. + rewrite <- Float32.cmp_swap. auto. + Qed. + +(* TODO gourdinl UNUSUED ? Remark branch_on_X31: + forall normal lbl (rs: regset) m b, + rs#X31 = Val.of_bool (eqb normal b) -> + exec_instr ge fn (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity. + Qed.*) + Ltac ArgsInv := repeat (match goal with | [ H: Error _ = OK _ |- _ ] => discriminate @@ -321,84 +417,203 @@ Proof. { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } clear EVAL MEXT AG. destruct cond; simpl in TRANSL; ArgsInv. - (* Pbeqw / Cmp *) - { destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero32, Op.zero32 in *; - eexists; eexists; eauto; split; constructor; auto; - simpl in *. - + destruct (rs x); simpl in *; try congruence. - assert (HB: (Int.eq Int.zero i) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - assert (HB: (Int.eq i Int.zero) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - destruct (rs x0); try congruence. - assert (HB: (Int.eq i i0) = b) by congruence. - rewrite HB; destruct b; simpl; auto. } - (* Pbnew / Cmp *) - { destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero32, Op.zero32 in *; - eexists; eexists; eauto; split; constructor; auto; - simpl in *. - + destruct (rs x); simpl in *; try congruence. - assert (HB: negb (Int.eq Int.zero i) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - assert (HB: negb (Int.eq i Int.zero) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - destruct (rs x0); try congruence. - assert (HB: negb (Int.eq i i0) = b) by congruence. - rewrite HB; destruct b; simpl; auto. } - (* Pbeqw, Pbnew, Pbltw, Pbtluw, Pbgew, Pbgeuw / Cmpu *) - 1-6: - destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero32, Op.zero32 in *; - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. - (* Pbeql / Cmpl *) - { destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; - eexists; eexists; eauto; split; constructor; - simpl in *; auto. - + destruct (rs x); simpl in *; try congruence. - assert (HB: (Int64.eq Int64.zero i) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - assert (HB: (Int64.eq i Int64.zero) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - destruct (rs x0); try congruence. - assert (HB: (Int64.eq i i0) = b) by congruence. - rewrite HB; destruct b; simpl; auto. } - (* Pbnel / Cmpl *) - { destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; - eexists; eexists; eauto; split; constructor; - simpl in *; auto. - + destruct (rs x); simpl in *; try congruence. - assert (HB: negb (Int64.eq Int64.zero i) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - assert (HB: negb (Int64.eq i Int64.zero) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - destruct (rs x0); try congruence. - assert (HB: negb (Int64.eq i i0) = b) by congruence. - rewrite HB; destruct b; simpl; auto. } - (* Pbeql, Pbnel, Pbltl, Pbtlul, Pbgel, Pbgeul / Cmplu *) - 1-6: - destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. + - exists rs, (transl_cbranch_int32s c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. +- exists rs, (transl_cbranch_int32u c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. +- predSpec Int.eq Int.eq_spec n Int.zero. ++ subst n. exists rs, (transl_cbranch_int32s c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. ++ exploit (loadimm32_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int32s c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int32s_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- predSpec Int.eq Int.eq_spec n Int.zero. ++ subst n. exists rs, (transl_cbranch_int32u c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. ++ exploit (loadimm32_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int32u c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int32u_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- exists rs, (transl_cbranch_int64s c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. +- exists rs, (transl_cbranch_int64u c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. +- predSpec Int64.eq Int64.eq_spec n Int64.zero. ++ subst n. exists rs, (transl_cbranch_int64s c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. ++ exploit (loadimm64_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int64s c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int64s_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- predSpec Int64.eq Int64.eq_spec n Int64.zero. ++ subst n. exists rs, (transl_cbranch_int64u c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. ++ exploit (loadimm64_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int64u c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int64u_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (eqb normal b)). + { unfold v, Val.cmpf. rewrite EVAL'. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + assert (EVAL'': Val.cmpf_bool c0 (rs x) (rs x0) = Some (negb b)). + { destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } + set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (xorb normal b)). + { unfold v, Val.cmpf. rewrite EVAL''. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (eqb normal b)). + { unfold v, Val.cmpfs. rewrite EVAL'. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + assert (EVAL'': Val.cmpfs_bool c0 (rs x) (rs x0) = Some (negb b)). + { destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } + set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (xorb normal b)). + { unfold v, Val.cmpfs. rewrite EVAL''. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. + +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; auto; + simpl in *. + + destruct (rs x); simpl in *; try congruence. + assert (HB: (Int.eq Int.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + assert (HB: (Int.eq i Int.zero) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + destruct (rs x0); try congruence. + assert (HB: (Int.eq i i0) = b) by congruence. + rewrite HB; destruct b; simpl; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; auto; + simpl in *. + + destruct (rs x); simpl in *; try congruence. + assert (HB: negb (Int.eq Int.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + assert (HB: negb (Int.eq i Int.zero) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + destruct (rs x0); try congruence. + assert (HB: negb (Int.eq i i0) = b) by congruence. + rewrite HB; destruct b; simpl; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; auto. + + destruct (rs x); simpl in *; try congruence. + assert (HB: (Int64.eq Int64.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + assert (HB: (Int64.eq i Int64.zero) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + destruct (rs x0); try congruence. + assert (HB: (Int64.eq i i0) = b) by congruence. + rewrite HB; destruct b; simpl; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; auto. + + destruct (rs x); simpl in *; try congruence. + assert (HB: negb (Int64.eq Int64.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + assert (HB: negb (Int64.eq i Int64.zero) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + destruct (rs x0); try congruence. + assert (HB: negb (Int64.eq i i0) = b) by congruence. + rewrite HB; destruct b; simpl; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. Qed. Lemma transl_cbranch_correct_true: @@ -432,6 +647,405 @@ Proof. intros; Simpl. Qed. +(** Translation of condition operators *) + +Lemma transl_cond_int32s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int32s cmp rd r1 r2 k) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs##r1 rs##r2) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs##r1); auto. destruct (rs##r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs##r1); auto. destruct (rs##r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmp. rewrite <- Val.swap_cmp_bool. + simpl. rewrite (Val.negate_cmp_bool Clt). + destruct (Val.cmp_bool Clt rs##r2 rs##r1) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmp. rewrite <- Val.swap_cmp_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmp. rewrite (Val.negate_cmp_bool Clt). + destruct (Val.cmp_bool Clt rs##r1 rs##r2) as [[]|]; auto. +Qed. + +Lemma transl_cond_int32u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int32u cmp rd r1 r2 k) rs m k rs' m + /\ rs'#rd = Val.cmpu (Mem.valid_pointer m) cmp rs##r1 rs##r2 + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpu. rewrite <- Val.swap_cmpu_bool. + simpl. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Cle). + destruct (Val.cmpu_bool (Mem.valid_pointer m) Cle rs##r1 rs##r2) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmpu. rewrite <- Val.swap_cmpu_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpu. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Clt). + destruct (Val.cmpu_bool (Mem.valid_pointer m) Clt rs##r1 rs##r2) as [[]|]; auto. +Qed. + +Lemma transl_cond_int64s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int64s cmp rd r1 r2 k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs###r1 rs###r2)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs###r1); auto. destruct (rs###r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs###r1); auto. destruct (rs###r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpl. rewrite <- Val.swap_cmpl_bool. + simpl. rewrite (Val.negate_cmpl_bool Clt). + destruct (Val.cmpl_bool Clt rs###r2 rs###r1) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmpl. rewrite <- Val.swap_cmpl_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpl. rewrite (Val.negate_cmpl_bool Clt). + destruct (Val.cmpl_bool Clt rs###r1 rs###r2) as [[]|]; auto. +Qed. + +Lemma transl_cond_int64u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int64u cmp rd r1 r2 k) rs m k rs' m + /\ rs'#rd = Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs###r1 rs###r2) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmplu. rewrite <- Val.swap_cmplu_bool. + simpl. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Cle). + destruct (Val.cmplu_bool (Mem.valid_pointer m) Cle rs###r1 rs###r2) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmplu. rewrite <- Val.swap_cmplu_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmplu. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Clt). + destruct (Val.cmplu_bool (Mem.valid_pointer m) Clt rs###r1 rs###r2) as [[]|]; auto. +Qed. + +Lemma transl_condimm_int32s_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int32s cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int32s. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. exploit transl_cond_int32s_correct. intros (rs' & A & B & C). + exists rs'; eauto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm32 X31 n (transl_cond_int32s cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ unfold xorimm32. + exploit (opimm32_correct Pxorw Pxoriw Val.xor); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmp in B2; simpl in B2; rewrite Int.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ unfold xorimm32. + exploit (opimm32_correct Pxorw Pxoriw Val.xor); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmp in B2; simpl in B2; rewrite Int.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ predSpec Int.eq Int.eq_spec n (Int.repr Int.max_signed). +* subst n. exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + unfold Val.cmp; destruct (rs#r1); simpl; auto. rewrite B1. + unfold Int.lt. rewrite zlt_false. auto. + change (Int.signed (Int.repr Int.max_signed)) with Int.max_signed. + generalize (Int.signed_range i); omega. +* exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + rewrite B1. unfold Val.cmp; simpl; destruct (rs#r1); simpl; auto. + unfold Int.lt. replace (Int.signed (Int.add n Int.one)) with (Int.signed n + 1). + destruct (zlt (Int.signed n) (Int.signed i)). + rewrite zlt_false by omega. auto. + rewrite zlt_true by omega. auto. + rewrite Int.add_signed. symmetry; apply Int.signed_repr. + assert (Int.signed n <> Int.max_signed). + { red; intros E. elim H1. rewrite <- (Int.repr_signed n). rewrite E. auto. } + generalize (Int.signed_range n); omega. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_condimm_int32u_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int32u cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int32u. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. exploit transl_cond_int32u_correct. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. rewrite B; auto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm32 X31 n (transl_cond_int32u cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32u_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. rewrite B2; auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ apply DFL. ++ apply DFL. ++ exploit (opimm32_correct Psltuw Psltiuw (Val.cmpu (Mem.valid_pointer m) Clt) m); eauto. + intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ apply DFL. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_condimm_int64s_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int64s cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int64s. + predSpec Int64.eq Int64.eq_spec n Int64.zero. +- subst n. exploit transl_cond_int64s_correct. intros (rs' & A & B & C). + exists rs'; eauto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm64 X31 n (transl_cond_int64s cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ unfold xorimm64. + exploit (opimm64_correct Pxorl Pxoril Val.xorl); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmpl in B2; simpl in B2; rewrite Int64.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ unfold xorimm64. + exploit (opimm64_correct Pxorl Pxoril Val.xorl); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmpl in B2; simpl in B2; rewrite Int64.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ predSpec Int64.eq Int64.eq_spec n (Int64.repr Int64.max_signed). +* subst n. exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + unfold Val.cmpl; destruct (rs#r1); simpl; auto. rewrite B1. + unfold Int64.lt. rewrite zlt_false. auto. + change (Int64.signed (Int64.repr Int64.max_signed)) with Int64.max_signed. + generalize (Int64.signed_range i); omega. +* exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + rewrite B1. unfold Val.cmpl; simpl; destruct (rs#r1); simpl; auto. + unfold Int64.lt. replace (Int64.signed (Int64.add n Int64.one)) with (Int64.signed n + 1). + destruct (zlt (Int64.signed n) (Int64.signed i)). + rewrite zlt_false by omega. auto. + rewrite zlt_true by omega. auto. + rewrite Int64.add_signed. symmetry; apply Int64.signed_repr. + assert (Int64.signed n <> Int64.max_signed). + { red; intros E. elim H1. rewrite <- (Int64.repr_signed n). rewrite E. auto. } + generalize (Int64.signed_range n); omega. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_condimm_int64u_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int64u cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int64u. + predSpec Int64.eq Int64.eq_spec n Int64.zero. +- subst n. exploit transl_cond_int64u_correct. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. rewrite B; auto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64u_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. rewrite B2; auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ apply DFL. ++ apply DFL. ++ exploit (opimm64_correct Psltul Psltiul (fun v1 v2 => Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 v2)) m); eauto. + intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ apply DFL. ++ apply DFL. ++ apply DFL. + Qed. + +Lemma transl_cond_op_correct: + forall cond rd args k c rs m, + transl_cond_op cond rd args k = OK c -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + assert (MKTOT: forall ob, Val.of_optbool ob = Val.maketotal (option_map Val.of_bool ob)). + { destruct ob as [[]|]; reflexivity. } + intros until m; intros TR. + destruct cond; simpl in TR; ArgsInv. ++ (* cmp *) + exploit transl_cond_int32s_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. ++ (* cmpu *) + exploit transl_cond_int32u_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite B; auto. ++ (* cmpimm *) + apply transl_condimm_int32s_correct; eauto with asmgen. ++ (* cmpuimm *) + apply transl_condimm_int32u_correct; eauto with asmgen. ++ (* cmpl *) + exploit transl_cond_int64s_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmplu *) + exploit transl_cond_int64u_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. ++ (* cmplimm *) + exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmpluimm *) + exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmpf *) + destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. + fold (Val.cmpf c0 (rs x) (rs x0)). + set (v := Val.cmpf c0 (rs x) (rs x0)). + destruct normal; inv EQ2. +* econstructor; split. + apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. + split; intros; Simpl. +* econstructor; split. + eapply exec_straight_two. + eapply transl_cond_float_correct with (v := Val.notbool v); eauto. + simpl; reflexivity. + auto. auto. + split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto. ++ (* notcmpf *) + destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. + rewrite Val.notbool_negb_3. fold (Val.cmpf c0 (rs x) (rs x0)). + set (v := Val.cmpf c0 (rs x) (rs x0)). + destruct normal; inv EQ2. +* econstructor; split. + eapply exec_straight_two. + eapply transl_cond_float_correct with (v := v); eauto. + simpl; reflexivity. + auto. auto. + split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto. +* econstructor; split. + apply exec_straight_one. eapply transl_cond_float_correct with (v := Val.notbool v); eauto. auto. + split; intros; Simpl. ++ (* cmpfs *) + destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR. + fold (Val.cmpfs c0 (rs x) (rs x0)). + set (v := Val.cmpfs c0 (rs x) (rs x0)). + destruct normal; inv EQ2. +* econstructor; split. + apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. + split; intros; Simpl. +* econstructor; split. + eapply exec_straight_two. + eapply transl_cond_single_correct with (v := Val.notbool v); eauto. + simpl; reflexivity. + auto. auto. + split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto. ++ (* notcmpfs *) + destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR. + rewrite Val.notbool_negb_3. fold (Val.cmpfs c0 (rs x) (rs x0)). + set (v := Val.cmpfs c0 (rs x) (rs x0)). + destruct normal; inv EQ2. +* econstructor; split. + eapply exec_straight_two. + eapply transl_cond_single_correct with (v := v); eauto. + simpl; reflexivity. + auto. auto. + split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto. +* econstructor; split. + apply exec_straight_one. eapply transl_cond_single_correct with (v := Val.notbool v); eauto. auto. + split; intros; Simpl. + Qed. + (** Some arithmetic properties. *) Remark cast32unsigned_from_cast32signed: @@ -640,6 +1254,9 @@ Opaque Int.eq. eapply exec_straight_step. simpl; reflexivity. auto. apply exec_straight_one. simpl; reflexivity. auto. split; intros; Simpl. } + (* cond *) + { exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. eauto with asmgen. } (* Expanded instructions from RTL *) 7,8,15,16: econstructor; split; try apply exec_straight_one; simpl; eauto; -- cgit From 801cd27eb78a9ba9dce6f62626288531905fcfed Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Tue, 2 Mar 2021 18:48:53 +0100 Subject: [Admitted checker] Oracle expansion for float/float32 constant init --- riscV/ExpansionOracle.ml | 25 +++++++++++++++++++++++-- riscV/PrintOp.ml | 8 ++++---- 2 files changed, 27 insertions(+), 6 deletions(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 95a300c5..c6710a95 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -379,7 +379,7 @@ let rec write_tree exp current code' new_order = | _ -> failwith "ExpansionOracle.write_tree: inconsistent instruction." let expanse (sb : superblock) code pm = - (*debug_flag := true;*) + debug_flag := true; let new_order = ref [] in let liveins = ref sb.liveins in let exp = ref [] in @@ -393,6 +393,7 @@ let expanse (sb : superblock) code pm = was_exp := false; let inst = get_some @@ PTree.get n code in (match inst with + (* Expansion of conditions - Ocmp *) | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> debug "Iop/Ccomp\n"; exp := cond_int32s false c a1 a2 dest succ []; @@ -441,6 +442,7 @@ let expanse (sb : superblock) code pm = debug "Iop/Cnotcompfs\n"; exp := expanse_cond_fp true cond_single c f1 f2 dest succ []; was_exp := true + (* Expansion of branches - Ccomp *) | Icond (Ccomp c, a1 :: a2 :: nil, succ1, succ2, info) -> debug "Icond/Ccomp\n"; exp := cbranch_int32s false c a1 a2 info succ1 succ2 []; @@ -502,6 +504,25 @@ let expanse (sb : superblock) code pm = exp := expanse_cbranch_fp true cond_single c f1 f2 info succ1 succ2 []; was_branch := true; was_exp := true + (* Expansion of fp constants *) + | Iop (Ofloatconst f, nil, dest, succ) -> + debug "Iop/Ofloatconst\n"; + let r = r2pi () in + exp := + [ + Iop (Olongconst (Floats.Float.to_bits f), [], r, n2pi ()); + Iop (Ofloat_of_bits, [ r ], dest, succ); + ]; + was_exp := true + | Iop (Osingleconst f, nil, dest, succ) -> + debug "Iop/Osingleconst\n"; + let r = r2pi () in + exp := + [ + Iop (Ointconst (Floats.Float32.to_bits f), [], r, n2pi ()); + Iop (Osingle_of_bits, [ r ], dest, succ); + ]; + was_exp := true | _ -> new_order := n :: !new_order); if !was_exp then ( node := !node + 1; @@ -521,7 +542,7 @@ let expanse (sb : superblock) code pm = sb.instructions; sb.instructions <- Array.of_list (List.rev !new_order); sb.liveins <- !liveins; - (*debug_flag := false;*) + debug_flag := false; (!code', !pm') let rec find_last_node_reg = function diff --git a/riscV/PrintOp.ml b/riscV/PrintOp.ml index 84380251..4734795a 100644 --- a/riscV/PrintOp.ml +++ b/riscV/PrintOp.ml @@ -97,10 +97,10 @@ let print_condition reg pp = function let print_operation reg pp = function | Omove, [r1] -> reg pp r1 - | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) - | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n) - | Ofloatconst n, [] -> fprintf pp "%F" (camlfloat_of_coqfloat n) - | Osingleconst n, [] -> fprintf pp "%Ff" (camlfloat_of_coqfloat32 n) + | Ointconst n, [] -> fprintf pp "Ointconst(%ld)" (camlint_of_coqint n) + | Olongconst n, [] -> fprintf pp "Olongconst(%LdL)" (camlint64_of_coqint n) + | Ofloatconst n, [] -> fprintf pp "Ofloatconst(%F)" (camlfloat_of_coqfloat n) + | Osingleconst n, [] -> fprintf pp "Osingleconst(%Ff)" (camlfloat_of_coqfloat32 n) | Oaddrsymbol(id, ofs), [] -> fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) | Oaddrstack ofs, [] -> -- cgit From 6f71a2a369d07a8e812fb3893f30be528b28d3ee Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Tue, 2 Mar 2021 20:07:50 +0100 Subject: Adding fp init expansions --- riscV/RTLpathSE_simplify.v | 15 +++++++++++++++ 1 file changed, 15 insertions(+) (limited to 'riscV') diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index 6a0297e9..29389850 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -368,6 +368,14 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let is_inv := is_inv_cmp_float c in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in Some (expanse_cond_fp true cond_single c lhsv) + | Ofloatconst f, nil => + let bits_const := fSop (Olongconst (Float.to_bits f)) fSnil in + let hl := make_lhsv_single bits_const in + Some (fSop (Ofloat_of_bits) hl) + | Osingleconst f, nil => + let bits_const := fSop (Ointconst (Float32.to_bits f)) fSnil in + let hl := make_lhsv_single bits_const in + Some (fSop (Osingle_of_bits) hl) | _, _ => None end. @@ -1211,6 +1219,13 @@ Proof. unfold target_op_simplify; simpl. intros H (LREF & SREF & SREG & SMEM) ? ? ?. destruct op; try congruence. + (* FP const expansions *) + 1,2: + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + try rewrite Float.of_to_bits; + try rewrite Float32.of_to_bits; trivial. + (* Ocmp expansions *) destruct cond; repeat (destruct lr; simpl; try congruence); simpl in OK1; try (destruct (seval_sval ge sp (si_sreg st r) rs0 m0) eqn:OKv1; try congruence); -- cgit From eb35c3000530e379dcd79e82f001a400be8b28e9 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Tue, 2 Mar 2021 20:27:34 +0100 Subject: Adding a flag to test fp_init_exp --- riscV/ExpansionOracle.ml | 307 ++++++++++++++++++++++++----------------------- 1 file changed, 157 insertions(+), 150 deletions(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index c6710a95..23e3c38e 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -389,156 +389,163 @@ let expanse (sb : superblock) code pm = let pm' = ref pm in Array.iter (fun n -> - was_branch := false; - was_exp := false; - let inst = get_some @@ PTree.get n code in - (match inst with - (* Expansion of conditions - Ocmp *) - | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccomp\n"; - exp := cond_int32s false c a1 a2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccompu c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccompu\n"; - exp := cond_int32u false c a1 a2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccompimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccompimm\n"; - exp := expanse_condimm_int32s c a1 imm dest succ []; - was_exp := true - | Iop (Ocmp (Ccompuimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccompuimm\n"; - exp := expanse_condimm_int32u c a1 imm dest succ []; - was_exp := true - | Iop (Ocmp (Ccompl c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccompl\n"; - exp := cond_int64s false c a1 a2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccomplu c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccomplu\n"; - exp := cond_int64u false c a1 a2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccomplimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccomplimm\n"; - exp := expanse_condimm_int64s c a1 imm dest succ []; - was_exp := true - | Iop (Ocmp (Ccompluimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccompluimm\n"; - exp := expanse_condimm_int64u c a1 imm dest succ []; - was_exp := true - | Iop (Ocmp (Ccompf c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Ccompf\n"; - exp := expanse_cond_fp false cond_float c f1 f2 dest succ []; - was_exp := true - | Iop (Ocmp (Cnotcompf c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Cnotcompf\n"; - exp := expanse_cond_fp true cond_float c f1 f2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccompfs c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Ccompfs\n"; - exp := expanse_cond_fp false cond_single c f1 f2 dest succ []; - was_exp := true - | Iop (Ocmp (Cnotcompfs c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Cnotcompfs\n"; - exp := expanse_cond_fp true cond_single c f1 f2 dest succ []; - was_exp := true - (* Expansion of branches - Ccomp *) - | Icond (Ccomp c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccomp\n"; - exp := cbranch_int32s false c a1 a2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompu c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompu\n"; - exp := cbranch_int32u false c a1 a2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompimm\n"; - exp := expanse_cbranchimm_int32s c a1 imm info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompuimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompuimm\n"; - exp := expanse_cbranchimm_int32u c a1 imm info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompl c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompl\n"; - exp := cbranch_int64s false c a1 a2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccomplu c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccomplu\n"; - exp := cbranch_int64u false c a1 a2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccomplimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccomplimm\n"; - exp := expanse_cbranchimm_int64s c a1 imm info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompluimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompluimm\n"; - exp := expanse_cbranchimm_int64u c a1 imm info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompf c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompf\n"; - exp := expanse_cbranch_fp false cond_float c f1 f2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Cnotcompf c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Cnotcompf\n"; - exp := expanse_cbranch_fp true cond_float c f1 f2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompfs\n"; - exp := - expanse_cbranch_fp false cond_single c f1 f2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Cnotcompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Cnotcompfs\n"; - exp := expanse_cbranch_fp true cond_single c f1 f2 info succ1 succ2 []; - was_branch := true; - was_exp := true - (* Expansion of fp constants *) - | Iop (Ofloatconst f, nil, dest, succ) -> - debug "Iop/Ofloatconst\n"; - let r = r2pi () in - exp := - [ - Iop (Olongconst (Floats.Float.to_bits f), [], r, n2pi ()); - Iop (Ofloat_of_bits, [ r ], dest, succ); - ]; - was_exp := true - | Iop (Osingleconst f, nil, dest, succ) -> - debug "Iop/Osingleconst\n"; - let r = r2pi () in - exp := - [ - Iop (Ointconst (Floats.Float32.to_bits f), [], r, n2pi ()); - Iop (Osingle_of_bits, [ r ], dest, succ); - ]; - was_exp := true - | _ -> new_order := n :: !new_order); - if !was_exp then ( - node := !node + 1; - (if !was_branch then - let lives = PTree.get n !liveins in - match lives with - | Some lives -> - let new_branch_pc = - Camlcoq.P.of_int (!node - (List.length !exp - 1)) - in - liveins := PTree.set new_branch_pc lives !liveins; - liveins := PTree.remove n !liveins - | _ -> ()); - write_pathmap sb.instructions.(0) (List.length !exp) pm'; - write_initial_node n code' new_order; - write_tree !exp !node code' new_order)) + begin ( + was_branch := false; + was_exp := false; + let inst = get_some @@ PTree.get n code in + if !Clflags.option_fexpanse_rtlcond then ( + match inst with + (* Expansion of conditions - Ocmp *) + | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccomp\n"; + exp := cond_int32s false c a1 a2 dest succ []; + was_exp := true + | Iop (Ocmp (Ccompu c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccompu\n"; + exp := cond_int32u false c a1 a2 dest succ []; + was_exp := true + | Iop (Ocmp (Ccompimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccompimm\n"; + exp := expanse_condimm_int32s c a1 imm dest succ []; + was_exp := true + | Iop (Ocmp (Ccompuimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccompuimm\n"; + exp := expanse_condimm_int32u c a1 imm dest succ []; + was_exp := true + | Iop (Ocmp (Ccompl c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccompl\n"; + exp := cond_int64s false c a1 a2 dest succ []; + was_exp := true + | Iop (Ocmp (Ccomplu c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccomplu\n"; + exp := cond_int64u false c a1 a2 dest succ []; + was_exp := true + | Iop (Ocmp (Ccomplimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccomplimm\n"; + exp := expanse_condimm_int64s c a1 imm dest succ []; + was_exp := true + | Iop (Ocmp (Ccompluimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccompluimm\n"; + exp := expanse_condimm_int64u c a1 imm dest succ []; + was_exp := true + | Iop (Ocmp (Ccompf c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Ccompf\n"; + exp := expanse_cond_fp false cond_float c f1 f2 dest succ []; + was_exp := true + | Iop (Ocmp (Cnotcompf c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Cnotcompf\n"; + exp := expanse_cond_fp true cond_float c f1 f2 dest succ []; + was_exp := true + | Iop (Ocmp (Ccompfs c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Ccompfs\n"; + exp := expanse_cond_fp false cond_single c f1 f2 dest succ []; + was_exp := true + | Iop (Ocmp (Cnotcompfs c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Cnotcompfs\n"; + exp := expanse_cond_fp true cond_single c f1 f2 dest succ []; + was_exp := true + (* Expansion of branches - Ccomp *) + | Icond (Ccomp c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccomp\n"; + exp := cbranch_int32s false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompu c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompu\n"; + exp := cbranch_int32u false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompimm\n"; + exp := expanse_cbranchimm_int32s c a1 imm info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompuimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompuimm\n"; + exp := expanse_cbranchimm_int32u c a1 imm info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompl c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompl\n"; + exp := cbranch_int64s false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccomplu c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccomplu\n"; + exp := cbranch_int64u false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccomplimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccomplimm\n"; + exp := expanse_cbranchimm_int64s c a1 imm info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompluimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompluimm\n"; + exp := expanse_cbranchimm_int64u c a1 imm info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompf c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompf\n"; + exp := expanse_cbranch_fp false cond_float c f1 f2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Cnotcompf c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Cnotcompf\n"; + exp := expanse_cbranch_fp true cond_float c f1 f2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompfs\n"; + exp := + expanse_cbranch_fp false cond_single c f1 f2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Cnotcompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Cnotcompfs\n"; + exp := expanse_cbranch_fp true cond_single c f1 f2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | _ -> ()); + if (!Clflags.option_fexpanse_fpconst && not !was_exp) then ( + match inst with + (* Expansion of fp constants *) + | Iop (Ofloatconst f, nil, dest, succ) -> + debug "Iop/Ofloatconst\n"; + let r = r2pi () in + exp := + [ + Iop (Olongconst (Floats.Float.to_bits f), [], r, n2pi ()); + Iop (Ofloat_of_bits, [ r ], dest, succ); + ]; + was_exp := true + | Iop (Osingleconst f, nil, dest, succ) -> + debug "Iop/Osingleconst\n"; + let r = r2pi () in + exp := + [ + Iop (Ointconst (Floats.Float32.to_bits f), [], r, n2pi ()); + Iop (Osingle_of_bits, [ r ], dest, succ); + ]; + was_exp := true + | _ -> ()); + if !was_exp then ( + node := !node + 1; + (if !was_branch then + let lives = PTree.get n !liveins in + match lives with + | Some lives -> + let new_branch_pc = + Camlcoq.P.of_int (!node - (List.length !exp - 1)) + in + liveins := PTree.set new_branch_pc lives !liveins; + liveins := PTree.remove n !liveins + | _ -> ()); + write_pathmap sb.instructions.(0) (List.length !exp) pm'; + write_initial_node n code' new_order; + write_tree !exp !node code' new_order) + else new_order := n :: !new_order) + end) sb.instructions; sb.instructions <- Array.of_list (List.rev !new_order); sb.liveins <- !liveins; -- cgit From c19ecc9326d0278989d7651bf8c8cf0d1c387235 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Sat, 6 Mar 2021 12:36:11 +0100 Subject: Adding a mini CSE pass in the expansion oracle --- riscV/Asmgen.v | 8 +- riscV/Asmgenproof1.v | 6 +- riscV/ExpansionOracle.ml | 238 ++++++++++++++++++++++++++++++--------------- riscV/NeedOp.v | 5 +- riscV/Op.v | 63 +++++------- riscV/PrintOp.ml | 5 +- riscV/RTLpathSE_simplify.v | 90 +++++++++-------- riscV/ValueAOp.v | 41 ++++---- 8 files changed, 263 insertions(+), 193 deletions(-) (limited to 'riscV') diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index 957166b6..87db0181 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -565,10 +565,10 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pxoriw rd rs n :: k) - | OEluiw n _, a1 :: nil => + | OEluiw n, nil => do rd <- ireg_of res; OK (Pluiw rd n :: k) - | OEaddiwr0 n _, a1 :: nil => + | OEaddiwr0 n, nil => do rd <- ireg_of res; OK (Paddiw rd X0 n :: k) | OEseql optR0, a1 :: a2 :: nil => @@ -613,10 +613,10 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pxoril rd rs n :: k) - | OEluil n, a1 :: nil => + | OEluil n, nil => do rd <- ireg_of res; OK (Pluil rd n :: k) - | OEaddilr0 n, a1 :: nil => + | OEaddilr0 n, nil => do rd <- ireg_of res; OK (Paddil rd X0 n :: k) | OEloadli n, nil => diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index f0def29b..20d9e1da 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -641,11 +641,11 @@ Opaque Int.eq. apply exec_straight_one. simpl; reflexivity. auto. split; intros; Simpl. } (* Expanded instructions from RTL *) - 7,8,15,16: + 7,14: econstructor; split; try apply exec_straight_one; simpl; eauto; - split; intros; Simpl; unfold may_undef_int; try destruct is_long; simpl; + split; intros; Simpl; simpl; try rewrite Int.add_commut; try rewrite Int64.add_commut; - destruct (rs (preg_of m0)); try discriminate; eauto. + auto. 1-12: destruct optR0 as [[]|]; unfold apply_bin_r0_r0r0, apply_bin_r0; econstructor; split; try apply exec_straight_one; simpl; eauto; diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 95a300c5..44049ecf 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -20,14 +20,21 @@ open Asmgen open DebugPrint open RTLpath open! Integers +open Camlcoq + +type sop = Sop of operation * P.t list + +type sval = Si of RTL.instruction | Sr of P.t let reg = ref 1 let node = ref 1 -let r2p () = Camlcoq.P.of_int !reg +let p2i r = P.to_int r + +let r2p () = P.of_int !reg -let n2p () = Camlcoq.P.of_int !node +let n2p () = P.of_int !node let r2pi () = reg := !reg + 1; @@ -39,30 +46,72 @@ let n2pi () = type immt = Xoriw | Xoril | Sltiw | Sltiuw | Sltil | Sltiul -let load_hilo32 a1 dest hi lo succ is_long k = - if Int.eq lo Int.zero then Iop (OEluiw (hi, is_long), [ a1 ], dest, succ) :: k +let debug_was_cse = ref false + +let find_or_addnmove op args rd succ sargs map_consts = + let sop = Sop (op, sargs) in + match Hashtbl.find_opt map_consts sop with + | Some r -> + debug_was_cse := true; + Sr (P.of_int r) + | None -> + Hashtbl.add map_consts sop (p2i rd); + Si (Iop (op, args, rd, succ)) + +let build_head_tuple head sv = + match sv with Si i -> (head @ [ i ], None) | Sr r -> (head, Some r) + +let load_hilo32 dest hi lo succ map_consts = + let op1 = OEluiw hi in + if Int.eq lo Int.zero then + let sv = find_or_addnmove op1 [] dest succ [] map_consts in + build_head_tuple [] sv else let r = r2pi () in - Iop (OEluiw (hi, is_long), [ a1 ], r, n2pi ()) - :: Iop (Oaddimm lo, [ r ], dest, succ) :: k - -let load_hilo64 a1 dest hi lo succ k = - if Int64.eq lo Int64.zero then Iop (OEluil hi, [ a1 ], dest, succ) :: k + let op2 = Oaddimm lo in + match find_or_addnmove op1 [] r (n2pi ()) [] map_consts with + | Si i -> + let sv = find_or_addnmove op2 [ r ] dest succ [ r ] map_consts in + build_head_tuple [ i ] sv + | Sr r' -> + let sv = find_or_addnmove op2 [ r' ] dest succ [ r' ] map_consts in + build_head_tuple [] sv + +let load_hilo64 dest hi lo succ map_consts = + let op1 = OEluil hi in + if Int64.eq lo Int64.zero then + let sv = find_or_addnmove op1 [] dest succ [] map_consts in + build_head_tuple [] sv else let r = r2pi () in - Iop (OEluil hi, [ a1 ], r, n2pi ()) - :: Iop (Oaddlimm lo, [ r ], dest, succ) :: k - -let loadimm32 a1 dest n succ is_long k = + let op2 = Oaddlimm lo in + match find_or_addnmove op1 [] r (n2pi ()) [] map_consts with + | Si i -> + let sv = find_or_addnmove op2 [ r ] dest succ [ r ] map_consts in + build_head_tuple [ i ] sv + | Sr r' -> + let sv = find_or_addnmove op2 [ r' ] dest succ [ r' ] map_consts in + build_head_tuple [] sv + +let loadimm32 dest n succ map_consts = match make_immed32 n with - | Imm32_single imm -> Iop (OEaddiwr0 (imm, is_long), [ a1 ], dest, succ) :: k - | Imm32_pair (hi, lo) -> load_hilo32 a1 dest hi lo succ is_long k + | Imm32_single imm -> + let op1 = OEaddiwr0 imm in + let sv = find_or_addnmove op1 [] dest succ [] map_consts in + build_head_tuple [] sv + | Imm32_pair (hi, lo) -> load_hilo32 dest hi lo succ map_consts -let loadimm64 a1 dest n succ k = +let loadimm64 dest n succ map_consts = match make_immed64 n with - | Imm64_single imm -> Iop (OEaddilr0 imm, [ a1 ], dest, succ) :: k - | Imm64_pair (hi, lo) -> load_hilo64 a1 dest hi lo succ k - | Imm64_large imm -> Iop (OEloadli imm, [], dest, succ) :: k + | Imm64_single imm -> + let op1 = OEaddilr0 imm in + let sv = find_or_addnmove op1 [] dest succ [] map_consts in + build_head_tuple [] sv + | Imm64_pair (hi, lo) -> load_hilo64 dest hi lo succ map_consts + | Imm64_large imm -> + let op1 = OEloadli imm in + let sv = find_or_addnmove op1 [] dest succ [] map_consts in + build_head_tuple [] sv let get_opimm imm = function | Xoriw -> OExoriw imm @@ -72,32 +121,42 @@ let get_opimm imm = function | Sltil -> OEsltil imm | Sltiul -> OEsltiul imm -let opimm32 a1 dest n succ is_long k op opimm = +let unzip_head_tuple ht r = match ht with l, Some r' -> r' | l, None -> r + +let opimm32 a1 dest n succ k op opimm map_consts = match make_immed32 n with | Imm32_single imm -> Iop (get_opimm imm opimm, [ a1 ], dest, succ) :: k | Imm32_pair (hi, lo) -> let r = r2pi () in - load_hilo32 a1 r hi lo (n2pi ()) is_long - (Iop (op, [ a1; r ], dest, succ) :: k) + let ht = load_hilo32 r hi lo (n2pi ()) map_consts in + let r' = unzip_head_tuple ht r in + fst ht @ Iop (op, [ a1; r' ], dest, succ) :: k -let opimm64 a1 dest n succ k op opimm = +let opimm64 a1 dest n succ k op opimm map_consts = match make_immed64 n with | Imm64_single imm -> Iop (get_opimm imm opimm, [ a1 ], dest, succ) :: k | Imm64_pair (hi, lo) -> let r = r2pi () in - load_hilo64 a1 r hi lo (n2pi ()) (Iop (op, [ a1; r ], dest, succ) :: k) + let ht = load_hilo64 r hi lo (n2pi ()) map_consts in + let r' = unzip_head_tuple ht r in + fst ht @ Iop (op, [ a1; r' ], dest, succ) :: k | Imm64_large imm -> let r = r2pi () in - Iop (OEloadli imm, [], r, n2pi ()) :: Iop (op, [ a1; r ], dest, succ) :: k + let op1 = OEloadli imm in + let inode = n2pi () in + let sv = find_or_addnmove op1 [] r inode [] map_consts in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + fst ht @ Iop (op, [ a1; r' ], dest, succ) :: k -let xorimm32 a1 dest n succ is_long k = - opimm32 a1 dest n succ is_long k Oxor Xoriw +let xorimm32 a1 dest n succ k map_consts = + opimm32 a1 dest n succ k Oxor Xoriw map_consts -let sltimm32 a1 dest n succ is_long k = - opimm32 a1 dest n succ is_long k (OEsltw None) Sltiw +let sltimm32 a1 dest n succ k map_consts = + opimm32 a1 dest n succ k (OEsltw None) Sltiw map_consts -let sltuimm32 a1 dest n succ is_long k = - opimm32 a1 dest n succ is_long k (OEsltuw None) Sltiuw +let sltuimm32 a1 dest n succ k map_consts = + opimm32 a1 dest n succ k (OEsltuw None) Sltiuw map_consts let xorimm64 a1 dest n succ k = opimm64 a1 dest n succ k Oxorl Xoril @@ -233,85 +292,101 @@ let cond_single cmp f1 f2 dest succ = | Cgt -> Iop (OEflts, [ f2; f1 ], dest, succ) | Cge -> Iop (OEfles, [ f2; f1 ], dest, succ) -let expanse_cbranchimm_int32s cmp a1 n info succ1 succ2 k = +let expanse_cbranchimm_int32s cmp a1 n info succ1 succ2 k map_consts = if Int.eq n Int.zero then cbranch_int32s true cmp a1 a1 info succ1 succ2 k else let r = r2pi () in - loadimm32 a1 r n (n2pi ()) false - (cbranch_int32s false cmp a1 r info succ1 succ2 k) + let ht = loadimm32 r n (n2pi ()) map_consts in + let r' = unzip_head_tuple ht r in + fst ht @ cbranch_int32s false cmp a1 r' info succ1 succ2 k -let expanse_cbranchimm_int32u cmp a1 n info succ1 succ2 k = +let expanse_cbranchimm_int32u cmp a1 n info succ1 succ2 k map_consts = if Int.eq n Int.zero then cbranch_int32u true cmp a1 a1 info succ1 succ2 k else let r = r2pi () in - loadimm32 a1 r n (n2pi ()) false - (cbranch_int32u false cmp a1 r info succ1 succ2 k) + let ht = loadimm32 r n (n2pi ()) map_consts in + let r' = unzip_head_tuple ht r in + fst ht @ cbranch_int32u false cmp a1 r' info succ1 succ2 k -let expanse_cbranchimm_int64s cmp a1 n info succ1 succ2 k = +let expanse_cbranchimm_int64s cmp a1 n info succ1 succ2 k map_consts = if Int64.eq n Int64.zero then cbranch_int64s true cmp a1 a1 info succ1 succ2 k else let r = r2pi () in - loadimm64 a1 r n (n2pi ()) - (cbranch_int64s false cmp a1 r info succ1 succ2 k) + let ht = loadimm64 r n (n2pi ()) map_consts in + let r' = unzip_head_tuple ht r in + fst ht @ cbranch_int64s false cmp a1 r' info succ1 succ2 k -let expanse_cbranchimm_int64u cmp a1 n info succ1 succ2 k = +let expanse_cbranchimm_int64u cmp a1 n info succ1 succ2 k map_consts = if Int64.eq n Int64.zero then cbranch_int64u true cmp a1 a1 info succ1 succ2 k else let r = r2pi () in - loadimm64 a1 r n (n2pi ()) - (cbranch_int64u false cmp a1 r info succ1 succ2 k) + let ht = loadimm64 r n (n2pi ()) map_consts in + let r' = unzip_head_tuple ht r in + fst ht @ cbranch_int64u false cmp a1 r' info succ1 succ2 k -let expanse_condimm_int32s cmp a1 n dest succ k = +let expanse_condimm_int32s cmp a1 n dest succ k map_consts = if Int.eq n Int.zero then cond_int32s true cmp a1 a1 dest succ k else match cmp with | Ceq | Cne -> let r = r2pi () in - xorimm32 a1 r n (n2pi ()) false (cond_int32s true cmp r r dest succ k) - | Clt -> sltimm32 a1 dest n succ false k + xorimm32 a1 r n (n2pi ()) + (cond_int32s true cmp r r dest succ k) + map_consts + | Clt -> sltimm32 a1 dest n succ k map_consts | Cle -> if Int.eq n (Int.repr Int.max_signed) then - loadimm32 a1 dest Int.one succ false k - else sltimm32 a1 dest (Int.add n Int.one) succ false k + let ht = loadimm32 dest Int.one succ map_consts in + fst ht @ k + else sltimm32 a1 dest (Int.add n Int.one) succ k map_consts | _ -> let r = r2pi () in - loadimm32 a1 r n (n2pi ()) false - (cond_int32s false cmp a1 r dest succ k) + let ht = loadimm32 r n (n2pi ()) map_consts in + let r' = unzip_head_tuple ht r in + fst ht @ cond_int32s false cmp a1 r' dest succ k -let expanse_condimm_int32u cmp a1 n dest succ k = +let expanse_condimm_int32u cmp a1 n dest succ k map_consts = if Int.eq n Int.zero then cond_int32u true cmp a1 a1 dest succ k else match cmp with - | Clt -> sltuimm32 a1 dest n succ false k + | Clt -> sltuimm32 a1 dest n succ k map_consts | _ -> let r = r2pi () in - loadimm32 a1 r n (n2pi ()) false - (cond_int32u false cmp a1 r dest succ k) + let ht = loadimm32 r n (n2pi ()) map_consts in + let r' = unzip_head_tuple ht r in + fst ht @ cond_int32u false cmp a1 r' dest succ k -let expanse_condimm_int64s cmp a1 n dest succ k = +let expanse_condimm_int64s cmp a1 n dest succ k map_consts = if Int64.eq n Int64.zero then cond_int64s true cmp a1 a1 dest succ k else match cmp with | Ceq | Cne -> let r = r2pi () in - xorimm64 a1 r n (n2pi ()) (cond_int64s true cmp r r dest succ k) - | Clt -> sltimm64 a1 dest n succ k + xorimm64 a1 r n (n2pi ()) + (cond_int64s true cmp r r dest succ k) + map_consts + | Clt -> sltimm64 a1 dest n succ k map_consts | Cle -> if Int64.eq n (Int64.repr Int64.max_signed) then - loadimm32 a1 dest Int.one succ true k - else sltimm64 a1 dest (Int64.add n Int64.one) succ k + let ht = loadimm32 dest Int.one succ map_consts in + fst ht @ k + else sltimm64 a1 dest (Int64.add n Int64.one) succ k map_consts | _ -> let r = r2pi () in - loadimm64 a1 r n (n2pi ()) (cond_int64s false cmp a1 r dest succ k) + let ht = loadimm64 r n (n2pi ()) map_consts in + let r' = unzip_head_tuple ht r in + fst ht @ cond_int64s false cmp a1 r' dest succ k -let expanse_condimm_int64u cmp a1 n dest succ k = +let expanse_condimm_int64u cmp a1 n dest succ k map_consts = if Int64.eq n Int64.zero then cond_int64u true cmp a1 a1 dest succ k else match cmp with - | Clt -> sltuimm64 a1 dest n succ k + | Clt -> sltuimm64 a1 dest n succ k map_consts | _ -> let r = r2pi () in - loadimm64 a1 r n (n2pi ()) (cond_int64u false cmp a1 r dest succ k) + let ht = loadimm64 r n (n2pi ()) map_consts in + let r' = unzip_head_tuple ht r in + fst ht @ cond_int64u false cmp a1 r' dest succ k let expanse_cond_fp cnot fn_cond cmp f1 f2 dest succ k = let normal = is_normal_cmp cmp in @@ -368,12 +443,12 @@ let write_pathmap initial esize pm' = let rec write_tree exp current code' new_order = match exp with | (Iop (_, _, _, succ) as inst) :: k -> - code' := PTree.set (Camlcoq.P.of_int current) inst !code'; - new_order := Camlcoq.P.of_int current :: !new_order; + code' := PTree.set (P.of_int current) inst !code'; + new_order := P.of_int current :: !new_order; write_tree k (current - 1) code' new_order | (Icond (_, _, succ1, succ2, _) as inst) :: k -> - code' := PTree.set (Camlcoq.P.of_int current) inst !code'; - new_order := Camlcoq.P.of_int current :: !new_order; + code' := PTree.set (P.of_int current) inst !code'; + new_order := P.of_int current :: !new_order; write_tree k (current - 1) code' new_order | [] -> () | _ -> failwith "ExpansionOracle.write_tree: inconsistent instruction." @@ -387,11 +462,13 @@ let expanse (sb : superblock) code pm = let was_exp = ref false in let code' = ref code in let pm' = ref pm in + let map_consts = Hashtbl.create 100 in Array.iter (fun n -> was_branch := false; was_exp := false; let inst = get_some @@ PTree.get n code in + (*print_instruction stderr (0, inst);*) (match inst with | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> debug "Iop/Ccomp\n"; @@ -403,11 +480,11 @@ let expanse (sb : superblock) code pm = was_exp := true | Iop (Ocmp (Ccompimm (c, imm)), a1 :: nil, dest, succ) -> debug "Iop/Ccompimm\n"; - exp := expanse_condimm_int32s c a1 imm dest succ []; + exp := expanse_condimm_int32s c a1 imm dest succ [] map_consts; was_exp := true | Iop (Ocmp (Ccompuimm (c, imm)), a1 :: nil, dest, succ) -> debug "Iop/Ccompuimm\n"; - exp := expanse_condimm_int32u c a1 imm dest succ []; + exp := expanse_condimm_int32u c a1 imm dest succ [] map_consts; was_exp := true | Iop (Ocmp (Ccompl c), a1 :: a2 :: nil, dest, succ) -> debug "Iop/Ccompl\n"; @@ -419,11 +496,11 @@ let expanse (sb : superblock) code pm = was_exp := true | Iop (Ocmp (Ccomplimm (c, imm)), a1 :: nil, dest, succ) -> debug "Iop/Ccomplimm\n"; - exp := expanse_condimm_int64s c a1 imm dest succ []; + exp := expanse_condimm_int64s c a1 imm dest succ [] map_consts; was_exp := true | Iop (Ocmp (Ccompluimm (c, imm)), a1 :: nil, dest, succ) -> debug "Iop/Ccompluimm\n"; - exp := expanse_condimm_int64u c a1 imm dest succ []; + exp := expanse_condimm_int64u c a1 imm dest succ [] map_consts; was_exp := true | Iop (Ocmp (Ccompf c), f1 :: f2 :: nil, dest, succ) -> debug "Iop/Ccompf\n"; @@ -453,12 +530,14 @@ let expanse (sb : superblock) code pm = was_exp := true | Icond (Ccompimm (c, imm), a1 :: nil, succ1, succ2, info) -> debug "Icond/Ccompimm\n"; - exp := expanse_cbranchimm_int32s c a1 imm info succ1 succ2 []; + exp := + expanse_cbranchimm_int32s c a1 imm info succ1 succ2 [] map_consts; was_branch := true; was_exp := true | Icond (Ccompuimm (c, imm), a1 :: nil, succ1, succ2, info) -> debug "Icond/Ccompuimm\n"; - exp := expanse_cbranchimm_int32u c a1 imm info succ1 succ2 []; + exp := + expanse_cbranchimm_int32u c a1 imm info succ1 succ2 [] map_consts; was_branch := true; was_exp := true | Icond (Ccompl c, a1 :: a2 :: nil, succ1, succ2, info) -> @@ -473,12 +552,14 @@ let expanse (sb : superblock) code pm = was_exp := true | Icond (Ccomplimm (c, imm), a1 :: nil, succ1, succ2, info) -> debug "Icond/Ccomplimm\n"; - exp := expanse_cbranchimm_int64s c a1 imm info succ1 succ2 []; + exp := + expanse_cbranchimm_int64s c a1 imm info succ1 succ2 [] map_consts; was_branch := true; was_exp := true | Icond (Ccompluimm (c, imm), a1 :: nil, succ1, succ2, info) -> debug "Icond/Ccompluimm\n"; - exp := expanse_cbranchimm_int64u c a1 imm info succ1 succ2 []; + exp := + expanse_cbranchimm_int64u c a1 imm info succ1 succ2 [] map_consts; was_branch := true; was_exp := true | Icond (Ccompf c, f1 :: f2 :: nil, succ1, succ2, info) -> @@ -509,9 +590,7 @@ let expanse (sb : superblock) code pm = let lives = PTree.get n !liveins in match lives with | Some lives -> - let new_branch_pc = - Camlcoq.P.of_int (!node - (List.length !exp - 1)) - in + let new_branch_pc = P.of_int (!node - (List.length !exp - 1)) in liveins := PTree.set new_branch_pc lives !liveins; liveins := PTree.remove n !liveins | _ -> ()); @@ -521,6 +600,7 @@ let expanse (sb : superblock) code pm = sb.instructions; sb.instructions <- Array.of_list (List.rev !new_order); sb.liveins <- !liveins; + (*print_arrayp sb.instructions;*) (*debug_flag := false;*) (!code', !pm') @@ -530,7 +610,7 @@ let rec find_last_node_reg = function let rec traverse_list var = function | [] -> () | e :: t -> - let e' = Camlcoq.P.to_int e in + let e' = p2i e in if e' > !var then var := e'; traverse_list var t in diff --git a/riscV/NeedOp.v b/riscV/NeedOp.v index 4b309f5b..46d6ee73 100644 --- a/riscV/NeedOp.v +++ b/riscV/NeedOp.v @@ -96,8 +96,8 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | OEsltiw _ => op1 (default nv) | OEsltiuw _ => op1 (default nv) | OExoriw _ => op1 (bitwise nv) - | OEluiw _ _ => op1 (default nv) - | OEaddiwr0 _ _ => op1 (default nv) (* TODO gourdinl modarith impossible? *) + | OEluiw _ => op1 (default nv) + | OEaddiwr0 _ => op1 (default nv) (* TODO gourdinl modarith impossible? *) | OEseql _ => op2 (default nv) | OEsnel _ => op2 (default nv) | OEsequl _ => op2 (default nv) @@ -110,6 +110,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | OEluil _ => op1 (default nv) | OEaddilr0 _ => op1 (default nv) (* TODO gourdinl modarith impossible? *) | OEloadli _ => op1 (default nv) + | OEmayundef _ => op2 (default nv) | OEfeqd => op2 (default nv) | OEfltd => op2 (default nv) | OEfled => op2 (default nv) diff --git a/riscV/Op.v b/riscV/Op.v index 8b4d444d..d902c907 100644 --- a/riscV/Op.v +++ b/riscV/Op.v @@ -181,8 +181,8 @@ Inductive operation : Type := | OEsltiw (n: int) (**r set-less-than immediate *) | OEsltiuw (n: int) (**r set-less-than unsigned immediate *) | OExoriw (n: int) (**r xor immediate *) - | OEluiw (n: int) (is_long: bool) (**r load upper-immediate *) - | OEaddiwr0 (n: int) (is_long: bool) (**r add immediate *) + | OEluiw (n: int) (**r load upper-immediate *) + | OEaddiwr0 (n: int) (**r add immediate *) | OEseql (optR0: option bool) (**r [rd <- rs1 == rs2] signed *) | OEsnel (optR0: option bool) (**r [rd <- rs1 != rs2] signed *) | OEsequl (optR0: option bool) (**r [rd <- rs1 == rs2] unsigned *) @@ -195,6 +195,7 @@ Inductive operation : Type := | OEluil (n: int64) (**r load upper-immediate *) | OEaddilr0 (n: int64) (**r add immediate *) | OEloadli (n: int64) (**r load an immediate int64 *) + | OEmayundef (is_long: bool) | OEfeqd (**r compare equal *) | OEfltd (**r compare less-than *) | OEfled (**r compare less-than/equal *) @@ -269,24 +270,18 @@ Definition apply_bin_r0 {B} (optR0: option bool) (sem: val -> val -> B) (v1 v2 v | Some false => sem v1 vz end. -Definition may_undef_int (is_long: bool) (sem: val -> val -> val) (v1 vimm vz: val): val := +Definition may_undef_int (is_long: bool) (v1 v2: val): val := if negb is_long then match v1 with - | Vint _ => sem vimm vz + | Vint _ => v2 | _ => Vundef end else match v1 with - | Vlong _ => sem vimm vz + | Vlong _ => v2 | _ => Vundef end. -Definition may_undef_luil (v1: val) (n: int64): val := - match v1 with - | Vlong _ => Vlong (Int64.sign_ext 32 (Int64.shl n (Int64.repr 12))) - | _ => Vundef - end. - Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := match cond, vl with | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 @@ -432,8 +427,8 @@ Definition eval_operation | OEsltiw n, v1::nil => Some (Val.cmp Clt v1 (Vint n)) | OEsltiuw n, v1::nil => Some (Val.cmpu (Mem.valid_pointer m) Clt v1 (Vint n)) | OExoriw n, v1::nil => Some (Val.xor v1 (Vint n)) - | OEluiw n is_long, v1::nil => Some (may_undef_int is_long Val.shl v1 (Vint n) (Vint (Int.repr 12))) - | OEaddiwr0 n is_long, v1::nil => Some (may_undef_int is_long Val.add v1 (Vint n) zero32) + | OEluiw n, nil => Some (Val.shl (Vint n) (Vint (Int.repr 12))) + | OEaddiwr0 n, nil => Some (Val.add (Vint n) zero32) | OEseql optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Ceq) v1 v2 zero64)) | OEsnel optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Cne) v1 v2 zero64)) | OEsequl optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) Ceq) v1 v2 zero64)) @@ -443,9 +438,10 @@ Definition eval_operation | OEsltil n, v1::nil => Some (Val.maketotal (Val.cmpl Clt v1 (Vlong n))) | OEsltiul n, v1::nil => Some (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 (Vlong n))) | OExoril n, v1::nil => Some (Val.xorl v1 (Vlong n)) - | OEluil n, v1::nil => Some (may_undef_luil v1 n) - | OEaddilr0 n, v1::nil => Some (may_undef_int true Val.addl v1 (Vlong n) zero64) + | OEluil n, nil => Some (Vlong (Int64.sign_ext 32 (Int64.shl n (Int64.repr 12)))) + | OEaddilr0 n, nil => Some (Val.addl (Vlong n) zero64) | OEloadli n, nil => Some (Vlong n) + | OEmayundef is_long, v1::v2::nil => Some (may_undef_int is_long v1 v2) | OEfeqd, v1::v2::nil => Some (Val.cmpf Ceq v1 v2) | OEfltd, v1::v2::nil => Some (Val.cmpf Clt v1 v2) | OEfled, v1::v2::nil => Some (Val.cmpf Cle v1 v2) @@ -634,8 +630,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | OEsltiw _ => (Tint :: nil, Tint) | OEsltiuw _ => (Tint :: nil, Tint) | OExoriw _ => (Tint :: nil, Tint) - | OEluiw _ _ => (Tint :: nil, Tint) - | OEaddiwr0 _ _ => (Tint :: nil, Tint) + | OEluiw _ => (nil, Tint) + | OEaddiwr0 _ => (nil, Tint) | OEseql _ => (Tlong :: Tlong :: nil, Tint) | OEsnel _ => (Tlong :: Tlong :: nil, Tint) | OEsequl _ => (Tlong :: Tlong :: nil, Tint) @@ -645,9 +641,10 @@ Definition type_of_operation (op: operation) : list typ * typ := | OEsltil _ => (Tlong :: nil, Tint) | OEsltiul _ => (Tlong :: nil, Tint) | OExoril _ => (Tlong :: nil, Tlong) - | OEluil _ => (Tlong :: nil, Tlong) - | OEaddilr0 _ => (Tlong :: nil, Tlong) + | OEluil _ => (nil, Tlong) + | OEaddilr0 _ => (nil, Tlong) | OEloadli _ => (nil, Tlong) + | OEmayundef _ => (Tany64 :: Tany64 :: nil, Tany64) | OEfeqd => (Tfloat :: Tfloat :: nil, Tint) | OEfltd => (Tfloat :: Tfloat :: nil, Tint) | OEfled => (Tfloat :: Tfloat :: nil, Tint) @@ -892,10 +889,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0... (* OEluiw *) - unfold may_undef_int; - destruct v0, is_long; simpl; trivial; destruct (Int.ltu _ _); cbn; trivial. (* OEaddiwr0 *) - - destruct v0, is_long; simpl; trivial. + - simpl; trivial. (* OEseql *) - destruct optR0 as [[]|]; simpl; unfold Val.cmpl; destruct Val.cmpl_bool... all: destruct b... @@ -922,11 +918,14 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* OExoril *) - destruct v0... (* OEluil *) - - destruct v0; simpl; trivial. + - simpl; trivial. (* OEaddilr0 *) - - destruct v0; simpl; trivial. + - simpl; trivial. (* OEloadli *) - trivial. + (* OEmayundef *) + - unfold may_undef_int; + destruct is_long, v0, v1; simpl; trivial. (* OEfeqd *) - destruct v0; destruct v1; cbn; auto. destruct Float.cmp; cbn; auto. @@ -1740,14 +1739,7 @@ Proof. (* OExoriw *) - inv H4; simpl; auto. (* OEluiw *) - - unfold may_undef_int; - destruct is_long; - inv H4; simpl; auto; - destruct (Int.ltu _ _); auto. - (* OEaddiwr0 *) - - unfold may_undef_int; - destruct is_long; - inv H4; simpl; auto. + - destruct (Int.ltu _ _); auto. (* OEseql *) - destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmpl; inv H4; inv H2; simpl; try destruct (Int64.eq _ _); simpl; cbn; auto; @@ -1772,11 +1764,10 @@ Proof. - apply eval_cmplu_bool_inj; auto. (* OExoril *) - inv H4; simpl; auto. - (* OEluil *) - - inv H4; simpl; auto. - (* OEaddilr0 *) - - unfold may_undef_int; - inv H4; simpl; auto. + (* OEmayundef *) + - destruct is_long; inv H4; inv H2; + unfold may_undef_int; simpl; auto; + eapply Val.inject_ptr; eauto. (* OEfeqd *) - inv H4; inv H2; cbn; simpl; auto. destruct Float.cmp; unfold Vtrue, Vfalse; cbn; auto. diff --git a/riscV/PrintOp.ml b/riscV/PrintOp.ml index 84380251..8ba72fb2 100644 --- a/riscV/PrintOp.ml +++ b/riscV/PrintOp.ml @@ -202,8 +202,8 @@ let print_operation reg pp = function | OEsltiw n, [r1] -> fprintf pp "OEsltiw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEsltiuw n, [r1] -> fprintf pp "OEsltiuw(%a,%ld)" reg r1 (camlint_of_coqint n) | OExoriw n, [r1] -> fprintf pp "OExoriw(%a,%ld)" reg r1 (camlint_of_coqint n) - | OEluiw (n, _), _ -> fprintf pp "OEluiw(%ld)" (camlint_of_coqint n) - | OEaddiwr0 (n, _), _ -> fprintf pp "OEaddiwr0(%ld,X0)" (camlint_of_coqint n) + | OEluiw n, _ -> fprintf pp "OEluiw(%ld)" (camlint_of_coqint n) + | OEaddiwr0 n, _ -> fprintf pp "OEaddiwr0(%ld,X0)" (camlint_of_coqint n) | OEseql optR0, [r1;r2] -> fprintf pp "OEseql"; (get_optR0_s Ceq reg pp r1 r2 optR0) | OEsnel optR0, [r1;r2] -> fprintf pp "OEsnel"; (get_optR0_s Cne reg pp r1 r2 optR0) | OEsequl optR0, [r1;r2] -> fprintf pp "OEsequl"; (get_optR0_s Ceq reg pp r1 r2 optR0) @@ -216,6 +216,7 @@ let print_operation reg pp = function | OEluil n, _ -> fprintf pp "OEluil(%ld)" (camlint_of_coqint n) | OEaddilr0 n, _ -> fprintf pp "OEaddilr0(%ld,X0)" (camlint_of_coqint n) | OEloadli n, _ -> fprintf pp "OEloadli(%ld)" (camlint_of_coqint n) + | OEmayundef isl, [r1;r2] -> fprintf pp "OEmayundef (%b,%a,%a)" isl reg r1 reg r2 | OEfeqd, [r1;r2] -> fprintf pp "OEfeqd(%a,%s,%a)" reg r1 (comparison_name Ceq) reg r2 | OEfltd, [r1;r2] -> fprintf pp "OEfltd(%a,%s,%a)" reg r1 (comparison_name Clt) reg r2 | OEfled, [r1;r2] -> fprintf pp "OEfled(%a,%s,%a)" reg r1 (comparison_name Cle) reg r2 diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index 6a0297e9..0180c0dd 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -31,48 +31,44 @@ Definition make_lhsv_single (hvs: hsval) : list_hsval := (* Immediate loads *) -Definition load_hilo32 (hv1: hsval) (hi lo: int) (is_long: bool) := - let hl := make_lhsv_single hv1 in +Definition load_hilo32 (hi lo: int) := if Int.eq lo Int.zero then - fSop (OEluiw hi is_long) hl + fSop (OEluiw hi) fSnil else - let hvs := fSop (OEluiw hi is_long) hl in - let hl' := make_lhsv_single hvs in - fSop (Oaddimm lo) hl'. + let hvs := fSop (OEluiw hi) fSnil in + let hl := make_lhsv_single hvs in + fSop (Oaddimm lo) hl. -Definition load_hilo64 (hv1: hsval) (hi lo: int64) := - let hl := make_lhsv_single hv1 in +Definition load_hilo64 (hi lo: int64) := if Int64.eq lo Int64.zero then - fSop (OEluil hi) hl + fSop (OEluil hi) fSnil else - let hvs := fSop (OEluil hi) hl in + let hvs := fSop (OEluil hi) fSnil in let hl := make_lhsv_single hvs in fSop (Oaddlimm lo) hl. -Definition loadimm32 (hv1: hsval) (n: int) (is_long: bool) := +Definition loadimm32 (n: int) := match make_immed32 n with | Imm32_single imm => - let hl := make_lhsv_single hv1 in - fSop (OEaddiwr0 imm is_long) hl - | Imm32_pair hi lo => load_hilo32 hv1 hi lo is_long + fSop (OEaddiwr0 imm) fSnil + | Imm32_pair hi lo => load_hilo32 hi lo end. -Definition loadimm64 (hv1: hsval) (n: int64) := +Definition loadimm64 (n: int64) := match make_immed64 n with | Imm64_single imm => - let hl := make_lhsv_single hv1 in - fSop (OEaddilr0 imm) hl - | Imm64_pair hi lo => load_hilo64 hv1 hi lo + fSop (OEaddilr0 imm) fSnil + | Imm64_pair hi lo => load_hilo64 hi lo | Imm64_large imm => fSop (OEloadli imm) fSnil end. -Definition opimm32 (hv1: hsval) (n: int) (op: operation) (opimm: int -> operation) (is_long: bool) := +Definition opimm32 (hv1: hsval) (n: int) (op: operation) (opimm: int -> operation) := match make_immed32 n with | Imm32_single imm => let hl := make_lhsv_single hv1 in fSop (opimm imm) hl | Imm32_pair hi lo => - let hvs := load_hilo32 hv1 hi lo is_long in + let hvs := load_hilo32 hi lo in let hl := make_lhsv_cmp false hv1 hvs in fSop op hl end. @@ -83,7 +79,7 @@ Definition opimm64 (hv1: hsval) (n: int64) (op: operation) (opimm: int64 -> oper let hl := make_lhsv_single hv1 in fSop (opimm imm) hl | Imm64_pair hi lo => - let hvs := load_hilo64 hv1 hi lo in + let hvs := load_hilo64 hi lo in let hl := make_lhsv_cmp false hv1 hvs in fSop op hl | Imm64_large imm => @@ -92,9 +88,9 @@ Definition opimm64 (hv1: hsval) (n: int64) (op: operation) (opimm: int64 -> oper fSop op hl end. -Definition xorimm32 (hv1: hsval) (n: int) (is_long: bool) := opimm32 hv1 n Oxor OExoriw is_long. -Definition sltimm32 (hv1: hsval) (n: int) (is_long: bool) := opimm32 hv1 n (OEsltw None) OEsltiw is_long. -Definition sltuimm32 (hv1: hsval) (n: int) (is_long: bool) := opimm32 hv1 n (OEsltuw None) OEsltiuw is_long. +Definition xorimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oxor OExoriw. +Definition sltimm32 (hv1: hsval) (n: int) := opimm32 hv1 n (OEsltw None) OEsltiw. +Definition sltuimm32 (hv1: hsval) (n: int) := opimm32 hv1 n (OEsltuw None) OEsltiuw. Definition xorimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oxorl OExoril. Definition sltimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltl None) OEsltil. Definition sltuimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltul None) OEsltiul. @@ -155,17 +151,19 @@ Definition expanse_condimm_int32s (cmp: comparison) (hv1: hsval) (n: int) := match cmp with | Ceq | Cne => let optR0 := make_optR0 true is_inv in - let hvs := xorimm32 hv1 n false in + let hvs := xorimm32 hv1 n in let hl := make_lhsv_cmp false hvs hvs in cond_int32s cmp hl optR0 - | Clt => sltimm32 hv1 n false + | Clt => sltimm32 hv1 n | Cle => if Int.eq n (Int.repr Int.max_signed) then - loadimm32 hv1 Int.one false - else sltimm32 hv1 (Int.add n Int.one) false + let hvs := loadimm32 Int.one in + let hl := make_lhsv_cmp false hv1 hvs in + fSop (OEmayundef false) hl + else sltimm32 hv1 (Int.add n Int.one) | _ => let optR0 := make_optR0 false is_inv in - let hvs := loadimm32 hv1 n false in + let hvs := loadimm32 n in let hl := make_lhsv_cmp is_inv hv1 hvs in cond_int32s cmp hl optR0 end. @@ -178,10 +176,10 @@ Definition expanse_condimm_int32u (cmp: comparison) (hv1: hsval) (n: int) := cond_int32u cmp hl optR0 else match cmp with - | Clt => sltuimm32 hv1 n false + | Clt => sltuimm32 hv1 n | _ => let optR0 := make_optR0 false is_inv in - let hvs := loadimm32 hv1 n false in + let hvs := loadimm32 n in let hl := make_lhsv_cmp is_inv hv1 hvs in cond_int32u cmp hl optR0 end. @@ -202,11 +200,13 @@ Definition expanse_condimm_int64s (cmp: comparison) (hv1: hsval) (n: int64) := | Clt => sltimm64 hv1 n | Cle => if Int64.eq n (Int64.repr Int64.max_signed) then - loadimm32 hv1 Int.one true + let hvs := loadimm32 Int.one in + let hl := make_lhsv_cmp false hv1 hvs in + fSop (OEmayundef true) hl else sltimm64 hv1 (Int64.add n Int64.one) | _ => let optR0 := make_optR0 false is_inv in - let hvs := loadimm64 hv1 n in + let hvs := loadimm64 n in let hl := make_lhsv_cmp is_inv hv1 hvs in cond_int64s cmp hl optR0 end. @@ -222,7 +222,7 @@ Definition expanse_condimm_int64u (cmp: comparison) (hv1: hsval) (n: int64) := | Clt => sltuimm64 hv1 n | _ => let optR0 := make_optR0 false is_inv in - let hvs := loadimm64 hv1 n in + let hvs := loadimm64 n in let hl := make_lhsv_cmp is_inv hv1 hvs in cond_int64u cmp hl optR0 end. @@ -395,7 +395,7 @@ Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args let cond := transl_cbranch_int32s c (make_optR0 true is_inv) in Some (cond, lhsv) else - let hvs := loadimm32 hv1 n false in + let hvs := loadimm32 n in let lhsv := make_lhsv_cmp is_inv hv1 hvs in let cond := transl_cbranch_int32s c (make_optR0 false is_inv) in Some (cond, lhsv)) @@ -407,7 +407,7 @@ Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args let cond := transl_cbranch_int32u c (make_optR0 true is_inv) in Some (cond, lhsv) else - let hvs := loadimm32 hv1 n false in + let hvs := loadimm32 n in let lhsv := make_lhsv_cmp is_inv hv1 hvs in let cond := transl_cbranch_int32u c (make_optR0 false is_inv) in Some (cond, lhsv)) @@ -433,7 +433,7 @@ Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args let cond := transl_cbranch_int64s c (make_optR0 true is_inv) in Some (cond, lhsv) else - let hvs := loadimm64 hv1 n in + let hvs := loadimm64 n in let lhsv := make_lhsv_cmp is_inv hv1 hvs in let cond := transl_cbranch_int64s c (make_optR0 false is_inv) in Some (cond, lhsv)) @@ -445,7 +445,7 @@ Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args let cond := transl_cbranch_int64u c (make_optR0 true is_inv) in Some (cond, lhsv) else - let hvs := loadimm64 hv1 n in + let hvs := loadimm64 n in let lhsv := make_lhsv_cmp is_inv hv1 hvs in let cond := transl_cbranch_int64u c (make_optR0 false is_inv) in Some (cond, lhsv)) @@ -842,7 +842,6 @@ Proof. try rewrite OKv1; try rewrite OK2; try rewrite (Int.add_commut _ Int.zero), Int.add_zero_l in H; subst; - try rewrite xor_neg_ltle_cmp; trivial; unfold Val.cmp, may_undef_int, zero32, Val.add; simpl; destruct v; auto. all: @@ -896,12 +895,12 @@ Proof. rewrite HMEM; unfold may_undef_int, Val.cmpu; destruct v; simpl; auto; - try rewrite EQIMM; try destruct (Archi.ptr64); simpl; + try rewrite EQIMM; try destruct (Archi.ptr64) eqn:EQARCH; simpl; try rewrite ltu_12_wordsize; trivial; - try rewrite Int.add_commut, Int.add_zero_l; + try rewrite Int.add_commut, Int.add_zero_l in *; try destruct (Int.ltu _ _) eqn:EQLTU; simpl; - try rewrite EQLTU; simpl; - trivial. + try rewrite EQLTU; simpl; try rewrite EQIMM; + try rewrite EQARCH; trivial. Qed. Lemma simplify_ccompl_correct ge sp hst st c r r0 rs0 m0 v v0: forall @@ -1008,12 +1007,11 @@ Proof. try erewrite !fsi_sreg_get_correct; eauto; try rewrite OKv1; try rewrite OK2; - unfold may_undef_luil; try rewrite (Int64.add_commut _ Int64.zero), Int64.add_zero_l in H; subst; try fold (Val.cmpl Clt v (Vlong imm)); try rewrite xor_neg_ltge_cmpl; trivial; try rewrite xor_neg_ltle_cmpl; trivial; - unfold Val.cmpl, may_undef_luil, Val.addl; + unfold Val.cmpl, Val.addl; try rewrite xorl_zero_eq_cmpl; trivial; try rewrite optbool_mktotal; trivial; unfold may_undef_int, zero32, Val.add; simpl; @@ -1286,7 +1284,7 @@ Proof. try destruct (Int64.eq lo Int64.zero) eqn:EQLO; try apply Int.same_if_eq in EQLO; simpl; trivial; try apply Int64.same_if_eq in EQLO; simpl; trivial; - unfold may_undef_int, may_undef_luil; + unfold may_undef_int; try erewrite !fsi_sreg_get_correct; eauto; try rewrite OKv1; simpl; trivial; try destruct v; try rewrite H; diff --git a/riscV/ValueAOp.v b/riscV/ValueAOp.v index 97f3ff61..d50bd00f 100644 --- a/riscV/ValueAOp.v +++ b/riscV/ValueAOp.v @@ -27,24 +27,18 @@ Definition apply_bin_r0 {B} (optR0: option bool) (sem: aval -> aval -> B) (v1 v2 | Some false => sem v1 vz end. -Definition may_undef_int (is_long: bool) (sem: aval -> aval -> aval) (v1 vimm vz: aval): aval := +Definition may_undef_int (is_long: bool) (v1 v2: aval): aval := if negb is_long then match v1 with - | I _ => sem vimm vz + | I _ => v2 | _ => Ifptr Ptop end else match v1 with - | L _ => sem vimm vz + | L _ => v2 | _ => Ifptr Ptop end. -Definition may_undef_luil (v1: aval) (n: int64): aval := - match v1 with - | L _ => sign_ext 32 (shll (L n) (L (Int64.repr 12))) - | _ => Ifptr Ptop - end. - Definition eval_static_condition (cond: condition) (vl: list aval): abool := match cond, vl with | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2 @@ -223,8 +217,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | OEsltiw n, v1::nil => of_optbool (cmp_bool Clt v1 (I n)) | OEsltiuw n, v1::nil => of_optbool (cmpu_bool Clt v1 (I n)) | OExoriw n, v1::nil => xor v1 (I n) - | OEluiw n is_long, v1::nil => may_undef_int is_long shl v1 (I n) (I (Int.repr 12)) - | OEaddiwr0 n is_long, v1::nil => may_undef_int is_long add v1 (I n) zero32 + | OEluiw n, nil => shl (I n) (I (Int.repr 12)) + | OEaddiwr0 n, nil => add (I n) zero32 | OEseql optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Ceq) v1 v2 zero64) | OEsnel optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Cne) v1 v2 zero64) | OEsequl optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmplu_bool Ceq) v1 v2 zero64) @@ -234,9 +228,10 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | OEsltil n, v1::nil => of_optbool (cmpl_bool Clt v1 (L n)) | OEsltiul n, v1::nil => of_optbool (cmplu_bool Clt v1 (L n)) | OExoril n, v1::nil => xorl v1 (L n) - | OEluil n, v1::nil => may_undef_luil v1 n - | OEaddilr0 n, v1::nil => may_undef_int true addl v1 (L n) zero64 + | OEluil n, nil => sign_ext 32 (shll (L n) (L (Int64.repr 12))) + | OEaddilr0 n, nil => addl (L n) zero64 | OEloadli n, nil => L (n) + | OEmayundef is_long, v1::v2::nil => may_undef_int is_long v1 v2 | OEfeqd, v1::v2::nil => of_optbool (cmpf_bool Ceq v1 v2) | OEfltd, v1::v2::nil => of_optbool (cmpf_bool Clt v1 v2) | OEfled, v1::v2::nil => of_optbool (cmpf_bool Cle v1 v2) @@ -464,14 +459,18 @@ Proof. 1,2,3: apply eval_cmp_sound; auto. unfold Val.cmp; apply of_optbool_sound; eauto with va. unfold Val.cmpu; apply of_optbool_sound; eauto with va. - unfold zero32; simpl; eauto with va. - - 1,2,11,12: - try unfold Op.may_undef_int, may_undef_int, Op.zero32, zero32, Op.zero64, zero64; - try unfold Op.may_undef_luil, may_undef_luil; simpl; unfold ntop1; - inv H1; try destruct is_long; simpl; try destruct (Int.ltu _ _); eauto with va; - try apply vmatch_ifptr_i; try apply vmatch_ifptr_l. - + + simpl; try destruct (Int.ltu _ _); eauto with va; unfold ntop1; + try apply vmatch_ifptr_undef. + 10: + simpl; unfold ntop1, sign_ext, Int64.sign_ext, sgn; simpl; + apply vmatch_ifptr_l. + 1,10: simpl; eauto with va. + 9: + unfold Op.may_undef_int, may_undef_int; destruct is_long; + simpl; inv H0; inv H1; eauto with va; inv H; + apply vmatch_ifptr_p; eauto with va. + 3,4,6: apply eval_cmplu_sound; auto. 1,2,3: apply eval_cmpl_sound; auto. unfold Val.cmpl; apply of_optbool_maketotal_sound; eauto with va. -- cgit From 9882b3427b9dfc7e8f2de3402773fb3a1a49f14a Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Sat, 6 Mar 2021 16:46:23 +0100 Subject: some simplification in miniCSE --- riscV/ExpansionOracle.ml | 31 ++++++++++++++----------------- 1 file changed, 14 insertions(+), 17 deletions(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 44049ecf..ccaad6f4 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -46,13 +46,10 @@ let n2pi () = type immt = Xoriw | Xoril | Sltiw | Sltiuw | Sltil | Sltiul -let debug_was_cse = ref false - -let find_or_addnmove op args rd succ sargs map_consts = - let sop = Sop (op, sargs) in +let find_or_addnmove op args rd succ map_consts = + let sop = Sop (op, args) in match Hashtbl.find_opt map_consts sop with | Some r -> - debug_was_cse := true; Sr (P.of_int r) | None -> Hashtbl.add map_consts sop (p2i rd); @@ -64,40 +61,40 @@ let build_head_tuple head sv = let load_hilo32 dest hi lo succ map_consts = let op1 = OEluiw hi in if Int.eq lo Int.zero then - let sv = find_or_addnmove op1 [] dest succ [] map_consts in + let sv = find_or_addnmove op1 [] dest succ map_consts in build_head_tuple [] sv else let r = r2pi () in let op2 = Oaddimm lo in - match find_or_addnmove op1 [] r (n2pi ()) [] map_consts with + match find_or_addnmove op1 [] r (n2pi ()) map_consts with | Si i -> - let sv = find_or_addnmove op2 [ r ] dest succ [ r ] map_consts in + let sv = find_or_addnmove op2 [ r ] dest succ map_consts in build_head_tuple [ i ] sv | Sr r' -> - let sv = find_or_addnmove op2 [ r' ] dest succ [ r' ] map_consts in + let sv = find_or_addnmove op2 [ r' ] dest succ map_consts in build_head_tuple [] sv let load_hilo64 dest hi lo succ map_consts = let op1 = OEluil hi in if Int64.eq lo Int64.zero then - let sv = find_or_addnmove op1 [] dest succ [] map_consts in + let sv = find_or_addnmove op1 [] dest succ map_consts in build_head_tuple [] sv else let r = r2pi () in let op2 = Oaddlimm lo in - match find_or_addnmove op1 [] r (n2pi ()) [] map_consts with + match find_or_addnmove op1 [] r (n2pi ()) map_consts with | Si i -> - let sv = find_or_addnmove op2 [ r ] dest succ [ r ] map_consts in + let sv = find_or_addnmove op2 [ r ] dest succ map_consts in build_head_tuple [ i ] sv | Sr r' -> - let sv = find_or_addnmove op2 [ r' ] dest succ [ r' ] map_consts in + let sv = find_or_addnmove op2 [ r' ] dest succ map_consts in build_head_tuple [] sv let loadimm32 dest n succ map_consts = match make_immed32 n with | Imm32_single imm -> let op1 = OEaddiwr0 imm in - let sv = find_or_addnmove op1 [] dest succ [] map_consts in + let sv = find_or_addnmove op1 [] dest succ map_consts in build_head_tuple [] sv | Imm32_pair (hi, lo) -> load_hilo32 dest hi lo succ map_consts @@ -105,12 +102,12 @@ let loadimm64 dest n succ map_consts = match make_immed64 n with | Imm64_single imm -> let op1 = OEaddilr0 imm in - let sv = find_or_addnmove op1 [] dest succ [] map_consts in + let sv = find_or_addnmove op1 [] dest succ map_consts in build_head_tuple [] sv | Imm64_pair (hi, lo) -> load_hilo64 dest hi lo succ map_consts | Imm64_large imm -> let op1 = OEloadli imm in - let sv = find_or_addnmove op1 [] dest succ [] map_consts in + let sv = find_or_addnmove op1 [] dest succ map_consts in build_head_tuple [] sv let get_opimm imm = function @@ -144,7 +141,7 @@ let opimm64 a1 dest n succ k op opimm map_consts = let r = r2pi () in let op1 = OEloadli imm in let inode = n2pi () in - let sv = find_or_addnmove op1 [] r inode [] map_consts in + let sv = find_or_addnmove op1 [] r inode map_consts in let ht = build_head_tuple [] sv in let r' = unzip_head_tuple ht r in fst ht @ Iop (op, [ a1; r' ], dest, succ) :: k -- cgit From d1d6493816e7c561f82f7549f100442f0bf52a15 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Mon, 8 Mar 2021 09:41:01 +0100 Subject: Adding miniCSE here too --- riscV/ExpansionOracle.ml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index a61e5c95..b3c19802 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -451,7 +451,7 @@ let rec write_tree exp current code' new_order = | _ -> failwith "ExpansionOracle.write_tree: inconsistent instruction." let expanse (sb : superblock) code pm = - debug_flag := true; + (*debug_flag := true;*) let new_order = ref [] in let liveins = ref sb.liveins in let exp = ref [] in @@ -479,11 +479,11 @@ let expanse (sb : superblock) code pm = was_exp := true | Iop (Ocmp (Ccompimm (c, imm)), a1 :: nil, dest, succ) -> debug "Iop/Ccompimm\n"; - exp := expanse_condimm_int32s c a1 imm dest succ []; + exp := expanse_condimm_int32s c a1 imm dest succ [] map_consts; was_exp := true | Iop (Ocmp (Ccompuimm (c, imm)), a1 :: nil, dest, succ) -> debug "Iop/Ccompuimm\n"; - exp := expanse_condimm_int32u c a1 imm dest succ []; + exp := expanse_condimm_int32u c a1 imm dest succ [] map_consts; was_exp := true | Iop (Ocmp (Ccompl c), a1 :: a2 :: nil, dest, succ) -> debug "Iop/Ccompl\n"; @@ -495,11 +495,11 @@ let expanse (sb : superblock) code pm = was_exp := true | Iop (Ocmp (Ccomplimm (c, imm)), a1 :: nil, dest, succ) -> debug "Iop/Ccomplimm\n"; - exp := expanse_condimm_int64s c a1 imm dest succ []; + exp := expanse_condimm_int64s c a1 imm dest succ [] map_consts; was_exp := true | Iop (Ocmp (Ccompluimm (c, imm)), a1 :: nil, dest, succ) -> debug "Iop/Ccompluimm\n"; - exp := expanse_condimm_int64u c a1 imm dest succ []; + exp := expanse_condimm_int64u c a1 imm dest succ [] map_consts; was_exp := true | Iop (Ocmp (Ccompf c), f1 :: f2 :: nil, dest, succ) -> debug "Iop/Ccompf\n"; @@ -530,12 +530,12 @@ let expanse (sb : superblock) code pm = was_exp := true | Icond (Ccompimm (c, imm), a1 :: nil, succ1, succ2, info) -> debug "Icond/Ccompimm\n"; - exp := expanse_cbranchimm_int32s c a1 imm info succ1 succ2 []; + exp := expanse_cbranchimm_int32s c a1 imm info succ1 succ2 [] map_consts; was_branch := true; was_exp := true | Icond (Ccompuimm (c, imm), a1 :: nil, succ1, succ2, info) -> debug "Icond/Ccompuimm\n"; - exp := expanse_cbranchimm_int32u c a1 imm info succ1 succ2 []; + exp := expanse_cbranchimm_int32u c a1 imm info succ1 succ2 [] map_consts; was_branch := true; was_exp := true | Icond (Ccompl c, a1 :: a2 :: nil, succ1, succ2, info) -> @@ -550,12 +550,12 @@ let expanse (sb : superblock) code pm = was_exp := true | Icond (Ccomplimm (c, imm), a1 :: nil, succ1, succ2, info) -> debug "Icond/Ccomplimm\n"; - exp := expanse_cbranchimm_int64s c a1 imm info succ1 succ2 []; + exp := expanse_cbranchimm_int64s c a1 imm info succ1 succ2 [] map_consts; was_branch := true; was_exp := true | Icond (Ccompluimm (c, imm), a1 :: nil, succ1, succ2, info) -> debug "Icond/Ccompluimm\n"; - exp := expanse_cbranchimm_int64u c a1 imm info succ1 succ2 []; + exp := expanse_cbranchimm_int64u c a1 imm info succ1 succ2 [] map_consts; was_branch := true; was_exp := true | Icond (Ccompf c, f1 :: f2 :: nil, succ1, succ2, info) -> @@ -622,7 +622,7 @@ let expanse (sb : superblock) code pm = sb.instructions; sb.instructions <- Array.of_list (List.rev !new_order); sb.liveins <- !liveins; - debug_flag := false; + (*debug_flag := false;*) (!code', !pm') let rec find_last_node_reg = function -- cgit From 21d43bc4e129baf7ca31d3293dddb3a23e4ca5d9 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Sun, 21 Mar 2021 22:43:17 +0100 Subject: Remove first nop when doing expansion --- riscV/ExpansionOracle.ml | 400 +++++++++++++++++++++++++---------------------- 1 file changed, 212 insertions(+), 188 deletions(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index b3c19802..81c369f7 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -21,6 +21,7 @@ open DebugPrint open RTLpath open! Integers open Camlcoq +open Option type sop = Sop of operation * P.t list @@ -49,8 +50,7 @@ type immt = Xoriw | Xoril | Sltiw | Sltiuw | Sltil | Sltiul let find_or_addnmove op args rd succ map_consts = let sop = Sop (op, args) in match Hashtbl.find_opt map_consts sop with - | Some r -> - Sr (P.of_int r) + | Some r -> Sr (P.of_int r) | None -> Hashtbl.add map_consts sop (p2i rd); Si (Iop (op, args, rd, succ)) @@ -205,7 +205,7 @@ let cbranch_int64u is_x0 cmp a1 a2 info succ1 succ2 k = | Cgt -> Icond (CEbltul optR0, [ a2; a1 ], succ1, succ2, info) :: k | Cge -> Icond (CEbgeul optR0, [ a1; a2 ], succ1, succ2, info) :: k -let cond_int32s is_x0 cmp a1 a2 dest succ k = +let cond_int32s is_x0 cmp a1 a2 dest tmp_reg succ k = let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in match cmp with | Ceq -> Iop (OEseqw optR0, [ a1; a2 ], dest, succ) :: k @@ -213,15 +213,15 @@ let cond_int32s is_x0 cmp a1 a2 dest succ k = | Clt -> Iop (OEsltw optR0, [ a1; a2 ], dest, succ) :: k | Cle -> let r = r2pi () in - Iop (OEsltw optR0, [ a2; a1 ], r, n2pi ()) + Iop (OEsltw optR0, [ a2; a1 ], r, get tmp_reg) :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k | Cgt -> Iop (OEsltw optR0, [ a2; a1 ], dest, succ) :: k | Cge -> let r = r2pi () in - Iop (OEsltw optR0, [ a1; a2 ], r, n2pi ()) + Iop (OEsltw optR0, [ a1; a2 ], r, get tmp_reg) :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k -let cond_int32u is_x0 cmp a1 a2 dest succ k = +let cond_int32u is_x0 cmp a1 a2 dest tmp_reg succ k = let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in match cmp with | Ceq -> Iop (OEsequw optR0, [ a1; a2 ], dest, succ) :: k @@ -229,15 +229,15 @@ let cond_int32u is_x0 cmp a1 a2 dest succ k = | Clt -> Iop (OEsltuw optR0, [ a1; a2 ], dest, succ) :: k | Cle -> let r = r2pi () in - Iop (OEsltuw optR0, [ a2; a1 ], r, n2pi ()) + Iop (OEsltuw optR0, [ a2; a1 ], r, get tmp_reg) :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k | Cgt -> Iop (OEsltuw optR0, [ a2; a1 ], dest, succ) :: k | Cge -> let r = r2pi () in - Iop (OEsltuw optR0, [ a1; a2 ], r, n2pi ()) + Iop (OEsltuw optR0, [ a1; a2 ], r, get tmp_reg) :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k -let cond_int64s is_x0 cmp a1 a2 dest succ k = +let cond_int64s is_x0 cmp a1 a2 dest tmp_reg succ k = let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in match cmp with | Ceq -> Iop (OEseql optR0, [ a1; a2 ], dest, succ) :: k @@ -245,15 +245,15 @@ let cond_int64s is_x0 cmp a1 a2 dest succ k = | Clt -> Iop (OEsltl optR0, [ a1; a2 ], dest, succ) :: k | Cle -> let r = r2pi () in - Iop (OEsltl optR0, [ a2; a1 ], r, n2pi ()) + Iop (OEsltl optR0, [ a2; a1 ], r, get tmp_reg) :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k | Cgt -> Iop (OEsltl optR0, [ a2; a1 ], dest, succ) :: k | Cge -> let r = r2pi () in - Iop (OEsltl optR0, [ a1; a2 ], r, n2pi ()) + Iop (OEsltl optR0, [ a1; a2 ], r, get tmp_reg) :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k -let cond_int64u is_x0 cmp a1 a2 dest succ k = +let cond_int64u is_x0 cmp a1 a2 dest tmp_reg succ k = let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in match cmp with | Ceq -> Iop (OEsequl optR0, [ a1; a2 ], dest, succ) :: k @@ -261,12 +261,12 @@ let cond_int64u is_x0 cmp a1 a2 dest succ k = | Clt -> Iop (OEsltul optR0, [ a1; a2 ], dest, succ) :: k | Cle -> let r = r2pi () in - Iop (OEsltul optR0, [ a2; a1 ], r, n2pi ()) + Iop (OEsltul optR0, [ a2; a1 ], r, get tmp_reg) :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k | Cgt -> Iop (OEsltul optR0, [ a2; a1 ], dest, succ) :: k | Cge -> let r = r2pi () in - Iop (OEsltul optR0, [ a1; a2 ], r, n2pi ()) + Iop (OEsltul optR0, [ a1; a2 ], r, get tmp_reg) :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k let is_normal_cmp = function Cne -> false | _ -> true @@ -321,14 +321,18 @@ let expanse_cbranchimm_int64u cmp a1 n info succ1 succ2 k map_consts = let r' = unzip_head_tuple ht r in fst ht @ cbranch_int64u false cmp a1 r' info succ1 succ2 k +let get_tmp_reg = function Cle | Cge -> Some (n2pi ()) | _ -> None + let expanse_condimm_int32s cmp a1 n dest succ k map_consts = - if Int.eq n Int.zero then cond_int32s true cmp a1 a1 dest succ k + if Int.eq n Int.zero then + let tmp_reg = get_tmp_reg cmp in + cond_int32s true cmp a1 a1 dest tmp_reg succ k else match cmp with | Ceq | Cne -> let r = r2pi () in xorimm32 a1 r n (n2pi ()) - (cond_int32s true cmp r r dest succ k) + (cond_int32s true cmp r r dest None succ k) map_consts | Clt -> sltimm32 a1 dest n succ k map_consts | Cle -> @@ -338,12 +342,14 @@ let expanse_condimm_int32s cmp a1 n dest succ k map_consts = else sltimm32 a1 dest (Int.add n Int.one) succ k map_consts | _ -> let r = r2pi () in + let tmp_reg = get_tmp_reg cmp in let ht = loadimm32 r n (n2pi ()) map_consts in let r' = unzip_head_tuple ht r in - fst ht @ cond_int32s false cmp a1 r' dest succ k + fst ht @ cond_int32s false cmp a1 r' dest tmp_reg succ k let expanse_condimm_int32u cmp a1 n dest succ k map_consts = - if Int.eq n Int.zero then cond_int32u true cmp a1 a1 dest succ k + let tmp_reg = get_tmp_reg cmp in + if Int.eq n Int.zero then cond_int32u true cmp a1 a1 dest tmp_reg succ k else match cmp with | Clt -> sltuimm32 a1 dest n succ k map_consts @@ -351,16 +357,18 @@ let expanse_condimm_int32u cmp a1 n dest succ k map_consts = let r = r2pi () in let ht = loadimm32 r n (n2pi ()) map_consts in let r' = unzip_head_tuple ht r in - fst ht @ cond_int32u false cmp a1 r' dest succ k + fst ht @ cond_int32u false cmp a1 r' dest tmp_reg succ k let expanse_condimm_int64s cmp a1 n dest succ k map_consts = - if Int64.eq n Int64.zero then cond_int64s true cmp a1 a1 dest succ k + if Int64.eq n Int64.zero then + let tmp_reg = get_tmp_reg cmp in + cond_int64s true cmp a1 a1 dest tmp_reg succ k else match cmp with | Ceq | Cne -> let r = r2pi () in xorimm64 a1 r n (n2pi ()) - (cond_int64s true cmp r r dest succ k) + (cond_int64s true cmp r r dest None succ k) map_consts | Clt -> sltimm64 a1 dest n succ k map_consts | Cle -> @@ -370,12 +378,14 @@ let expanse_condimm_int64s cmp a1 n dest succ k map_consts = else sltimm64 a1 dest (Int64.add n Int64.one) succ k map_consts | _ -> let r = r2pi () in + let tmp_reg = get_tmp_reg cmp in let ht = loadimm64 r n (n2pi ()) map_consts in let r' = unzip_head_tuple ht r in - fst ht @ cond_int64s false cmp a1 r' dest succ k + fst ht @ cond_int64s false cmp a1 r' dest tmp_reg succ k let expanse_condimm_int64u cmp a1 n dest succ k map_consts = - if Int64.eq n Int64.zero then cond_int64u true cmp a1 a1 dest succ k + let tmp_reg = get_tmp_reg cmp in + if Int64.eq n Int64.zero then cond_int64u true cmp a1 a1 dest tmp_reg succ k else match cmp with | Clt -> sltuimm64 a1 dest n succ k map_consts @@ -383,7 +393,7 @@ let expanse_condimm_int64u cmp a1 n dest succ k map_consts = let r = r2pi () in let ht = loadimm64 r n (n2pi ()) map_consts in let r' = unzip_head_tuple ht r in - fst ht @ cond_int64u false cmp a1 r' dest succ k + fst ht @ cond_int64u false cmp a1 r' dest tmp_reg succ k let expanse_cond_fp cnot fn_cond cmp f1 f2 dest succ k = let normal = is_normal_cmp cmp in @@ -437,16 +447,22 @@ let write_pathmap initial esize pm' = in pm' := PTree.set initial path' !pm' -let rec write_tree exp current code' new_order = +let rec write_tree exp initial current code' new_order = + let target_node, next_node = + if current = !node then ( + node := !node + 1; + (P.to_int initial, current)) + else (current, current - 1) + in match exp with | (Iop (_, _, _, succ) as inst) :: k -> - code' := PTree.set (P.of_int current) inst !code'; - new_order := P.of_int current :: !new_order; - write_tree k (current - 1) code' new_order + code' := PTree.set (P.of_int target_node) inst !code'; + new_order := P.of_int target_node :: !new_order; + write_tree k initial next_node code' new_order | (Icond (_, _, succ1, succ2, _) as inst) :: k -> - code' := PTree.set (P.of_int current) inst !code'; - new_order := P.of_int current :: !new_order; - write_tree k (current - 1) code' new_order + code' := PTree.set (P.of_int target_node) inst !code'; + new_order := P.of_int target_node :: !new_order; + write_tree k initial next_node code' new_order | [] -> () | _ -> failwith "ExpansionOracle.write_tree: inconsistent instruction." @@ -462,163 +478,171 @@ let expanse (sb : superblock) code pm = let map_consts = Hashtbl.create 100 in Array.iter (fun n -> - begin ( - was_branch := false; - was_exp := false; - let inst = get_some @@ PTree.get n code in - if !Clflags.option_fexpanse_rtlcond then ( - match inst with - (* Expansion of conditions - Ocmp *) - | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccomp\n"; - exp := cond_int32s false c a1 a2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccompu c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccompu\n"; - exp := cond_int32u false c a1 a2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccompimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccompimm\n"; - exp := expanse_condimm_int32s c a1 imm dest succ [] map_consts; - was_exp := true - | Iop (Ocmp (Ccompuimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccompuimm\n"; - exp := expanse_condimm_int32u c a1 imm dest succ [] map_consts; - was_exp := true - | Iop (Ocmp (Ccompl c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccompl\n"; - exp := cond_int64s false c a1 a2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccomplu c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccomplu\n"; - exp := cond_int64u false c a1 a2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccomplimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccomplimm\n"; - exp := expanse_condimm_int64s c a1 imm dest succ [] map_consts; - was_exp := true - | Iop (Ocmp (Ccompluimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccompluimm\n"; - exp := expanse_condimm_int64u c a1 imm dest succ [] map_consts; - was_exp := true - | Iop (Ocmp (Ccompf c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Ccompf\n"; - exp := expanse_cond_fp false cond_float c f1 f2 dest succ []; - was_exp := true - | Iop (Ocmp (Cnotcompf c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Cnotcompf\n"; - exp := expanse_cond_fp true cond_float c f1 f2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccompfs c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Ccompfs\n"; - exp := expanse_cond_fp false cond_single c f1 f2 dest succ []; - was_exp := true - | Iop (Ocmp (Cnotcompfs c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Cnotcompfs\n"; - exp := expanse_cond_fp true cond_single c f1 f2 dest succ []; - was_exp := true - (* Expansion of branches - Ccomp *) - | Icond (Ccomp c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccomp\n"; - exp := cbranch_int32s false c a1 a2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompu c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompu\n"; - exp := cbranch_int32u false c a1 a2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompimm\n"; - exp := expanse_cbranchimm_int32s c a1 imm info succ1 succ2 [] map_consts; - was_branch := true; - was_exp := true - | Icond (Ccompuimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompuimm\n"; - exp := expanse_cbranchimm_int32u c a1 imm info succ1 succ2 [] map_consts; - was_branch := true; - was_exp := true - | Icond (Ccompl c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompl\n"; - exp := cbranch_int64s false c a1 a2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccomplu c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccomplu\n"; - exp := cbranch_int64u false c a1 a2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccomplimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccomplimm\n"; - exp := expanse_cbranchimm_int64s c a1 imm info succ1 succ2 [] map_consts; - was_branch := true; - was_exp := true - | Icond (Ccompluimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompluimm\n"; - exp := expanse_cbranchimm_int64u c a1 imm info succ1 succ2 [] map_consts; - was_branch := true; - was_exp := true - | Icond (Ccompf c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompf\n"; - exp := expanse_cbranch_fp false cond_float c f1 f2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Cnotcompf c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Cnotcompf\n"; - exp := expanse_cbranch_fp true cond_float c f1 f2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompfs\n"; - exp := - expanse_cbranch_fp false cond_single c f1 f2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Cnotcompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Cnotcompfs\n"; - exp := expanse_cbranch_fp true cond_single c f1 f2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | _ -> ()); - if (!Clflags.option_fexpanse_fpconst && not !was_exp) then ( - match inst with - (* Expansion of fp constants *) - | Iop (Ofloatconst f, nil, dest, succ) -> - debug "Iop/Ofloatconst\n"; - let r = r2pi () in - exp := - [ - Iop (Olongconst (Floats.Float.to_bits f), [], r, n2pi ()); - Iop (Ofloat_of_bits, [ r ], dest, succ); - ]; - was_exp := true - | Iop (Osingleconst f, nil, dest, succ) -> - debug "Iop/Osingleconst\n"; - let r = r2pi () in - exp := - [ - Iop (Ointconst (Floats.Float32.to_bits f), [], r, n2pi ()); - Iop (Osingle_of_bits, [ r ], dest, succ); - ]; - was_exp := true - | _ -> ()); - if !was_exp then ( - node := !node + 1; - (if !was_branch then - let lives = PTree.get n !liveins in - match lives with - | Some lives -> - let new_branch_pc = - Camlcoq.P.of_int (!node - (List.length !exp - 1)) - in - liveins := PTree.set new_branch_pc lives !liveins; - liveins := PTree.remove n !liveins - | _ -> ()); - write_pathmap sb.instructions.(0) (List.length !exp) pm'; - write_initial_node n code' new_order; - write_tree !exp !node code' new_order) - else new_order := n :: !new_order) - end) + was_branch := false; + was_exp := false; + let inst = get_some @@ PTree.get n code in + (if !Clflags.option_fexpanse_rtlcond then + match inst with + (* Expansion of conditions - Ocmp *) + | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccomp\n"; + let tmp_reg = get_tmp_reg c in + exp := cond_int32s false c a1 a2 dest tmp_reg succ []; + was_exp := true + | Iop (Ocmp (Ccompu c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccompu\n"; + let tmp_reg = get_tmp_reg c in + exp := cond_int32u false c a1 a2 dest tmp_reg succ []; + was_exp := true + | Iop (Ocmp (Ccompimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccompimm\n"; + exp := expanse_condimm_int32s c a1 imm dest succ [] map_consts; + was_exp := true + | Iop (Ocmp (Ccompuimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccompuimm\n"; + exp := expanse_condimm_int32u c a1 imm dest succ [] map_consts; + was_exp := true + | Iop (Ocmp (Ccompl c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccompl\n"; + let tmp_reg = get_tmp_reg c in + exp := cond_int64s false c a1 a2 dest tmp_reg succ []; + was_exp := true + | Iop (Ocmp (Ccomplu c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccomplu\n"; + let tmp_reg = get_tmp_reg c in + exp := cond_int64u false c a1 a2 dest tmp_reg succ []; + was_exp := true + | Iop (Ocmp (Ccomplimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccomplimm\n"; + exp := expanse_condimm_int64s c a1 imm dest succ [] map_consts; + was_exp := true + | Iop (Ocmp (Ccompluimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccompluimm\n"; + exp := expanse_condimm_int64u c a1 imm dest succ [] map_consts; + was_exp := true + | Iop (Ocmp (Ccompf c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Ccompf\n"; + exp := expanse_cond_fp false cond_float c f1 f2 dest succ []; + was_exp := true + | Iop (Ocmp (Cnotcompf c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Cnotcompf\n"; + exp := expanse_cond_fp true cond_float c f1 f2 dest succ []; + was_exp := true + | Iop (Ocmp (Ccompfs c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Ccompfs\n"; + exp := expanse_cond_fp false cond_single c f1 f2 dest succ []; + was_exp := true + | Iop (Ocmp (Cnotcompfs c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Cnotcompfs\n"; + exp := expanse_cond_fp true cond_single c f1 f2 dest succ []; + was_exp := true + (* Expansion of branches - Ccomp *) + | Icond (Ccomp c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccomp\n"; + exp := cbranch_int32s false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompu c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompu\n"; + exp := cbranch_int32u false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompimm\n"; + exp := + expanse_cbranchimm_int32s c a1 imm info succ1 succ2 [] map_consts; + was_branch := true; + was_exp := true + | Icond (Ccompuimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompuimm\n"; + exp := + expanse_cbranchimm_int32u c a1 imm info succ1 succ2 [] map_consts; + was_branch := true; + was_exp := true + | Icond (Ccompl c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompl\n"; + exp := cbranch_int64s false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccomplu c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccomplu\n"; + exp := cbranch_int64u false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccomplimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccomplimm\n"; + exp := + expanse_cbranchimm_int64s c a1 imm info succ1 succ2 [] map_consts; + was_branch := true; + was_exp := true + | Icond (Ccompluimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompluimm\n"; + exp := + expanse_cbranchimm_int64u c a1 imm info succ1 succ2 [] map_consts; + was_branch := true; + was_exp := true + | Icond (Ccompf c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompf\n"; + exp := + expanse_cbranch_fp false cond_float c f1 f2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Cnotcompf c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Cnotcompf\n"; + exp := expanse_cbranch_fp true cond_float c f1 f2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompfs\n"; + exp := + expanse_cbranch_fp false cond_single c f1 f2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Cnotcompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Cnotcompfs\n"; + exp := + expanse_cbranch_fp true cond_single c f1 f2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | _ -> ()); + (if !Clflags.option_fexpanse_fpconst && not !was_exp then + match inst with + (* Expansion of fp constants *) + | Iop (Ofloatconst f, nil, dest, succ) -> + debug "Iop/Ofloatconst\n"; + let r = r2pi () in + exp := + [ + Iop (Olongconst (Floats.Float.to_bits f), [], r, n2pi ()); + Iop (Ofloat_of_bits, [ r ], dest, succ); + ]; + was_exp := true + | Iop (Osingleconst f, nil, dest, succ) -> + debug "Iop/Osingleconst\n"; + let r = r2pi () in + exp := + [ + Iop (Ointconst (Floats.Float32.to_bits f), [], r, n2pi ()); + Iop (Osingle_of_bits, [ r ], dest, succ); + ]; + was_exp := true + | _ -> ()); + if !was_exp then ( + (*node := !node + 1;*) + (*(if !was_branch then + let lives = PTree.get n !liveins in + match lives with + | Some lives -> + let new_branch_pc = + Camlcoq.P.of_int (!node - (List.length !exp - 1)) + in + liveins := PTree.set new_branch_pc lives !liveins; + liveins := PTree.remove n !liveins + | _ -> ());*) + write_pathmap sb.instructions.(0) (List.length !exp - 1) pm'; + (*write_initial_node n code' new_order;*) + write_tree !exp n !node code' new_order) + else new_order := n :: !new_order) sb.instructions; sb.instructions <- Array.of_list (List.rev !new_order); sb.liveins <- !liveins; -- cgit From ca78138a8a81af44a36e339ad1ecf86ca3862e50 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Tue, 23 Mar 2021 09:50:55 +0100 Subject: Bugfix liveness --- riscV/ExpansionOracle.ml | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 81c369f7..27a36283 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -628,19 +628,15 @@ let expanse (sb : superblock) code pm = was_exp := true | _ -> ()); if !was_exp then ( - (*node := !node + 1;*) - (*(if !was_branch then - let lives = PTree.get n !liveins in - match lives with - | Some lives -> - let new_branch_pc = - Camlcoq.P.of_int (!node - (List.length !exp - 1)) - in - liveins := PTree.set new_branch_pc lives !liveins; - liveins := PTree.remove n !liveins - | _ -> ());*) + (if !was_branch && List.length !exp > 1 then + let lives = PTree.get n !liveins in + match lives with + | Some lives -> + let new_branch_pc = n2p () in + liveins := PTree.set new_branch_pc lives !liveins; + liveins := PTree.remove n !liveins + | _ -> ()); write_pathmap sb.instructions.(0) (List.length !exp - 1) pm'; - (*write_initial_node n code' new_order;*) write_tree !exp n !node code' new_order) else new_order := n :: !new_order) sb.instructions; -- cgit From 95205e72ca536907fa89c7c884f0e22fc605063d Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Fri, 26 Mar 2021 12:49:02 +0100 Subject: Adding more expansions, improving miniCSE, and tuning prepass --- riscV/Asmgen.v | 24 ++ riscV/Asmgenproof1.v | 12 +- riscV/ExpansionOracle.ml | 587 +++++++++++++++++++++++++----------- riscV/NeedOp.v | 22 +- riscV/Op.v | 120 +++++++- riscV/OpWeights.ml | 334 ++++++++++----------- riscV/PrintOp.ml | 10 +- riscV/RTLpathSE_simplify.v | 732 ++++++++++++++++++++++++++++++++++++++++++++- riscV/ValueAOp.v | 65 +++- 9 files changed, 1518 insertions(+), 388 deletions(-) (limited to 'riscV') diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index 8b86ec5a..d4c6b73a 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -815,9 +815,21 @@ Definition transl_op | OEluiw n, nil => do rd <- ireg_of res; OK (Pluiw rd n :: k) + | OEaddiw n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Paddiw rd rs n :: k) | OEaddiwr0 n, nil => do rd <- ireg_of res; OK (Paddiw rd X0 n :: k) + | OEandiw n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Pandiw rd rs n :: k) + | OEoriw n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Poriw rd rs n :: k) | OEseql optR0, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; @@ -863,9 +875,21 @@ Definition transl_op | OEluil n, nil => do rd <- ireg_of res; OK (Pluil rd n :: k) + | OEaddil n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Paddil rd rs n :: k) | OEaddilr0 n, nil => do rd <- ireg_of res; OK (Paddil rd X0 n :: k) + | OEandil n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Pandil rd rs n :: k) + | OEoril n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Poril rd rs n :: k) | OEloadli n, nil => do rd <- ireg_of res; OK (Ploadli rd n :: k) diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 0be56e47..639c9a64 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -1258,11 +1258,15 @@ Opaque Int.eq. { exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. } (* Expanded instructions from RTL *) - 7,14: + 7,8,9,10,17,18,19,20: econstructor; split; try apply exec_straight_one; simpl; eauto; - split; intros; Simpl; simpl; - try rewrite Int.add_commut; try rewrite Int64.add_commut; - auto. + split; intros; Simpl; try destruct (rs x0); + try rewrite Int64.add_commut; + try rewrite Int.add_commut; auto; + try rewrite Int64.and_commut; + try rewrite Int.and_commut; auto; + try rewrite Int64.or_commut; + try rewrite Int.or_commut; auto. 1-12: destruct optR0 as [[]|]; unfold apply_bin_r0_r0r0, apply_bin_r0; econstructor; split; try apply exec_straight_one; simpl; eauto; diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 27a36283..676b8da6 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -45,12 +45,26 @@ let n2pi () = node := !node + 1; n2p () -type immt = Xoriw | Xoril | Sltiw | Sltiuw | Sltil | Sltiul - -let find_or_addnmove op args rd succ map_consts = +type immt = + | Addiw + | Addil + | Andiw + | Andil + | Oriw + | Oril + | Xoriw + | Xoril + | Sltiw + | Sltiuw + | Sltil + | Sltiul + +let find_or_addnmove op args rd succ map_consts node_dec = let sop = Sop (op, args) in match Hashtbl.find_opt map_consts sop with - | Some r -> Sr (P.of_int r) + | Some r -> + if node_dec then node := !node - 1; + Sr (P.of_int r) | None -> Hashtbl.add map_consts sop (p2i rd); Si (Iop (op, args, rd, succ)) @@ -58,93 +72,114 @@ let find_or_addnmove op args rd succ map_consts = let build_head_tuple head sv = match sv with Si i -> (head @ [ i ], None) | Sr r -> (head, Some r) -let load_hilo32 dest hi lo succ map_consts = +let unzip_head_tuple ht r = match ht with l, Some r' -> r' | l, None -> r + +let unzip_head_tuple_move ht r succ = + match ht with l, Some r' -> [ Iop (Omove, [ r' ], r, succ) ] | l, None -> l + +let build_full_ilist op args dest succ hd k map_consts = + let sv = find_or_addnmove op args dest succ map_consts false in + let ht = build_head_tuple hd sv in + unzip_head_tuple_move ht dest succ @ k + +let load_hilo32 dest hi lo succ map_consts node_dec = let op1 = OEluiw hi in if Int.eq lo Int.zero then - let sv = find_or_addnmove op1 [] dest succ map_consts in + let sv = find_or_addnmove op1 [] dest succ map_consts node_dec in build_head_tuple [] sv else let r = r2pi () in - let op2 = Oaddimm lo in - match find_or_addnmove op1 [] r (n2pi ()) map_consts with - | Si i -> - let sv = find_or_addnmove op2 [ r ] dest succ map_consts in - build_head_tuple [ i ] sv - | Sr r' -> - let sv = find_or_addnmove op2 [ r' ] dest succ map_consts in - build_head_tuple [] sv - -let load_hilo64 dest hi lo succ map_consts = + let sv1 = find_or_addnmove op1 [] r (n2pi ()) map_consts node_dec in + let ht1 = build_head_tuple [] sv1 in + let r' = unzip_head_tuple ht1 r in + let op2 = OEaddiw lo in + let sv2 = find_or_addnmove op2 [ r' ] dest succ map_consts node_dec in + build_head_tuple (fst ht1) sv2 + +let load_hilo64 dest hi lo succ map_consts node_dec = let op1 = OEluil hi in if Int64.eq lo Int64.zero then - let sv = find_or_addnmove op1 [] dest succ map_consts in + let sv = find_or_addnmove op1 [] dest succ map_consts node_dec in build_head_tuple [] sv else let r = r2pi () in - let op2 = Oaddlimm lo in - match find_or_addnmove op1 [] r (n2pi ()) map_consts with - | Si i -> - let sv = find_or_addnmove op2 [ r ] dest succ map_consts in - build_head_tuple [ i ] sv - | Sr r' -> - let sv = find_or_addnmove op2 [ r' ] dest succ map_consts in - build_head_tuple [] sv - -let loadimm32 dest n succ map_consts = + let sv1 = find_or_addnmove op1 [] r (n2pi ()) map_consts node_dec in + let ht1 = build_head_tuple [] sv1 in + let r' = unzip_head_tuple ht1 r in + let op2 = OEaddil lo in + let sv2 = find_or_addnmove op2 [ r' ] dest succ map_consts node_dec in + build_head_tuple (fst ht1) sv2 + +let loadimm32 dest n succ map_consts node_dec = match make_immed32 n with | Imm32_single imm -> let op1 = OEaddiwr0 imm in - let sv = find_or_addnmove op1 [] dest succ map_consts in + let sv = find_or_addnmove op1 [] dest succ map_consts node_dec in build_head_tuple [] sv - | Imm32_pair (hi, lo) -> load_hilo32 dest hi lo succ map_consts + | Imm32_pair (hi, lo) -> load_hilo32 dest hi lo succ map_consts node_dec -let loadimm64 dest n succ map_consts = +let loadimm64 dest n succ map_consts node_dec = match make_immed64 n with | Imm64_single imm -> let op1 = OEaddilr0 imm in - let sv = find_or_addnmove op1 [] dest succ map_consts in + let sv = find_or_addnmove op1 [] dest succ map_consts node_dec in build_head_tuple [] sv - | Imm64_pair (hi, lo) -> load_hilo64 dest hi lo succ map_consts + | Imm64_pair (hi, lo) -> load_hilo64 dest hi lo succ map_consts node_dec | Imm64_large imm -> let op1 = OEloadli imm in - let sv = find_or_addnmove op1 [] dest succ map_consts in + let sv = find_or_addnmove op1 [] dest succ map_consts node_dec in build_head_tuple [] sv let get_opimm imm = function + | Addiw -> OEaddiw imm + | Andiw -> OEandiw imm + | Oriw -> OEoriw imm | Xoriw -> OExoriw imm | Sltiw -> OEsltiw imm | Sltiuw -> OEsltiuw imm + | Addil -> OEaddil imm + | Andil -> OEandil imm + | Oril -> OEoril imm | Xoril -> OExoril imm | Sltil -> OEsltil imm | Sltiul -> OEsltiul imm -let unzip_head_tuple ht r = match ht with l, Some r' -> r' | l, None -> r - let opimm32 a1 dest n succ k op opimm map_consts = match make_immed32 n with - | Imm32_single imm -> Iop (get_opimm imm opimm, [ a1 ], dest, succ) :: k + | Imm32_single imm -> + build_full_ilist (get_opimm imm opimm) [ a1 ] dest succ [] k map_consts | Imm32_pair (hi, lo) -> let r = r2pi () in - let ht = load_hilo32 r hi lo (n2pi ()) map_consts in + let ht = load_hilo32 r hi lo (n2pi ()) map_consts true in let r' = unzip_head_tuple ht r in - fst ht @ Iop (op, [ a1; r' ], dest, succ) :: k + build_full_ilist op [ a1; r' ] dest succ (fst ht) k map_consts let opimm64 a1 dest n succ k op opimm map_consts = match make_immed64 n with - | Imm64_single imm -> Iop (get_opimm imm opimm, [ a1 ], dest, succ) :: k + | Imm64_single imm -> + build_full_ilist (get_opimm imm opimm) [ a1 ] dest succ [] k map_consts | Imm64_pair (hi, lo) -> let r = r2pi () in - let ht = load_hilo64 r hi lo (n2pi ()) map_consts in + let ht = load_hilo64 r hi lo (n2pi ()) map_consts true in let r' = unzip_head_tuple ht r in - fst ht @ Iop (op, [ a1; r' ], dest, succ) :: k - | Imm64_large imm -> + build_full_ilist op [ a1; r' ] dest succ (fst ht) k map_consts + | Imm64_large imm ->( let r = r2pi () in let op1 = OEloadli imm in let inode = n2pi () in - let sv = find_or_addnmove op1 [] r inode map_consts in + let sv = find_or_addnmove op1 [] r inode map_consts true in let ht = build_head_tuple [] sv in let r' = unzip_head_tuple ht r in - fst ht @ Iop (op, [ a1; r' ], dest, succ) :: k + build_full_ilist op [ a1; r' ] dest succ (fst ht) k map_consts) + +let addimm32 a1 dest n succ k map_consts = + opimm32 a1 dest n succ k Oadd Addiw map_consts + +let andimm32 a1 dest n succ k map_consts = + opimm32 a1 dest n succ k Oand Andiw map_consts + +let orimm32 a1 dest n succ k map_consts = + opimm32 a1 dest n succ k Oor Oriw map_consts let xorimm32 a1 dest n succ k map_consts = opimm32 a1 dest n succ k Oxor Xoriw map_consts @@ -155,6 +190,12 @@ let sltimm32 a1 dest n succ k map_consts = let sltuimm32 a1 dest n succ k map_consts = opimm32 a1 dest n succ k (OEsltuw None) Sltiuw map_consts +let addimm64 a1 dest n succ k = opimm64 a1 dest n succ k Oaddl Addil + +let andimm64 a1 dest n succ k = opimm64 a1 dest n succ k Oandl Andil + +let orimm64 a1 dest n succ k = opimm64 a1 dest n succ k Oorl Oril + let xorimm64 a1 dest n succ k = opimm64 a1 dest n succ k Oxorl Xoril let sltimm64 a1 dest n succ k = opimm64 a1 dest n succ k (OEsltl None) Sltil @@ -205,95 +246,119 @@ let cbranch_int64u is_x0 cmp a1 a2 info succ1 succ2 k = | Cgt -> Icond (CEbltul optR0, [ a2; a1 ], succ1, succ2, info) :: k | Cge -> Icond (CEbgeul optR0, [ a1; a2 ], succ1, succ2, info) :: k -let cond_int32s is_x0 cmp a1 a2 dest tmp_reg succ k = +let cond_int32s is_x0 cmp a1 a2 dest tmp_reg succ map_consts = let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Iop (OEseqw optR0, [ a1; a2 ], dest, succ) :: k - | Cne -> Iop (OEsnew optR0, [ a1; a2 ], dest, succ) :: k - | Clt -> Iop (OEsltw optR0, [ a1; a2 ], dest, succ) :: k + | Ceq -> [ Iop (OEseqw optR0, [ a1; a2 ], dest, succ) ] + | Cne -> [ Iop (OEsnew optR0, [ a1; a2 ], dest, succ) ] + | Clt -> [ Iop (OEsltw optR0, [ a1; a2 ], dest, succ) ] | Cle -> let r = r2pi () in - Iop (OEsltw optR0, [ a2; a1 ], r, get tmp_reg) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k - | Cgt -> Iop (OEsltw optR0, [ a2; a1 ], dest, succ) :: k + let op = OEsltw optR0 in + let sv = find_or_addnmove op [ a2; a1 ] r (get tmp_reg) map_consts true in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] + | Cgt -> [ Iop (OEsltw optR0, [ a2; a1 ], dest, succ) ] | Cge -> let r = r2pi () in - Iop (OEsltw optR0, [ a1; a2 ], r, get tmp_reg) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + let op = OEsltw optR0 in + let sv = find_or_addnmove op [ a1; a2 ] r (get tmp_reg) map_consts true in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] -let cond_int32u is_x0 cmp a1 a2 dest tmp_reg succ k = +let cond_int32u is_x0 cmp a1 a2 dest tmp_reg succ map_consts = let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Iop (OEsequw optR0, [ a1; a2 ], dest, succ) :: k - | Cne -> Iop (OEsneuw optR0, [ a1; a2 ], dest, succ) :: k - | Clt -> Iop (OEsltuw optR0, [ a1; a2 ], dest, succ) :: k + | Ceq -> [ Iop (OEsequw optR0, [ a1; a2 ], dest, succ) ] + | Cne -> [ Iop (OEsneuw optR0, [ a1; a2 ], dest, succ) ] + | Clt -> [ Iop (OEsltuw optR0, [ a1; a2 ], dest, succ) ] | Cle -> let r = r2pi () in - Iop (OEsltuw optR0, [ a2; a1 ], r, get tmp_reg) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k - | Cgt -> Iop (OEsltuw optR0, [ a2; a1 ], dest, succ) :: k + let op = OEsltuw optR0 in + let sv = find_or_addnmove op [ a2; a1 ] r (get tmp_reg) map_consts true in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] + | Cgt -> [ Iop (OEsltuw optR0, [ a2; a1 ], dest, succ) ] | Cge -> let r = r2pi () in - Iop (OEsltuw optR0, [ a1; a2 ], r, get tmp_reg) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + let op = OEsltuw optR0 in + let sv = find_or_addnmove op [ a1; a2 ] r (get tmp_reg) map_consts true in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] -let cond_int64s is_x0 cmp a1 a2 dest tmp_reg succ k = +let cond_int64s is_x0 cmp a1 a2 dest tmp_reg succ map_consts = let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Iop (OEseql optR0, [ a1; a2 ], dest, succ) :: k - | Cne -> Iop (OEsnel optR0, [ a1; a2 ], dest, succ) :: k - | Clt -> Iop (OEsltl optR0, [ a1; a2 ], dest, succ) :: k + | Ceq -> [ Iop (OEseql optR0, [ a1; a2 ], dest, succ) ] + | Cne -> [ Iop (OEsnel optR0, [ a1; a2 ], dest, succ) ] + | Clt -> [ Iop (OEsltl optR0, [ a1; a2 ], dest, succ) ] | Cle -> let r = r2pi () in - Iop (OEsltl optR0, [ a2; a1 ], r, get tmp_reg) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k - | Cgt -> Iop (OEsltl optR0, [ a2; a1 ], dest, succ) :: k + let op = OEsltl optR0 in + let sv = find_or_addnmove op [ a2; a1 ] r (get tmp_reg) map_consts true in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] + | Cgt -> [ Iop (OEsltl optR0, [ a2; a1 ], dest, succ) ] | Cge -> let r = r2pi () in - Iop (OEsltl optR0, [ a1; a2 ], r, get tmp_reg) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + let op = OEsltl optR0 in + let sv = find_or_addnmove op [ a1; a2 ] r (get tmp_reg) map_consts true in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] -let cond_int64u is_x0 cmp a1 a2 dest tmp_reg succ k = +let cond_int64u is_x0 cmp a1 a2 dest tmp_reg succ map_consts = let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Iop (OEsequl optR0, [ a1; a2 ], dest, succ) :: k - | Cne -> Iop (OEsneul optR0, [ a1; a2 ], dest, succ) :: k - | Clt -> Iop (OEsltul optR0, [ a1; a2 ], dest, succ) :: k + | Ceq -> [ Iop (OEsequl optR0, [ a1; a2 ], dest, succ) ] + | Cne -> [ Iop (OEsneul optR0, [ a1; a2 ], dest, succ) ] + | Clt -> [ Iop (OEsltul optR0, [ a1; a2 ], dest, succ) ] | Cle -> let r = r2pi () in - Iop (OEsltul optR0, [ a2; a1 ], r, get tmp_reg) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k - | Cgt -> Iop (OEsltul optR0, [ a2; a1 ], dest, succ) :: k + let op = OEsltul optR0 in + let sv = find_or_addnmove op [ a2; a1 ] r (get tmp_reg) map_consts true in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] + | Cgt -> [ Iop (OEsltul optR0, [ a2; a1 ], dest, succ) ] | Cge -> let r = r2pi () in - Iop (OEsltul optR0, [ a1; a2 ], r, get tmp_reg) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + let op = OEsltul optR0 in + let sv = find_or_addnmove op [ a1; a2 ] r (get tmp_reg) map_consts true in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] let is_normal_cmp = function Cne -> false | _ -> true -let cond_float cmp f1 f2 dest succ = +let cond_float cmp f1 f2 dest succ map_consts = match cmp with - | Ceq -> Iop (OEfeqd, [ f1; f2 ], dest, succ) - | Cne -> Iop (OEfeqd, [ f1; f2 ], dest, succ) - | Clt -> Iop (OEfltd, [ f1; f2 ], dest, succ) - | Cle -> Iop (OEfled, [ f1; f2 ], dest, succ) - | Cgt -> Iop (OEfltd, [ f2; f1 ], dest, succ) - | Cge -> Iop (OEfled, [ f2; f1 ], dest, succ) - -let cond_single cmp f1 f2 dest succ = + | Ceq -> [ Iop (OEfeqd, [ f1; f2 ], dest, succ) ] + | Cne -> [ Iop (OEfeqd, [ f1; f2 ], dest, succ) ] + | Clt -> [ Iop (OEfltd, [ f1; f2 ], dest, succ) ] + | Cle -> [ Iop (OEfled, [ f1; f2 ], dest, succ) ] + | Cgt -> [ Iop (OEfltd, [ f2; f1 ], dest, succ) ] + | Cge -> [ Iop (OEfled, [ f2; f1 ], dest, succ) ] + +let cond_single cmp f1 f2 dest succ map_consts = match cmp with - | Ceq -> Iop (OEfeqs, [ f1; f2 ], dest, succ) - | Cne -> Iop (OEfeqs, [ f1; f2 ], dest, succ) - | Clt -> Iop (OEflts, [ f1; f2 ], dest, succ) - | Cle -> Iop (OEfles, [ f1; f2 ], dest, succ) - | Cgt -> Iop (OEflts, [ f2; f1 ], dest, succ) - | Cge -> Iop (OEfles, [ f2; f1 ], dest, succ) + | Ceq -> [ Iop (OEfeqs, [ f1; f2 ], dest, succ) ] + | Cne -> [ Iop (OEfeqs, [ f1; f2 ], dest, succ) ] + | Clt -> [ Iop (OEflts, [ f1; f2 ], dest, succ) ] + | Cle -> [ Iop (OEfles, [ f1; f2 ], dest, succ) ] + | Cgt -> [ Iop (OEflts, [ f2; f1 ], dest, succ) ] + | Cge -> [ Iop (OEfles, [ f2; f1 ], dest, succ) ] let expanse_cbranchimm_int32s cmp a1 n info succ1 succ2 k map_consts = if Int.eq n Int.zero then cbranch_int32s true cmp a1 a1 info succ1 succ2 k else let r = r2pi () in - let ht = loadimm32 r n (n2pi ()) map_consts in + let ht = loadimm32 r n (n2pi ()) map_consts true in let r' = unzip_head_tuple ht r in fst ht @ cbranch_int32s false cmp a1 r' info succ1 succ2 k @@ -301,7 +366,7 @@ let expanse_cbranchimm_int32u cmp a1 n info succ1 succ2 k map_consts = if Int.eq n Int.zero then cbranch_int32u true cmp a1 a1 info succ1 succ2 k else let r = r2pi () in - let ht = loadimm32 r n (n2pi ()) map_consts in + let ht = loadimm32 r n (n2pi ()) map_consts true in let r' = unzip_head_tuple ht r in fst ht @ cbranch_int32u false cmp a1 r' info succ1 succ2 k @@ -309,7 +374,7 @@ let expanse_cbranchimm_int64s cmp a1 n info succ1 succ2 k map_consts = if Int64.eq n Int64.zero then cbranch_int64s true cmp a1 a1 info succ1 succ2 k else let r = r2pi () in - let ht = loadimm64 r n (n2pi ()) map_consts in + let ht = loadimm64 r n (n2pi ()) map_consts true in let r' = unzip_head_tuple ht r in fst ht @ cbranch_int64s false cmp a1 r' info succ1 succ2 k @@ -317,102 +382,103 @@ let expanse_cbranchimm_int64u cmp a1 n info succ1 succ2 k map_consts = if Int64.eq n Int64.zero then cbranch_int64u true cmp a1 a1 info succ1 succ2 k else let r = r2pi () in - let ht = loadimm64 r n (n2pi ()) map_consts in + let ht = loadimm64 r n (n2pi ()) map_consts true in let r' = unzip_head_tuple ht r in fst ht @ cbranch_int64u false cmp a1 r' info succ1 succ2 k let get_tmp_reg = function Cle | Cge -> Some (n2pi ()) | _ -> None -let expanse_condimm_int32s cmp a1 n dest succ k map_consts = +let expanse_condimm_int32s cmp a1 n dest succ map_consts = if Int.eq n Int.zero then let tmp_reg = get_tmp_reg cmp in - cond_int32s true cmp a1 a1 dest tmp_reg succ k + cond_int32s true cmp a1 a1 dest tmp_reg succ map_consts else match cmp with | Ceq | Cne -> let r = r2pi () in xorimm32 a1 r n (n2pi ()) - (cond_int32s true cmp r r dest None succ k) + (cond_int32s true cmp r r dest None succ map_consts) map_consts - | Clt -> sltimm32 a1 dest n succ k map_consts + | Clt -> sltimm32 a1 dest n succ [] map_consts | Cle -> if Int.eq n (Int.repr Int.max_signed) then - let ht = loadimm32 dest Int.one succ map_consts in - fst ht @ k - else sltimm32 a1 dest (Int.add n Int.one) succ k map_consts + let ht = loadimm32 dest Int.one succ map_consts false in + fst ht + else sltimm32 a1 dest (Int.add n Int.one) succ [] map_consts | _ -> let r = r2pi () in let tmp_reg = get_tmp_reg cmp in - let ht = loadimm32 r n (n2pi ()) map_consts in + let ht = loadimm32 r n (n2pi ()) map_consts true in let r' = unzip_head_tuple ht r in - fst ht @ cond_int32s false cmp a1 r' dest tmp_reg succ k + fst ht @ cond_int32s false cmp a1 r' dest tmp_reg succ map_consts -let expanse_condimm_int32u cmp a1 n dest succ k map_consts = +let expanse_condimm_int32u cmp a1 n dest succ map_consts = let tmp_reg = get_tmp_reg cmp in - if Int.eq n Int.zero then cond_int32u true cmp a1 a1 dest tmp_reg succ k + if Int.eq n Int.zero then + cond_int32u true cmp a1 a1 dest tmp_reg succ map_consts else match cmp with - | Clt -> sltuimm32 a1 dest n succ k map_consts + | Clt -> sltuimm32 a1 dest n succ [] map_consts | _ -> let r = r2pi () in - let ht = loadimm32 r n (n2pi ()) map_consts in + let ht = loadimm32 r n (n2pi ()) map_consts true in let r' = unzip_head_tuple ht r in - fst ht @ cond_int32u false cmp a1 r' dest tmp_reg succ k + fst ht @ cond_int32u false cmp a1 r' dest tmp_reg succ map_consts -let expanse_condimm_int64s cmp a1 n dest succ k map_consts = +let expanse_condimm_int64s cmp a1 n dest succ map_consts = if Int64.eq n Int64.zero then let tmp_reg = get_tmp_reg cmp in - cond_int64s true cmp a1 a1 dest tmp_reg succ k + cond_int64s true cmp a1 a1 dest tmp_reg succ map_consts else match cmp with | Ceq | Cne -> let r = r2pi () in xorimm64 a1 r n (n2pi ()) - (cond_int64s true cmp r r dest None succ k) + (cond_int64s true cmp r r dest None succ map_consts) map_consts - | Clt -> sltimm64 a1 dest n succ k map_consts + | Clt -> sltimm64 a1 dest n succ [] map_consts | Cle -> if Int64.eq n (Int64.repr Int64.max_signed) then - let ht = loadimm32 dest Int.one succ map_consts in - fst ht @ k - else sltimm64 a1 dest (Int64.add n Int64.one) succ k map_consts + let ht = loadimm32 dest Int.one succ map_consts false in + fst ht + else sltimm64 a1 dest (Int64.add n Int64.one) succ [] map_consts | _ -> let r = r2pi () in let tmp_reg = get_tmp_reg cmp in - let ht = loadimm64 r n (n2pi ()) map_consts in + let ht = loadimm64 r n (n2pi ()) map_consts true in let r' = unzip_head_tuple ht r in - fst ht @ cond_int64s false cmp a1 r' dest tmp_reg succ k + fst ht @ cond_int64s false cmp a1 r' dest tmp_reg succ map_consts -let expanse_condimm_int64u cmp a1 n dest succ k map_consts = +let expanse_condimm_int64u cmp a1 n dest succ map_consts = let tmp_reg = get_tmp_reg cmp in - if Int64.eq n Int64.zero then cond_int64u true cmp a1 a1 dest tmp_reg succ k + if Int64.eq n Int64.zero then + cond_int64u true cmp a1 a1 dest tmp_reg succ map_consts else match cmp with - | Clt -> sltuimm64 a1 dest n succ k map_consts + | Clt -> sltuimm64 a1 dest n succ [] map_consts | _ -> let r = r2pi () in - let ht = loadimm64 r n (n2pi ()) map_consts in + let ht = loadimm64 r n (n2pi ()) map_consts true in let r' = unzip_head_tuple ht r in - fst ht @ cond_int64u false cmp a1 r' dest tmp_reg succ k + fst ht @ cond_int64u false cmp a1 r' dest tmp_reg succ map_consts -let expanse_cond_fp cnot fn_cond cmp f1 f2 dest succ k = +let expanse_cond_fp cnot fn_cond cmp f1 f2 dest succ map_consts = let normal = is_normal_cmp cmp in let normal' = if cnot then not normal else normal in let succ' = if normal' then succ else n2pi () in - let insn = fn_cond cmp f1 f2 dest succ' in - insn - :: (if normal' then k else Iop (OExoriw Int.one, [ dest ], dest, succ) :: k) + let insn = fn_cond cmp f1 f2 dest succ' map_consts in + if normal' then insn + else build_full_ilist (OExoriw Int.one) [ dest ] dest succ insn [] map_consts -let expanse_cbranch_fp cnot fn_cond cmp f1 f2 info succ1 succ2 k = +let expanse_cbranch_fp cnot fn_cond cmp f1 f2 info succ1 succ2 map_consts = let r = r2pi () in let normal = is_normal_cmp cmp in let normal' = if cnot then not normal else normal in - let insn = fn_cond cmp f1 f2 r (n2pi ()) in + let insn = List.hd (fn_cond cmp f1 f2 r (n2pi ()) map_consts) in insn :: - (if normal' then Icond (CEbnew (Some false), [ r; r ], succ1, succ2, info) - else Icond (CEbeqw (Some false), [ r; r ], succ1, succ2, info)) - :: k + (if normal' then [ Icond (CEbnew (Some false), [ r; r ], succ1, succ2, info) ] + else [ Icond (CEbeqw (Some false), [ r; r ], succ1, succ2, info) ]) let get_regindent = function Coq_inr _ -> [] | Coq_inl r -> [ r ] @@ -447,24 +513,19 @@ let write_pathmap initial esize pm' = in pm' := PTree.set initial path' !pm' -let rec write_tree exp initial current code' new_order = +let rec write_tree exp initial current code' new_order fturn = + (*Printf.eprintf "wt: node is %d\n" !node;*) let target_node, next_node = - if current = !node then ( - node := !node + 1; - (P.to_int initial, current)) - else (current, current - 1) + if fturn then (P.to_int initial, current) else (current, current - 1) in match exp with - | (Iop (_, _, _, succ) as inst) :: k -> + | inst :: k -> + (*let open PrintRTL in*) + (*print_instruction stderr (target_node, inst);*) code' := PTree.set (P.of_int target_node) inst !code'; new_order := P.of_int target_node :: !new_order; - write_tree k initial next_node code' new_order - | (Icond (_, _, succ1, succ2, _) as inst) :: k -> - code' := PTree.set (P.of_int target_node) inst !code'; - new_order := P.of_int target_node :: !new_order; - write_tree k initial next_node code' new_order + write_tree k initial next_node code' new_order false | [] -> () - | _ -> failwith "ExpansionOracle.write_tree: inconsistent instruction." let expanse (sb : superblock) code pm = (*debug_flag := true;*) @@ -487,54 +548,54 @@ let expanse (sb : superblock) code pm = | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> debug "Iop/Ccomp\n"; let tmp_reg = get_tmp_reg c in - exp := cond_int32s false c a1 a2 dest tmp_reg succ []; + exp := cond_int32s false c a1 a2 dest tmp_reg succ map_consts; was_exp := true | Iop (Ocmp (Ccompu c), a1 :: a2 :: nil, dest, succ) -> debug "Iop/Ccompu\n"; let tmp_reg = get_tmp_reg c in - exp := cond_int32u false c a1 a2 dest tmp_reg succ []; + exp := cond_int32u false c a1 a2 dest tmp_reg succ map_consts; was_exp := true | Iop (Ocmp (Ccompimm (c, imm)), a1 :: nil, dest, succ) -> debug "Iop/Ccompimm\n"; - exp := expanse_condimm_int32s c a1 imm dest succ [] map_consts; + exp := expanse_condimm_int32s c a1 imm dest succ map_consts; was_exp := true | Iop (Ocmp (Ccompuimm (c, imm)), a1 :: nil, dest, succ) -> debug "Iop/Ccompuimm\n"; - exp := expanse_condimm_int32u c a1 imm dest succ [] map_consts; + exp := expanse_condimm_int32u c a1 imm dest succ map_consts; was_exp := true | Iop (Ocmp (Ccompl c), a1 :: a2 :: nil, dest, succ) -> debug "Iop/Ccompl\n"; let tmp_reg = get_tmp_reg c in - exp := cond_int64s false c a1 a2 dest tmp_reg succ []; + exp := cond_int64s false c a1 a2 dest tmp_reg succ map_consts; was_exp := true | Iop (Ocmp (Ccomplu c), a1 :: a2 :: nil, dest, succ) -> debug "Iop/Ccomplu\n"; let tmp_reg = get_tmp_reg c in - exp := cond_int64u false c a1 a2 dest tmp_reg succ []; + exp := cond_int64u false c a1 a2 dest tmp_reg succ map_consts; was_exp := true | Iop (Ocmp (Ccomplimm (c, imm)), a1 :: nil, dest, succ) -> debug "Iop/Ccomplimm\n"; - exp := expanse_condimm_int64s c a1 imm dest succ [] map_consts; + exp := expanse_condimm_int64s c a1 imm dest succ map_consts; was_exp := true | Iop (Ocmp (Ccompluimm (c, imm)), a1 :: nil, dest, succ) -> debug "Iop/Ccompluimm\n"; - exp := expanse_condimm_int64u c a1 imm dest succ [] map_consts; + exp := expanse_condimm_int64u c a1 imm dest succ map_consts; was_exp := true | Iop (Ocmp (Ccompf c), f1 :: f2 :: nil, dest, succ) -> debug "Iop/Ccompf\n"; - exp := expanse_cond_fp false cond_float c f1 f2 dest succ []; + exp := expanse_cond_fp false cond_float c f1 f2 dest succ map_consts; was_exp := true | Iop (Ocmp (Cnotcompf c), f1 :: f2 :: nil, dest, succ) -> debug "Iop/Cnotcompf\n"; - exp := expanse_cond_fp true cond_float c f1 f2 dest succ []; + exp := expanse_cond_fp true cond_float c f1 f2 dest succ map_consts; was_exp := true | Iop (Ocmp (Ccompfs c), f1 :: f2 :: nil, dest, succ) -> debug "Iop/Ccompfs\n"; - exp := expanse_cond_fp false cond_single c f1 f2 dest succ []; + exp := expanse_cond_fp false cond_single c f1 f2 dest succ map_consts; was_exp := true | Iop (Ocmp (Cnotcompfs c), f1 :: f2 :: nil, dest, succ) -> debug "Iop/Cnotcompfs\n"; - exp := expanse_cond_fp true cond_single c f1 f2 dest succ []; + exp := expanse_cond_fp true cond_single c f1 f2 dest succ map_consts; was_exp := true (* Expansion of branches - Ccomp *) | Icond (Ccomp c, a1 :: a2 :: nil, succ1, succ2, info) -> @@ -584,24 +645,29 @@ let expanse (sb : superblock) code pm = | Icond (Ccompf c, f1 :: f2 :: nil, succ1, succ2, info) -> debug "Icond/Ccompf\n"; exp := - expanse_cbranch_fp false cond_float c f1 f2 info succ1 succ2 []; + expanse_cbranch_fp false cond_float c f1 f2 info succ1 succ2 + map_consts; was_branch := true; was_exp := true | Icond (Cnotcompf c, f1 :: f2 :: nil, succ1, succ2, info) -> debug "Icond/Cnotcompf\n"; - exp := expanse_cbranch_fp true cond_float c f1 f2 info succ1 succ2 []; + exp := + expanse_cbranch_fp true cond_float c f1 f2 info succ1 succ2 + map_consts; was_branch := true; was_exp := true | Icond (Ccompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> debug "Icond/Ccompfs\n"; exp := - expanse_cbranch_fp false cond_single c f1 f2 info succ1 succ2 []; + expanse_cbranch_fp false cond_single c f1 f2 info succ1 succ2 + map_consts; was_branch := true; was_exp := true | Icond (Cnotcompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> debug "Icond/Cnotcompfs\n"; exp := - expanse_cbranch_fp true cond_single c f1 f2 info succ1 succ2 []; + expanse_cbranch_fp true cond_single c f1 f2 info succ1 succ2 + map_consts; was_branch := true; was_exp := true | _ -> ()); @@ -611,22 +677,197 @@ let expanse (sb : superblock) code pm = | Iop (Ofloatconst f, nil, dest, succ) -> debug "Iop/Ofloatconst\n"; let r = r2pi () in + let ht = loadimm64 r (Floats.Float.to_bits f) (n2pi ()) map_consts true in + let r' = unzip_head_tuple ht r in exp := - [ - Iop (Olongconst (Floats.Float.to_bits f), [], r, n2pi ()); - Iop (Ofloat_of_bits, [ r ], dest, succ); - ]; + build_full_ilist Ofloat_of_bits [ r' ] dest succ (fst ht) [] + map_consts; was_exp := true | Iop (Osingleconst f, nil, dest, succ) -> debug "Iop/Osingleconst\n"; let r = r2pi () in + let ht = + loadimm32 r (Floats.Float32.to_bits f) (n2pi ()) map_consts true + in + let r' = unzip_head_tuple ht r in exp := - [ - Iop (Ointconst (Floats.Float32.to_bits f), [], r, n2pi ()); - Iop (Osingle_of_bits, [ r ], dest, succ); - ]; + build_full_ilist Osingle_of_bits [ r' ] dest succ (fst ht) [] + map_consts; was_exp := true | _ -> ()); + + (* TODO gourdinl flag ? *) + (match inst with + | Iop (Ointconst n, nil, dest, succ) -> + debug "Iop/Ointconst\n"; + let ht = loadimm32 dest n succ map_consts false in + exp := unzip_head_tuple_move ht dest succ; + was_exp := true + | Iop (Olongconst n, nil, dest, succ) -> + debug "Iop/Olongconst\n"; + let ht = loadimm64 dest n succ map_consts false in + exp := unzip_head_tuple_move ht dest succ; + was_exp := true + | Iop (Oaddimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oaddimm\n"; + exp := addimm32 a1 dest n succ [] map_consts; + was_exp := true + | Iop (Oaddlimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oaddlimm\n"; + exp := addimm64 a1 dest n succ [] map_consts; + was_exp := true + | Iop (Oandimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oandimm\n"; + exp := andimm32 a1 dest n succ [] map_consts; + was_exp := true + | Iop (Oandlimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oandlimm\n"; + exp := andimm64 a1 dest n succ [] map_consts; + was_exp := true + | Iop (Oorimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oorimm\n"; + exp := orimm32 a1 dest n succ [] map_consts; + was_exp := true + | Iop (Oorlimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oorlimm\n"; + exp := orimm64 a1 dest n succ [] map_consts; + was_exp := true + | Iop (Ocast8signed, a1 :: nil, dest, succ) -> + debug "Iop/cast8signed"; + let op = Oshlimm (Int.repr (Z.of_sint 24)) in + let r = r2pi () in + let sv = find_or_addnmove op [ a1 ] r (n2pi ()) map_consts true in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + exp := + build_full_ilist + (Oshrimm (Int.repr (Z.of_sint 24))) + [ r' ] dest succ (fst ht) [] map_consts; + was_exp := true + | Iop (Ocast16signed, a1 :: nil, dest, succ) -> + debug "Iop/cast8signed"; + let op = Oshlimm (Int.repr (Z.of_sint 16)) in + let r = r2pi () in + let sv = find_or_addnmove op [ a1 ] r (n2pi ()) map_consts true in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + exp := + build_full_ilist + (Oshrimm (Int.repr (Z.of_sint 16))) + [ r' ] dest succ (fst ht) [] map_consts; + was_exp := true + | Iop (Ocast32unsigned, a1 :: nil, dest, succ) -> + debug "Iop/Ocast32unsigned"; + let n2 = n2pi () in + let n1 = n2pi () in + let r1 = r2pi () in + let r2 = r2pi () in + let op1 = Ocast32signed in + let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in + let ht1 = build_head_tuple [] sv1 in + let r1' = unzip_head_tuple ht1 r1 in + + let op2 = Oshllimm (Int.repr (Z.of_sint 32)) in + let sv2 = find_or_addnmove op2 [ r1' ] r2 n2 map_consts true in + let ht2 = build_head_tuple (fst ht1) sv2 in + let r2' = unzip_head_tuple ht2 r2 in + + let op3 = Oshrluimm (Int.repr (Z.of_sint 32)) in + exp := build_full_ilist op3 [ r2' ] dest succ (fst ht2) [] map_consts + | Iop (Oshrximm n, a1 :: nil, dest, succ) -> + debug "Iop/Oshrximm"; + if Int.eq n Int.zero then exp := [ Iop (Omove, [ a1 ], dest, succ) ] + else if Int.eq n Int.one then + let n2 = n2pi () in + let n1 = n2pi () in + let r1 = r2pi () in + let r2 = r2pi () in + let op1 = Oshruimm (Int.repr (Z.of_sint 31)) in + let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in + let ht1 = build_head_tuple [] sv1 in + let r1' = unzip_head_tuple ht1 r1 in + + let op2 = Oadd in + let sv2 = find_or_addnmove op2 [ a1; r1' ] r2 n2 map_consts true in + let ht2 = build_head_tuple (fst ht1) sv2 in + let r2' = unzip_head_tuple ht2 r2 in + + let op3 = Oshrimm Int.one in + exp := + build_full_ilist op3 [ r2' ] dest succ (fst ht2) [] map_consts + else + let n3 = n2pi () in + let n2 = n2pi () in + let n1 = n2pi () in + let r1 = r2pi () in + let r2 = r2pi () in + let r3 = r2pi () in + let op1 = Oshrimm (Int.repr (Z.of_sint 31)) in + let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in + let ht1 = build_head_tuple [] sv1 in + let r1' = unzip_head_tuple ht1 r1 in + + let op2 = Oshruimm (Int.sub Int.iwordsize n) in + let sv2 = find_or_addnmove op2 [ r1' ] r2 n2 map_consts true in + let ht2 = build_head_tuple (fst ht1) sv2 in + let r2' = unzip_head_tuple ht2 r2 in + + let op3 = Oadd in + let sv3 = find_or_addnmove op3 [ a1; r2' ] r3 n3 map_consts true in + let ht3 = build_head_tuple (fst ht2) sv3 in + let r3' = unzip_head_tuple ht3 r3 in + + let op4 = Oshrimm n in + exp := + build_full_ilist op4 [ r3' ] dest succ (fst ht3) [] map_consts + | Iop (Oshrxlimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oshrxlimm"; + if Int.eq n Int.zero then exp := [ Iop (Omove, [ a1 ], dest, succ) ] + else if Int.eq n Int.one then + let n2 = n2pi () in + let n1 = n2pi () in + let r1 = r2pi () in + let r2 = r2pi () in + let op1 = Oshrluimm (Int.repr (Z.of_sint 63)) in + let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in + let ht1 = build_head_tuple [] sv1 in + let r1' = unzip_head_tuple ht1 r1 in + + let op2 = Oaddl in + let sv2 = find_or_addnmove op2 [ a1; r1' ] r2 n2 map_consts true in + let ht2 = build_head_tuple (fst ht1) sv2 in + let r2' = unzip_head_tuple ht2 r2 in + + let op3 = Oshrlimm Int.one in + exp := + build_full_ilist op3 [ r2' ] dest succ (fst ht2) [] map_consts + else + let n3 = n2pi () in + let n2 = n2pi () in + let n1 = n2pi () in + let r1 = r2pi () in + let r2 = r2pi () in + let r3 = r2pi () in + let op1 = Oshrlimm (Int.repr (Z.of_sint 63)) in + let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in + let ht1 = build_head_tuple [] sv1 in + let r1' = unzip_head_tuple ht1 r1 in + + let op2 = Oshrluimm (Int.sub Int64.iwordsize' n) in + let sv2 = find_or_addnmove op2 [ r1' ] r2 n2 map_consts true in + let ht2 = build_head_tuple (fst ht1) sv2 in + let r2' = unzip_head_tuple ht2 r2 in + + let op3 = Oaddl in + let sv3 = find_or_addnmove op3 [ a1; r2' ] r3 n3 map_consts true in + let ht3 = build_head_tuple (fst ht2) sv3 in + let r3' = unzip_head_tuple ht3 r3 in + + let op4 = Oshrlimm n in + exp := + build_full_ilist op4 [ r3' ] dest succ (fst ht3) [] map_consts + | _ -> ()); + if !was_exp then ( (if !was_branch && List.length !exp > 1 then let lives = PTree.get n !liveins in @@ -637,7 +878,7 @@ let expanse (sb : superblock) code pm = liveins := PTree.remove n !liveins | _ -> ()); write_pathmap sb.instructions.(0) (List.length !exp - 1) pm'; - write_tree !exp n !node code' new_order) + write_tree !exp n !node code' new_order true) else new_order := n :: !new_order) sb.instructions; sb.instructions <- Array.of_list (List.rev !new_order); diff --git a/riscV/NeedOp.v b/riscV/NeedOp.v index 46d6ee73..4ed9868c 100644 --- a/riscV/NeedOp.v +++ b/riscV/NeedOp.v @@ -97,7 +97,10 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | OEsltiuw _ => op1 (default nv) | OExoriw _ => op1 (bitwise nv) | OEluiw _ => op1 (default nv) - | OEaddiwr0 _ => op1 (default nv) (* TODO gourdinl modarith impossible? *) + | OEaddiw _ => op1 (default nv) + | OEaddiwr0 _ => op1 (default nv) + | OEandiw n => op1 (andimm nv n) + | OEoriw n => op1 (orimm nv n) | OEseql _ => op2 (default nv) | OEsnel _ => op2 (default nv) | OEsequl _ => op2 (default nv) @@ -108,9 +111,14 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | OEsltiul _ => op1 (default nv) | OExoril _ => op1 (default nv) | OEluil _ => op1 (default nv) - | OEaddilr0 _ => op1 (default nv) (* TODO gourdinl modarith impossible? *) + | OEaddil _ => op1 (default nv) + | OEaddilr0 _ => op1 (default nv) + | OEandil _ => op1 (default nv) + | OEoril _ => op1 (default nv) | OEloadli _ => op1 (default nv) | OEmayundef _ => op2 (default nv) + | OEshrxundef _ => op2 (default nv) + | OEshrxlundef _ => op2 (default nv) | OEfeqd => op2 (default nv) | OEfltd => op2 (default nv) | OEfled => op2 (default nv) @@ -189,6 +197,16 @@ Proof. - apply shlimm_sound; auto. - apply shrimm_sound; auto. - apply shruimm_sound; auto. +- fold (Val.and (Vint n) v0); + fold (Val.and (Vint n) v2); + rewrite (Val.and_commut (Vint n) v0); + rewrite (Val.and_commut (Vint n) v2); + apply andimm_sound; auto. +- fold (Val.or (Vint n) v0); + fold (Val.or (Vint n) v2); + rewrite (Val.or_commut (Vint n) v0); + rewrite (Val.or_commut (Vint n) v2); + apply orimm_sound; auto. - apply xor_sound; auto with na. - (* selectl *) unfold ExtValues.select01_long. diff --git a/riscV/Op.v b/riscV/Op.v index d902c907..0569676a 100644 --- a/riscV/Op.v +++ b/riscV/Op.v @@ -180,9 +180,12 @@ Inductive operation : Type := | OEsltuw (optR0: option bool) (**r set-less-than unsigned *) | OEsltiw (n: int) (**r set-less-than immediate *) | OEsltiuw (n: int) (**r set-less-than unsigned immediate *) + | OEaddiw (n: int) (**r add immediate *) + | OEaddiwr0 (n: int) (**r add immediate *) + | OEandiw (n: int) (**r and immediate *) + | OEoriw (n: int) (**r or immediate *) | OExoriw (n: int) (**r xor immediate *) | OEluiw (n: int) (**r load upper-immediate *) - | OEaddiwr0 (n: int) (**r add immediate *) | OEseql (optR0: option bool) (**r [rd <- rs1 == rs2] signed *) | OEsnel (optR0: option bool) (**r [rd <- rs1 != rs2] signed *) | OEsequl (optR0: option bool) (**r [rd <- rs1 == rs2] unsigned *) @@ -191,11 +194,16 @@ Inductive operation : Type := | OEsltul (optR0: option bool) (**r set-less-than unsigned *) | OEsltil (n: int64) (**r set-less-than immediate *) | OEsltiul (n: int64) (**r set-less-than unsigned immediate *) + | OEaddil (n: int64) (**r add immediate *) + | OEaddilr0 (n: int64) (**r add immediate *) + | OEandil (n: int64) (**r and immediate *) + | OEoril (n: int64) (**r or immediate *) | OExoril (n: int64) (**r xor immediate *) | OEluil (n: int64) (**r load upper-immediate *) - | OEaddilr0 (n: int64) (**r add immediate *) | OEloadli (n: int64) (**r load an immediate int64 *) | OEmayundef (is_long: bool) + | OEshrxundef (n: int) + | OEshrxlundef (n: int) | OEfeqd (**r compare equal *) | OEfltd (**r compare less-than *) | OEfled (**r compare less-than/equal *) @@ -252,13 +260,6 @@ Defined. *) Global Opaque eq_condition eq_addressing eq_operation. - -(** * Evaluation functions *) - -(** Evaluation of conditions, operators and addressing modes applied - to lists of values. Return [None] when the computation can trigger an - error, e.g. integer division by zero. [eval_condition] returns a boolean, - [eval_operation] and [eval_addressing] return a value. *) Definition zero32 := (Vint Int.zero). Definition zero64 := (Vlong Int64.zero). @@ -282,6 +283,39 @@ Definition may_undef_int (is_long: bool) (v1 v2: val): val := | _ => Vundef end. +Definition shrx_imm_undef (v1 v2: val): val := + match v1 with + | Vint n1 => + match v2 with + | Vint n2 => + if Int.ltu n2 (Int.repr 31) + then Vint n1 + else Vundef + | _ => Vundef + end + | _ => Vundef + end. + +Definition shrxl_imm_undef (v1 v2: val): val := + match v1 with + | Vlong n1 => + match v2 with + | Vint n2 => + if Int.ltu n2 (Int.repr 63) + then Vlong n1 + else Vundef + | _ => Vundef + end + | _ => Vundef + end. + +(** * Evaluation functions *) + +(** Evaluation of conditions, operators and addressing modes applied + to lists of values. Return [None] when the computation can trigger an + error, e.g. integer division by zero. [eval_condition] returns a boolean, + [eval_operation] and [eval_addressing] return a value. *) + Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := match cond, vl with | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 @@ -428,7 +462,10 @@ Definition eval_operation | OEsltiuw n, v1::nil => Some (Val.cmpu (Mem.valid_pointer m) Clt v1 (Vint n)) | OExoriw n, v1::nil => Some (Val.xor v1 (Vint n)) | OEluiw n, nil => Some (Val.shl (Vint n) (Vint (Int.repr 12))) + | OEaddiw n, v1::nil => Some (Val.add (Vint n) v1) | OEaddiwr0 n, nil => Some (Val.add (Vint n) zero32) + | OEandiw n, v1::nil => Some (Val.and (Vint n) v1) + | OEoriw n, v1::nil => Some (Val.or (Vint n) v1) | OEseql optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Ceq) v1 v2 zero64)) | OEsnel optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Cne) v1 v2 zero64)) | OEsequl optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) Ceq) v1 v2 zero64)) @@ -439,9 +476,14 @@ Definition eval_operation | OEsltiul n, v1::nil => Some (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 (Vlong n))) | OExoril n, v1::nil => Some (Val.xorl v1 (Vlong n)) | OEluil n, nil => Some (Vlong (Int64.sign_ext 32 (Int64.shl n (Int64.repr 12)))) + | OEaddil n, v1::nil => Some (Val.addl (Vlong n) v1) | OEaddilr0 n, nil => Some (Val.addl (Vlong n) zero64) + | OEandil n, v1::nil => Some (Val.andl (Vlong n) v1) + | OEoril n, v1::nil => Some (Val.orl (Vlong n) v1) | OEloadli n, nil => Some (Vlong n) | OEmayundef is_long, v1::v2::nil => Some (may_undef_int is_long v1 v2) + | OEshrxundef n, v1::nil => Some (shrx_imm_undef v1 (Vint n)) + | OEshrxlundef n, v1::nil => Some (shrxl_imm_undef v1 (Vint n)) | OEfeqd, v1::v2::nil => Some (Val.cmpf Ceq v1 v2) | OEfltd, v1::v2::nil => Some (Val.cmpf Clt v1 v2) | OEfled, v1::v2::nil => Some (Val.cmpf Cle v1 v2) @@ -631,7 +673,10 @@ Definition type_of_operation (op: operation) : list typ * typ := | OEsltiuw _ => (Tint :: nil, Tint) | OExoriw _ => (Tint :: nil, Tint) | OEluiw _ => (nil, Tint) + | OEaddiw _ => (Tint :: nil, Tint) | OEaddiwr0 _ => (nil, Tint) + | OEandiw _ => (Tint :: nil, Tint) + | OEoriw _ => (Tint :: nil, Tint) | OEseql _ => (Tlong :: Tlong :: nil, Tint) | OEsnel _ => (Tlong :: Tlong :: nil, Tint) | OEsequl _ => (Tlong :: Tlong :: nil, Tint) @@ -640,11 +685,16 @@ Definition type_of_operation (op: operation) : list typ * typ := | OEsltul _ => (Tlong :: Tlong :: nil, Tint) | OEsltil _ => (Tlong :: nil, Tint) | OEsltiul _ => (Tlong :: nil, Tint) + | OEandil _ => (Tlong :: nil, Tlong) + | OEoril _ => (Tlong :: nil, Tlong) | OExoril _ => (Tlong :: nil, Tlong) | OEluil _ => (nil, Tlong) + | OEaddil _ => (Tlong :: nil, Tlong) | OEaddilr0 _ => (nil, Tlong) | OEloadli _ => (nil, Tlong) | OEmayundef _ => (Tany64 :: Tany64 :: nil, Tany64) + | OEshrxundef _ => (Tint :: nil, Tint) + | OEshrxlundef _ => (Tlong :: nil, Tlong) | OEfeqd => (Tfloat :: Tfloat :: nil, Tint) | OEfltd => (Tfloat :: Tfloat :: nil, Tint) | OEfled => (Tfloat :: Tfloat :: nil, Tint) @@ -885,13 +935,19 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). all: destruct b... (* OEsltiuw *) - unfold Val.cmpu; destruct Val.cmpu_bool... destruct b... + (* OEaddiw *) + - fold (Val.add (Vint n) v0); apply type_add. + (* OEaddiwr0 *) + - trivial. + (* OEandiw *) + - destruct v0... + (* OEoriw *) + - destruct v0... (* OExoriw *) - destruct v0... (* OEluiw *) - unfold may_undef_int; destruct (Int.ltu _ _); cbn; trivial. - (* OEaddiwr0 *) - - simpl; trivial. (* OEseql *) - destruct optR0 as [[]|]; simpl; unfold Val.cmpl; destruct Val.cmpl_bool... all: destruct b... @@ -915,17 +971,31 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). all: destruct b... (* OEsltiul *) - unfold Val.cmplu; destruct Val.cmplu_bool... destruct b... + (* OEaddil *) + - fold (Val.addl (Vlong n) v0); apply type_addl. + (* OEaddilr0 *) + - trivial. + (* OEandil *) + - destruct v0... + (* OEoril *) + - destruct v0... (* OExoril *) - destruct v0... (* OEluil *) - simpl; trivial. - (* OEaddilr0 *) - - simpl; trivial. (* OEloadli *) - trivial. (* OEmayundef *) - unfold may_undef_int; destruct is_long, v0, v1; simpl; trivial. + (* OEshrxundef *) + - unfold shrx_imm_undef; + destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + (* OEshrxlundef *) + - unfold shrxl_imm_undef; + destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* OEfeqd *) - destruct v0; destruct v1; cbn; auto. destruct Float.cmp; cbn; auto. @@ -1736,6 +1806,14 @@ Proof. - inv H4; simpl; cbn; auto; try destruct (Int.lt _ _); apply Val.inject_int. (* OEsltiuw *) - apply eval_cmpu_bool_inj; auto. + (* OEaddiw *) + - fold (Val.add (Vint n) v); + fold (Val.add (Vint n) v'); + apply Val.add_inject; auto. + (* OEandiw *) + - inv H4; cbn; auto. + (* OEoriw *) + - inv H4; cbn; auto. (* OExoriw *) - inv H4; simpl; auto. (* OEluiw *) @@ -1762,12 +1840,28 @@ Proof. - inv H4; simpl; cbn; auto; try destruct (Int64.lt _ _); apply Val.inject_int. (* OEsltiul *) - apply eval_cmplu_bool_inj; auto. + (* OEaddil *) + - fold (Val.addl (Vlong n) v); + fold (Val.addl (Vlong n) v'); + apply Val.addl_inject; auto. + (* OEandil *) + - inv H4; cbn; auto. + (* OEoril *) + - inv H4; cbn; auto. (* OExoril *) - inv H4; simpl; auto. (* OEmayundef *) - destruct is_long; inv H4; inv H2; unfold may_undef_int; simpl; auto; eapply Val.inject_ptr; eauto. + (* OEshrxundef *) + - inv H4; + unfold shrx_imm_undef; simpl; auto. + destruct (Int.ltu _ _); auto. + (* OEshrxlundef *) + - inv H4; + unfold shrxl_imm_undef; simpl; auto. + destruct (Int.ltu _ _); auto. (* OEfeqd *) - inv H4; inv H2; cbn; simpl; auto. destruct Float.cmp; unfold Vtrue, Vfalse; cbn; auto. diff --git a/riscV/OpWeights.ml b/riscV/OpWeights.ml index 35ae81e6..23fbd4fc 100644 --- a/riscV/OpWeights.ml +++ b/riscV/OpWeights.ml @@ -1,177 +1,167 @@ -open Op;; -open PrepassSchedulingOracleDeps;; - -module Rocket = - struct - (* Attempt at modeling the Rocket core *) - - let resource_bounds = [| 1 |];; - let nr_non_pipelined_units = 1;; (* divider *) - - let latency_of_op (op : operation) (nargs : int) = - match op with - | Omul | Omulhs | Omulhu - | Omull | Omullhs | Omullhu -> 4 - - | Onegf -> 1 (*r [rd = - r1] *) - | Oabsf (*r [rd = abs(r1)] *) - | Oaddf (*r [rd = r1 + r2] *) - | Osubf (*r [rd = r1 - r2] *) - | Omulf -> 6 (*r [rd = r1 * r2] *) - | Onegfs -> 1 (*r [rd = - r1] *) - | Oabsfs (*r [rd = abs(r1)] *) - | Oaddfs (*r [rd = r1 + r2] *) - | Osubfs (*r [rd = r1 - r2] *) - | Omulfs -> 4 (*r [rd = r1 * r2] *) - | Osingleoffloat (*r [rd] is [r1] truncated to single-precision float *) - | Ofloatofsingle -> 4 (*r [rd] is [r1] extended to double-precision float *) - (*c Conversions between int and float: *) - | Ointoffloat (*r [rd = signed_int_of_float64(r1)] *) - | Ointuoffloat (*r [rd = unsigned_int_of_float64(r1)] *) - | Ofloatofint (*r [rd = float64_of_signed_int(r1)] *) - | Ofloatofintu -> 6 (*r [rd = float64_of_unsigned_int(r1)] *) - | Ointofsingle (*r [rd = signed_int_of_float32(r1)] *) - | Ointuofsingle (*r [rd = unsigned_int_of_float32(r1)] *) - | Osingleofint (*r [rd = float32_of_signed_int(r1)] *) - | Osingleofintu -> 4 (*r [rd = float32_of_unsigned_int(r1)] *) - | Olongoffloat (*r [rd = signed_long_of_float64(r1)] *) - | Olonguoffloat (*r [rd = unsigned_long_of_float64(r1)] *) - | Ofloatoflong (*r [rd = float64_of_signed_long(r1)] *) - | Ofloatoflongu -> 6 (*r [rd = float64_of_unsigned_long(r1)] *) - | Olongofsingle (*r [rd = signed_long_of_float32(r1)] *) - | Olonguofsingle (*r [rd = unsigned_long_of_float32(r1)] *) - | Osingleoflong (*r [rd = float32_of_signed_long(r1)] *) - | Osingleoflongu -> 4 (*r [rd = float32_of_unsigned_int(r1)] *) - - | Odiv | Odivu | Odivl | Odivlu -> 16 - | Odivfs -> 35 - | Odivf -> 50 - - | Ocmp cond -> - (match cond with - | Ccomp _ - | Ccompu _ - | Ccompimm _ - | Ccompuimm _ - | Ccompl _ - | Ccomplu _ - | Ccomplimm _ - | Ccompluimm _ - | CEbeqw _ - | CEbnew _ - | CEbequw _ - | CEbneuw _ - | CEbltw _ - | CEbltuw _ - | CEbgew _ - | CEbgeuw _ - | CEbeql _ - | CEbnel _ - | CEbequl _ - | CEbneul _ - | CEbltl _ - | CEbltul _ - | CEbgel _ - | CEbgeul _ -> 1 - | Ccompf _ - | Cnotcompf _ -> 6 - | Ccompfs _ - | Cnotcompfs _ -> 4) - | _ -> 1;; - - let resources_of_op (op : operation) (nargs : int) = resource_bounds;; - - let non_pipelined_resources_of_op (op : operation) (nargs : int) = - match op with - | Odiv | Odivu -> [| 29 |] - | Odivfs -> [| 20 |] - | Odivl | Odivlu | Odivf -> [| 50 |] - | _ -> [| -1 |];; - - let resources_of_cond (cond : condition) (nargs : int) = resource_bounds;; - - let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3;; - let latency_of_call _ _ = 6;; - - let resources_of_load trap chunk addressing nargs = resource_bounds;; - - let resources_of_store chunk addressing nargs = resource_bounds;; - - let resources_of_call _ _ = resource_bounds;; - let resources_of_builtin _ = resource_bounds;; - end;; - -module SweRV_EH1 = - struct - (* Attempt at modeling SweRV EH1 - [| issues ; LSU ; multiplier |] *) - let resource_bounds = [| 2 ; 1; 1 |];; - let nr_non_pipelined_units = 1;; (* divider *) - - let latency_of_op (op : operation) (nargs : int) = - match op with - | Omul | Omulhs | Omulhu - | Omull | Omullhs | Omullhu -> 3 - | Odiv | Odivu | Odivl | Odivlu -> 16 - | _ -> 1;; - - let resources_of_op (op : operation) (nargs : int) = - match op with - | Omul | Omulhs | Omulhu - | Omull | Omullhs | Omullhu -> [| 1 ; 0 ; 1 |] - | Odiv | Odivu | Odivl | Odivlu -> [| 0 ; 0; 0 |] - | _ -> [| 1; 0; 0 |];; - - let non_pipelined_resources_of_op (op : operation) (nargs : int) = - match op with - | Odiv | Odivu -> [| 29 |] - | Odivfs -> [| 20 |] - | Odivl | Odivlu | Odivf -> [| 50 |] - | _ -> [| -1 |];; - - let resources_of_cond (cond : condition) (nargs : int) = [| 1; 0; 0 |];; - - let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3;; - let latency_of_call _ _ = 6;; - - let resources_of_load trap chunk addressing nargs = [| 1; 1; 0 |];; - - let resources_of_store chunk addressing nargs = [| 1; 1; 0 |];; - - let resources_of_call _ _ = resource_bounds;; - let resources_of_builtin _ = resource_bounds;; - end;; +open Op +open PrepassSchedulingOracleDeps + +module Rocket = struct + (* Attempt at modeling the Rocket core *) + + let resource_bounds = [| 1 |] + + let nr_non_pipelined_units = 1 + + (* divider *) + + let latency_of_op (op : operation) (nargs : int) = + match op with + | Omul | Omulhs | Omulhu | Omull | Omullhs | Omullhu -> 4 + | Onegf -> 1 (*r [rd = - r1] *) + | Oabsf (*r [rd = abs(r1)] *) + | Oaddf (*r [rd = r1 + r2] *) + | Osubf (*r [rd = r1 - r2] *) + | Omulf -> + 6 (*r [rd = r1 * r2] *) + | Onegfs -> 1 (*r [rd = - r1] *) + | Oabsfs (*r [rd = abs(r1)] *) + | Oaddfs (*r [rd = r1 + r2] *) + | Osubfs (*r [rd = r1 - r2] *) + | Omulfs -> + 4 (*r [rd = r1 * r2] *) + | Osingleoffloat (*r [rd] is [r1] truncated to single-precision float *) + | Ofloatofsingle (*r [rd] is [r1] extended to double-precision float *) + (*c Conversions between int and float: *) + | Ofloatconst _ | Osingleconst _ + | Ointoffloat (*r [rd = signed_int_of_float64(r1)] *) + | Ointuoffloat (*r [rd = unsigned_int_of_float64(r1)] *) + | Ofloatofint (*r [rd = float64_of_signed_int(r1)] *) + | Ofloatofintu (*r [rd = float64_of_unsigned_int(r1)] *) + | Ointofsingle (*r [rd = signed_int_of_float32(r1)] *) + | Ointuofsingle (*r [rd = unsigned_int_of_float32(r1)] *) + | Osingleofint (*r [rd = float32_of_signed_int(r1)] *) + | Osingleofintu (*r [rd = float32_of_unsigned_int(r1)] *) + | Olongoffloat (*r [rd = signed_long_of_float64(r1)] *) + | Olonguoffloat (*r [rd = unsigned_long_of_float64(r1)] *) + | Ofloatoflong (*r [rd = float64_of_signed_long(r1)] *) + | Ofloatoflongu (*r [rd = float64_of_unsigned_long(r1)] *) + | Olongofsingle (*r [rd = signed_long_of_float32(r1)] *) + | Olonguofsingle (*r [rd = unsigned_long_of_float32(r1)] *) + | Osingleoflong (*r [rd = float32_of_signed_long(r1)] *) + | Osingleoflongu -> + 2 (*r [rd = float32_of_unsigned_int(r1)] *) + | OEfeqd | OEfltd | OEfeqs | OEflts | OEfles | OEfled | Obits_of_single + | Obits_of_float | Osingle_of_bits | Ofloat_of_bits -> + 2 + | OEloadli _ -> 2 + | Odiv | Odivu | Odivl | Odivlu -> 16 + | Odivfs -> 35 + | Odivf -> 50 + | Ocmp cond -> ( + match cond with + | Ccomp _ | Ccompu _ | Ccompimm _ | Ccompuimm _ | Ccompl _ | Ccomplu _ + | Ccomplimm _ | Ccompluimm _ | CEbeqw _ | CEbnew _ | CEbequw _ + | CEbneuw _ | CEbltw _ | CEbltuw _ | CEbgew _ | CEbgeuw _ | CEbeql _ + | CEbnel _ | CEbequl _ | CEbneul _ | CEbltl _ | CEbltul _ | CEbgel _ + | CEbgeul _ -> + 1 + | Ccompf _ | Cnotcompf _ -> 2 + | Ccompfs _ | Cnotcompfs _ -> 2) + | _ -> 1 + + let resources_of_op (op : operation) (nargs : int) = resource_bounds + + let non_pipelined_resources_of_op (op : operation) (nargs : int) = + match op with + | Odiv | Odivu -> [| 29 |] + | Odivfs -> [| 20 |] + | Odivl | Odivlu | Odivf -> [| 50 |] + | _ -> [| -1 |] + + let resources_of_cond (cond : condition) (nargs : int) = resource_bounds + + let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3 + + let latency_of_call _ _ = 6 + + let resources_of_load trap chunk addressing nargs = resource_bounds + + let resources_of_store chunk addressing nargs = resource_bounds + + let resources_of_call _ _ = resource_bounds + + let resources_of_builtin _ = resource_bounds +end + +module SweRV_EH1 = struct + (* Attempt at modeling SweRV EH1 + [| issues ; LSU ; multiplier |] *) + let resource_bounds = [| 2; 1; 1 |] + + let nr_non_pipelined_units = 1 + + (* divider *) + + let latency_of_op (op : operation) (nargs : int) = + match op with + | Omul | Omulhs | Omulhu | Omull | Omullhs | Omullhu -> 3 + | Odiv | Odivu | Odivl | Odivlu -> 16 + | _ -> 1 + + let resources_of_op (op : operation) (nargs : int) = + match op with + | Omul | Omulhs | Omulhu | Omull | Omullhs | Omullhu -> [| 1; 0; 1 |] + | Odiv | Odivu | Odivl | Odivlu -> [| 0; 0; 0 |] + | _ -> [| 1; 0; 0 |] + + let non_pipelined_resources_of_op (op : operation) (nargs : int) = + match op with + | Odiv | Odivu -> [| 29 |] + | Odivfs -> [| 20 |] + | Odivl | Odivlu | Odivf -> [| 50 |] + | _ -> [| -1 |] + + let resources_of_cond (cond : condition) (nargs : int) = [| 1; 0; 0 |] + + let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3 + + let latency_of_call _ _ = 6 + + let resources_of_load trap chunk addressing nargs = [| 1; 1; 0 |] + + let resources_of_store chunk addressing nargs = [| 1; 1; 0 |] + + let resources_of_call _ _ = resource_bounds + + let resources_of_builtin _ = resource_bounds +end let get_opweights () : opweights = match !Clflags.option_mtune with | "rocket" | "" -> - { - pipelined_resource_bounds = Rocket.resource_bounds; - nr_non_pipelined_units = Rocket.nr_non_pipelined_units; - latency_of_op = Rocket.latency_of_op; - resources_of_op = Rocket.resources_of_op; - non_pipelined_resources_of_op = Rocket.non_pipelined_resources_of_op; - latency_of_load = Rocket.latency_of_load; - resources_of_load = Rocket.resources_of_load; - resources_of_store = Rocket.resources_of_store; - resources_of_cond = Rocket.resources_of_cond; - latency_of_call = Rocket.latency_of_call; - resources_of_call = Rocket.resources_of_call; - resources_of_builtin = Rocket.resources_of_builtin - } + { + pipelined_resource_bounds = Rocket.resource_bounds; + nr_non_pipelined_units = Rocket.nr_non_pipelined_units; + latency_of_op = Rocket.latency_of_op; + resources_of_op = Rocket.resources_of_op; + non_pipelined_resources_of_op = Rocket.non_pipelined_resources_of_op; + latency_of_load = Rocket.latency_of_load; + resources_of_load = Rocket.resources_of_load; + resources_of_store = Rocket.resources_of_store; + resources_of_cond = Rocket.resources_of_cond; + latency_of_call = Rocket.latency_of_call; + resources_of_call = Rocket.resources_of_call; + resources_of_builtin = Rocket.resources_of_builtin; + } | "SweRV_EH1" | "EH1" -> - { - pipelined_resource_bounds = SweRV_EH1.resource_bounds; - nr_non_pipelined_units = SweRV_EH1.nr_non_pipelined_units; - latency_of_op = SweRV_EH1.latency_of_op; - resources_of_op = SweRV_EH1.resources_of_op; - non_pipelined_resources_of_op = SweRV_EH1.non_pipelined_resources_of_op; - latency_of_load = SweRV_EH1.latency_of_load; - resources_of_load = SweRV_EH1.resources_of_load; - resources_of_store = SweRV_EH1.resources_of_store; - resources_of_cond = SweRV_EH1.resources_of_cond; - latency_of_call = SweRV_EH1.latency_of_call; - resources_of_call = SweRV_EH1.resources_of_call; - resources_of_builtin = SweRV_EH1.resources_of_builtin - } - | xxx -> failwith (Printf.sprintf "unknown -mtune: %s" xxx);; + { + pipelined_resource_bounds = SweRV_EH1.resource_bounds; + nr_non_pipelined_units = SweRV_EH1.nr_non_pipelined_units; + latency_of_op = SweRV_EH1.latency_of_op; + resources_of_op = SweRV_EH1.resources_of_op; + non_pipelined_resources_of_op = SweRV_EH1.non_pipelined_resources_of_op; + latency_of_load = SweRV_EH1.latency_of_load; + resources_of_load = SweRV_EH1.resources_of_load; + resources_of_store = SweRV_EH1.resources_of_store; + resources_of_cond = SweRV_EH1.resources_of_cond; + latency_of_call = SweRV_EH1.latency_of_call; + resources_of_call = SweRV_EH1.resources_of_call; + resources_of_builtin = SweRV_EH1.resources_of_builtin; + } + | xxx -> failwith (Printf.sprintf "unknown -mtune: %s" xxx) diff --git a/riscV/PrintOp.ml b/riscV/PrintOp.ml index aa609e15..a37f5c9c 100644 --- a/riscV/PrintOp.ml +++ b/riscV/PrintOp.ml @@ -35,6 +35,10 @@ let get_optR0_s c reg pp r1 r2 = function | Some true -> fprintf pp "(X0 %s %a)" (comparison_name c) reg r1 | Some false -> fprintf pp "(%a %s X0)" reg r1 (comparison_name c) +let get_optR0_s_int reg pp r1 n = function + | None -> fprintf pp "(%a, %ld)" reg r1 n + | Some _ -> fprintf pp "(X0, %ld)" n + let print_condition reg pp = function | (Ccomp c, [r1;r2]) -> fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2 @@ -203,7 +207,8 @@ let print_operation reg pp = function | OEsltiuw n, [r1] -> fprintf pp "OEsltiuw(%a,%ld)" reg r1 (camlint_of_coqint n) | OExoriw n, [r1] -> fprintf pp "OExoriw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEluiw n, _ -> fprintf pp "OEluiw(%ld)" (camlint_of_coqint n) - | OEaddiwr0 n, _ -> fprintf pp "OEaddiwr0(%ld,X0)" (camlint_of_coqint n) + | OEaddiw n, [r1] -> fprintf pp "OEaddiw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEaddiwr0 n, [] -> fprintf pp "OEaddiwr0(X0,%ld)" (camlint_of_coqint n) | OEseql optR0, [r1;r2] -> fprintf pp "OEseql"; (get_optR0_s Ceq reg pp r1 r2 optR0) | OEsnel optR0, [r1;r2] -> fprintf pp "OEsnel"; (get_optR0_s Cne reg pp r1 r2 optR0) | OEsequl optR0, [r1;r2] -> fprintf pp "OEsequl"; (get_optR0_s Ceq reg pp r1 r2 optR0) @@ -214,7 +219,8 @@ let print_operation reg pp = function | OEsltiul n, [r1] -> fprintf pp "OEsltiul(%a,%ld)" reg r1 (camlint_of_coqint n) | OExoril n, [r1] -> fprintf pp "OExoril(%a,%ld)" reg r1 (camlint_of_coqint n) | OEluil n, _ -> fprintf pp "OEluil(%ld)" (camlint_of_coqint n) - | OEaddilr0 n, _ -> fprintf pp "OEaddilr0(%ld,X0)" (camlint_of_coqint n) + | OEaddil n, [r1] -> fprintf pp "OEaddil(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEaddilr0 n, [] -> fprintf pp "OEaddilr0(X0,%ld)" (camlint_of_coqint n) | OEloadli n, _ -> fprintf pp "OEloadli(%ld)" (camlint_of_coqint n) | OEmayundef isl, [r1;r2] -> fprintf pp "OEmayundef (%b,%a,%a)" isl reg r1 reg r2 | OEfeqd, [r1;r2] -> fprintf pp "OEfeqd(%a,%s,%a)" reg r1 (comparison_name Ceq) reg r2 diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index 9b91c5a2..11e54a00 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -37,7 +37,7 @@ Definition load_hilo32 (hi lo: int) := else let hvs := fSop (OEluiw hi) fSnil in let hl := make_lhsv_single hvs in - fSop (Oaddimm lo) hl. + fSop (OEaddiw lo) hl. Definition load_hilo64 (hi lo: int64) := if Int64.eq lo Int64.zero then @@ -45,7 +45,7 @@ Definition load_hilo64 (hi lo: int64) := else let hvs := fSop (OEluil hi) fSnil in let hl := make_lhsv_single hvs in - fSop (Oaddlimm lo) hl. + fSop (OEaddil lo) hl. Definition loadimm32 (n: int) := match make_immed32 n with @@ -88,9 +88,15 @@ Definition opimm64 (hv1: hsval) (n: int64) (op: operation) (opimm: int64 -> oper fSop op hl end. +Definition addimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oadd OEaddiw. +Definition andimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oand OEandiw. +Definition orimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oor OEoriw. Definition xorimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oxor OExoriw. Definition sltimm32 (hv1: hsval) (n: int) := opimm32 hv1 n (OEsltw None) OEsltiw. Definition sltuimm32 (hv1: hsval) (n: int) := opimm32 hv1 n (OEsltuw None) OEsltiuw. +Definition addimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oaddl OEaddil. +Definition andimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oandl OEandil. +Definition orimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oorl OEoril. Definition xorimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oxorl OExoril. Definition sltimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltl None) OEsltil. Definition sltuimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltul None) OEsltiul. @@ -300,6 +306,17 @@ Definition expanse_cbranch_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) : (con let hl := make_lhsv_cmp false hvs hvs in if normal' then ((CEbnew (Some false)), hl) else ((CEbeqw (Some false)), hl). +(** Add pointer expansion *) + +(*Definition addptrofs (hv1: hsval) (n: ptrofs) :=*) + (*if Ptrofs.eq_dec n Ptrofs.zero then*) + (*let lhsv := make_lhsv_single hv1 in*) + (*fSop Omove lhsv*) + (*else*) + (*if Archi.ptr64*) + (*then addimm64 hv1 (Ptrofs.to_int64 n)*) + (*else addimm32 hv1 (Ptrofs.to_int n).*) + (** Target op simplifications using "fake" values *) Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_local): option hsval := @@ -369,13 +386,110 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let lhsv := make_lhsv_cmp is_inv hv1 hv2 in Some (expanse_cond_fp true cond_single c lhsv) | Ofloatconst f, nil => - let bits_const := fSop (Olongconst (Float.to_bits f)) fSnil in - let hl := make_lhsv_single bits_const in + let hvs := loadimm64 (Float.to_bits f) in + let hl := make_lhsv_single hvs in Some (fSop (Ofloat_of_bits) hl) | Osingleconst f, nil => - let bits_const := fSop (Ointconst (Float32.to_bits f)) fSnil in - let hl := make_lhsv_single bits_const in + let hvs := loadimm32 (Float32.to_bits f) in + let hl := make_lhsv_single hvs in Some (fSop (Osingle_of_bits) hl) + | Ointconst n, nil => + Some (loadimm32 n) + | Olongconst n, nil => + Some (loadimm64 n) + | Oaddimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (addimm32 hv1 n) + | Oaddlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (addimm64 hv1 n) + | Oandimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (andimm32 hv1 n) + | Oandlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (andimm64 hv1 n) + | Oorimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (orimm32 hv1 n) + | Oorlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (orimm64 hv1 n) + | Ocast8signed, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + let hvs := fSop (Oshlimm (Int.repr 24)) hl in + let hl' := make_lhsv_single hvs in + Some (fSop (Oshrimm (Int.repr 24)) hl') + | Ocast16signed, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + let hvs := fSop (Oshlimm (Int.repr 16)) hl in + let hl' := make_lhsv_single hvs in + Some (fSop (Oshrimm (Int.repr 16)) hl') + | Ocast32unsigned, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + let cast32s_s := fSop Ocast32signed hl in + let cast32s_l := make_lhsv_single cast32s_s in + let sllil_s := fSop (Oshllimm (Int.repr 32)) cast32s_l in + let sllil_l := make_lhsv_single sllil_s in + Some (fSop (Oshrluimm (Int.repr 32)) sllil_l) + | Oshrximm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + if Int.eq n Int.zero then + let move_s := fSop Omove hl in + let move_l := make_lhsv_single move_s in + Some (fSop (OEshrxundef n) move_l) + else + if Int.eq n Int.one then + let srliw_s := fSop (Oshruimm (Int.repr 31)) hl in + let srliw_l := make_lhsv_cmp false hv1 srliw_s in + let addw_s := fSop Oadd srliw_l in + let addw_l := make_lhsv_single addw_s in + let sraiw_s := fSop (Oshrimm Int.one) addw_l in + let sraiw_l := make_lhsv_single sraiw_s in + Some (fSop (OEshrxundef n) sraiw_l) + else + let sraiw_s := fSop (Oshrimm (Int.repr 31)) hl in + let sraiw_l := make_lhsv_single sraiw_s in + let srliw_s := fSop (Oshruimm (Int.sub Int.iwordsize n)) sraiw_l in + let srliw_l := make_lhsv_cmp false hv1 srliw_s in + let addw_s := fSop Oadd srliw_l in + let addw_l := make_lhsv_single addw_s in + let sraiw_s' := fSop (Oshrimm n) addw_l in + let sraiw_l' := make_lhsv_single sraiw_s' in + Some (fSop (OEshrxundef n) sraiw_l') + | Oshrxlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + if Int.eq n Int.zero then + let move_s := fSop Omove hl in + let move_l := make_lhsv_single move_s in + Some (fSop (OEshrxlundef n) move_l) + else + if Int.eq n Int.one then + let srlil_s := fSop (Oshrluimm (Int.repr 63)) hl in + let srlil_l := make_lhsv_cmp false hv1 srlil_s in + let addl_s := fSop Oaddl srlil_l in + let addl_l := make_lhsv_single addl_s in + let srail_s := fSop (Oshrlimm Int.one) addl_l in + let srail_l := make_lhsv_single srail_s in + Some (fSop (OEshrxlundef n) srail_l) + else + let srail_s := fSop (Oshrlimm (Int.repr 63)) hl in + let srail_l := make_lhsv_single srail_s in + let srlil_s := fSop (Oshrluimm (Int.sub Int64.iwordsize' n)) srail_l in + let srlil_l := make_lhsv_cmp false hv1 srlil_s in + let addl_s := fSop Oaddl srlil_l in + let addl_l := make_lhsv_single addl_s in + let srail_s' := fSop (Oshrlimm n) addl_l in + let srail_l' := make_lhsv_single srail_s' in + Some (fSop (OEshrxlundef n) srail_l') + (*| Oaddrstack n, nil =>*) + (*let hv1 := fsi_sreg_get hst a1 in*) + (*OK (addptrofs hv1 n)*) | _, _ => None end. @@ -857,6 +971,9 @@ Proof. try rewrite <- H; try (apply cmp_ltle_add_one; auto); try rewrite Int.add_commut, Int.add_zero_l in *; + try rewrite Int.add_commut; + try rewrite <- H; try rewrite cmp_ltle_add_one; + try rewrite Int.add_zero_l; try ( simpl; trivial; try rewrite Int.xor_is_zero; @@ -906,6 +1023,8 @@ Proof. try rewrite EQIMM; try destruct (Archi.ptr64) eqn:EQARCH; simpl; try rewrite ltu_12_wordsize; trivial; try rewrite Int.add_commut, Int.add_zero_l in *; + try rewrite Int.add_commut; + try rewrite Int.add_zero_l; try destruct (Int.ltu _ _) eqn:EQLTU; simpl; try rewrite EQLTU; simpl; try rewrite EQIMM; try rewrite EQARCH; trivial. @@ -1024,20 +1143,29 @@ Proof. try rewrite optbool_mktotal; trivial; unfold may_undef_int, zero32, Val.add; simpl; destruct v; auto. - 6,7,8: + 1,2,3,4,5,6,7,8,9,10,11,12: try rewrite <- optbool_mktotal; trivial; try rewrite Int64.add_commut, Int64.add_zero_l in *; + try rewrite Int64.add_commut; + try rewrite Int64.add_zero_l; try fold (Val.cmpl Clt (Vlong i) (Vlong imm)); try fold (Val.cmpl Clt (Vlong i) (Vlong (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))))); try fold (Val.cmpl Clt (Vlong i) (Vlong (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo))); try rewrite xor_neg_ltge_cmpl; trivial; try rewrite xor_neg_ltle_cmpl; trivial. + 6: + try rewrite Int64.add_commut; + rewrite <- H; + try apply cmpl_ltle_add_one; auto. all: try rewrite <- H; try apply cmpl_ltle_add_one; auto; try rewrite ltu_12_wordsize; try rewrite Int.add_commut, Int.add_zero_l in *; try rewrite Int64.add_commut, Int64.add_zero_l in *; + try rewrite Int.add_commut; + try rewrite Int64.add_commut; + try rewrite Int64.add_zero_l; simpl; try rewrite lt_maxsgn_false_long; try (rewrite <- H; trivial; fail); simpl; trivial. @@ -1085,6 +1213,8 @@ Proof. unfold Val.cmplu, may_undef_int, zero64, Val.addl; try apply Int64.same_if_eq in EQLO; subst; try rewrite Int64.add_commut, Int64.add_zero_l in *; trivial; + try rewrite Int64.add_commut; + try rewrite Int64.add_zero_l; try (rewrite <- xor_neg_ltle_cmplu; unfold Val.cmplu; trivial; fail); try (replace (Clt) with (swap_comparison Cgt) by auto; @@ -1204,6 +1334,561 @@ Proof. all: destruct (Float32.cmp _ _ _); trivial. Qed. +Lemma simplify_floatconst_correct ge sp rs0 m0 args m n fsv lr st: forall + (H : match lr with + | nil => + Some + (fSop Ofloat_of_bits + (make_lhsv_single (loadimm64 (Float.to_bits n)))) + | _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Ofloatconst n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold loadimm64, load_hilo64; simpl; + specialize make_immed64_sound with (Float.to_bits n); + destruct (make_immed64 (Float.to_bits n)) eqn:EQMKI; intros; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; + simpl. + - try rewrite Int64.add_commut, Int64.add_zero_l; inv H; + try rewrite Float.of_to_bits; trivial. + - apply Int64.same_if_eq in EQLO; subst. + try rewrite Int64.add_commut, Int64.add_zero_l in H. + rewrite <- H; try rewrite Float.of_to_bits; trivial. + - try rewrite Int64.add_commut; + rewrite <- H; try rewrite Float.of_to_bits; trivial. + - rewrite <- H; try rewrite Float.of_to_bits; trivial. +Qed. + +Lemma simplify_singleconst_correct ge sp rs0 m0 args m n fsv lr st: forall + (H : match lr with + | nil => + Some + (fSop Osingle_of_bits + (make_lhsv_single (loadimm32 (Float32.to_bits n)))) + | _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Osingleconst n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold loadimm32, load_hilo32; simpl; + specialize make_immed32_sound with (Float32.to_bits n); + destruct (make_immed32 (Float32.to_bits n)) eqn:EQMKI; intros; + try destruct (Int.eq lo Int.zero) eqn:EQLO; + simpl. + { try rewrite Int.add_commut, Int.add_zero_l; inv H; + try rewrite Float32.of_to_bits; trivial. } + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l in H; simpl; + try rewrite Int.add_commut in H; + rewrite ltu_12_wordsize; simpl; try rewrite <- H; + try rewrite Float32.of_to_bits; trivial. +Qed. + +Lemma simplify_addimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (addimm32 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oaddimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold addimm32, opimm32, load_hilo32, make_lhsv_cmp; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.add (Vint imm) v); rewrite Val.add_commut; trivial. + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite Int.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_addlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (addimm64 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oaddlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold addimm64, opimm64, load_hilo64, make_lhsv_cmp; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.addl (Vlong imm) v); rewrite Val.addl_commut; trivial. + all: + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_andimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (andimm32 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oandimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold andimm32, opimm32, load_hilo32, make_lhsv_cmp; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.and (Vint imm) v); rewrite Val.and_commut; trivial. + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite Int.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_andlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (andimm64 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oandlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold andimm64, opimm64, load_hilo64, make_lhsv_cmp; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.andl (Vlong imm) v); rewrite Val.andl_commut; trivial. + all: + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_orimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (orimm32 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oorimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold orimm32, opimm32, load_hilo32, make_lhsv_cmp; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.or (Vint imm) v); rewrite Val.or_commut; trivial. + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite Int.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_orlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (orimm64 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oorlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold orimm64, opimm64, load_hilo64, make_lhsv_cmp; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.orl (Vlong imm) v); rewrite Val.orl_commut; trivial. + all: + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_intconst_correct ge sp rs0 m0 args m n fsv lr st: forall + (H : match lr with + | nil => Some (loadimm32 n) + | _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Ointconst n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold loadimm32, load_hilo32, make_lhsv_single; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite Int.add_commut; + try rewrite ltu_12_wordsize; try rewrite H; trivial. +Qed. + +Lemma simplify_longconst_correct ge sp rs0 m0 args m n fsv lr st: forall + (H : match lr with + | nil => Some (loadimm64 n) + | _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Olongconst n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold loadimm64, load_hilo64, make_lhsv_single; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; try rewrite H; trivial. +Qed. + +Lemma simplify_cast8signed_correct ge sp rs0 m0 lr hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + Some + (fSop (Oshrimm (Int.repr 24)) + (make_lhsv_single + (fSop (Oshlimm (Int.repr 24)) + (make_lhsv_single (fsi_sreg_get hst a1))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp Ocast8signed args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + unfold Val.shr, Val.shl, Val.sign_ext; + destruct v; simpl; auto. + assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. + rewrite A. rewrite Int.sign_ext_shr_shl; simpl; trivial. cbn; lia. +Qed. + +Lemma simplify_cast16signed_correct ge sp rs0 m0 lr hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + Some + (fSop (Oshrimm (Int.repr 16)) + (make_lhsv_single + (fSop (Oshlimm (Int.repr 16)) + (make_lhsv_single (fsi_sreg_get hst a1))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp Ocast16signed args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + unfold Val.shr, Val.shl, Val.sign_ext; + destruct v; simpl; auto. + assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. + rewrite A. rewrite Int.sign_ext_shr_shl; simpl; trivial. cbn; lia. +Qed. + +Lemma simplify_shrximm_correct ge sp rs0 m0 lr hst fsv st args m n: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + if Int.eq n Int.zero + then + Some + (fSop (OEshrxundef n) + (make_lhsv_single + (fSop Omove (make_lhsv_single (fsi_sreg_get hst a1))))) + else + if Int.eq n Int.one + then + Some + (fSop (OEshrxundef n) + (make_lhsv_single + (fSop (Oshrimm Int.one) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.repr 31)) + (make_lhsv_single (fsi_sreg_get hst a1))))))))) + else + Some + (fSop (OEshrxundef n) + (make_lhsv_single + (fSop (Oshrimm n) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.sub Int.iwordsize n)) + (make_lhsv_single + (fSop (Oshrimm (Int.repr 31)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oshrximm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence). + assert (A: Int.ltu Int.zero (Int.repr 31) = true) by auto. + assert (B: Int.ltu (Int.repr 31) Int.iwordsize = true) by auto. + assert (C: Int.ltu Int.one Int.iwordsize = true) by auto. + destruct (Int.eq n Int.zero) eqn:EQ0; + destruct (Int.eq n Int.one) eqn:EQ1. + { apply Int.same_if_eq in EQ0. + apply Int.same_if_eq in EQ1; subst. discriminate. } + all: + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1; + destruct (Val.shrx v (Vint n)) eqn:TOTAL; cbn; + unfold shrx_imm_undef. + 2,4,6: + unfold Val.shrx in TOTAL; + destruct v; simpl in TOTAL; simpl; try congruence; + try rewrite B; simpl; try rewrite C; simpl; + try destruct (Val.shr _ _); + destruct (Int.ltu n (Int.repr 31)); try congruence. + - destruct v; simpl in TOTAL; try congruence; + apply Int.same_if_eq in EQ0; subst; + rewrite A, Int.shrx_zero in TOTAL; + [auto | cbn; lia]. + - apply Int.same_if_eq in EQ1; subst; + unfold Val.shr, Val.shru, Val.shrx, Val.add; simpl; + destruct v; simpl in *; try discriminate; trivial. + rewrite B, C. + rewrite Int.shrx1_shr in TOTAL; auto. + - exploit Val.shrx_shr_2; eauto. rewrite EQ0. + intros; subst. + destruct v; simpl in *; try discriminate; trivial. + rewrite B in *. + destruct Int.ltu eqn:EQN0 in TOTAL; try discriminate. + simpl in *. + destruct Int.ltu eqn:EQN1 in TOTAL; try discriminate. + replace Int.iwordsize with (Int.repr 32) in * by auto. + rewrite !EQN1. simpl in *. + destruct Int.ltu eqn:EQN2 in TOTAL; try discriminate. + rewrite !EQN2. rewrite EQN0. + reflexivity. +Qed. + +Lemma simplify_shrxlimm_correct ge sp rs0 m0 lr hst fsv st args m n: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + if Int.eq n Int.zero + then + Some + (fSop (OEshrxlundef n) + (make_lhsv_single + (fSop Omove (make_lhsv_single (fsi_sreg_get hst a1))))) + else + if Int.eq n Int.one + then + Some + (fSop (OEshrxlundef n) + (make_lhsv_single + (fSop (Oshrlimm Int.one) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.repr 63)) + (make_lhsv_single (fsi_sreg_get hst a1))))))))) + else + Some + (fSop (OEshrxlundef n) + (make_lhsv_single + (fSop (Oshrlimm n) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.sub Int64.iwordsize' n)) + (make_lhsv_single + (fSop (Oshrlimm (Int.repr 63)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oshrxlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence). + assert (A: Int.ltu Int.zero (Int.repr 63) = true) by auto. + assert (B: Int.ltu (Int.repr 63) Int64.iwordsize' = true) by auto. + assert (C: Int.ltu Int.one Int64.iwordsize' = true) by auto. + destruct (Int.eq n Int.zero) eqn:EQ0; + destruct (Int.eq n Int.one) eqn:EQ1. + { apply Int.same_if_eq in EQ0. + apply Int.same_if_eq in EQ1; subst. discriminate. } + all: + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1; + destruct (Val.shrxl v (Vint n)) eqn:TOTAL; cbn; + unfold shrxl_imm_undef. + 2,4,6: + unfold Val.shrxl in TOTAL; + destruct v; simpl in TOTAL; simpl; try congruence; + try rewrite B; simpl; try rewrite C; simpl; + try destruct (Val.shrl _ _); + destruct (Int.ltu n (Int.repr 63)); try congruence. + - destruct v; simpl in TOTAL; try congruence; + apply Int.same_if_eq in EQ0; subst; + rewrite A, Int64.shrx'_zero in *. + assumption. + - apply Int.same_if_eq in EQ1; subst; + unfold Val.shrl, Val.shrlu, Val.shrxl, Val.addl; simpl; + destruct v; simpl in *; try discriminate; trivial. + rewrite B, C. + rewrite Int64.shrx'1_shr' in TOTAL; auto. + - exploit Val.shrxl_shrl_2; eauto. rewrite EQ0. + intros; subst. + destruct v; simpl in *; try discriminate; trivial. + rewrite B in *. + destruct Int.ltu eqn:EQN0 in TOTAL; try discriminate. + simpl in *. + destruct Int.ltu eqn:EQN1 in TOTAL; try discriminate. + replace Int64.iwordsize' with (Int.repr 64) in * by auto. + rewrite !EQN1. simpl in *. + destruct Int.ltu eqn:EQN2 in TOTAL; try discriminate. + rewrite !EQN2. rewrite EQN0. + reflexivity. +Qed. + +Lemma simplify_cast32unsigned_correct ge sp rs0 m0 lr hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + Some + (fSop (Oshrluimm (Int.repr 32)) + (make_lhsv_single + (fSop (Oshllimm (Int.repr 32)) + (make_lhsv_single + (fSop Ocast32signed + (make_lhsv_single (fsi_sreg_get hst a1))))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp Ocast32unsigned args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + unfold Val.shrlu, Val.shll, Val.longofint, Val.longofintu. + destruct v; simpl; auto. + assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. + rewrite A. rewrite Int64.shru'_shl'; auto. + replace (Int.ltu (Int.repr 32) (Int.repr 32)) with (false) by auto. + rewrite cast32unsigned_from_cast32signed. + replace Int64.zwordsize with 64 by auto. + rewrite Int.unsigned_repr; cbn; try lia. + replace (Int.sub (Int.repr 32) (Int.repr 32)) with (Int.zero) by auto. + rewrite Int64.shru'_zero. reflexivity. +Qed. + (* Main proof of simplification *) Lemma target_op_simplify_correct op lr hst fsv ge sp rs0 m0 st args m: forall @@ -1217,12 +1902,29 @@ Proof. unfold target_op_simplify; simpl. intros H (LREF & SREF & SREG & SMEM) ? ? ?. destruct op; try congruence. + (* int and long constants *) + eapply simplify_intconst_correct; eauto. + eapply simplify_longconst_correct; eauto. (* FP const expansions *) - 1,2: - repeat (destruct lr; simpl; try congruence); - simpl in OK1; inv OK1; inv H; simpl; - try rewrite Float.of_to_bits; - try rewrite Float32.of_to_bits; trivial. + eapply simplify_floatconst_correct; eauto. + eapply simplify_singleconst_correct; eauto. + (* cast 8/16 operations *) + eapply simplify_cast8signed_correct; eauto. + eapply simplify_cast16signed_correct; eauto. + (* Immediate int operations *) + eapply simplify_addimm_correct; eauto. + eapply simplify_andimm_correct; eauto. + eapply simplify_orimm_correct; eauto. + (* Shrx imm int operation *) + eapply simplify_shrximm_correct; eauto. + (* cast 32u operation *) + eapply simplify_cast32unsigned_correct; eauto. + (* Immediate long operations *) + eapply simplify_addlimm_correct; eauto. + eapply simplify_andlimm_correct; eauto. + eapply simplify_orlimm_correct; eauto. + (* Shrx imm long operation *) + eapply simplify_shrxlimm_correct; eauto. (* Ocmp expansions *) destruct cond; repeat (destruct lr; simpl; try congruence); simpl in OK1; @@ -1253,7 +1955,8 @@ Proof. - eapply simplify_ccompfs_correct; eauto. (* Cnotcompfs *) - eapply simplify_cnotcompfs_correct; eauto. -Qed. +(*Qed.*) +Admitted. Lemma target_cbranch_expanse_correct hst c l ge sp rs0 m0 st c' l': forall (TARGET: target_cbranch_expanse hst c l = Some (c', l')) @@ -1305,7 +2008,10 @@ Proof. try destruct v; try rewrite H; try rewrite ltu_12_wordsize; try rewrite EQLO; try rewrite Int.add_commut, Int.add_zero_l; + try rewrite Int.add_commut; try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite Int.add_zero_l; try rewrite Int64.add_zero_l; auto; simpl; try rewrite H in EQIMM; try rewrite EQLO in EQIMM; diff --git a/riscV/ValueAOp.v b/riscV/ValueAOp.v index d50bd00f..fe519921 100644 --- a/riscV/ValueAOp.v +++ b/riscV/ValueAOp.v @@ -39,6 +39,32 @@ Definition may_undef_int (is_long: bool) (v1 v2: aval): aval := | _ => Ifptr Ptop end. +Definition shrx_imm_undef (v1 v2: aval): aval := + match v1 with + | I n1 => + match v2 with + | I n2 => + if Int.ltu n2 (Int.repr 31) + then I n1 + else Ifptr Ptop + | _ => Ifptr Ptop + end + | _ => Ifptr Ptop + end. + +Definition shrxl_imm_undef (v1 v2: aval): aval := + match v1 with + | L n1 => + match v2 with + | I n2 => + if Int.ltu n2 (Int.repr 63) + then L n1 + else Ifptr Ptop + | _ => Ifptr Ptop + end + | _ => Ifptr Ptop + end. + Definition eval_static_condition (cond: condition) (vl: list aval): abool := match cond, vl with | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2 @@ -218,7 +244,10 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | OEsltiuw n, v1::nil => of_optbool (cmpu_bool Clt v1 (I n)) | OExoriw n, v1::nil => xor v1 (I n) | OEluiw n, nil => shl (I n) (I (Int.repr 12)) + | OEaddiw n, v1::nil => add (I n) v1 | OEaddiwr0 n, nil => add (I n) zero32 + | OEandiw n, v1::nil => and (I n) v1 + | OEoriw n, v1::nil => or (I n) v1 | OEseql optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Ceq) v1 v2 zero64) | OEsnel optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Cne) v1 v2 zero64) | OEsequl optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmplu_bool Ceq) v1 v2 zero64) @@ -227,11 +256,16 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | OEsltul optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmplu_bool Clt) v1 v2 zero64) | OEsltil n, v1::nil => of_optbool (cmpl_bool Clt v1 (L n)) | OEsltiul n, v1::nil => of_optbool (cmplu_bool Clt v1 (L n)) + | OEandil n, v1::nil => andl (L n) v1 + | OEoril n, v1::nil => orl (L n) v1 | OExoril n, v1::nil => xorl v1 (L n) | OEluil n, nil => sign_ext 32 (shll (L n) (L (Int64.repr 12))) + | OEaddil n, v1::nil => addl (L n) v1 | OEaddilr0 n, nil => addl (L n) zero64 | OEloadli n, nil => L (n) | OEmayundef is_long, v1::v2::nil => may_undef_int is_long v1 v2 + | OEshrxundef n, v1::nil => shrx_imm_undef v1 (I n) + | OEshrxlundef n, v1::nil => shrxl_imm_undef v1 (I n) | OEfeqd, v1::v2::nil => of_optbool (cmpf_bool Ceq v1 v2) | OEfltd, v1::v2::nil => of_optbool (cmpf_bool Clt v1 v2) | OEfled, v1::v2::nil => of_optbool (cmpf_bool Cle v1 v2) @@ -460,22 +494,35 @@ Proof. unfold Val.cmp; apply of_optbool_sound; eauto with va. unfold Val.cmpu; apply of_optbool_sound; eauto with va. - simpl; try destruct (Int.ltu _ _); eauto with va; unfold ntop1; - try apply vmatch_ifptr_undef. - 10: - simpl; unfold ntop1, sign_ext, Int64.sign_ext, sgn; simpl; - apply vmatch_ifptr_l. + { fold (Val.add (Vint n) a1); eauto with va. } + { unfold zero32; simpl; eauto with va. } + { fold (Val.and (Vint n) a1); eauto with va. } + { fold (Val.or (Vint n) a1); eauto with va. } + { simpl; try destruct (Int.ltu _ _); eauto with va; unfold ntop1; + try apply vmatch_ifptr_undef. } + 9: { fold (Val.addl (Vlong n) a1); eauto with va. } + 10: { fold (Val.andl (Vlong n) a1); eauto with va. } + 10: { fold (Val.orl (Vlong n) a1); eauto with va. } + 10: { simpl; unfold ntop1, sign_ext, Int64.sign_ext, sgn; simpl; + apply vmatch_ifptr_l. } + 1,10: simpl; eauto with va. - 9: + 2: unfold Op.may_undef_int, may_undef_int; destruct is_long; simpl; inv H0; inv H1; eauto with va; inv H; apply vmatch_ifptr_p; eauto with va. 3,4,6: apply eval_cmplu_sound; auto. 1,2,3: apply eval_cmpl_sound; auto. - unfold Val.cmpl; apply of_optbool_maketotal_sound; eauto with va. - unfold Val.cmplu; apply of_optbool_maketotal_sound; eauto with va. - unfold zero64; simpl; eauto with va. + { unfold Val.cmpl; apply of_optbool_maketotal_sound; eauto with va. } + { unfold Val.cmplu; apply of_optbool_maketotal_sound; eauto with va. } + { unfold zero64; simpl; eauto with va. } + { unfold Op.shrx_imm_undef, shrx_imm_undef. + simpl; inv H1; eauto with va; + destruct (Int.ltu _ _); simpl; eauto with va. } + { unfold Op.shrxl_imm_undef, shrxl_imm_undef. + simpl; inv H1; eauto with va; + destruct (Int.ltu _ _); simpl; eauto with va. } all: unfold Val.cmpf; apply of_optbool_sound; eauto with va. Qed. -- cgit From 63ddeebc8b5a4e8fe1748cf859085c683aefe404 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Fri, 26 Mar 2021 12:52:26 +0100 Subject: Compiler options to manage expansions --- riscV/ExpansionOracle.ml | 351 +++++++++++++++++++++++------------------------ 1 file changed, 174 insertions(+), 177 deletions(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 676b8da6..a5fa4a0a 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -163,14 +163,14 @@ let opimm64 a1 dest n succ k op opimm map_consts = let ht = load_hilo64 r hi lo (n2pi ()) map_consts true in let r' = unzip_head_tuple ht r in build_full_ilist op [ a1; r' ] dest succ (fst ht) k map_consts - | Imm64_large imm ->( + | Imm64_large imm -> let r = r2pi () in let op1 = OEloadli imm in let inode = n2pi () in let sv = find_or_addnmove op1 [] r inode map_consts true in let ht = build_head_tuple [] sv in let r' = unzip_head_tuple ht r in - build_full_ilist op [ a1; r' ] dest succ (fst ht) k map_consts) + build_full_ilist op [ a1; r' ] dest succ (fst ht) k map_consts let addimm32 a1 dest n succ k map_consts = opimm32 a1 dest n succ k Oadd Addiw map_consts @@ -671,13 +671,15 @@ let expanse (sb : superblock) code pm = was_branch := true; was_exp := true | _ -> ()); - (if !Clflags.option_fexpanse_fpconst && not !was_exp then + (if !Clflags.option_fexpanse_others && not !was_exp then match inst with (* Expansion of fp constants *) | Iop (Ofloatconst f, nil, dest, succ) -> debug "Iop/Ofloatconst\n"; let r = r2pi () in - let ht = loadimm64 r (Floats.Float.to_bits f) (n2pi ()) map_consts true in + let ht = + loadimm64 r (Floats.Float.to_bits f) (n2pi ()) map_consts true + in let r' = unzip_head_tuple ht r in exp := build_full_ilist Ofloat_of_bits [ r' ] dest succ (fst ht) [] @@ -694,180 +696,175 @@ let expanse (sb : superblock) code pm = build_full_ilist Osingle_of_bits [ r' ] dest succ (fst ht) [] map_consts; was_exp := true + | Iop (Ointconst n, nil, dest, succ) -> + debug "Iop/Ointconst\n"; + let ht = loadimm32 dest n succ map_consts false in + exp := unzip_head_tuple_move ht dest succ; + was_exp := true + | Iop (Olongconst n, nil, dest, succ) -> + debug "Iop/Olongconst\n"; + let ht = loadimm64 dest n succ map_consts false in + exp := unzip_head_tuple_move ht dest succ; + was_exp := true + | Iop (Oaddimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oaddimm\n"; + exp := addimm32 a1 dest n succ [] map_consts; + was_exp := true + | Iop (Oaddlimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oaddlimm\n"; + exp := addimm64 a1 dest n succ [] map_consts; + was_exp := true + | Iop (Oandimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oandimm\n"; + exp := andimm32 a1 dest n succ [] map_consts; + was_exp := true + | Iop (Oandlimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oandlimm\n"; + exp := andimm64 a1 dest n succ [] map_consts; + was_exp := true + | Iop (Oorimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oorimm\n"; + exp := orimm32 a1 dest n succ [] map_consts; + was_exp := true + | Iop (Oorlimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oorlimm\n"; + exp := orimm64 a1 dest n succ [] map_consts; + was_exp := true + | Iop (Ocast8signed, a1 :: nil, dest, succ) -> + debug "Iop/cast8signed"; + let op = Oshlimm (Int.repr (Z.of_sint 24)) in + let r = r2pi () in + let sv = find_or_addnmove op [ a1 ] r (n2pi ()) map_consts true in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + exp := + build_full_ilist + (Oshrimm (Int.repr (Z.of_sint 24))) + [ r' ] dest succ (fst ht) [] map_consts; + was_exp := true + | Iop (Ocast16signed, a1 :: nil, dest, succ) -> + debug "Iop/cast8signed"; + let op = Oshlimm (Int.repr (Z.of_sint 16)) in + let r = r2pi () in + let sv = find_or_addnmove op [ a1 ] r (n2pi ()) map_consts true in + let ht = build_head_tuple [] sv in + let r' = unzip_head_tuple ht r in + exp := + build_full_ilist + (Oshrimm (Int.repr (Z.of_sint 16))) + [ r' ] dest succ (fst ht) [] map_consts; + was_exp := true + | Iop (Ocast32unsigned, a1 :: nil, dest, succ) -> + debug "Iop/Ocast32unsigned"; + let n2 = n2pi () in + let n1 = n2pi () in + let r1 = r2pi () in + let r2 = r2pi () in + let op1 = Ocast32signed in + let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in + let ht1 = build_head_tuple [] sv1 in + let r1' = unzip_head_tuple ht1 r1 in + + let op2 = Oshllimm (Int.repr (Z.of_sint 32)) in + let sv2 = find_or_addnmove op2 [ r1' ] r2 n2 map_consts true in + let ht2 = build_head_tuple (fst ht1) sv2 in + let r2' = unzip_head_tuple ht2 r2 in + + let op3 = Oshrluimm (Int.repr (Z.of_sint 32)) in + exp := build_full_ilist op3 [ r2' ] dest succ (fst ht2) [] map_consts + | Iop (Oshrximm n, a1 :: nil, dest, succ) -> + debug "Iop/Oshrximm"; + if Int.eq n Int.zero then exp := [ Iop (Omove, [ a1 ], dest, succ) ] + else if Int.eq n Int.one then + let n2 = n2pi () in + let n1 = n2pi () in + let r1 = r2pi () in + let r2 = r2pi () in + let op1 = Oshruimm (Int.repr (Z.of_sint 31)) in + let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in + let ht1 = build_head_tuple [] sv1 in + let r1' = unzip_head_tuple ht1 r1 in + + let op2 = Oadd in + let sv2 = find_or_addnmove op2 [ a1; r1' ] r2 n2 map_consts true in + let ht2 = build_head_tuple (fst ht1) sv2 in + let r2' = unzip_head_tuple ht2 r2 in + + let op3 = Oshrimm Int.one in + exp := + build_full_ilist op3 [ r2' ] dest succ (fst ht2) [] map_consts + else + let n3 = n2pi () in + let n2 = n2pi () in + let n1 = n2pi () in + let r1 = r2pi () in + let r2 = r2pi () in + let r3 = r2pi () in + let op1 = Oshrimm (Int.repr (Z.of_sint 31)) in + let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in + let ht1 = build_head_tuple [] sv1 in + let r1' = unzip_head_tuple ht1 r1 in + + let op2 = Oshruimm (Int.sub Int.iwordsize n) in + let sv2 = find_or_addnmove op2 [ r1' ] r2 n2 map_consts true in + let ht2 = build_head_tuple (fst ht1) sv2 in + let r2' = unzip_head_tuple ht2 r2 in + + let op3 = Oadd in + let sv3 = find_or_addnmove op3 [ a1; r2' ] r3 n3 map_consts true in + let ht3 = build_head_tuple (fst ht2) sv3 in + let r3' = unzip_head_tuple ht3 r3 in + + let op4 = Oshrimm n in + exp := + build_full_ilist op4 [ r3' ] dest succ (fst ht3) [] map_consts + | Iop (Oshrxlimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oshrxlimm"; + if Int.eq n Int.zero then exp := [ Iop (Omove, [ a1 ], dest, succ) ] + else if Int.eq n Int.one then + let n2 = n2pi () in + let n1 = n2pi () in + let r1 = r2pi () in + let r2 = r2pi () in + let op1 = Oshrluimm (Int.repr (Z.of_sint 63)) in + let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in + let ht1 = build_head_tuple [] sv1 in + let r1' = unzip_head_tuple ht1 r1 in + + let op2 = Oaddl in + let sv2 = find_or_addnmove op2 [ a1; r1' ] r2 n2 map_consts true in + let ht2 = build_head_tuple (fst ht1) sv2 in + let r2' = unzip_head_tuple ht2 r2 in + + let op3 = Oshrlimm Int.one in + exp := + build_full_ilist op3 [ r2' ] dest succ (fst ht2) [] map_consts + else + let n3 = n2pi () in + let n2 = n2pi () in + let n1 = n2pi () in + let r1 = r2pi () in + let r2 = r2pi () in + let r3 = r2pi () in + let op1 = Oshrlimm (Int.repr (Z.of_sint 63)) in + let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in + let ht1 = build_head_tuple [] sv1 in + let r1' = unzip_head_tuple ht1 r1 in + + let op2 = Oshrluimm (Int.sub Int64.iwordsize' n) in + let sv2 = find_or_addnmove op2 [ r1' ] r2 n2 map_consts true in + let ht2 = build_head_tuple (fst ht1) sv2 in + let r2' = unzip_head_tuple ht2 r2 in + + let op3 = Oaddl in + let sv3 = find_or_addnmove op3 [ a1; r2' ] r3 n3 map_consts true in + let ht3 = build_head_tuple (fst ht2) sv3 in + let r3' = unzip_head_tuple ht3 r3 in + + let op4 = Oshrlimm n in + exp := + build_full_ilist op4 [ r3' ] dest succ (fst ht3) [] map_consts | _ -> ()); - - (* TODO gourdinl flag ? *) - (match inst with - | Iop (Ointconst n, nil, dest, succ) -> - debug "Iop/Ointconst\n"; - let ht = loadimm32 dest n succ map_consts false in - exp := unzip_head_tuple_move ht dest succ; - was_exp := true - | Iop (Olongconst n, nil, dest, succ) -> - debug "Iop/Olongconst\n"; - let ht = loadimm64 dest n succ map_consts false in - exp := unzip_head_tuple_move ht dest succ; - was_exp := true - | Iop (Oaddimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oaddimm\n"; - exp := addimm32 a1 dest n succ [] map_consts; - was_exp := true - | Iop (Oaddlimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oaddlimm\n"; - exp := addimm64 a1 dest n succ [] map_consts; - was_exp := true - | Iop (Oandimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oandimm\n"; - exp := andimm32 a1 dest n succ [] map_consts; - was_exp := true - | Iop (Oandlimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oandlimm\n"; - exp := andimm64 a1 dest n succ [] map_consts; - was_exp := true - | Iop (Oorimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oorimm\n"; - exp := orimm32 a1 dest n succ [] map_consts; - was_exp := true - | Iop (Oorlimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oorlimm\n"; - exp := orimm64 a1 dest n succ [] map_consts; - was_exp := true - | Iop (Ocast8signed, a1 :: nil, dest, succ) -> - debug "Iop/cast8signed"; - let op = Oshlimm (Int.repr (Z.of_sint 24)) in - let r = r2pi () in - let sv = find_or_addnmove op [ a1 ] r (n2pi ()) map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in - exp := - build_full_ilist - (Oshrimm (Int.repr (Z.of_sint 24))) - [ r' ] dest succ (fst ht) [] map_consts; - was_exp := true - | Iop (Ocast16signed, a1 :: nil, dest, succ) -> - debug "Iop/cast8signed"; - let op = Oshlimm (Int.repr (Z.of_sint 16)) in - let r = r2pi () in - let sv = find_or_addnmove op [ a1 ] r (n2pi ()) map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in - exp := - build_full_ilist - (Oshrimm (Int.repr (Z.of_sint 16))) - [ r' ] dest succ (fst ht) [] map_consts; - was_exp := true - | Iop (Ocast32unsigned, a1 :: nil, dest, succ) -> - debug "Iop/Ocast32unsigned"; - let n2 = n2pi () in - let n1 = n2pi () in - let r1 = r2pi () in - let r2 = r2pi () in - let op1 = Ocast32signed in - let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in - let ht1 = build_head_tuple [] sv1 in - let r1' = unzip_head_tuple ht1 r1 in - - let op2 = Oshllimm (Int.repr (Z.of_sint 32)) in - let sv2 = find_or_addnmove op2 [ r1' ] r2 n2 map_consts true in - let ht2 = build_head_tuple (fst ht1) sv2 in - let r2' = unzip_head_tuple ht2 r2 in - - let op3 = Oshrluimm (Int.repr (Z.of_sint 32)) in - exp := build_full_ilist op3 [ r2' ] dest succ (fst ht2) [] map_consts - | Iop (Oshrximm n, a1 :: nil, dest, succ) -> - debug "Iop/Oshrximm"; - if Int.eq n Int.zero then exp := [ Iop (Omove, [ a1 ], dest, succ) ] - else if Int.eq n Int.one then - let n2 = n2pi () in - let n1 = n2pi () in - let r1 = r2pi () in - let r2 = r2pi () in - let op1 = Oshruimm (Int.repr (Z.of_sint 31)) in - let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in - let ht1 = build_head_tuple [] sv1 in - let r1' = unzip_head_tuple ht1 r1 in - - let op2 = Oadd in - let sv2 = find_or_addnmove op2 [ a1; r1' ] r2 n2 map_consts true in - let ht2 = build_head_tuple (fst ht1) sv2 in - let r2' = unzip_head_tuple ht2 r2 in - - let op3 = Oshrimm Int.one in - exp := - build_full_ilist op3 [ r2' ] dest succ (fst ht2) [] map_consts - else - let n3 = n2pi () in - let n2 = n2pi () in - let n1 = n2pi () in - let r1 = r2pi () in - let r2 = r2pi () in - let r3 = r2pi () in - let op1 = Oshrimm (Int.repr (Z.of_sint 31)) in - let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in - let ht1 = build_head_tuple [] sv1 in - let r1' = unzip_head_tuple ht1 r1 in - - let op2 = Oshruimm (Int.sub Int.iwordsize n) in - let sv2 = find_or_addnmove op2 [ r1' ] r2 n2 map_consts true in - let ht2 = build_head_tuple (fst ht1) sv2 in - let r2' = unzip_head_tuple ht2 r2 in - - let op3 = Oadd in - let sv3 = find_or_addnmove op3 [ a1; r2' ] r3 n3 map_consts true in - let ht3 = build_head_tuple (fst ht2) sv3 in - let r3' = unzip_head_tuple ht3 r3 in - - let op4 = Oshrimm n in - exp := - build_full_ilist op4 [ r3' ] dest succ (fst ht3) [] map_consts - | Iop (Oshrxlimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oshrxlimm"; - if Int.eq n Int.zero then exp := [ Iop (Omove, [ a1 ], dest, succ) ] - else if Int.eq n Int.one then - let n2 = n2pi () in - let n1 = n2pi () in - let r1 = r2pi () in - let r2 = r2pi () in - let op1 = Oshrluimm (Int.repr (Z.of_sint 63)) in - let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in - let ht1 = build_head_tuple [] sv1 in - let r1' = unzip_head_tuple ht1 r1 in - - let op2 = Oaddl in - let sv2 = find_or_addnmove op2 [ a1; r1' ] r2 n2 map_consts true in - let ht2 = build_head_tuple (fst ht1) sv2 in - let r2' = unzip_head_tuple ht2 r2 in - - let op3 = Oshrlimm Int.one in - exp := - build_full_ilist op3 [ r2' ] dest succ (fst ht2) [] map_consts - else - let n3 = n2pi () in - let n2 = n2pi () in - let n1 = n2pi () in - let r1 = r2pi () in - let r2 = r2pi () in - let r3 = r2pi () in - let op1 = Oshrlimm (Int.repr (Z.of_sint 63)) in - let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in - let ht1 = build_head_tuple [] sv1 in - let r1' = unzip_head_tuple ht1 r1 in - - let op2 = Oshrluimm (Int.sub Int64.iwordsize' n) in - let sv2 = find_or_addnmove op2 [ r1' ] r2 n2 map_consts true in - let ht2 = build_head_tuple (fst ht1) sv2 in - let r2' = unzip_head_tuple ht2 r2 in - - let op3 = Oaddl in - let sv3 = find_or_addnmove op3 [ a1; r2' ] r3 n3 map_consts true in - let ht3 = build_head_tuple (fst ht2) sv3 in - let r3' = unzip_head_tuple ht3 r3 in - - let op4 = Oshrlimm n in - exp := - build_full_ilist op4 [ r3' ] dest succ (fst ht3) [] map_consts - | _ -> ()); - if !was_exp then ( (if !was_branch && List.length !exp > 1 then let lives = PTree.get n !liveins in -- cgit From bc865be27b1aeaf1c7428789dc0dd7b1bf547d99 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Fri, 26 Mar 2021 13:00:09 +0100 Subject: fix admit --- riscV/RTLpathSE_simplify.v | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'riscV') diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index 11e54a00..5804e67e 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -1955,8 +1955,7 @@ Proof. - eapply simplify_ccompfs_correct; eauto. (* Cnotcompfs *) - eapply simplify_cnotcompfs_correct; eauto. -(*Qed.*) -Admitted. +Qed. Lemma target_cbranch_expanse_correct hst c l ge sp rs0 m0 st c' l': forall (TARGET: target_cbranch_expanse hst c l = Some (c', l')) -- cgit From 17b35c465bf8aca074c8354e910af0bf8f686c09 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Fri, 26 Mar 2021 17:22:55 +0100 Subject: bugfix and printOp --- riscV/ExpansionOracle.ml | 42 +++++++++++++++++++++++------------------- riscV/PrintOp.ml | 6 ++++++ 2 files changed, 29 insertions(+), 19 deletions(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index a5fa4a0a..6eb82274 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -59,14 +59,15 @@ type immt = | Sltil | Sltiul -let find_or_addnmove op args rd succ map_consts node_dec = +let find_or_addnmove op args rd succ map_consts not_final = let sop = Sop (op, args) in match Hashtbl.find_opt map_consts sop with | Some r -> - if node_dec then node := !node - 1; + if not_final then node := !node - 1; Sr (P.of_int r) | None -> - Hashtbl.add map_consts sop (p2i rd); + if not (List.exists (fun a -> a = rd) args) && not_final then + Hashtbl.add map_consts sop (p2i rd); Si (Iop (op, args, rd, succ)) let build_head_tuple head sv = @@ -75,59 +76,62 @@ let build_head_tuple head sv = let unzip_head_tuple ht r = match ht with l, Some r' -> r' | l, None -> r let unzip_head_tuple_move ht r succ = - match ht with l, Some r' -> [ Iop (Omove, [ r' ], r, succ) ] | l, None -> l + match ht with + | l, Some r' -> + if r' != r then [ Iop (Omove, [ r' ], r, succ) ] else [ Inop succ ] + | l, None -> l let build_full_ilist op args dest succ hd k map_consts = let sv = find_or_addnmove op args dest succ map_consts false in let ht = build_head_tuple hd sv in unzip_head_tuple_move ht dest succ @ k -let load_hilo32 dest hi lo succ map_consts node_dec = +let load_hilo32 dest hi lo succ map_consts not_final = let op1 = OEluiw hi in if Int.eq lo Int.zero then - let sv = find_or_addnmove op1 [] dest succ map_consts node_dec in + let sv = find_or_addnmove op1 [] dest succ map_consts not_final in build_head_tuple [] sv else let r = r2pi () in - let sv1 = find_or_addnmove op1 [] r (n2pi ()) map_consts node_dec in + let sv1 = find_or_addnmove op1 [] r (n2pi ()) map_consts not_final in let ht1 = build_head_tuple [] sv1 in let r' = unzip_head_tuple ht1 r in let op2 = OEaddiw lo in - let sv2 = find_or_addnmove op2 [ r' ] dest succ map_consts node_dec in + let sv2 = find_or_addnmove op2 [ r' ] dest succ map_consts not_final in build_head_tuple (fst ht1) sv2 -let load_hilo64 dest hi lo succ map_consts node_dec = +let load_hilo64 dest hi lo succ map_consts not_final = let op1 = OEluil hi in if Int64.eq lo Int64.zero then - let sv = find_or_addnmove op1 [] dest succ map_consts node_dec in + let sv = find_or_addnmove op1 [] dest succ map_consts not_final in build_head_tuple [] sv else let r = r2pi () in - let sv1 = find_or_addnmove op1 [] r (n2pi ()) map_consts node_dec in + let sv1 = find_or_addnmove op1 [] r (n2pi ()) map_consts not_final in let ht1 = build_head_tuple [] sv1 in let r' = unzip_head_tuple ht1 r in let op2 = OEaddil lo in - let sv2 = find_or_addnmove op2 [ r' ] dest succ map_consts node_dec in + let sv2 = find_or_addnmove op2 [ r' ] dest succ map_consts not_final in build_head_tuple (fst ht1) sv2 -let loadimm32 dest n succ map_consts node_dec = +let loadimm32 dest n succ map_consts not_final = match make_immed32 n with | Imm32_single imm -> let op1 = OEaddiwr0 imm in - let sv = find_or_addnmove op1 [] dest succ map_consts node_dec in + let sv = find_or_addnmove op1 [] dest succ map_consts not_final in build_head_tuple [] sv - | Imm32_pair (hi, lo) -> load_hilo32 dest hi lo succ map_consts node_dec + | Imm32_pair (hi, lo) -> load_hilo32 dest hi lo succ map_consts not_final -let loadimm64 dest n succ map_consts node_dec = +let loadimm64 dest n succ map_consts not_final = match make_immed64 n with | Imm64_single imm -> let op1 = OEaddilr0 imm in - let sv = find_or_addnmove op1 [] dest succ map_consts node_dec in + let sv = find_or_addnmove op1 [] dest succ map_consts not_final in build_head_tuple [] sv - | Imm64_pair (hi, lo) -> load_hilo64 dest hi lo succ map_consts node_dec + | Imm64_pair (hi, lo) -> load_hilo64 dest hi lo succ map_consts not_final | Imm64_large imm -> let op1 = OEloadli imm in - let sv = find_or_addnmove op1 [] dest succ map_consts node_dec in + let sv = find_or_addnmove op1 [] dest succ map_consts not_final in build_head_tuple [] sv let get_opimm imm = function diff --git a/riscV/PrintOp.ml b/riscV/PrintOp.ml index a37f5c9c..4494080e 100644 --- a/riscV/PrintOp.ml +++ b/riscV/PrintOp.ml @@ -209,6 +209,8 @@ let print_operation reg pp = function | OEluiw n, _ -> fprintf pp "OEluiw(%ld)" (camlint_of_coqint n) | OEaddiw n, [r1] -> fprintf pp "OEaddiw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEaddiwr0 n, [] -> fprintf pp "OEaddiwr0(X0,%ld)" (camlint_of_coqint n) + | OEandiw n, [r1] -> fprintf pp "OEandiw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEoriw n, [r1] -> fprintf pp "OEoriw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEseql optR0, [r1;r2] -> fprintf pp "OEseql"; (get_optR0_s Ceq reg pp r1 r2 optR0) | OEsnel optR0, [r1;r2] -> fprintf pp "OEsnel"; (get_optR0_s Cne reg pp r1 r2 optR0) | OEsequl optR0, [r1;r2] -> fprintf pp "OEsequl"; (get_optR0_s Ceq reg pp r1 r2 optR0) @@ -221,8 +223,12 @@ let print_operation reg pp = function | OEluil n, _ -> fprintf pp "OEluil(%ld)" (camlint_of_coqint n) | OEaddil n, [r1] -> fprintf pp "OEaddil(%a,%ld)" reg r1 (camlint_of_coqint n) | OEaddilr0 n, [] -> fprintf pp "OEaddilr0(X0,%ld)" (camlint_of_coqint n) + | OEandil n, [r1] -> fprintf pp "OEandil(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEoril n, [r1] -> fprintf pp "OEoril(%a,%ld)" reg r1 (camlint_of_coqint n) | OEloadli n, _ -> fprintf pp "OEloadli(%ld)" (camlint_of_coqint n) | OEmayundef isl, [r1;r2] -> fprintf pp "OEmayundef (%b,%a,%a)" isl reg r1 reg r2 + | OEshrxundef n, [r1] -> fprintf pp "OEshrxundef (%ld,%a)" (camlint_of_coqint n) reg r1 + | OEshrxlundef n, [r1] -> fprintf pp "OEshrxlundef (%ld,%a)" (camlint_of_coqint n) reg r1 | OEfeqd, [r1;r2] -> fprintf pp "OEfeqd(%a,%s,%a)" reg r1 (comparison_name Ceq) reg r2 | OEfltd, [r1;r2] -> fprintf pp "OEfltd(%a,%s,%a)" reg r1 (comparison_name Clt) reg r2 | OEfled, [r1;r2] -> fprintf pp "OEfled(%a,%s,%a)" reg r1 (comparison_name Cle) reg r2 -- cgit From 0d98d7fec937d3a9a2324f1731b041cfbf16dcbe Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Tue, 30 Mar 2021 10:11:01 +0200 Subject: Refactoring the mayundef OP to be more general... --- riscV/NeedOp.v | 2 - riscV/Op.v | 109 ++++++++++-------------- riscV/PrintOp.ml | 10 ++- riscV/RTLpathSE_simplify.v | 204 ++++++++++++++++++++++++++------------------- riscV/ValueAOp.v | 67 +++++---------- 5 files changed, 191 insertions(+), 201 deletions(-) (limited to 'riscV') diff --git a/riscV/NeedOp.v b/riscV/NeedOp.v index 4ed9868c..cfadea37 100644 --- a/riscV/NeedOp.v +++ b/riscV/NeedOp.v @@ -117,8 +117,6 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | OEoril _ => op1 (default nv) | OEloadli _ => op1 (default nv) | OEmayundef _ => op2 (default nv) - | OEshrxundef _ => op2 (default nv) - | OEshrxlundef _ => op2 (default nv) | OEfeqd => op2 (default nv) | OEfltd => op2 (default nv) | OEfled => op2 (default nv) diff --git a/riscV/Op.v b/riscV/Op.v index 0569676a..b8835c61 100644 --- a/riscV/Op.v +++ b/riscV/Op.v @@ -69,6 +69,13 @@ Inductive condition : Type := | CEbgel (optR0: option bool) (**r branch-if-greater-or-equal signed *) | CEbgeul (optR0: option bool). (**r branch-if-greater-or-equal unsigned *) +(* This type will define the eval function of a OEmayundef operation. *) +Inductive mayundef: Type := + | MUint: mayundef + | MUlong: mayundef + | MUshrx: int -> mayundef + | MUshrxl: int -> mayundef. + (** Arithmetic and logical operations. In the descriptions, [rd] is the result of the operation and [r1], [r2], etc, are the arguments. *) @@ -201,9 +208,7 @@ Inductive operation : Type := | OExoril (n: int64) (**r xor immediate *) | OEluil (n: int64) (**r load upper-immediate *) | OEloadli (n: int64) (**r load an immediate int64 *) - | OEmayundef (is_long: bool) - | OEshrxundef (n: int) - | OEshrxlundef (n: int) + | OEmayundef (mu: mayundef) | OEfeqd (**r compare equal *) | OEfltd (**r compare less-than *) | OEfled (**r compare less-than/equal *) @@ -242,9 +247,9 @@ Defined. Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition bool_dec; intros. + generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition bool_dec Val.eq; intros. decide equality. - all: destruct optR0, optR1; decide equality. + all: try destruct optR0, optR1; try decide equality. Defined. (* Alternate definition: @@ -271,42 +276,28 @@ Definition apply_bin_r0 {B} (optR0: option bool) (sem: val -> val -> B) (v1 v2 v | Some false => sem v1 vz end. -Definition may_undef_int (is_long: bool) (v1 v2: val): val := - if negb is_long then - match v1 with - | Vint _ => v2 - | _ => Vundef - end - else - match v1 with - | Vlong _ => v2 - | _ => Vundef - end. - -Definition shrx_imm_undef (v1 v2: val): val := - match v1 with - | Vint n1 => - match v2 with - | Vint n2 => - if Int.ltu n2 (Int.repr 31) - then Vint n1 - else Vundef +Definition eval_may_undef (mu: mayundef) (v1 v2: val): val := + match mu with + | MUint => match v1 with + | Vint _ => v2 + | _ => Vundef + end + | MUlong => match v1 with + | Vlong _ => v2 + | _ => Vundef + end + | MUshrx i => + match v1 with + | Vint _ => + if Int.ltu i (Int.repr 31) then v1 else Vundef | _ => Vundef end - | _ => Vundef - end. - -Definition shrxl_imm_undef (v1 v2: val): val := - match v1 with - | Vlong n1 => - match v2 with - | Vint n2 => - if Int.ltu n2 (Int.repr 63) - then Vlong n1 - else Vundef + | MUshrxl i => + match v1 with + | Vlong _ => + if Int.ltu i (Int.repr 63) then v1 else Vundef | _ => Vundef end - | _ => Vundef end. (** * Evaluation functions *) @@ -481,9 +472,7 @@ Definition eval_operation | OEandil n, v1::nil => Some (Val.andl (Vlong n) v1) | OEoril n, v1::nil => Some (Val.orl (Vlong n) v1) | OEloadli n, nil => Some (Vlong n) - | OEmayundef is_long, v1::v2::nil => Some (may_undef_int is_long v1 v2) - | OEshrxundef n, v1::nil => Some (shrx_imm_undef v1 (Vint n)) - | OEshrxlundef n, v1::nil => Some (shrxl_imm_undef v1 (Vint n)) + | OEmayundef mu, v1 :: v2 :: nil => Some (eval_may_undef mu v1 v2) | OEfeqd, v1::v2::nil => Some (Val.cmpf Ceq v1 v2) | OEfltd, v1::v2::nil => Some (Val.cmpf Clt v1 v2) | OEfled, v1::v2::nil => Some (Val.cmpf Cle v1 v2) @@ -693,8 +682,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | OEaddilr0 _ => (nil, Tlong) | OEloadli _ => (nil, Tlong) | OEmayundef _ => (Tany64 :: Tany64 :: nil, Tany64) - | OEshrxundef _ => (Tint :: nil, Tint) - | OEshrxlundef _ => (Tlong :: nil, Tlong) | OEfeqd => (Tfloat :: Tfloat :: nil, Tint) | OEfltd => (Tfloat :: Tfloat :: nil, Tint) | OEfled => (Tfloat :: Tfloat :: nil, Tint) @@ -736,6 +723,14 @@ Proof. intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto. Qed. +Remark type_mayundef: + forall mu v1 v2, Val.has_type (eval_may_undef mu v1 v2) Tany64. +Proof. + intros. unfold eval_may_undef. + destruct mu eqn:EQMU, v1, v2; simpl; auto. + all: destruct Int.ltu; simpl; auto. +Qed. + Lemma type_of_operation_sound: forall op vl sp v m, op <> Omove -> @@ -946,8 +941,7 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* OExoriw *) - destruct v0... (* OEluiw *) - - unfold may_undef_int; - destruct (Int.ltu _ _); cbn; trivial. + - destruct (Int.ltu _ _); cbn; trivial. (* OEseql *) - destruct optR0 as [[]|]; simpl; unfold Val.cmpl; destruct Val.cmpl_bool... all: destruct b... @@ -986,16 +980,7 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* OEloadli *) - trivial. (* OEmayundef *) - - unfold may_undef_int; - destruct is_long, v0, v1; simpl; trivial. - (* OEshrxundef *) - - unfold shrx_imm_undef; - destruct v0; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. - (* OEshrxlundef *) - - unfold shrxl_imm_undef; - destruct v0; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. + - apply type_mayundef. (* OEfeqd *) - destruct v0; destruct v1; cbn; auto. destruct Float.cmp; cbn; auto. @@ -1721,7 +1706,7 @@ Proof. (* shru, shruimm *) - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. - (* shrx *) + (* shrx *) - inv H4; cbn; try apply Val.val_inject_undef. destruct (Int.ltu n (Int.repr 63)); cbn. apply Val.inject_long. @@ -1851,17 +1836,9 @@ Proof. (* OExoril *) - inv H4; simpl; auto. (* OEmayundef *) - - destruct is_long; inv H4; inv H2; - unfold may_undef_int; simpl; auto; - eapply Val.inject_ptr; eauto. - (* OEshrxundef *) - - inv H4; - unfold shrx_imm_undef; simpl; auto. - destruct (Int.ltu _ _); auto. - (* OEshrxlundef *) - - inv H4; - unfold shrxl_imm_undef; simpl; auto. - destruct (Int.ltu _ _); auto. + - destruct mu; inv H4; inv H2; simpl; auto; + try destruct (Int.ltu _ _); simpl; auto. + all: eapply Val.inject_ptr; eauto. (* OEfeqd *) - inv H4; inv H2; cbn; simpl; auto. destruct Float.cmp; unfold Vtrue, Vfalse; cbn; auto. diff --git a/riscV/PrintOp.ml b/riscV/PrintOp.ml index 4494080e..3a775c20 100644 --- a/riscV/PrintOp.ml +++ b/riscV/PrintOp.ml @@ -30,6 +30,12 @@ let comparison_name = function | Cgt -> ">" | Cge -> ">=" +let mu_name pp = function + | MUint -> fprintf pp "MUint" + | MUlong -> fprintf pp "MUlong" + | MUshrx i -> fprintf pp "MUshrx(%ld)" (camlint_of_coqint i) + | MUshrxl i -> fprintf pp "MUshrxl(%ld)" (camlint_of_coqint i) + let get_optR0_s c reg pp r1 r2 = function | None -> fprintf pp "(%a %s %a)" reg r1 (comparison_name c) reg r2 | Some true -> fprintf pp "(X0 %s %a)" (comparison_name c) reg r1 @@ -226,9 +232,7 @@ let print_operation reg pp = function | OEandil n, [r1] -> fprintf pp "OEandil(%a,%ld)" reg r1 (camlint_of_coqint n) | OEoril n, [r1] -> fprintf pp "OEoril(%a,%ld)" reg r1 (camlint_of_coqint n) | OEloadli n, _ -> fprintf pp "OEloadli(%ld)" (camlint_of_coqint n) - | OEmayundef isl, [r1;r2] -> fprintf pp "OEmayundef (%b,%a,%a)" isl reg r1 reg r2 - | OEshrxundef n, [r1] -> fprintf pp "OEshrxundef (%ld,%a)" (camlint_of_coqint n) reg r1 - | OEshrxlundef n, [r1] -> fprintf pp "OEshrxlundef (%ld,%a)" (camlint_of_coqint n) reg r1 + | OEmayundef mu, [r1;r2] -> fprintf pp "OEmayundef (%a,%a,%a)" mu_name mu reg r1 reg r2 | OEfeqd, [r1;r2] -> fprintf pp "OEfeqd(%a,%s,%a)" reg r1 (comparison_name Ceq) reg r2 | OEfltd, [r1;r2] -> fprintf pp "OEfltd(%a,%s,%a)" reg r1 (comparison_name Clt) reg r2 | OEfled, [r1;r2] -> fprintf pp "OEfled(%a,%s,%a)" reg r1 (comparison_name Cle) reg r2 diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index 5804e67e..6066c7f5 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -165,7 +165,7 @@ Definition expanse_condimm_int32s (cmp: comparison) (hv1: hsval) (n: int) := if Int.eq n (Int.repr Int.max_signed) then let hvs := loadimm32 Int.one in let hl := make_lhsv_cmp false hv1 hvs in - fSop (OEmayundef false) hl + fSop (OEmayundef MUint) hl else sltimm32 hv1 (Int.add n Int.one) | _ => let optR0 := make_optR0 false is_inv in @@ -208,7 +208,7 @@ Definition expanse_condimm_int64s (cmp: comparison) (hv1: hsval) (n: int64) := if Int64.eq n (Int64.repr Int64.max_signed) then let hvs := loadimm32 Int.one in let hl := make_lhsv_cmp false hv1 hvs in - fSop (OEmayundef true) hl + fSop (OEmayundef MUlong) hl else sltimm64 hv1 (Int64.add n Int64.one) | _ => let optR0 := make_optR0 false is_inv in @@ -440,8 +440,8 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let hl := make_lhsv_single hv1 in if Int.eq n Int.zero then let move_s := fSop Omove hl in - let move_l := make_lhsv_single move_s in - Some (fSop (OEshrxundef n) move_l) + let move_l := make_lhsv_cmp false move_s move_s in + Some (fSop (OEmayundef (MUshrx n)) move_l) else if Int.eq n Int.one then let srliw_s := fSop (Oshruimm (Int.repr 31)) hl in @@ -449,8 +449,8 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let addw_s := fSop Oadd srliw_l in let addw_l := make_lhsv_single addw_s in let sraiw_s := fSop (Oshrimm Int.one) addw_l in - let sraiw_l := make_lhsv_single sraiw_s in - Some (fSop (OEshrxundef n) sraiw_l) + let sraiw_l := make_lhsv_cmp false sraiw_s sraiw_s in + Some (fSop (OEmayundef (MUshrx n)) sraiw_l) else let sraiw_s := fSop (Oshrimm (Int.repr 31)) hl in let sraiw_l := make_lhsv_single sraiw_s in @@ -459,15 +459,15 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let addw_s := fSop Oadd srliw_l in let addw_l := make_lhsv_single addw_s in let sraiw_s' := fSop (Oshrimm n) addw_l in - let sraiw_l' := make_lhsv_single sraiw_s' in - Some (fSop (OEshrxundef n) sraiw_l') + let sraiw_l' := make_lhsv_cmp false sraiw_s' sraiw_s' in + Some (fSop (OEmayundef (MUshrx n)) sraiw_l') | Oshrxlimm n, a1 :: nil => let hv1 := fsi_sreg_get hst a1 in let hl := make_lhsv_single hv1 in if Int.eq n Int.zero then let move_s := fSop Omove hl in - let move_l := make_lhsv_single move_s in - Some (fSop (OEshrxlundef n) move_l) + let move_l := make_lhsv_cmp false move_s move_s in + Some (fSop (OEmayundef (MUshrxl n)) move_l) else if Int.eq n Int.one then let srlil_s := fSop (Oshrluimm (Int.repr 63)) hl in @@ -475,8 +475,8 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let addl_s := fSop Oaddl srlil_l in let addl_l := make_lhsv_single addl_s in let srail_s := fSop (Oshrlimm Int.one) addl_l in - let srail_l := make_lhsv_single srail_s in - Some (fSop (OEshrxlundef n) srail_l) + let srail_l := make_lhsv_cmp false srail_s srail_s in + Some (fSop (OEmayundef (MUshrxl n)) srail_l) else let srail_s := fSop (Oshrlimm (Int.repr 63)) hl in let srail_l := make_lhsv_single srail_s in @@ -485,8 +485,8 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let addl_s := fSop Oaddl srlil_l in let addl_l := make_lhsv_single addl_s in let srail_s' := fSop (Oshrlimm n) addl_l in - let srail_l' := make_lhsv_single srail_s' in - Some (fSop (OEshrxlundef n) srail_l') + let srail_l' := make_lhsv_cmp false srail_s' srail_s' in + Some (fSop (OEmayundef (MUshrxl n)) srail_l') (*| Oaddrstack n, nil =>*) (*let hv1 := fsi_sreg_get hst a1 in*) (*OK (addptrofs hv1 n)*) @@ -964,7 +964,7 @@ Proof. try rewrite OKv1; try rewrite OK2; try rewrite (Int.add_commut _ Int.zero), Int.add_zero_l in H; subst; - unfold Val.cmp, may_undef_int, zero32, Val.add; simpl; + unfold Val.cmp, eval_may_undef, zero32, Val.add; simpl; destruct v; auto. all: try rewrite ltu_12_wordsize; @@ -1018,7 +1018,7 @@ Proof. try rewrite OKv1; try rewrite OK2; rewrite HMEM; - unfold may_undef_int, Val.cmpu; + unfold eval_may_undef, Val.cmpu; destruct v; simpl; auto; try rewrite EQIMM; try destruct (Archi.ptr64) eqn:EQARCH; simpl; try rewrite ltu_12_wordsize; trivial; @@ -1141,7 +1141,7 @@ Proof. unfold Val.cmpl, Val.addl; try rewrite xorl_zero_eq_cmpl; trivial; try rewrite optbool_mktotal; trivial; - unfold may_undef_int, zero32, Val.add; simpl; + unfold eval_may_undef, zero32, Val.add; simpl; destruct v; auto. 1,2,3,4,5,6,7,8,9,10,11,12: try rewrite <- optbool_mktotal; trivial; @@ -1210,7 +1210,7 @@ Proof. all: try apply xor_neg_ltle_cmplu; trivial. (* Others subcases with swap/negation *) all: - unfold Val.cmplu, may_undef_int, zero64, Val.addl; + unfold Val.cmplu, eval_may_undef, zero64, Val.addl; try apply Int64.same_if_eq in EQLO; subst; try rewrite Int64.add_commut, Int64.add_zero_l in *; trivial; try rewrite Int64.add_commut; @@ -1681,41 +1681,57 @@ Lemma simplify_shrximm_correct ge sp rs0 m0 lr hst fsv st args m n: forall hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (si_sreg st r) rs0 m0) (H : match lr with - | nil => None - | a1 :: nil => - if Int.eq n Int.zero - then - Some - (fSop (OEshrxundef n) - (make_lhsv_single - (fSop Omove (make_lhsv_single (fsi_sreg_get hst a1))))) - else - if Int.eq n Int.one + | nil => None + | a1 :: nil => + if Int.eq n Int.zero then Some - (fSop (OEshrxundef n) - (make_lhsv_single - (fSop (Oshrimm Int.one) - (make_lhsv_single - (fSop Oadd - (make_lhsv_cmp false (fsi_sreg_get hst a1) - (fSop (Oshruimm (Int.repr 31)) - (make_lhsv_single (fsi_sreg_get hst a1))))))))) + (fSop (OEmayundef (MUshrx n)) + (make_lhsv_cmp false + (fSop Omove (make_lhsv_single (fsi_sreg_get hst a1))) + (fSop Omove (make_lhsv_single (fsi_sreg_get hst a1))))) else - Some - (fSop (OEshrxundef n) - (make_lhsv_single - (fSop (Oshrimm n) - (make_lhsv_single - (fSop Oadd - (make_lhsv_cmp false (fsi_sreg_get hst a1) - (fSop (Oshruimm (Int.sub Int.iwordsize n)) - (make_lhsv_single - (fSop (Oshrimm (Int.repr 31)) - (make_lhsv_single - (fsi_sreg_get hst a1))))))))))) - | a1 :: _ :: _ => None - end = Some fsv) + if Int.eq n Int.one + then + Some + (fSop (OEmayundef (MUshrx n)) + (make_lhsv_cmp false + (fSop (Oshrimm Int.one) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.repr 31)) + (make_lhsv_single (fsi_sreg_get hst a1))))))) + (fSop (Oshrimm Int.one) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.repr 31)) + (make_lhsv_single (fsi_sreg_get hst a1))))))))) + else + Some + (fSop (OEmayundef (MUshrx n)) + (make_lhsv_cmp false + (fSop (Oshrimm n) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.sub Int.iwordsize n)) + (make_lhsv_single + (fSop (Oshrimm (Int.repr 31)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))) + (fSop (Oshrimm n) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.sub Int.iwordsize n)) + (make_lhsv_single + (fSop (Oshrimm (Int.repr 31)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))))) + | a1 :: _ :: _ => None + end = Some fsv) (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), seval_sval ge sp (hsval_proj fsv) rs0 m0 = eval_operation ge sp (Oshrximm n) args m. @@ -1734,7 +1750,7 @@ Proof. erewrite !fsi_sreg_get_correct; eauto; destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1; destruct (Val.shrx v (Vint n)) eqn:TOTAL; cbn; - unfold shrx_imm_undef. + unfold eval_may_undef. 2,4,6: unfold Val.shrx in TOTAL; destruct v; simpl in TOTAL; simpl; try congruence; @@ -1769,41 +1785,57 @@ Lemma simplify_shrxlimm_correct ge sp rs0 m0 lr hst fsv st args m n: forall hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (si_sreg st r) rs0 m0) (H : match lr with - | nil => None - | a1 :: nil => - if Int.eq n Int.zero - then - Some - (fSop (OEshrxlundef n) - (make_lhsv_single - (fSop Omove (make_lhsv_single (fsi_sreg_get hst a1))))) - else - if Int.eq n Int.one + | nil => None + | a1 :: nil => + if Int.eq n Int.zero then Some - (fSop (OEshrxlundef n) - (make_lhsv_single - (fSop (Oshrlimm Int.one) - (make_lhsv_single - (fSop Oaddl - (make_lhsv_cmp false (fsi_sreg_get hst a1) - (fSop (Oshrluimm (Int.repr 63)) - (make_lhsv_single (fsi_sreg_get hst a1))))))))) + (fSop (OEmayundef (MUshrxl n)) + (make_lhsv_cmp false + (fSop Omove (make_lhsv_single (fsi_sreg_get hst a1))) + (fSop Omove (make_lhsv_single (fsi_sreg_get hst a1))))) else - Some - (fSop (OEshrxlundef n) - (make_lhsv_single - (fSop (Oshrlimm n) - (make_lhsv_single - (fSop Oaddl - (make_lhsv_cmp false (fsi_sreg_get hst a1) - (fSop (Oshrluimm (Int.sub Int64.iwordsize' n)) - (make_lhsv_single - (fSop (Oshrlimm (Int.repr 63)) - (make_lhsv_single - (fsi_sreg_get hst a1))))))))))) - | a1 :: _ :: _ => None - end = Some fsv) + if Int.eq n Int.one + then + Some + (fSop (OEmayundef (MUshrxl n)) + (make_lhsv_cmp false + (fSop (Oshrlimm Int.one) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.repr 63)) + (make_lhsv_single (fsi_sreg_get hst a1))))))) + (fSop (Oshrlimm Int.one) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.repr 63)) + (make_lhsv_single (fsi_sreg_get hst a1))))))))) + else + Some + (fSop (OEmayundef (MUshrxl n)) + (make_lhsv_cmp false + (fSop (Oshrlimm n) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.sub Int64.iwordsize' n)) + (make_lhsv_single + (fSop (Oshrlimm (Int.repr 63)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))) + (fSop (Oshrlimm n) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.sub Int64.iwordsize' n)) + (make_lhsv_single + (fSop (Oshrlimm (Int.repr 63)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))))) + | a1 :: _ :: _ => None + end = Some fsv) (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), seval_sval ge sp (hsval_proj fsv) rs0 m0 = eval_operation ge sp (Oshrxlimm n) args m. @@ -1822,7 +1854,7 @@ Proof. erewrite !fsi_sreg_get_correct; eauto; destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1; destruct (Val.shrxl v (Vint n)) eqn:TOTAL; cbn; - unfold shrxl_imm_undef. + unfold eval_may_undef. 2,4,6: unfold Val.shrxl in TOTAL; destruct v; simpl in TOTAL; simpl; try congruence; @@ -1850,7 +1882,7 @@ Proof. destruct Int.ltu eqn:EQN2 in TOTAL; try discriminate. rewrite !EQN2. rewrite EQN0. reflexivity. -Qed. + Qed. Lemma simplify_cast32unsigned_correct ge sp rs0 m0 lr hst fsv st args m: forall (SREG: forall r: positive, @@ -2001,7 +2033,7 @@ Proof. try destruct (Int64.eq lo Int64.zero) eqn:EQLO; try apply Int.same_if_eq in EQLO; simpl; trivial; try apply Int64.same_if_eq in EQLO; simpl; trivial; - unfold may_undef_int; + unfold eval_may_undef; try erewrite !fsi_sreg_get_correct; eauto; try rewrite OKv1; simpl; trivial; try destruct v; try rewrite H; diff --git a/riscV/ValueAOp.v b/riscV/ValueAOp.v index fe519921..82291f9c 100644 --- a/riscV/ValueAOp.v +++ b/riscV/ValueAOp.v @@ -27,42 +27,28 @@ Definition apply_bin_r0 {B} (optR0: option bool) (sem: aval -> aval -> B) (v1 v2 | Some false => sem v1 vz end. -Definition may_undef_int (is_long: bool) (v1 v2: aval): aval := - if negb is_long then - match v1 with - | I _ => v2 - | _ => Ifptr Ptop - end - else - match v1 with - | L _ => v2 - | _ => Ifptr Ptop - end. - -Definition shrx_imm_undef (v1 v2: aval): aval := - match v1 with - | I n1 => - match v2 with - | I n2 => - if Int.ltu n2 (Int.repr 31) - then I n1 - else Ifptr Ptop +Definition eval_may_undef (mu: mayundef) (v1 v2: aval): aval := + match mu with + | MUint => match v1 with + | I _ => v2 + | _ => Ifptr Ptop + end + | MUlong => match v1 with + | L _ => v2 + | _ => Ifptr Ptop + end + | MUshrx i => + match v1 with + | I _ => + if Int.ltu i (Int.repr 31) then v1 else Ifptr Ptop | _ => Ifptr Ptop end - | _ => Ifptr Ptop - end. - -Definition shrxl_imm_undef (v1 v2: aval): aval := - match v1 with - | L n1 => - match v2 with - | I n2 => - if Int.ltu n2 (Int.repr 63) - then L n1 - else Ifptr Ptop + | MUshrxl i => + match v1 with + | L _ => + if Int.ltu i (Int.repr 63) then v1 else Ifptr Ptop | _ => Ifptr Ptop end - | _ => Ifptr Ptop end. Definition eval_static_condition (cond: condition) (vl: list aval): abool := @@ -263,9 +249,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | OEaddil n, v1::nil => addl (L n) v1 | OEaddilr0 n, nil => addl (L n) zero64 | OEloadli n, nil => L (n) - | OEmayundef is_long, v1::v2::nil => may_undef_int is_long v1 v2 - | OEshrxundef n, v1::nil => shrx_imm_undef v1 (I n) - | OEshrxlundef n, v1::nil => shrxl_imm_undef v1 (I n) + | OEmayundef mu, v1 :: v2 :: nil => eval_may_undef mu v1 v2 | OEfeqd, v1::v2::nil => of_optbool (cmpf_bool Ceq v1 v2) | OEfltd, v1::v2::nil => of_optbool (cmpf_bool Clt v1 v2) | OEfled, v1::v2::nil => of_optbool (cmpf_bool Cle v1 v2) @@ -508,21 +492,16 @@ Proof. 1,10: simpl; eauto with va. 2: - unfold Op.may_undef_int, may_undef_int; destruct is_long; - simpl; inv H0; inv H1; eauto with va; inv H; - apply vmatch_ifptr_p; eauto with va. + unfold Op.eval_may_undef, eval_may_undef; destruct mu; + inv H1; inv H0; eauto with va; + try destruct (Int.ltu _ _); simpl; + try eapply vmatch_ifptr_p, pmatch_top'; eauto with va. 3,4,6: apply eval_cmplu_sound; auto. 1,2,3: apply eval_cmpl_sound; auto. { unfold Val.cmpl; apply of_optbool_maketotal_sound; eauto with va. } { unfold Val.cmplu; apply of_optbool_maketotal_sound; eauto with va. } { unfold zero64; simpl; eauto with va. } - { unfold Op.shrx_imm_undef, shrx_imm_undef. - simpl; inv H1; eauto with va; - destruct (Int.ltu _ _); simpl; eauto with va. } - { unfold Op.shrxl_imm_undef, shrxl_imm_undef. - simpl; inv H1; eauto with va; - destruct (Int.ltu _ _); simpl; eauto with va. } all: unfold Val.cmpf; apply of_optbool_sound; eauto with va. Qed. -- cgit From 83b556a101b7ed490acf9e127c5b4b9db40e1019 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Tue, 30 Mar 2021 11:25:28 +0200 Subject: Now a more general way to perform imm operations --- riscV/Asmgen.v | 15 +++++++++------ riscV/Asmgenproof.v | 1 + riscV/Asmgenproof1.v | 7 ++++++- riscV/ExpansionOracle.ml | 4 ++-- riscV/NeedOp.v | 3 +-- riscV/Op.v | 34 ++++++++++++++++++++++++---------- riscV/PrintOp.ml | 7 +++++-- riscV/RTLpathSE_simplify.v | 4 ++-- riscV/ValueAOp.v | 31 ++++++++++++++++++------------- 9 files changed, 68 insertions(+), 38 deletions(-) (limited to 'riscV') diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index d4c6b73a..54c7a7c0 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -219,6 +219,12 @@ Definition apply_bin_r0_r0r0 (optR0: option bool) (sem: ireg0 -> ireg0 -> instru | Some false => sem r1 X0 end. +Definition get_opimmR0 (rd: ireg) (opi: opimm) := + match opi with + | OPimmADD i => Paddiw rd X0 i + | OPimmADDL i => Paddil rd X0 i + end. + Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) := match cond, args with @@ -770,6 +776,9 @@ Definition transl_op | Ocmp cmp, _ => do rd <- ireg_of res; transl_cond_op cmp rd args k + | OEimmR0 opi, nil => + do rd <- ireg_of res; + OK (get_opimmR0 rd opi :: k) | OEseqw optR0, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; @@ -819,9 +828,6 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; OK (Paddiw rd rs n :: k) - | OEaddiwr0 n, nil => - do rd <- ireg_of res; - OK (Paddiw rd X0 n :: k) | OEandiw n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -879,9 +885,6 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; OK (Paddil rd rs n :: k) - | OEaddilr0 n, nil => - do rd <- ireg_of res; - OK (Paddil rd X0 n :: k) | OEandil n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 82c1917d..9a458b77 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -308,6 +308,7 @@ Opaque Int.eq. - apply opimm64_label; intros; exact I. - destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. - eapply transl_cond_op_label; eauto. +- destruct opi; simpl; TailNoLabel. - destruct optR0 as [[]|]; simpl; TailNoLabel. - destruct optR0 as [[]|]; simpl; TailNoLabel. - destruct optR0 as [[]|]; simpl; TailNoLabel. diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 639c9a64..6e5cc531 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -1258,7 +1258,12 @@ Opaque Int.eq. { exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. } (* Expanded instructions from RTL *) - 7,8,9,10,17,18,19,20: + { unfold get_opimmR0; destruct opi; simpl; + econstructor; split; try apply exec_straight_one; simpl; eauto; + split; intros; Simpl. + try rewrite Int.add_commut; auto. + try rewrite Int64.add_commut; auto. } + 7,8,9,16,17,18: econstructor; split; try apply exec_straight_one; simpl; eauto; split; intros; Simpl; try destruct (rs x0); try rewrite Int64.add_commut; diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 6eb82274..c03e0d03 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -117,7 +117,7 @@ let load_hilo64 dest hi lo succ map_consts not_final = let loadimm32 dest n succ map_consts not_final = match make_immed32 n with | Imm32_single imm -> - let op1 = OEaddiwr0 imm in + let op1 = OEimmR0 (OPimmADD imm) in let sv = find_or_addnmove op1 [] dest succ map_consts not_final in build_head_tuple [] sv | Imm32_pair (hi, lo) -> load_hilo32 dest hi lo succ map_consts not_final @@ -125,7 +125,7 @@ let loadimm32 dest n succ map_consts not_final = let loadimm64 dest n succ map_consts not_final = match make_immed64 n with | Imm64_single imm -> - let op1 = OEaddilr0 imm in + let op1 = OEimmR0 (OPimmADDL imm) in let sv = find_or_addnmove op1 [] dest succ map_consts not_final in build_head_tuple [] sv | Imm64_pair (hi, lo) -> load_hilo64 dest hi lo succ map_consts not_final diff --git a/riscV/NeedOp.v b/riscV/NeedOp.v index cfadea37..715951a0 100644 --- a/riscV/NeedOp.v +++ b/riscV/NeedOp.v @@ -87,6 +87,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv) | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) | Ocmp c => needs_of_condition c + | OEimmR0 _ => op1 (default nv) | OEseqw _ => op2 (default nv) | OEsnew _ => op2 (default nv) | OEsequw _ => op2 (default nv) @@ -98,7 +99,6 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | OExoriw _ => op1 (bitwise nv) | OEluiw _ => op1 (default nv) | OEaddiw _ => op1 (default nv) - | OEaddiwr0 _ => op1 (default nv) | OEandiw n => op1 (andimm nv n) | OEoriw n => op1 (orimm nv n) | OEseql _ => op2 (default nv) @@ -112,7 +112,6 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | OExoril _ => op1 (default nv) | OEluil _ => op1 (default nv) | OEaddil _ => op1 (default nv) - | OEaddilr0 _ => op1 (default nv) | OEandil _ => op1 (default nv) | OEoril _ => op1 (default nv) | OEloadli _ => op1 (default nv) diff --git a/riscV/Op.v b/riscV/Op.v index b8835c61..2ceffd4a 100644 --- a/riscV/Op.v +++ b/riscV/Op.v @@ -76,6 +76,11 @@ Inductive mayundef: Type := | MUshrx: int -> mayundef | MUshrxl: int -> mayundef. +(* This allow to have a single RTL constructor to perform an arith operation between an immediate and X0 *) +Inductive opimm: Type := + | OPimmADD: int -> opimm + | OPimmADDL: int64 -> opimm. + (** Arithmetic and logical operations. In the descriptions, [rd] is the result of the operation and [r1], [r2], etc, are the arguments. *) @@ -179,6 +184,7 @@ Inductive operation : Type := (*c Boolean tests: *) | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) (* Expansed conditions *) + | OEimmR0 (opi: opimm) | OEseqw (optR0: option bool) (**r [rd <- rs1 == rs2] signed *) | OEsnew (optR0: option bool) (**r [rd <- rs1 != rs2] signed *) | OEsequw (optR0: option bool) (**r [rd <- rs1 == rs2] unsigned *) @@ -188,7 +194,6 @@ Inductive operation : Type := | OEsltiw (n: int) (**r set-less-than immediate *) | OEsltiuw (n: int) (**r set-less-than unsigned immediate *) | OEaddiw (n: int) (**r add immediate *) - | OEaddiwr0 (n: int) (**r add immediate *) | OEandiw (n: int) (**r and immediate *) | OEoriw (n: int) (**r or immediate *) | OExoriw (n: int) (**r xor immediate *) @@ -202,7 +207,6 @@ Inductive operation : Type := | OEsltil (n: int64) (**r set-less-than immediate *) | OEsltiul (n: int64) (**r set-less-than unsigned immediate *) | OEaddil (n: int64) (**r add immediate *) - | OEaddilr0 (n: int64) (**r add immediate *) | OEandil (n: int64) (**r and immediate *) | OEoril (n: int64) (**r or immediate *) | OExoril (n: int64) (**r xor immediate *) @@ -300,6 +304,12 @@ Definition eval_may_undef (mu: mayundef) (v1 v2: val): val := end end. +Definition eval_opimmR0 (opi: opimm): val := + match opi with + | OPimmADD i => Val.add (Vint i) zero32 + | OPimmADDL i => Val.addl (Vlong i) zero64 + end. + (** * Evaluation functions *) (** Evaluation of conditions, operators and addressing modes applied @@ -443,6 +453,7 @@ Definition eval_operation | Ofloat_of_bits, v1::nil => Some (ExtValues.float_of_bits v1) | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) (* Expansed conditions *) + | OEimmR0 opi, nil => Some (eval_opimmR0 opi) | OEseqw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmp Ceq) v1 v2 zero32) | OEsnew optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmp Cne) v1 v2 zero32) | OEsequw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) Ceq) v1 v2 zero32) @@ -454,7 +465,6 @@ Definition eval_operation | OExoriw n, v1::nil => Some (Val.xor v1 (Vint n)) | OEluiw n, nil => Some (Val.shl (Vint n) (Vint (Int.repr 12))) | OEaddiw n, v1::nil => Some (Val.add (Vint n) v1) - | OEaddiwr0 n, nil => Some (Val.add (Vint n) zero32) | OEandiw n, v1::nil => Some (Val.and (Vint n) v1) | OEoriw n, v1::nil => Some (Val.or (Vint n) v1) | OEseql optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Ceq) v1 v2 zero64)) @@ -468,7 +478,6 @@ Definition eval_operation | OExoril n, v1::nil => Some (Val.xorl v1 (Vlong n)) | OEluil n, nil => Some (Vlong (Int64.sign_ext 32 (Int64.shl n (Int64.repr 12)))) | OEaddil n, v1::nil => Some (Val.addl (Vlong n) v1) - | OEaddilr0 n, nil => Some (Val.addl (Vlong n) zero64) | OEandil n, v1::nil => Some (Val.andl (Vlong n) v1) | OEoril n, v1::nil => Some (Val.orl (Vlong n) v1) | OEloadli n, nil => Some (Vlong n) @@ -557,6 +566,12 @@ Definition type_of_condition (c: condition) : list typ := | CEbgeul _ => Tlong :: Tlong :: nil end. +Definition type_of_opimmR0 (opi: opimm) : typ := + match opi with + | OPimmADD _ => Tint + | OPimmADDL _ => Tlong + end. + Definition type_of_operation (op: operation) : list typ * typ := match op with | Omove => (nil, Tint) (* treated specially *) @@ -652,6 +667,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Osingleoflong => (Tlong :: nil, Tsingle) | Osingleoflongu => (Tlong :: nil, Tsingle) | Ocmp c => (type_of_condition c, Tint) + | OEimmR0 opi => (nil, type_of_opimmR0 opi) | OEseqw _ => (Tint :: Tint :: nil, Tint) | OEsnew _ => (Tint :: Tint :: nil, Tint) | OEsequw _ => (Tint :: Tint :: nil, Tint) @@ -663,7 +679,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | OExoriw _ => (Tint :: nil, Tint) | OEluiw _ => (nil, Tint) | OEaddiw _ => (Tint :: nil, Tint) - | OEaddiwr0 _ => (nil, Tint) | OEandiw _ => (Tint :: nil, Tint) | OEoriw _ => (Tint :: nil, Tint) | OEseql _ => (Tlong :: Tlong :: nil, Tint) @@ -679,7 +694,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | OExoril _ => (Tlong :: nil, Tlong) | OEluil _ => (nil, Tlong) | OEaddil _ => (Tlong :: nil, Tlong) - | OEaddilr0 _ => (nil, Tlong) | OEloadli _ => (nil, Tlong) | OEmayundef _ => (Tany64 :: Tany64 :: nil, Tany64) | OEfeqd => (Tfloat :: Tfloat :: nil, Tint) @@ -907,6 +921,8 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; cbn; trivial. (* cmp *) - destruct (eval_condition cond vl m)... destruct b... + (* OEimmR0 *) + - destruct opi; unfold eval_opimmR0; simpl; auto. (* OEseqw *) - destruct optR0 as [[]|]; simpl; unfold Val.cmp; destruct Val.cmp_bool... all: destruct b... @@ -932,8 +948,6 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - unfold Val.cmpu; destruct Val.cmpu_bool... destruct b... (* OEaddiw *) - fold (Val.add (Vint n) v0); apply type_add. - (* OEaddiwr0 *) - - trivial. (* OEandiw *) - destruct v0... (* OEoriw *) @@ -967,8 +981,6 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - unfold Val.cmplu; destruct Val.cmplu_bool... destruct b... (* OEaddil *) - fold (Val.addl (Vlong n) v0); apply type_addl. - (* OEaddilr0 *) - - trivial. (* OEandil *) - destruct v0... (* OEoril *) @@ -1769,6 +1781,8 @@ Proof. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. destruct b; simpl; constructor. simpl; constructor. + (* OEimmR0 *) + - destruct opi; unfold eval_opimmR0; simpl; auto. (* OEseqw *) - destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmp; inv H4; inv H2; simpl; try destruct (Int.eq _ _); simpl; cbn; auto; diff --git a/riscV/PrintOp.ml b/riscV/PrintOp.ml index 3a775c20..9b3e8835 100644 --- a/riscV/PrintOp.ml +++ b/riscV/PrintOp.ml @@ -36,6 +36,10 @@ let mu_name pp = function | MUshrx i -> fprintf pp "MUshrx(%ld)" (camlint_of_coqint i) | MUshrxl i -> fprintf pp "MUshrxl(%ld)" (camlint_of_coqint i) +let get_immR0 pp = function + | OPimmADD i -> fprintf pp "OPimmADD(%ld)" (camlint_of_coqint i) + | OPimmADDL i -> fprintf pp "OPimmADDL(%ld)" (camlint_of_coqint i) + let get_optR0_s c reg pp r1 r2 = function | None -> fprintf pp "(%a %s %a)" reg r1 (comparison_name c) reg r2 | Some true -> fprintf pp "(X0 %s %a)" (comparison_name c) reg r1 @@ -203,6 +207,7 @@ let print_operation reg pp = function | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 | Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1 | Ocmp c, args -> print_condition reg pp (c, args) + | OEimmR0 opi, [] -> fprintf pp "OEimmR0(%a)" get_immR0 opi | OEseqw optR0, [r1;r2] -> fprintf pp "OEseqw"; (get_optR0_s Ceq reg pp r1 r2 optR0) | OEsnew optR0, [r1;r2] -> fprintf pp "OEsnew"; (get_optR0_s Cne reg pp r1 r2 optR0) | OEsequw optR0, [r1;r2] -> fprintf pp "OEsequw"; (get_optR0_s Ceq reg pp r1 r2 optR0) @@ -214,7 +219,6 @@ let print_operation reg pp = function | OExoriw n, [r1] -> fprintf pp "OExoriw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEluiw n, _ -> fprintf pp "OEluiw(%ld)" (camlint_of_coqint n) | OEaddiw n, [r1] -> fprintf pp "OEaddiw(%a,%ld)" reg r1 (camlint_of_coqint n) - | OEaddiwr0 n, [] -> fprintf pp "OEaddiwr0(X0,%ld)" (camlint_of_coqint n) | OEandiw n, [r1] -> fprintf pp "OEandiw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEoriw n, [r1] -> fprintf pp "OEoriw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEseql optR0, [r1;r2] -> fprintf pp "OEseql"; (get_optR0_s Ceq reg pp r1 r2 optR0) @@ -228,7 +232,6 @@ let print_operation reg pp = function | OExoril n, [r1] -> fprintf pp "OExoril(%a,%ld)" reg r1 (camlint_of_coqint n) | OEluil n, _ -> fprintf pp "OEluil(%ld)" (camlint_of_coqint n) | OEaddil n, [r1] -> fprintf pp "OEaddil(%a,%ld)" reg r1 (camlint_of_coqint n) - | OEaddilr0 n, [] -> fprintf pp "OEaddilr0(X0,%ld)" (camlint_of_coqint n) | OEandil n, [r1] -> fprintf pp "OEandil(%a,%ld)" reg r1 (camlint_of_coqint n) | OEoril n, [r1] -> fprintf pp "OEoril(%a,%ld)" reg r1 (camlint_of_coqint n) | OEloadli n, _ -> fprintf pp "OEloadli(%ld)" (camlint_of_coqint n) diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index 6066c7f5..08c1a6a0 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -50,14 +50,14 @@ Definition load_hilo64 (hi lo: int64) := Definition loadimm32 (n: int) := match make_immed32 n with | Imm32_single imm => - fSop (OEaddiwr0 imm) fSnil + fSop (OEimmR0 (OPimmADD imm)) fSnil | Imm32_pair hi lo => load_hilo32 hi lo end. Definition loadimm64 (n: int64) := match make_immed64 n with | Imm64_single imm => - fSop (OEaddilr0 imm) fSnil + fSop (OEimmR0 (OPimmADDL imm)) fSnil | Imm64_pair hi lo => load_hilo64 hi lo | Imm64_large imm => fSop (OEloadli imm) fSnil end. diff --git a/riscV/ValueAOp.v b/riscV/ValueAOp.v index 82291f9c..b64040e1 100644 --- a/riscV/ValueAOp.v +++ b/riscV/ValueAOp.v @@ -51,6 +51,12 @@ Definition eval_may_undef (mu: mayundef) (v1 v2: aval): aval := end end. +Definition eval_opimmR0 (opi: opimm): aval := + match opi with + | OPimmADD i => add (I i) zero32 + | OPimmADDL i => addl (L i) zero64 + end. + Definition eval_static_condition (cond: condition) (vl: list aval): abool := match cond, vl with | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2 @@ -220,6 +226,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoflong, v1::nil => singleoflong v1 | Osingleoflongu, v1::nil => singleoflongu v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) + | OEimmR0 opi, nil => eval_opimmR0 opi | OEseqw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmp_bool Ceq) v1 v2 zero32) | OEsnew optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmp_bool Cne) v1 v2 zero32) | OEsequw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpu_bool Ceq) v1 v2 zero32) @@ -231,7 +238,6 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | OExoriw n, v1::nil => xor v1 (I n) | OEluiw n, nil => shl (I n) (I (Int.repr 12)) | OEaddiw n, v1::nil => add (I n) v1 - | OEaddiwr0 n, nil => add (I n) zero32 | OEandiw n, v1::nil => and (I n) v1 | OEoriw n, v1::nil => or (I n) v1 | OEseql optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Ceq) v1 v2 zero64) @@ -247,7 +253,6 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | OExoril n, v1::nil => xorl v1 (L n) | OEluil n, nil => sign_ext 32 (shll (L n) (L (Int64.repr 12))) | OEaddil n, v1::nil => addl (L n) v1 - | OEaddilr0 n, nil => addl (L n) zero64 | OEloadli n, nil => L (n) | OEmayundef mu, v1 :: v2 :: nil => eval_may_undef mu v1 v2 | OEfeqd, v1::v2::nil => of_optbool (cmpf_bool Ceq v1 v2) @@ -472,36 +477,36 @@ Proof. destruct (propagate_float_constants tt); constructor. rewrite Ptrofs.add_zero_l; eauto with va. apply of_optbool_sound. eapply eval_static_condition_sound; eauto. - + + unfold Op.eval_opimmR0, eval_opimmR0, Op.zero32, zero32, Op.zero64, zero64; + destruct opi; eauto with va. 3,4,6: apply eval_cmpu_sound; auto. 1,2,3: apply eval_cmp_sound; auto. unfold Val.cmp; apply of_optbool_sound; eauto with va. unfold Val.cmpu; apply of_optbool_sound; eauto with va. { fold (Val.add (Vint n) a1); eauto with va. } - { unfold zero32; simpl; eauto with va. } { fold (Val.and (Vint n) a1); eauto with va. } { fold (Val.or (Vint n) a1); eauto with va. } { simpl; try destruct (Int.ltu _ _); eauto with va; unfold ntop1; try apply vmatch_ifptr_undef. } 9: { fold (Val.addl (Vlong n) a1); eauto with va. } - 10: { fold (Val.andl (Vlong n) a1); eauto with va. } - 10: { fold (Val.orl (Vlong n) a1); eauto with va. } - 10: { simpl; unfold ntop1, sign_ext, Int64.sign_ext, sgn; simpl; + 9: { fold (Val.andl (Vlong n) a1); eauto with va. } + 9: { fold (Val.orl (Vlong n) a1); eauto with va. } + 9: { simpl; unfold ntop1, sign_ext, Int64.sign_ext, sgn; simpl; apply vmatch_ifptr_l. } 1,10: simpl; eauto with va. - 2: + 10: unfold Op.eval_may_undef, eval_may_undef; destruct mu; inv H1; inv H0; eauto with va; try destruct (Int.ltu _ _); simpl; try eapply vmatch_ifptr_p, pmatch_top'; eauto with va. - 3,4,6: apply eval_cmplu_sound; auto. - 1,2,3: apply eval_cmpl_sound; auto. - { unfold Val.cmpl; apply of_optbool_maketotal_sound; eauto with va. } - { unfold Val.cmplu; apply of_optbool_maketotal_sound; eauto with va. } - { unfold zero64; simpl; eauto with va. } + 4,5,7: apply eval_cmplu_sound; auto. + 1,3,4: apply eval_cmpl_sound; auto. + 2: { unfold Val.cmpl; apply of_optbool_maketotal_sound; eauto with va. } + 2: { unfold Val.cmplu; apply of_optbool_maketotal_sound; eauto with va. } all: unfold Val.cmpf; apply of_optbool_sound; eauto with va. Qed. -- cgit From df9aab806ae8d20393b56e4175e210ed6cff1ef1 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Tue, 30 Mar 2021 12:48:51 +0200 Subject: a more general way to manage special registers before introducing SP --- riscV/Asmgen.v | 157 +++++++++++++----------- riscV/Asmgenproof.v | 56 ++++----- riscV/Asmgenproof1.v | 142 +++++++++++----------- riscV/ExpansionOracle.ml | 121 +++++++++--------- riscV/Op.v | 296 +++++++++++++++++++++++---------------------- riscV/PrintOp.ml | 98 +++++++-------- riscV/RTLpathSE_simplify.v | 185 ++++++++++++++-------------- riscV/ValueAOp.v | 98 +++++++-------- 8 files changed, 593 insertions(+), 560 deletions(-) (limited to 'riscV') diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index 54c7a7c0..88d4f73f 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -205,20 +205,13 @@ Definition transl_cond_single (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := | Cge => (Pfles rd fs2 fs1, true) end. -Definition apply_bin_r0_r0r0lbl (optR0: option bool) (sem: ireg0 -> ireg0 -> label -> instruction) (r1 r2: ireg0) (lbl: label) := - match optR0 with - | None => sem r1 r2 lbl - | Some true => sem X0 r1 lbl - | Some false => sem r1 X0 lbl +Definition apply_bin_oreg_ireg0 (optR: option oreg) (r1 r2: ireg0): (ireg0 * ireg0) := + match optR with + | None => (r1, r2) + | Some X0_L => (X0, r1) + | Some X0_R => (r1, X0) end. -Definition apply_bin_r0_r0r0 (optR0: option bool) (sem: ireg0 -> ireg0 -> instruction) (r1 r2: ireg0) := - match optR0 with - | None => sem r1 r2 - | Some true => sem X0 r1 - | Some false => sem r1 X0 - end. - Definition get_opimmR0 (rd: ireg) (opi: opimm) := match opi with | OPimmADD i => Paddiw rd X0 i @@ -281,54 +274,70 @@ Definition transl_cbranch let (insn, normal) := transl_cond_single c X31 r1 r2 in OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) - | CEbeqw optR0, a1 :: a2 :: nil => + | CEbeqw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbeqw r1 r2 lbl :: k) - | CEbnew optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbeqw r1' r2' lbl :: k) + | CEbnew optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbnew r1 r2 lbl :: k) - | CEbequw optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbnew r1' r2' lbl :: k) + | CEbequw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbeqw r1 r2 lbl :: k) - | CEbneuw optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbeqw r1' r2' lbl :: k) + | CEbneuw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbnew r1 r2 lbl :: k) - | CEbltw optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbnew r1' r2' lbl :: k) + | CEbltw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbltw r1 r2 lbl :: k) - | CEbltuw optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbltw r1' r2' lbl :: k) + | CEbltuw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbltuw r1 r2 lbl :: k) - | CEbgew optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbltuw r1' r2' lbl :: k) + | CEbgew optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbgew r1 r2 lbl :: k) - | CEbgeuw optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbgew r1' r2' lbl :: k) + | CEbgeuw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbgeuw r1 r2 lbl :: k) - | CEbeql optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbgeuw r1' r2' lbl :: k) + | CEbeql optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbeql r1 r2 lbl :: k) - | CEbnel optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbeql r1' r2' lbl :: k) + | CEbnel optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbnel r1 r2 lbl :: k) - | CEbequl optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbnel r1' r2' lbl :: k) + | CEbequl optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbeql r1 r2 lbl :: k) - | CEbneul optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbeql r1' r2' lbl :: k) + | CEbneul optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbnel r1 r2 lbl :: k) - | CEbltl optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbnel r1' r2' lbl :: k) + | CEbltl optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbltl r1 r2 lbl :: k) - | CEbltul optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbltl r1' r2' lbl :: k) + | CEbltul optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbltul r1 r2 lbl :: k) - | CEbgel optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbltul r1' r2' lbl :: k) + | CEbgel optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbgel r1 r2 lbl :: k) - | CEbgeul optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbgel r1' r2' lbl :: k) + | CEbgeul optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbgeul r1 r2 lbl :: k) + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbgeul r1' r2' lbl :: k) | _, _ => Error(msg "Asmgen.transl_cond_branch") end. @@ -779,36 +788,42 @@ Definition transl_op | OEimmR0 opi, nil => do rd <- ireg_of res; OK (get_opimmR0 rd opi :: k) - | OEseqw optR0, a1 :: a2 :: nil => + | OEseqw optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Pseqw rd) rs1 rs2 :: k) - | OEsnew optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Pseqw rd rs1' rs2' :: k) + | OEsnew optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psnew rd) rs1 rs2 :: k) - | OEsequw optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psnew rd rs1' rs2' :: k) + | OEsequw optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Pseqw rd) rs1 rs2 :: k) - | OEsneuw optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Pseqw rd rs1' rs2' :: k) + | OEsneuw optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psnew rd) rs1 rs2 :: k) - | OEsltw optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psnew rd rs1' rs2' :: k) + | OEsltw optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psltw rd) rs1 rs2 :: k) - | OEsltuw optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psltw rd rs1' rs2' :: k) + | OEsltuw optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psltuw rd) rs1 rs2 :: k) + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psltuw rd rs1' rs2' :: k) | OEsltiw n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -836,36 +851,42 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; OK (Poriw rd rs n :: k) - | OEseql optR0, a1 :: a2 :: nil => + | OEseql optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Pseql rd) rs1 rs2 :: k) - | OEsnel optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Pseql rd rs1' rs2' :: k) + | OEsnel optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psnel rd) rs1 rs2 :: k) - | OEsequl optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psnel rd rs1' rs2' :: k) + | OEsequl optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Pseql rd) rs1 rs2 :: k) - | OEsneul optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Pseql rd rs1' rs2' :: k) + | OEsneul optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psnel rd) rs1 rs2 :: k) - | OEsltl optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psnel rd rs1' rs2' :: k) + | OEsltl optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psltl rd) rs1 rs2 :: k) - | OEsltul optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psltl rd rs1' rs2' :: k) + | OEsltul optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psltul rd) rs1 rs2 :: k) + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psltul rd rs1' rs2' :: k) | OEsltil n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 9a458b77..101bfa9c 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -212,22 +212,22 @@ Proof. - destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. destruct normal; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. -- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. Qed. Remark transl_cond_op_label: @@ -309,18 +309,18 @@ Opaque Int.eq. - destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. - eapply transl_cond_op_label; eauto. - destruct opi; simpl; TailNoLabel. -- destruct optR0 as [[]|]; simpl; TailNoLabel. -- destruct optR0 as [[]|]; simpl; TailNoLabel. -- destruct optR0 as [[]|]; simpl; TailNoLabel. -- destruct optR0 as [[]|]; simpl; TailNoLabel. -- destruct optR0 as [[]|]; simpl; TailNoLabel. -- destruct optR0 as [[]|]; simpl; TailNoLabel. -- destruct optR0 as [[]|]; simpl; TailNoLabel. -- destruct optR0 as [[]|]; simpl; TailNoLabel. -- destruct optR0 as [[]|]; simpl; TailNoLabel. -- destruct optR0 as [[]|]; simpl; TailNoLabel. -- destruct optR0 as [[]|]; simpl; TailNoLabel. -- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. Qed. Remark indexed_memory_access_label: diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 6e5cc531..1e17c4e2 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -494,124 +494,128 @@ Proof. split. rewrite V; destruct normal, b; reflexivity. intros; Simpl. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32 in *; - eexists; eexists; eauto; split; constructor; auto; + destruct (rs x) eqn:EQRS; simpl in *; try congruence; + inv EQ2; eexists; eexists; eauto; split; constructor; auto; simpl in *. - + destruct (rs x); simpl in *; try congruence. + + rewrite EQRS; assert (HB: (Int.eq Int.zero i) = b) by congruence. rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. + + rewrite EQRS; assert (HB: (Int.eq i Int.zero) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. + rewrite <- HB; destruct b; simpl; auto. + + rewrite EQRS; destruct (rs x0); try congruence. assert (HB: (Int.eq i i0) = b) by congruence. - rewrite HB; destruct b; simpl; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + rewrite <- HB; destruct b; simpl; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32 in *; - eexists; eexists; eauto; split; constructor; auto; + destruct (rs x) eqn:EQRS; simpl in *; try congruence; + inv EQ2; eexists; eexists; eauto; split; constructor; auto; simpl in *. - + destruct (rs x); simpl in *; try congruence. + + rewrite EQRS; assert (HB: negb (Int.eq Int.zero i) = b) by congruence. rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. + + rewrite EQRS; assert (HB: negb (Int.eq i Int.zero) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. + rewrite <- HB; destruct b; simpl; auto. + + rewrite EQRS; destruct (rs x0); try congruence. assert (HB: negb (Int.eq i i0) = b) by congruence. - rewrite HB; destruct b; simpl; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero32, Op.zero32 in *; + rewrite <- HB; destruct b; simpl; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero32, Op.zero32 in *; +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero32, Op.zero32 in *; +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero32, Op.zero32 in *; +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero32, Op.zero32 in *; +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero32, Op.zero32 in *; +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + destruct (rs x) eqn:EQRS; simpl in *; try congruence; eexists; eexists; eauto; split; constructor; simpl in *; auto. - + destruct (rs x); simpl in *; try congruence. + + rewrite EQRS; assert (HB: (Int64.eq Int64.zero i) = b) by congruence. rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. + + rewrite EQRS; assert (HB: (Int64.eq i Int64.zero) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. + rewrite <- HB; destruct b; simpl; auto. + + rewrite EQRS; destruct (rs x0); try congruence. assert (HB: (Int64.eq i i0) = b) by congruence. - rewrite HB; destruct b; simpl; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; + rewrite <- HB; destruct b; simpl; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + destruct (rs x) eqn:EQRS; simpl in *; try congruence; eexists; eexists; eauto; split; constructor; simpl in *; auto. - + destruct (rs x); simpl in *; try congruence. + + rewrite EQRS; assert (HB: negb (Int64.eq Int64.zero i) = b) by congruence. rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. + + rewrite EQRS; assert (HB: negb (Int64.eq i Int64.zero) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. + rewrite <- HB; destruct b; simpl; auto. + + rewrite EQRS; destruct (rs x0); try congruence. assert (HB: negb (Int64.eq i i0) = b) by congruence. - rewrite HB; destruct b; simpl; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; + rewrite <- HB; destruct b; simpl; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. -- destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. Qed. @@ -1273,7 +1277,7 @@ Opaque Int.eq. try rewrite Int64.or_commut; try rewrite Int.or_commut; auto. 1-12: - destruct optR0 as [[]|]; unfold apply_bin_r0_r0r0, apply_bin_r0; + destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; inv EQ3; econstructor; split; try apply exec_straight_one; simpl; eauto; split; intros; Simpl; destruct (rs x0); auto; diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index c03e0d03..16f1ee4b 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -66,7 +66,7 @@ let find_or_addnmove op args rd succ map_consts not_final = if not_final then node := !node - 1; Sr (P.of_int r) | None -> - if not (List.exists (fun a -> a = rd) args) && not_final then + if (not (List.exists (fun a -> a = rd) args)) && not_final then Hashtbl.add map_consts sop (p2i rd); Si (Iop (op, args, rd, succ)) @@ -208,131 +208,132 @@ let sltuimm64 a1 dest n succ k = opimm64 a1 dest n succ k (OEsltul None) Sltiul let is_inv_cmp = function Cle | Cgt -> true | _ -> false -let make_optR0 is_x0 is_inv = if is_x0 then Some is_inv else None +let make_optR is_x0 is_inv = + if is_x0 then if is_inv then Some X0_L else Some X0_R else None let cbranch_int32s is_x0 cmp a1 a2 info succ1 succ2 k = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Icond (CEbeqw optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cne -> Icond (CEbnew optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Clt -> Icond (CEbltw optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cle -> Icond (CEbgew optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cgt -> Icond (CEbltw optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cge -> Icond (CEbgew optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Ceq -> Icond (CEbeqw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Icond (CEbnew optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Icond (CEbltw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Icond (CEbgew optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Icond (CEbltw optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Icond (CEbgew optR, [ a1; a2 ], succ1, succ2, info) :: k let cbranch_int32u is_x0 cmp a1 a2 info succ1 succ2 k = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Icond (CEbequw optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cne -> Icond (CEbneuw optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Clt -> Icond (CEbltuw optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cle -> Icond (CEbgeuw optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cgt -> Icond (CEbltuw optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cge -> Icond (CEbgeuw optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Ceq -> Icond (CEbequw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Icond (CEbneuw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Icond (CEbltuw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Icond (CEbgeuw optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Icond (CEbltuw optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Icond (CEbgeuw optR, [ a1; a2 ], succ1, succ2, info) :: k let cbranch_int64s is_x0 cmp a1 a2 info succ1 succ2 k = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Icond (CEbeql optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cne -> Icond (CEbnel optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Clt -> Icond (CEbltl optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cle -> Icond (CEbgel optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cgt -> Icond (CEbltl optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cge -> Icond (CEbgel optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Ceq -> Icond (CEbeql optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Icond (CEbnel optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Icond (CEbltl optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Icond (CEbgel optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Icond (CEbltl optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Icond (CEbgel optR, [ a1; a2 ], succ1, succ2, info) :: k let cbranch_int64u is_x0 cmp a1 a2 info succ1 succ2 k = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Icond (CEbequl optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cne -> Icond (CEbneul optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Clt -> Icond (CEbltul optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cle -> Icond (CEbgeul optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cgt -> Icond (CEbltul optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cge -> Icond (CEbgeul optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Ceq -> Icond (CEbequl optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Icond (CEbneul optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Icond (CEbltul optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Icond (CEbgeul optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Icond (CEbltul optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Icond (CEbgeul optR, [ a1; a2 ], succ1, succ2, info) :: k let cond_int32s is_x0 cmp a1 a2 dest tmp_reg succ map_consts = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> [ Iop (OEseqw optR0, [ a1; a2 ], dest, succ) ] - | Cne -> [ Iop (OEsnew optR0, [ a1; a2 ], dest, succ) ] - | Clt -> [ Iop (OEsltw optR0, [ a1; a2 ], dest, succ) ] + | Ceq -> [ Iop (OEseqw optR, [ a1; a2 ], dest, succ) ] + | Cne -> [ Iop (OEsnew optR, [ a1; a2 ], dest, succ) ] + | Clt -> [ Iop (OEsltw optR, [ a1; a2 ], dest, succ) ] | Cle -> let r = r2pi () in - let op = OEsltw optR0 in + let op = OEsltw optR in let sv = find_or_addnmove op [ a2; a1 ] r (get tmp_reg) map_consts true in let ht = build_head_tuple [] sv in let r' = unzip_head_tuple ht r in fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] - | Cgt -> [ Iop (OEsltw optR0, [ a2; a1 ], dest, succ) ] + | Cgt -> [ Iop (OEsltw optR, [ a2; a1 ], dest, succ) ] | Cge -> let r = r2pi () in - let op = OEsltw optR0 in + let op = OEsltw optR in let sv = find_or_addnmove op [ a1; a2 ] r (get tmp_reg) map_consts true in let ht = build_head_tuple [] sv in let r' = unzip_head_tuple ht r in fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] let cond_int32u is_x0 cmp a1 a2 dest tmp_reg succ map_consts = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> [ Iop (OEsequw optR0, [ a1; a2 ], dest, succ) ] - | Cne -> [ Iop (OEsneuw optR0, [ a1; a2 ], dest, succ) ] - | Clt -> [ Iop (OEsltuw optR0, [ a1; a2 ], dest, succ) ] + | Ceq -> [ Iop (OEsequw optR, [ a1; a2 ], dest, succ) ] + | Cne -> [ Iop (OEsneuw optR, [ a1; a2 ], dest, succ) ] + | Clt -> [ Iop (OEsltuw optR, [ a1; a2 ], dest, succ) ] | Cle -> let r = r2pi () in - let op = OEsltuw optR0 in + let op = OEsltuw optR in let sv = find_or_addnmove op [ a2; a1 ] r (get tmp_reg) map_consts true in let ht = build_head_tuple [] sv in let r' = unzip_head_tuple ht r in fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] - | Cgt -> [ Iop (OEsltuw optR0, [ a2; a1 ], dest, succ) ] + | Cgt -> [ Iop (OEsltuw optR, [ a2; a1 ], dest, succ) ] | Cge -> let r = r2pi () in - let op = OEsltuw optR0 in + let op = OEsltuw optR in let sv = find_or_addnmove op [ a1; a2 ] r (get tmp_reg) map_consts true in let ht = build_head_tuple [] sv in let r' = unzip_head_tuple ht r in fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] let cond_int64s is_x0 cmp a1 a2 dest tmp_reg succ map_consts = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> [ Iop (OEseql optR0, [ a1; a2 ], dest, succ) ] - | Cne -> [ Iop (OEsnel optR0, [ a1; a2 ], dest, succ) ] - | Clt -> [ Iop (OEsltl optR0, [ a1; a2 ], dest, succ) ] + | Ceq -> [ Iop (OEseql optR, [ a1; a2 ], dest, succ) ] + | Cne -> [ Iop (OEsnel optR, [ a1; a2 ], dest, succ) ] + | Clt -> [ Iop (OEsltl optR, [ a1; a2 ], dest, succ) ] | Cle -> let r = r2pi () in - let op = OEsltl optR0 in + let op = OEsltl optR in let sv = find_or_addnmove op [ a2; a1 ] r (get tmp_reg) map_consts true in let ht = build_head_tuple [] sv in let r' = unzip_head_tuple ht r in fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] - | Cgt -> [ Iop (OEsltl optR0, [ a2; a1 ], dest, succ) ] + | Cgt -> [ Iop (OEsltl optR, [ a2; a1 ], dest, succ) ] | Cge -> let r = r2pi () in - let op = OEsltl optR0 in + let op = OEsltl optR in let sv = find_or_addnmove op [ a1; a2 ] r (get tmp_reg) map_consts true in let ht = build_head_tuple [] sv in let r' = unzip_head_tuple ht r in fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] let cond_int64u is_x0 cmp a1 a2 dest tmp_reg succ map_consts = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> [ Iop (OEsequl optR0, [ a1; a2 ], dest, succ) ] - | Cne -> [ Iop (OEsneul optR0, [ a1; a2 ], dest, succ) ] - | Clt -> [ Iop (OEsltul optR0, [ a1; a2 ], dest, succ) ] + | Ceq -> [ Iop (OEsequl optR, [ a1; a2 ], dest, succ) ] + | Cne -> [ Iop (OEsneul optR, [ a1; a2 ], dest, succ) ] + | Clt -> [ Iop (OEsltul optR, [ a1; a2 ], dest, succ) ] | Cle -> let r = r2pi () in - let op = OEsltul optR0 in + let op = OEsltul optR in let sv = find_or_addnmove op [ a2; a1 ] r (get tmp_reg) map_consts true in let ht = build_head_tuple [] sv in let r' = unzip_head_tuple ht r in fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] - | Cgt -> [ Iop (OEsltul optR0, [ a2; a1 ], dest, succ) ] + | Cgt -> [ Iop (OEsltul optR, [ a2; a1 ], dest, succ) ] | Cge -> let r = r2pi () in - let op = OEsltul optR0 in + let op = OEsltul optR in let sv = find_or_addnmove op [ a1; a2 ] r (get tmp_reg) map_consts true in let ht = build_head_tuple [] sv in let r' = unzip_head_tuple ht r in @@ -481,8 +482,8 @@ let expanse_cbranch_fp cnot fn_cond cmp f1 f2 info succ1 succ2 map_consts = let insn = List.hd (fn_cond cmp f1 f2 r (n2pi ()) map_consts) in insn :: - (if normal' then [ Icond (CEbnew (Some false), [ r; r ], succ1, succ2, info) ] - else [ Icond (CEbeqw (Some false), [ r; r ], succ1, succ2, info) ]) + (if normal' then [ Icond (CEbnew (Some X0_R), [ r; r ], succ1, succ2, info) ] + else [ Icond (CEbeqw (Some X0_R), [ r; r ], succ1, succ2, info) ]) let get_regindent = function Coq_inr _ -> [] | Coq_inl r -> [ r ] diff --git a/riscV/Op.v b/riscV/Op.v index 2ceffd4a..a8ff3666 100644 --- a/riscV/Op.v +++ b/riscV/Op.v @@ -38,6 +38,11 @@ Set Implicit Arguments. (** Conditions (boolean-valued operators). *) +(* Type to modelize the use of a special register in arith operations *) +Inductive oreg: Type := + | X0_L: oreg + | X0_R: oreg. + Inductive condition : Type := | Ccomp (c: comparison) (**r signed integer comparison *) | Ccompu (c: comparison) (**r unsigned integer comparison *) @@ -52,22 +57,22 @@ Inductive condition : Type := | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) | Cnotcompfs (c: comparison) (**r negation of a floating-point comparison *) (* Expansed branches *) - | CEbeqw (optR0: option bool) (**r branch-if-equal signed *) - | CEbnew (optR0: option bool) (**r branch-if-not-equal signed *) - | CEbequw (optR0: option bool) (**r branch-if-equal unsigned *) - | CEbneuw (optR0: option bool) (**r branch-if-not-equal unsigned *) - | CEbltw (optR0: option bool) (**r branch-if-less signed *) - | CEbltuw (optR0: option bool) (**r branch-if-less unsigned *) - | CEbgew (optR0: option bool) (**r branch-if-greater-or-equal signed *) - | CEbgeuw (optR0: option bool) (**r branch-if-greater-or-equal unsigned *) - | CEbeql (optR0: option bool) (**r branch-if-equal signed *) - | CEbnel (optR0: option bool) (**r branch-if-not-equal signed *) - | CEbequl (optR0: option bool) (**r branch-if-equal unsigned *) - | CEbneul (optR0: option bool) (**r branch-if-not-equal unsigned *) - | CEbltl (optR0: option bool) (**r branch-if-less signed *) - | CEbltul (optR0: option bool) (**r branch-if-less unsigned *) - | CEbgel (optR0: option bool) (**r branch-if-greater-or-equal signed *) - | CEbgeul (optR0: option bool). (**r branch-if-greater-or-equal unsigned *) + | CEbeqw (optR: option oreg) (**r branch-if-equal signed *) + | CEbnew (optR: option oreg) (**r branch-if-not-equal signed *) + | CEbequw (optR: option oreg) (**r branch-if-equal unsigned *) + | CEbneuw (optR: option oreg) (**r branch-if-not-equal unsigned *) + | CEbltw (optR: option oreg) (**r branch-if-less signed *) + | CEbltuw (optR: option oreg) (**r branch-if-less unsigned *) + | CEbgew (optR: option oreg) (**r branch-if-greater-or-equal signed *) + | CEbgeuw (optR: option oreg) (**r branch-if-greater-or-equal unsigned *) + | CEbeql (optR: option oreg) (**r branch-if-equal signed *) + | CEbnel (optR: option oreg) (**r branch-if-not-equal signed *) + | CEbequl (optR: option oreg) (**r branch-if-equal unsigned *) + | CEbneul (optR: option oreg) (**r branch-if-not-equal unsigned *) + | CEbltl (optR: option oreg) (**r branch-if-less signed *) + | CEbltul (optR: option oreg) (**r branch-if-less unsigned *) + | CEbgel (optR: option oreg) (**r branch-if-greater-or-equal signed *) + | CEbgeul (optR: option oreg). (**r branch-if-greater-or-equal unsigned *) (* This type will define the eval function of a OEmayundef operation. *) Inductive mayundef: Type := @@ -76,7 +81,7 @@ Inductive mayundef: Type := | MUshrx: int -> mayundef | MUshrxl: int -> mayundef. -(* This allow to have a single RTL constructor to perform an arith operation between an immediate and X0 *) +(* Type for allowing a single RTL constructor to perform an arith operation between an immediate and X0 *) Inductive opimm: Type := | OPimmADD: int -> opimm | OPimmADDL: int64 -> opimm. @@ -185,12 +190,12 @@ Inductive operation : Type := | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) (* Expansed conditions *) | OEimmR0 (opi: opimm) - | OEseqw (optR0: option bool) (**r [rd <- rs1 == rs2] signed *) - | OEsnew (optR0: option bool) (**r [rd <- rs1 != rs2] signed *) - | OEsequw (optR0: option bool) (**r [rd <- rs1 == rs2] unsigned *) - | OEsneuw (optR0: option bool) (**r [rd <- rs1 != rs2] unsigned *) - | OEsltw (optR0: option bool) (**r set-less-than *) - | OEsltuw (optR0: option bool) (**r set-less-than unsigned *) + | OEseqw (optR: option oreg) (**r [rd <- rs1 == rs2] signed *) + | OEsnew (optR: option oreg) (**r [rd <- rs1 != rs2] signed *) + | OEsequw (optR: option oreg) (**r [rd <- rs1 == rs2] unsigned *) + | OEsneuw (optR: option oreg) (**r [rd <- rs1 != rs2] unsigned *) + | OEsltw (optR: option oreg) (**r set-less-than *) + | OEsltuw (optR: option oreg) (**r set-less-than unsigned *) | OEsltiw (n: int) (**r set-less-than immediate *) | OEsltiuw (n: int) (**r set-less-than unsigned immediate *) | OEaddiw (n: int) (**r add immediate *) @@ -198,12 +203,12 @@ Inductive operation : Type := | OEoriw (n: int) (**r or immediate *) | OExoriw (n: int) (**r xor immediate *) | OEluiw (n: int) (**r load upper-immediate *) - | OEseql (optR0: option bool) (**r [rd <- rs1 == rs2] signed *) - | OEsnel (optR0: option bool) (**r [rd <- rs1 != rs2] signed *) - | OEsequl (optR0: option bool) (**r [rd <- rs1 == rs2] unsigned *) - | OEsneul (optR0: option bool) (**r [rd <- rs1 != rs2] unsigned *) - | OEsltl (optR0: option bool) (**r set-less-than *) - | OEsltul (optR0: option bool) (**r set-less-than unsigned *) + | OEseql (optR: option oreg) (**r [rd <- rs1 == rs2] signed *) + | OEsnel (optR: option oreg) (**r [rd <- rs1 != rs2] signed *) + | OEsequl (optR: option oreg) (**r [rd <- rs1 == rs2] unsigned *) + | OEsneul (optR: option oreg) (**r [rd <- rs1 != rs2] unsigned *) + | OEsltl (optR: option oreg) (**r set-less-than *) + | OEsltul (optR: option oreg) (**r set-less-than unsigned *) | OEsltil (n: int64) (**r set-less-than immediate *) | OEsltiul (n: int64) (**r set-less-than unsigned immediate *) | OEaddil (n: int64) (**r add immediate *) @@ -235,12 +240,15 @@ Inductive addressing: Type := (** Comparison functions (used in modules [CSE] and [Allocation]). *) +Definition oreg_eq: forall (x y: oreg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + Definition eq_condition (x y: condition) : {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Int64.eq_dec bool_dec; intros. + generalize Int.eq_dec Int64.eq_dec bool_dec oreg_eq; intros. assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. decide equality. - all: destruct optR0, optR1; decide equality. + all: destruct optR, optR0; decide equality. Defined. Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. @@ -251,9 +259,9 @@ Defined. Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition bool_dec Val.eq; intros. + generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition bool_dec Val.eq oreg_eq; intros. decide equality. - all: try destruct optR0, optR1; try decide equality. + all: try destruct optR, optR0; try decide equality. Defined. (* Alternate definition: @@ -273,11 +281,11 @@ Global Opaque eq_condition eq_addressing eq_operation. Definition zero32 := (Vint Int.zero). Definition zero64 := (Vlong Int64.zero). -Definition apply_bin_r0 {B} (optR0: option bool) (sem: val -> val -> B) (v1 v2 vz: val): B := - match optR0 with +Definition apply_bin_oreg {B} (optR: option oreg) (sem: val -> val -> B) (v1 v2 vz: val): B := + match optR with | None => sem v1 v2 - | Some true => sem vz v1 - | Some false => sem v1 vz + | Some X0_L => sem vz v1 + | Some X0_R => sem v1 vz end. Definition eval_may_undef (mu: mayundef) (v1 v2: val): val := @@ -332,22 +340,22 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2 | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) (* Expansed branches *) - | CEbeqw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmp_bool Ceq) v1 v2 zero32 - | CEbnew optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmp_bool Cne) v1 v2 zero32 - | CEbequw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero32 - | CEbneuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpu_bool (Mem.valid_pointer m) Cne) v1 v2 zero32 - | CEbltw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmp_bool Clt) v1 v2 zero32 - | CEbltuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpu_bool (Mem.valid_pointer m) Clt) v1 v2 zero32 - | CEbgew optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmp_bool Cge) v1 v2 zero32 - | CEbgeuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpu_bool (Mem.valid_pointer m) Cge) v1 v2 zero32 - | CEbeql optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpl_bool Ceq) v1 v2 zero64 - | CEbnel optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpl_bool Cne) v1 v2 zero64 - | CEbequl optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmplu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero64 - | CEbneul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmplu_bool (Mem.valid_pointer m) Cne) v1 v2 zero64 - | CEbltl optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpl_bool Clt) v1 v2 zero64 - | CEbltul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmplu_bool (Mem.valid_pointer m) Clt) v1 v2 zero64 - | CEbgel optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpl_bool Cge) v1 v2 zero64 - | CEbgeul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmplu_bool (Mem.valid_pointer m) Cge) v1 v2 zero64 + | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Ceq) v1 v2 zero32 + | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cne) v1 v2 zero32 + | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero32 + | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cne) v1 v2 zero32 + | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Clt) v1 v2 zero32 + | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Clt) v1 v2 zero32 + | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cge) v1 v2 zero32 + | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cge) v1 v2 zero32 + | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Ceq) v1 v2 zero64 + | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cne) v1 v2 zero64 + | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero64 + | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cne) v1 v2 zero64 + | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Clt) v1 v2 zero64 + | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Clt) v1 v2 zero64 + | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cge) v1 v2 zero64 + | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cge) v1 v2 zero64 | _, _ => None end. @@ -454,12 +462,12 @@ Definition eval_operation | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) (* Expansed conditions *) | OEimmR0 opi, nil => Some (eval_opimmR0 opi) - | OEseqw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmp Ceq) v1 v2 zero32) - | OEsnew optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmp Cne) v1 v2 zero32) - | OEsequw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) Ceq) v1 v2 zero32) - | OEsneuw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) Cne) v1 v2 zero32) - | OEsltw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmp Clt) v1 v2 zero32) - | OEsltuw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) Clt) v1 v2 zero32) + | OEseqw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Ceq) v1 v2 zero32) + | OEsnew optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Cne) v1 v2 zero32) + | OEsequw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Ceq) v1 v2 zero32) + | OEsneuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Cne) v1 v2 zero32) + | OEsltw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Clt) v1 v2 zero32) + | OEsltuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Clt) v1 v2 zero32) | OEsltiw n, v1::nil => Some (Val.cmp Clt v1 (Vint n)) | OEsltiuw n, v1::nil => Some (Val.cmpu (Mem.valid_pointer m) Clt v1 (Vint n)) | OExoriw n, v1::nil => Some (Val.xor v1 (Vint n)) @@ -467,12 +475,12 @@ Definition eval_operation | OEaddiw n, v1::nil => Some (Val.add (Vint n) v1) | OEandiw n, v1::nil => Some (Val.and (Vint n) v1) | OEoriw n, v1::nil => Some (Val.or (Vint n) v1) - | OEseql optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Ceq) v1 v2 zero64)) - | OEsnel optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Cne) v1 v2 zero64)) - | OEsequl optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) Ceq) v1 v2 zero64)) - | OEsneul optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) Cne) v1 v2 zero64)) - | OEsltl optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Clt) v1 v2 zero64)) - | OEsltul optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) Clt) v1 v2 zero64)) + | OEseql optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Ceq) v1 v2 zero64)) + | OEsnel optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Cne) v1 v2 zero64)) + | OEsequl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Ceq) v1 v2 zero64)) + | OEsneul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Cne) v1 v2 zero64)) + | OEsltl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Clt) v1 v2 zero64)) + | OEsltul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Clt) v1 v2 zero64)) | OEsltil n, v1::nil => Some (Val.maketotal (Val.cmpl Clt v1 (Vlong n))) | OEsltiul n, v1::nil => Some (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 (Vlong n))) | OExoril n, v1::nil => Some (Val.xorl v1 (Vlong n)) @@ -924,22 +932,22 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* OEimmR0 *) - destruct opi; unfold eval_opimmR0; simpl; auto. (* OEseqw *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmp; + - destruct optR as [[]|]; simpl; unfold Val.cmp; destruct Val.cmp_bool... all: destruct b... (* OEsnew *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmp; + - destruct optR as [[]|]; simpl; unfold Val.cmp; destruct Val.cmp_bool... all: destruct b... (* OEsequw *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmpu; + - destruct optR as [[]|]; simpl; unfold Val.cmpu; destruct Val.cmpu_bool... all: destruct b... (* OEsneuw *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmpu; + - destruct optR as [[]|]; simpl; unfold Val.cmpu; destruct Val.cmpu_bool... all: destruct b... (* OEsltw *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmp; + - destruct optR as [[]|]; simpl; unfold Val.cmp; destruct Val.cmp_bool... all: destruct b... (* OEsltuw *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmpu; + - destruct optR as [[]|]; simpl; unfold Val.cmpu; destruct Val.cmpu_bool... all: destruct b... (* OEsltiw *) - unfold Val.cmp; destruct Val.cmp_bool... @@ -957,22 +965,22 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* OEluiw *) - destruct (Int.ltu _ _); cbn; trivial. (* OEseql *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmpl; + - destruct optR as [[]|]; simpl; unfold Val.cmpl; destruct Val.cmpl_bool... all: destruct b... (* OEsnel *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmpl; + - destruct optR as [[]|]; simpl; unfold Val.cmpl; destruct Val.cmpl_bool... all: destruct b... (* OEsequl *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmplu; + - destruct optR as [[]|]; simpl; unfold Val.cmplu; destruct Val.cmplu_bool... all: destruct b... (* OEsneul *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmplu; + - destruct optR as [[]|]; simpl; unfold Val.cmplu; destruct Val.cmplu_bool... all: destruct b... (* OEsltl *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmpl; + - destruct optR as [[]|]; simpl; unfold Val.cmpl; destruct Val.cmpl_bool... all: destruct b... (* OEsltul *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmplu; + - destruct optR as [[]|]; simpl; unfold Val.cmplu; destruct Val.cmplu_bool... all: destruct b... (* OEsltil *) - unfold Val.cmpl; destruct Val.cmpl_bool... @@ -1092,22 +1100,22 @@ Definition negate_condition (cond: condition): condition := | Cnotcompf c => Ccompf c | Ccompfs c => Cnotcompfs c | Cnotcompfs c => Ccompfs c - | CEbeqw optR0 => CEbnew optR0 - | CEbnew optR0 => CEbeqw optR0 - | CEbequw optR0 => CEbneuw optR0 - | CEbneuw optR0 => CEbequw optR0 - | CEbltw optR0 => CEbgew optR0 - | CEbltuw optR0 => CEbgeuw optR0 - | CEbgew optR0 => CEbltw optR0 - | CEbgeuw optR0 => CEbltuw optR0 - | CEbeql optR0 => CEbnel optR0 - | CEbnel optR0 => CEbeql optR0 - | CEbequl optR0 => CEbneul optR0 - | CEbneul optR0 => CEbequl optR0 - | CEbltl optR0 => CEbgel optR0 - | CEbltul optR0 => CEbgeul optR0 - | CEbgel optR0 => CEbltl optR0 - | CEbgeul optR0 => CEbltul optR0 + | CEbeqw optR => CEbnew optR + | CEbnew optR => CEbeqw optR + | CEbequw optR => CEbneuw optR + | CEbneuw optR => CEbequw optR + | CEbltw optR => CEbgew optR + | CEbltuw optR => CEbgeuw optR + | CEbgew optR => CEbltw optR + | CEbgeuw optR => CEbltuw optR + | CEbeql optR => CEbnel optR + | CEbnel optR => CEbeql optR + | CEbequl optR => CEbneul optR + | CEbneul optR => CEbequl optR + | CEbltl optR => CEbgel optR + | CEbltul optR => CEbgeul optR + | CEbgel optR => CEbltl optR + | CEbgeul optR => CEbltul optR end. Lemma eval_negate_condition: @@ -1128,37 +1136,37 @@ Proof. repeat (destruct vl; auto). repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto. - repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR as [[]|]; apply Val.negate_cmp_bool. - repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR as [[]|]; apply Val.negate_cmp_bool. - repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR as [[]|]; apply Val.negate_cmpu_bool. - repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR as [[]|]; apply Val.negate_cmpu_bool. - repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR as [[]|]; apply Val.negate_cmp_bool. - repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR as [[]|]; apply Val.negate_cmpu_bool. - repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR as [[]|]; apply Val.negate_cmp_bool. - repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR as [[]|]; apply Val.negate_cmpu_bool. - repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR as [[]|]; apply Val.negate_cmpl_bool. - repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR as [[]|]; apply Val.negate_cmpl_bool. - repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR as [[]|]; apply Val.negate_cmplu_bool. - repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR as [[]|]; apply Val.negate_cmplu_bool. - repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR as [[]|]; apply Val.negate_cmpl_bool. - repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR as [[]|]; apply Val.negate_cmplu_bool. - repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR as [[]|]; apply Val.negate_cmpl_bool. - repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR as [[]|]; apply Val.negate_cmplu_bool. Qed. @@ -1303,7 +1311,7 @@ Proof. f_equal. f_equal. apply cond_depends_on_memory_correct; trivial. all: intros; repeat (destruct args; auto); unfold Val.cmpu, Val.cmpu_bool, Val.cmplu, Val.cmplu_bool; - try destruct optR0 as [[]|]; simpl; + try destruct optR as [[]|]; simpl; destruct v; try destruct v0; simpl; auto; try apply negb_false_iff in H; try rewrite H; auto. Qed. @@ -1315,7 +1323,7 @@ Lemma cond_valid_pointer_eq: Proof. intros until m2. intro MEM. destruct cond eqn:COND; simpl; try congruence. all: repeat (destruct args; simpl; try congruence); - try destruct optR0 as [[]|]; simpl; + try destruct optR as [[]|]; simpl; try destruct v, v0; try rewrite !MEM; auto; try erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. Qed. @@ -1328,7 +1336,7 @@ Proof. intros until m2. destruct op; simpl; try congruence. intro MEM; erewrite cond_valid_pointer_eq; eauto. all: intros MEM; repeat (destruct args; simpl; try congruence); - try destruct optR0 as [[]|]; simpl; try destruct v, v0; try rewrite !MEM; auto; + try destruct optR as [[]|]; simpl; try destruct v, v0; try rewrite !MEM; auto; unfold Val.cmpu, Val.cmplu; erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. Qed. @@ -1460,14 +1468,14 @@ Proof. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. Qed. -Lemma eval_cmpu_bool_inj_opt: forall c v v' v0 v'0 optR0, +Lemma eval_cmpu_bool_inj_opt: forall c v v' v0 v'0 optR, Val.inject f v v' -> Val.inject f v0 v'0 -> - Val.inject f (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m1) c) v v0 zero32) - (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m2) c) v' v'0 zero32). + Val.inject f (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m1) c) v v0 zero32) + (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m2) c) v' v'0 zero32). Proof. - intros until optR0. intros HV1 HV2. - destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmpu; + intros until optR. intros HV1 HV2. + destruct optR as [[]|]; simpl; unfold zero32, Val.cmpu; destruct (Val.cmpu_bool (Mem.valid_pointer m1) c _ _) eqn:?; eauto; assert (HVI: Val.inject f (Vint Int.zero) (Vint Int.zero)) by apply Val.inject_int. + exploit eval_cmpu_bool_inj'. eapply HVI. eapply HV1. eapply Heqo. @@ -1501,14 +1509,14 @@ Proof. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. Qed. -Lemma eval_cmplu_bool_inj_opt: forall c v v' v0 v'0 optR0, +Lemma eval_cmplu_bool_inj_opt: forall c v v' v0 v'0 optR, Val.inject f v v' -> Val.inject f v0 v'0 -> - Val.inject f (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m1) c) v v0 zero64)) - (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m2) c) v' v'0 zero64)). + Val.inject f (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m1) c) v v0 zero64)) + (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m2) c) v' v'0 zero64)). Proof. - intros until optR0. intros HV1 HV2. - destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmplu; + intros until optR. intros HV1 HV2. + destruct optR as [[]|]; simpl; unfold zero64, Val.cmplu; destruct (Val.cmplu_bool (Mem.valid_pointer m1) c _ _) eqn:?; eauto; assert (HVI: Val.inject f (Vlong Int64.zero) (Vlong Int64.zero)) by apply Val.inject_long. + exploit eval_cmplu_bool_inj'. eapply HVI. eapply HV1. eapply Heqo. @@ -1541,37 +1549,37 @@ Proof. - inv H3; inv H2; simpl in H0; inv H0; auto. - inv H3; inv H2; simpl in H0; inv H0; auto. - inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmpu_bool_inj'; eauto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmpu_bool_inj'; eauto. -- destruct optR0 as [[]|]; simpl; +- destruct optR as [[]|]; simpl; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmpu_bool_inj'; eauto. -- destruct optR0 as [[]|]; simpl; +- destruct optR as [[]|]; simpl; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmpu_bool_inj'; eauto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmplu_bool_inj'; eauto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmplu_bool_inj'; eauto. -- destruct optR0 as [[]|]; simpl; +- destruct optR as [[]|]; simpl; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmplu_bool_inj'; eauto. -- destruct optR0 as [[]|]; simpl; +- destruct optR as [[]|]; simpl; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmplu_bool_inj'; eauto. Qed. @@ -1784,11 +1792,11 @@ Proof. (* OEimmR0 *) - destruct opi; unfold eval_opimmR0; simpl; auto. (* OEseqw *) - - destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmp; + - destruct optR as [[]|]; simpl; unfold zero32, Val.cmp; inv H4; inv H2; simpl; try destruct (Int.eq _ _); simpl; cbn; auto; try apply Val.inject_int. (* OEsnew *) - - destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmp; + - destruct optR as [[]|]; simpl; unfold zero32, Val.cmp; inv H4; inv H2; simpl; try destruct (Int.eq _ _); simpl; cbn; auto; try apply Val.inject_int. (* OEsequw *) @@ -1796,7 +1804,7 @@ Proof. (* OEsneuw *) - apply eval_cmpu_bool_inj_opt; auto. (* OEsltw *) - - destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmp; + - destruct optR as [[]|]; simpl; unfold zero32, Val.cmp; inv H4; inv H2; simpl; try destruct (Int.lt _ _); simpl; cbn; auto; try apply Val.inject_int. (* OEsltuw *) @@ -1818,11 +1826,11 @@ Proof. (* OEluiw *) - destruct (Int.ltu _ _); auto. (* OEseql *) - - destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmpl; + - destruct optR as [[]|]; simpl; unfold zero64, Val.cmpl; inv H4; inv H2; simpl; try destruct (Int64.eq _ _); simpl; cbn; auto; try apply Val.inject_int. (* OEsnel *) - - destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmpl; + - destruct optR as [[]|]; simpl; unfold zero64, Val.cmpl; inv H4; inv H2; simpl; try destruct (Int64.eq _ _); simpl; cbn; auto; try apply Val.inject_int. (* OEsequl *) @@ -1830,7 +1838,7 @@ Proof. (* OEsneul *) - apply eval_cmplu_bool_inj_opt; auto. (* OEsltl *) - - destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmpl; + - destruct optR as [[]|]; simpl; unfold zero64, Val.cmpl; inv H4; inv H2; simpl; try destruct (Int64.lt _ _); simpl; cbn; auto; try apply Val.inject_int. (* OEsltul *) diff --git a/riscV/PrintOp.ml b/riscV/PrintOp.ml index 9b3e8835..e18d31f6 100644 --- a/riscV/PrintOp.ml +++ b/riscV/PrintOp.ml @@ -40,14 +40,10 @@ let get_immR0 pp = function | OPimmADD i -> fprintf pp "OPimmADD(%ld)" (camlint_of_coqint i) | OPimmADDL i -> fprintf pp "OPimmADDL(%ld)" (camlint_of_coqint i) -let get_optR0_s c reg pp r1 r2 = function +let get_optR_s c reg pp r1 r2 = function | None -> fprintf pp "(%a %s %a)" reg r1 (comparison_name c) reg r2 - | Some true -> fprintf pp "(X0 %s %a)" (comparison_name c) reg r1 - | Some false -> fprintf pp "(%a %s X0)" reg r1 (comparison_name c) - -let get_optR0_s_int reg pp r1 n = function - | None -> fprintf pp "(%a, %ld)" reg r1 n - | Some _ -> fprintf pp "(X0, %ld)" n + | Some X0_L -> fprintf pp "(X0 %s %a)" (comparison_name c) reg r1 + | Some X0_R -> fprintf pp "(%a %s X0)" reg r1 (comparison_name c) let print_condition reg pp = function | (Ccomp c, [r1;r2]) -> @@ -74,38 +70,38 @@ let print_condition reg pp = function fprintf pp "%a %sfs %a" reg r1 (comparison_name c) reg r2 | (Cnotcompfs c, [r1;r2]) -> fprintf pp "%a not(%sfs) %a" reg r1 (comparison_name c) reg r2 - | (CEbeqw optR0, [r1;r2]) -> - fprintf pp "CEbeqw"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | (CEbnew optR0, [r1;r2]) -> - fprintf pp "CEbnew"; (get_optR0_s Cne reg pp r1 r2 optR0) - | (CEbequw optR0, [r1;r2]) -> - fprintf pp "CEbequw"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | (CEbneuw optR0, [r1;r2]) -> - fprintf pp "CEbneuw"; (get_optR0_s Cne reg pp r1 r2 optR0) - | (CEbltw optR0, [r1;r2]) -> - fprintf pp "CEbltw"; (get_optR0_s Clt reg pp r1 r2 optR0) - | (CEbltuw optR0, [r1;r2]) -> - fprintf pp "CEbltuw"; (get_optR0_s Clt reg pp r1 r2 optR0) - | (CEbgew optR0, [r1;r2]) -> - fprintf pp "CEbgew"; (get_optR0_s Cge reg pp r1 r2 optR0) - | (CEbgeuw optR0, [r1;r2]) -> - fprintf pp "CEbgeuw"; (get_optR0_s Cge reg pp r1 r2 optR0) - | (CEbeql optR0, [r1;r2]) -> - fprintf pp "CEbeql"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | (CEbnel optR0, [r1;r2]) -> - fprintf pp "CEbnel"; (get_optR0_s Cne reg pp r1 r2 optR0) - | (CEbequl optR0, [r1;r2]) -> - fprintf pp "CEbequl"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | (CEbneul optR0, [r1;r2]) -> - fprintf pp "CEbneul"; (get_optR0_s Cne reg pp r1 r2 optR0) - | (CEbltl optR0, [r1;r2]) -> - fprintf pp "CEbltl"; (get_optR0_s Clt reg pp r1 r2 optR0) - | (CEbltul optR0, [r1;r2]) -> - fprintf pp "CEbltul"; (get_optR0_s Clt reg pp r1 r2 optR0) - | (CEbgel optR0, [r1;r2]) -> - fprintf pp "CEbgel"; (get_optR0_s Cge reg pp r1 r2 optR0) - | (CEbgeul optR0, [r1;r2]) -> - fprintf pp "CEbgeul"; (get_optR0_s Cge reg pp r1 r2 optR0) + | (CEbeqw optR, [r1;r2]) -> + fprintf pp "CEbeqw"; (get_optR_s Ceq reg pp r1 r2 optR) + | (CEbnew optR, [r1;r2]) -> + fprintf pp "CEbnew"; (get_optR_s Cne reg pp r1 r2 optR) + | (CEbequw optR, [r1;r2]) -> + fprintf pp "CEbequw"; (get_optR_s Ceq reg pp r1 r2 optR) + | (CEbneuw optR, [r1;r2]) -> + fprintf pp "CEbneuw"; (get_optR_s Cne reg pp r1 r2 optR) + | (CEbltw optR, [r1;r2]) -> + fprintf pp "CEbltw"; (get_optR_s Clt reg pp r1 r2 optR) + | (CEbltuw optR, [r1;r2]) -> + fprintf pp "CEbltuw"; (get_optR_s Clt reg pp r1 r2 optR) + | (CEbgew optR, [r1;r2]) -> + fprintf pp "CEbgew"; (get_optR_s Cge reg pp r1 r2 optR) + | (CEbgeuw optR, [r1;r2]) -> + fprintf pp "CEbgeuw"; (get_optR_s Cge reg pp r1 r2 optR) + | (CEbeql optR, [r1;r2]) -> + fprintf pp "CEbeql"; (get_optR_s Ceq reg pp r1 r2 optR) + | (CEbnel optR, [r1;r2]) -> + fprintf pp "CEbnel"; (get_optR_s Cne reg pp r1 r2 optR) + | (CEbequl optR, [r1;r2]) -> + fprintf pp "CEbequl"; (get_optR_s Ceq reg pp r1 r2 optR) + | (CEbneul optR, [r1;r2]) -> + fprintf pp "CEbneul"; (get_optR_s Cne reg pp r1 r2 optR) + | (CEbltl optR, [r1;r2]) -> + fprintf pp "CEbltl"; (get_optR_s Clt reg pp r1 r2 optR) + | (CEbltul optR, [r1;r2]) -> + fprintf pp "CEbltul"; (get_optR_s Clt reg pp r1 r2 optR) + | (CEbgel optR, [r1;r2]) -> + fprintf pp "CEbgel"; (get_optR_s Cge reg pp r1 r2 optR) + | (CEbgeul optR, [r1;r2]) -> + fprintf pp "CEbgeul"; (get_optR_s Cge reg pp r1 r2 optR) | _ -> fprintf pp "" @@ -208,12 +204,12 @@ let print_operation reg pp = function | Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1 | Ocmp c, args -> print_condition reg pp (c, args) | OEimmR0 opi, [] -> fprintf pp "OEimmR0(%a)" get_immR0 opi - | OEseqw optR0, [r1;r2] -> fprintf pp "OEseqw"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | OEsnew optR0, [r1;r2] -> fprintf pp "OEsnew"; (get_optR0_s Cne reg pp r1 r2 optR0) - | OEsequw optR0, [r1;r2] -> fprintf pp "OEsequw"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | OEsneuw optR0, [r1;r2] -> fprintf pp "OEsneuw"; (get_optR0_s Cne reg pp r1 r2 optR0) - | OEsltw optR0, [r1;r2] -> fprintf pp "OEsltw"; (get_optR0_s Clt reg pp r1 r2 optR0) - | OEsltuw optR0, [r1;r2] -> fprintf pp "OEsltuw"; (get_optR0_s Clt reg pp r1 r2 optR0) + | OEseqw optR, [r1;r2] -> fprintf pp "OEseqw"; (get_optR_s Ceq reg pp r1 r2 optR) + | OEsnew optR, [r1;r2] -> fprintf pp "OEsnew"; (get_optR_s Cne reg pp r1 r2 optR) + | OEsequw optR, [r1;r2] -> fprintf pp "OEsequw"; (get_optR_s Ceq reg pp r1 r2 optR) + | OEsneuw optR, [r1;r2] -> fprintf pp "OEsneuw"; (get_optR_s Cne reg pp r1 r2 optR) + | OEsltw optR, [r1;r2] -> fprintf pp "OEsltw"; (get_optR_s Clt reg pp r1 r2 optR) + | OEsltuw optR, [r1;r2] -> fprintf pp "OEsltuw"; (get_optR_s Clt reg pp r1 r2 optR) | OEsltiw n, [r1] -> fprintf pp "OEsltiw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEsltiuw n, [r1] -> fprintf pp "OEsltiuw(%a,%ld)" reg r1 (camlint_of_coqint n) | OExoriw n, [r1] -> fprintf pp "OExoriw(%a,%ld)" reg r1 (camlint_of_coqint n) @@ -221,12 +217,12 @@ let print_operation reg pp = function | OEaddiw n, [r1] -> fprintf pp "OEaddiw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEandiw n, [r1] -> fprintf pp "OEandiw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEoriw n, [r1] -> fprintf pp "OEoriw(%a,%ld)" reg r1 (camlint_of_coqint n) - | OEseql optR0, [r1;r2] -> fprintf pp "OEseql"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | OEsnel optR0, [r1;r2] -> fprintf pp "OEsnel"; (get_optR0_s Cne reg pp r1 r2 optR0) - | OEsequl optR0, [r1;r2] -> fprintf pp "OEsequl"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | OEsneul optR0, [r1;r2] -> fprintf pp "OEsneul"; (get_optR0_s Cne reg pp r1 r2 optR0) - | OEsltl optR0, [r1;r2] -> fprintf pp "OEsltl"; (get_optR0_s Clt reg pp r1 r2 optR0) - | OEsltul optR0, [r1;r2] -> fprintf pp "OEsltul"; (get_optR0_s Clt reg pp r1 r2 optR0) + | OEseql optR, [r1;r2] -> fprintf pp "OEseql"; (get_optR_s Ceq reg pp r1 r2 optR) + | OEsnel optR, [r1;r2] -> fprintf pp "OEsnel"; (get_optR_s Cne reg pp r1 r2 optR) + | OEsequl optR, [r1;r2] -> fprintf pp "OEsequl"; (get_optR_s Ceq reg pp r1 r2 optR) + | OEsneul optR, [r1;r2] -> fprintf pp "OEsneul"; (get_optR_s Cne reg pp r1 r2 optR) + | OEsltl optR, [r1;r2] -> fprintf pp "OEsltl"; (get_optR_s Clt reg pp r1 r2 optR) + | OEsltul optR, [r1;r2] -> fprintf pp "OEsltul"; (get_optR_s Clt reg pp r1 r2 optR) | OEsltil n, [r1] -> fprintf pp "OEsltil(%a,%ld)" reg r1 (camlint_of_coqint n) | OEsltiul n, [r1] -> fprintf pp "OEsltiul(%a,%ld)" reg r1 (camlint_of_coqint n) | OExoril n, [r1] -> fprintf pp "OExoril(%a,%ld)" reg r1 (camlint_of_coqint n) diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index 08c1a6a0..5b44caba 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -14,8 +14,11 @@ Definition is_inv_cmp_int (cmp: comparison) : bool := Definition is_inv_cmp_float (cmp: comparison) : bool := match cmp with | Cge | Cgt => true | _ => false end. -Definition make_optR0 (is_x0 is_inv: bool) : option bool := - if is_x0 then Some is_inv else None. +Definition make_optR (is_x0 is_inv: bool) : option oreg := + if is_x0 then + (if is_inv then Some (X0_L) + else Some (X0_R)) + else None. (** Functions to manage lists of "fake" values *) @@ -103,46 +106,46 @@ Definition sltuimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltul None) OEs (* Comparisons intructions *) -Definition cond_int32s (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) := +Definition cond_int32s (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := match cmp with - | Ceq => fSop (OEseqw optR0) lhsv - | Cne => fSop (OEsnew optR0) lhsv - | Clt | Cgt => fSop (OEsltw optR0) lhsv + | Ceq => fSop (OEseqw optR) lhsv + | Cne => fSop (OEsnew optR) lhsv + | Clt | Cgt => fSop (OEsltw optR) lhsv | Cle | Cge => - let hvs := (fSop (OEsltw optR0) lhsv) in + let hvs := (fSop (OEsltw optR) lhsv) in let hl := make_lhsv_single hvs in fSop (OExoriw Int.one) hl end. -Definition cond_int32u (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) := +Definition cond_int32u (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := match cmp with - | Ceq => fSop (OEsequw optR0) lhsv - | Cne => fSop (OEsneuw optR0) lhsv - | Clt | Cgt => fSop (OEsltuw optR0) lhsv + | Ceq => fSop (OEsequw optR) lhsv + | Cne => fSop (OEsneuw optR) lhsv + | Clt | Cgt => fSop (OEsltuw optR) lhsv | Cle | Cge => - let hvs := (fSop (OEsltuw optR0) lhsv) in + let hvs := (fSop (OEsltuw optR) lhsv) in let hl := make_lhsv_single hvs in fSop (OExoriw Int.one) hl end. -Definition cond_int64s (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) := +Definition cond_int64s (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := match cmp with - | Ceq => fSop (OEseql optR0) lhsv - | Cne => fSop (OEsnel optR0) lhsv - | Clt | Cgt => fSop (OEsltl optR0) lhsv + | Ceq => fSop (OEseql optR) lhsv + | Cne => fSop (OEsnel optR) lhsv + | Clt | Cgt => fSop (OEsltl optR) lhsv | Cle | Cge => - let hvs := (fSop (OEsltl optR0) lhsv) in + let hvs := (fSop (OEsltl optR) lhsv) in let hl := make_lhsv_single hvs in fSop (OExoriw Int.one) hl end. -Definition cond_int64u (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) := +Definition cond_int64u (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := match cmp with - | Ceq => fSop (OEsequl optR0) lhsv - | Cne => fSop (OEsneul optR0) lhsv - | Clt | Cgt => fSop (OEsltul optR0) lhsv + | Ceq => fSop (OEsequl optR) lhsv + | Cne => fSop (OEsneul optR) lhsv + | Clt | Cgt => fSop (OEsltul optR) lhsv | Cle | Cge => - let hvs := (fSop (OEsltul optR0) lhsv) in + let hvs := (fSop (OEsltul optR) lhsv) in let hl := make_lhsv_single hvs in fSop (OExoriw Int.one) hl end. @@ -150,16 +153,16 @@ Definition cond_int64u (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) Definition expanse_condimm_int32s (cmp: comparison) (hv1: hsval) (n: int) := let is_inv := is_inv_cmp_int cmp in if Int.eq n Int.zero then - let optR0 := make_optR0 true is_inv in + let optR := make_optR true is_inv in let hl := make_lhsv_cmp is_inv hv1 hv1 in - cond_int32s cmp hl optR0 + cond_int32s cmp hl optR else match cmp with | Ceq | Cne => - let optR0 := make_optR0 true is_inv in + let optR := make_optR true is_inv in let hvs := xorimm32 hv1 n in let hl := make_lhsv_cmp false hvs hvs in - cond_int32s cmp hl optR0 + cond_int32s cmp hl optR | Clt => sltimm32 hv1 n | Cle => if Int.eq n (Int.repr Int.max_signed) then @@ -168,41 +171,41 @@ Definition expanse_condimm_int32s (cmp: comparison) (hv1: hsval) (n: int) := fSop (OEmayundef MUint) hl else sltimm32 hv1 (Int.add n Int.one) | _ => - let optR0 := make_optR0 false is_inv in + let optR := make_optR false is_inv in let hvs := loadimm32 n in let hl := make_lhsv_cmp is_inv hv1 hvs in - cond_int32s cmp hl optR0 + cond_int32s cmp hl optR end. Definition expanse_condimm_int32u (cmp: comparison) (hv1: hsval) (n: int) := let is_inv := is_inv_cmp_int cmp in if Int.eq n Int.zero then - let optR0 := make_optR0 true is_inv in + let optR := make_optR true is_inv in let hl := make_lhsv_cmp is_inv hv1 hv1 in - cond_int32u cmp hl optR0 + cond_int32u cmp hl optR else match cmp with | Clt => sltuimm32 hv1 n | _ => - let optR0 := make_optR0 false is_inv in + let optR := make_optR false is_inv in let hvs := loadimm32 n in let hl := make_lhsv_cmp is_inv hv1 hvs in - cond_int32u cmp hl optR0 + cond_int32u cmp hl optR end. Definition expanse_condimm_int64s (cmp: comparison) (hv1: hsval) (n: int64) := let is_inv := is_inv_cmp_int cmp in if Int64.eq n Int64.zero then - let optR0 := make_optR0 true is_inv in + let optR := make_optR true is_inv in let hl := make_lhsv_cmp is_inv hv1 hv1 in - cond_int64s cmp hl optR0 + cond_int64s cmp hl optR else match cmp with | Ceq | Cne => - let optR0 := make_optR0 true is_inv in + let optR := make_optR true is_inv in let hvs := xorimm64 hv1 n in let hl := make_lhsv_cmp false hvs hvs in - cond_int64s cmp hl optR0 + cond_int64s cmp hl optR | Clt => sltimm64 hv1 n | Cle => if Int64.eq n (Int64.repr Int64.max_signed) then @@ -211,26 +214,26 @@ Definition expanse_condimm_int64s (cmp: comparison) (hv1: hsval) (n: int64) := fSop (OEmayundef MUlong) hl else sltimm64 hv1 (Int64.add n Int64.one) | _ => - let optR0 := make_optR0 false is_inv in + let optR := make_optR false is_inv in let hvs := loadimm64 n in let hl := make_lhsv_cmp is_inv hv1 hvs in - cond_int64s cmp hl optR0 + cond_int64s cmp hl optR end. Definition expanse_condimm_int64u (cmp: comparison) (hv1: hsval) (n: int64) := let is_inv := is_inv_cmp_int cmp in if Int64.eq n Int64.zero then - let optR0 := make_optR0 true is_inv in + let optR := make_optR true is_inv in let hl := make_lhsv_cmp is_inv hv1 hv1 in - cond_int64u cmp hl optR0 + cond_int64u cmp hl optR else match cmp with | Clt => sltuimm64 hv1 n | _ => - let optR0 := make_optR0 false is_inv in + let optR := make_optR false is_inv in let hvs := loadimm64 n in let hl := make_lhsv_cmp is_inv hv1 hvs in - cond_int64u cmp hl optR0 + cond_int64u cmp hl optR end. Definition cond_float (cmp: comparison) (lhsv: list_hsval) := @@ -259,44 +262,44 @@ Definition expanse_cond_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) := (* Branches instructions *) -Definition transl_cbranch_int32s (cmp: comparison) (optR0: option bool) := +Definition transl_cbranch_int32s (cmp: comparison) (optR: option oreg) := match cmp with - | Ceq => CEbeqw optR0 - | Cne => CEbnew optR0 - | Clt => CEbltw optR0 - | Cle => CEbgew optR0 - | Cgt => CEbltw optR0 - | Cge => CEbgew optR0 + | Ceq => CEbeqw optR + | Cne => CEbnew optR + | Clt => CEbltw optR + | Cle => CEbgew optR + | Cgt => CEbltw optR + | Cge => CEbgew optR end. -Definition transl_cbranch_int32u (cmp: comparison) (optR0: option bool) := +Definition transl_cbranch_int32u (cmp: comparison) (optR: option oreg) := match cmp with - | Ceq => CEbequw optR0 - | Cne => CEbneuw optR0 - | Clt => CEbltuw optR0 - | Cle => CEbgeuw optR0 - | Cgt => CEbltuw optR0 - | Cge => CEbgeuw optR0 + | Ceq => CEbequw optR + | Cne => CEbneuw optR + | Clt => CEbltuw optR + | Cle => CEbgeuw optR + | Cgt => CEbltuw optR + | Cge => CEbgeuw optR end. -Definition transl_cbranch_int64s (cmp: comparison) (optR0: option bool) := +Definition transl_cbranch_int64s (cmp: comparison) (optR: option oreg) := match cmp with - | Ceq => CEbeql optR0 - | Cne => CEbnel optR0 - | Clt => CEbltl optR0 - | Cle => CEbgel optR0 - | Cgt => CEbltl optR0 - | Cge => CEbgel optR0 + | Ceq => CEbeql optR + | Cne => CEbnel optR + | Clt => CEbltl optR + | Cle => CEbgel optR + | Cgt => CEbltl optR + | Cge => CEbgel optR end. -Definition transl_cbranch_int64u (cmp: comparison) (optR0: option bool) := +Definition transl_cbranch_int64u (cmp: comparison) (optR: option oreg) := match cmp with - | Ceq => CEbequl optR0 - | Cne => CEbneul optR0 - | Clt => CEbltul optR0 - | Cle => CEbgeul optR0 - | Cgt => CEbltul optR0 - | Cge => CEbgeul optR0 + | Ceq => CEbequl optR + | Cne => CEbneul optR + | Clt => CEbltul optR + | Cle => CEbgeul optR + | Cgt => CEbltul optR + | Cge => CEbgeul optR end. Definition expanse_cbranch_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) : (condition * list_hsval) := @@ -304,7 +307,7 @@ Definition expanse_cbranch_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) : (con let normal' := if cnot then negb normal else normal in let hvs := fn_cond cmp lhsv in let hl := make_lhsv_cmp false hvs hvs in - if normal' then ((CEbnew (Some false)), hl) else ((CEbeqw (Some false)), hl). + if normal' then ((CEbnew (Some X0_R)), hl) else ((CEbeqw (Some X0_R)), hl). (** Add pointer expansion *) @@ -325,16 +328,16 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let hv1 := fsi_sreg_get hst a1 in let hv2 := fsi_sreg_get hst a2 in let is_inv := is_inv_cmp_int c in - let optR0 := make_optR0 false is_inv in + let optR := make_optR false is_inv in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in - Some (cond_int32s c lhsv optR0) + Some (cond_int32s c lhsv optR) | Ocmp (Ccompu c), a1 :: a2 :: nil => let hv1 := fsi_sreg_get hst a1 in let hv2 := fsi_sreg_get hst a2 in let is_inv := is_inv_cmp_int c in - let optR0 := make_optR0 false is_inv in + let optR := make_optR false is_inv in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in - Some (cond_int32u c lhsv optR0) + Some (cond_int32u c lhsv optR) | Ocmp (Ccompimm c imm), a1 :: nil => let hv1 := fsi_sreg_get hst a1 in Some (expanse_condimm_int32s c hv1 imm) @@ -345,16 +348,16 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let hv1 := fsi_sreg_get hst a1 in let hv2 := fsi_sreg_get hst a2 in let is_inv := is_inv_cmp_int c in - let optR0 := make_optR0 false is_inv in + let optR := make_optR false is_inv in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in - Some (cond_int64s c lhsv optR0) + Some (cond_int64s c lhsv optR) | Ocmp (Ccomplu c), a1 :: a2 :: nil => let hv1 := fsi_sreg_get hst a1 in let hv2 := fsi_sreg_get hst a2 in let is_inv := is_inv_cmp_int c in - let optR0 := make_optR0 false is_inv in + let optR := make_optR false is_inv in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in - Some (cond_int64u c lhsv optR0) + Some (cond_int64u c lhsv optR) | Ocmp (Ccomplimm c imm), a1 :: nil => let hv1 := fsi_sreg_get hst a1 in Some (expanse_condimm_int64s c hv1 imm) @@ -497,14 +500,14 @@ Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args match cond, args with | (Ccomp c), (a1 :: a2 :: nil) => let is_inv := is_inv_cmp_int c in - let cond := transl_cbranch_int32s c (make_optR0 false is_inv) in + let cond := transl_cbranch_int32s c (make_optR false is_inv) in let hv1 := fsi_sreg_get prev a1 in let hv2 := fsi_sreg_get prev a2 in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in Some (cond, lhsv) | (Ccompu c), (a1 :: a2 :: nil) => let is_inv := is_inv_cmp_int c in - let cond := transl_cbranch_int32u c (make_optR0 false is_inv) in + let cond := transl_cbranch_int32u c (make_optR false is_inv) in let hv1 := fsi_sreg_get prev a1 in let hv2 := fsi_sreg_get prev a2 in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in @@ -514,35 +517,35 @@ Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args let hv1 := fsi_sreg_get prev a1 in (if Int.eq n Int.zero then let lhsv := make_lhsv_cmp is_inv hv1 hv1 in - let cond := transl_cbranch_int32s c (make_optR0 true is_inv) in + let cond := transl_cbranch_int32s c (make_optR true is_inv) in Some (cond, lhsv) else let hvs := loadimm32 n in let lhsv := make_lhsv_cmp is_inv hv1 hvs in - let cond := transl_cbranch_int32s c (make_optR0 false is_inv) in + let cond := transl_cbranch_int32s c (make_optR false is_inv) in Some (cond, lhsv)) | (Ccompuimm c n), (a1 :: nil) => let is_inv := is_inv_cmp_int c in let hv1 := fsi_sreg_get prev a1 in (if Int.eq n Int.zero then let lhsv := make_lhsv_cmp is_inv hv1 hv1 in - let cond := transl_cbranch_int32u c (make_optR0 true is_inv) in + let cond := transl_cbranch_int32u c (make_optR true is_inv) in Some (cond, lhsv) else let hvs := loadimm32 n in let lhsv := make_lhsv_cmp is_inv hv1 hvs in - let cond := transl_cbranch_int32u c (make_optR0 false is_inv) in + let cond := transl_cbranch_int32u c (make_optR false is_inv) in Some (cond, lhsv)) | (Ccompl c), (a1 :: a2 :: nil) => let is_inv := is_inv_cmp_int c in - let cond := transl_cbranch_int64s c (make_optR0 false is_inv) in + let cond := transl_cbranch_int64s c (make_optR false is_inv) in let hv1 := fsi_sreg_get prev a1 in let hv2 := fsi_sreg_get prev a2 in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in Some (cond, lhsv) | (Ccomplu c), (a1 :: a2 :: nil) => let is_inv := is_inv_cmp_int c in - let cond := transl_cbranch_int64u c (make_optR0 false is_inv) in + let cond := transl_cbranch_int64u c (make_optR false is_inv) in let hv1 := fsi_sreg_get prev a1 in let hv2 := fsi_sreg_get prev a2 in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in @@ -552,24 +555,24 @@ Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args let hv1 := fsi_sreg_get prev a1 in (if Int64.eq n Int64.zero then let lhsv := make_lhsv_cmp is_inv hv1 hv1 in - let cond := transl_cbranch_int64s c (make_optR0 true is_inv) in + let cond := transl_cbranch_int64s c (make_optR true is_inv) in Some (cond, lhsv) else let hvs := loadimm64 n in let lhsv := make_lhsv_cmp is_inv hv1 hvs in - let cond := transl_cbranch_int64s c (make_optR0 false is_inv) in + let cond := transl_cbranch_int64s c (make_optR false is_inv) in Some (cond, lhsv)) | (Ccompluimm c n), (a1 :: nil) => let is_inv := is_inv_cmp_int c in let hv1 := fsi_sreg_get prev a1 in (if Int64.eq n Int64.zero then let lhsv := make_lhsv_cmp is_inv hv1 hv1 in - let cond := transl_cbranch_int64u c (make_optR0 true is_inv) in + let cond := transl_cbranch_int64u c (make_optR true is_inv) in Some (cond, lhsv) else let hvs := loadimm64 n in let lhsv := make_lhsv_cmp is_inv hv1 hvs in - let cond := transl_cbranch_int64u c (make_optR0 false is_inv) in + let cond := transl_cbranch_int64u c (make_optR false is_inv) in Some (cond, lhsv)) | (Ccompf c), (f1 :: f2 :: nil) => let hv1 := fsi_sreg_get prev f1 in diff --git a/riscV/ValueAOp.v b/riscV/ValueAOp.v index b64040e1..e48c4a5b 100644 --- a/riscV/ValueAOp.v +++ b/riscV/ValueAOp.v @@ -20,11 +20,11 @@ Require Import Zbits. Definition zero32 := (I Int.zero). Definition zero64 := (L Int64.zero). -Definition apply_bin_r0 {B} (optR0: option bool) (sem: aval -> aval -> B) (v1 v2 vz: aval): B := - match optR0 with +Definition apply_bin_oreg {B} (optR: option oreg) (sem: aval -> aval -> B) (v1 v2 vz: aval): B := + match optR with | None => sem v1 v2 - | Some true => sem vz v1 - | Some false => sem v1 vz + | Some X0_L => sem vz v1 + | Some X0_R => sem v1 vz end. Definition eval_may_undef (mu: mayundef) (v1 v2: aval): aval := @@ -71,22 +71,22 @@ Definition eval_static_condition (cond: condition) (vl: list aval): abool := | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2) | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2 | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2) - | CEbeqw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmp_bool Ceq) v1 v2 zero32 - | CEbnew optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmp_bool Cne) v1 v2 zero32 - | CEbequw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpu_bool Ceq) v1 v2 zero32 - | CEbneuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpu_bool Cne) v1 v2 zero32 - | CEbltw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmp_bool Clt) v1 v2 zero32 - | CEbltuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpu_bool Clt) v1 v2 zero32 - | CEbgew optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmp_bool Cge) v1 v2 zero32 - | CEbgeuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpu_bool Cge) v1 v2 zero32 - | CEbeql optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpl_bool Ceq) v1 v2 zero64 - | CEbnel optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpl_bool Cne) v1 v2 zero64 - | CEbequl optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmplu_bool Ceq) v1 v2 zero64 - | CEbneul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmplu_bool Cne) v1 v2 zero64 - | CEbltl optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpl_bool Clt) v1 v2 zero64 - | CEbltul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmplu_bool Clt) v1 v2 zero64 - | CEbgel optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpl_bool Cge) v1 v2 zero64 - | CEbgeul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmplu_bool Cge) v1 v2 zero64 + | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32 + | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32 + | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32 + | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32 + | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32 + | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32 + | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cge) v1 v2 zero32 + | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cge) v1 v2 zero32 + | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64 + | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64 + | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64 + | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64 + | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64 + | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64 + | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cge) v1 v2 zero64 + | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cge) v1 v2 zero64 | _, _ => Bnone end. @@ -227,12 +227,12 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoflongu, v1::nil => singleoflongu v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) | OEimmR0 opi, nil => eval_opimmR0 opi - | OEseqw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmp_bool Ceq) v1 v2 zero32) - | OEsnew optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmp_bool Cne) v1 v2 zero32) - | OEsequw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpu_bool Ceq) v1 v2 zero32) - | OEsneuw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpu_bool Cne) v1 v2 zero32) - | OEsltw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmp_bool Clt) v1 v2 zero32) - | OEsltuw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpu_bool Clt) v1 v2 zero32) + | OEseqw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32) + | OEsnew optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32) + | OEsequw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32) + | OEsneuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32) + | OEsltw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32) + | OEsltuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32) | OEsltiw n, v1::nil => of_optbool (cmp_bool Clt v1 (I n)) | OEsltiuw n, v1::nil => of_optbool (cmpu_bool Clt v1 (I n)) | OExoriw n, v1::nil => xor v1 (I n) @@ -240,12 +240,12 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | OEaddiw n, v1::nil => add (I n) v1 | OEandiw n, v1::nil => and (I n) v1 | OEoriw n, v1::nil => or (I n) v1 - | OEseql optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Ceq) v1 v2 zero64) - | OEsnel optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Cne) v1 v2 zero64) - | OEsequl optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmplu_bool Ceq) v1 v2 zero64) - | OEsneul optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmplu_bool Cne) v1 v2 zero64) - | OEsltl optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Clt) v1 v2 zero64) - | OEsltul optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmplu_bool Clt) v1 v2 zero64) + | OEseql optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64) + | OEsnel optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64) + | OEsequl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64) + | OEsneul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64) + | OEsltl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64) + | OEsltul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64) | OEsltil n, v1::nil => of_optbool (cmpl_bool Clt v1 (L n)) | OEsltiul n, v1::nil => of_optbool (cmplu_bool Clt v1 (L n)) | OEandil n, v1::nil => andl (L n) v1 @@ -358,7 +358,7 @@ Proof. inv H2. destruct cond; simpl; eauto with va. 17: destruct cond; simpl; eauto with va. - all: destruct optR0 as [[]|]; unfold apply_bin_r0, Op.apply_bin_r0; + all: destruct optR as [[]|]; unfold apply_bin_oreg, Op.apply_bin_oreg; unfold zero32, Op.zero32, zero64, Op.zero64; eauto with va. Qed. @@ -415,53 +415,53 @@ Proof. inv H; auto. simpl. destruct b; constructor. Qed. -Lemma eval_cmpu_sound c: forall a1 b1 a0 b0 optR0 m, +Lemma eval_cmpu_sound c: forall a1 b1 a0 b0 optR m, c = Ceq \/ c = Cne \/ c = Clt-> vmatch bc a1 b1 -> vmatch bc a0 b0 -> - vmatch bc (Op.apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) c) a1 a0 Op.zero32) - (of_optbool (apply_bin_r0 optR0 (cmpu_bool c) b1 b0 zero32)). + vmatch bc (Op.apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) c) a1 a0 Op.zero32) + (of_optbool (apply_bin_oreg optR (cmpu_bool c) b1 b0 zero32)). Proof. intros. - destruct optR0 as [[]|]; unfold Op.apply_bin_r0, apply_bin_r0; + destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; apply of_optbool_sound; unfold Op.zero32, zero32; eauto with va. Qed. -Lemma eval_cmplu_sound c: forall a1 b1 a0 b0 optR0 m, +Lemma eval_cmplu_sound c: forall a1 b1 a0 b0 optR m, c = Ceq \/ c = Cne \/ c = Clt-> vmatch bc a1 b1 -> vmatch bc a0 b0 -> vmatch bc (Val.maketotal - (Op.apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) c) a1 a0 + (Op.apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) c) a1 a0 Op.zero64)) - (of_optbool (apply_bin_r0 optR0 (cmplu_bool c) b1 b0 zero64)). + (of_optbool (apply_bin_oreg optR (cmplu_bool c) b1 b0 zero64)). Proof. intros. - destruct optR0 as [[]|]; unfold Op.apply_bin_r0, apply_bin_r0; + destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; apply of_optbool_maketotal_sound; unfold Op.zero64, zero64; eauto with va. Qed. -Lemma eval_cmp_sound: forall a1 b1 a0 b0 optR0 cmp, +Lemma eval_cmp_sound: forall a1 b1 a0 b0 optR cmp, vmatch bc a1 b1 -> vmatch bc a0 b0 -> - vmatch bc (Op.apply_bin_r0 optR0 (Val.cmp cmp) a1 a0 Op.zero32) - (of_optbool (apply_bin_r0 optR0 (cmp_bool cmp) b1 b0 zero32)). + vmatch bc (Op.apply_bin_oreg optR (Val.cmp cmp) a1 a0 Op.zero32) + (of_optbool (apply_bin_oreg optR (cmp_bool cmp) b1 b0 zero32)). Proof. intros. - destruct optR0 as [[]|]; unfold Op.apply_bin_r0, apply_bin_r0; + destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; apply of_optbool_sound; unfold Op.zero32, zero32; eauto with va. Qed. -Lemma eval_cmpl_sound: forall a1 b1 a0 b0 optR0 cmp, +Lemma eval_cmpl_sound: forall a1 b1 a0 b0 optR cmp, vmatch bc a1 b1 -> vmatch bc a0 b0 -> vmatch bc - (Val.maketotal (Op.apply_bin_r0 optR0 (Val.cmpl cmp) a1 a0 Op.zero64)) - (of_optbool (apply_bin_r0 optR0 (cmpl_bool cmp) b1 b0 zero64)). + (Val.maketotal (Op.apply_bin_oreg optR (Val.cmpl cmp) a1 a0 Op.zero64)) + (of_optbool (apply_bin_oreg optR (cmpl_bool cmp) b1 b0 zero64)). Proof. intros. - destruct optR0 as [[]|]; unfold Op.apply_bin_r0, apply_bin_r0; + destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; apply of_optbool_maketotal_sound; unfold Op.zero64, zero64; eauto with va. Qed. -- cgit From dd4767e17235adb5de922626ed1fea15f4eb9e3b Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Tue, 6 Apr 2021 23:37:22 +0200 Subject: Important commit on expansions' mini CSE, and a draft for addptrofs --- riscV/Asm.v | 2 +- riscV/Asmgen.v | 58 ++- riscV/Asmgenproof.v | 3 +- riscV/Asmgenproof1.v | 56 ++- riscV/ExpansionOracle.ml | 1106 ++++++++++++++++++++++++++------------------ riscV/NeedOp.v | 6 +- riscV/Op.v | 296 +++++++----- riscV/PrintOp.ml | 17 +- riscV/RTLpathSE_simplify.v | 156 +++---- riscV/ValueAOp.v | 133 +++--- 10 files changed, 1077 insertions(+), 756 deletions(-) (limited to 'riscV') diff --git a/riscV/Asm.v b/riscV/Asm.v index 5d3518f2..a16f57b5 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -982,6 +982,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out end | Pbuiltin ef args res => Stuck (**r treated specially below *) + | Pnop => Next (nextinstr rs) m (**r Pnop is used by an oracle during expansion *) (** The following instructions and directives are not generated directly by Asmgen, so we do not model them. *) @@ -1002,7 +1003,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfmsubd _ _ _ _ | Pfnmaddd _ _ _ _ | Pfnmsubd _ _ _ _ - | Pnop => Stuck end. diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index 88d4f73f..ff5d1a6e 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -204,19 +204,23 @@ Definition transl_cond_single (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := | Cgt => (Pflts rd fs2 fs1, true) | Cge => (Pfles rd fs2 fs1, true) end. - + +(** Functions to select a special register according to the op "oreg" argument from RTL *) + Definition apply_bin_oreg_ireg0 (optR: option oreg) (r1 r2: ireg0): (ireg0 * ireg0) := match optR with | None => (r1, r2) | Some X0_L => (X0, r1) | Some X0_R => (r1, X0) + | Some SP_S => (X SP, r1) end. -Definition get_opimmR0 (rd: ireg) (opi: opimm) := - match opi with - | OPimmADD i => Paddiw rd X0 i - | OPimmADDL i => Paddil rd X0 i - end. +Definition get_oreg (optR: option oreg) (r: ireg0) := + match optR with + | Some SP_S => X SP + | Some X0_L | Some X0_R => X0 + | _ => r + end. Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) := @@ -785,9 +789,8 @@ Definition transl_op | Ocmp cmp, _ => do rd <- ireg_of res; transl_cond_op cmp rd args k - | OEimmR0 opi, nil => - do rd <- ireg_of res; - OK (get_opimmR0 rd opi :: k) + + (* Instructions expanded in RTL *) | OEseqw optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; @@ -839,10 +842,21 @@ Definition transl_op | OEluiw n, nil => do rd <- ireg_of res; OK (Pluiw rd n :: k) - | OEaddiw n, a1 :: nil => + | OEaddiw optR n, nil => do rd <- ireg_of res; - do rs <- ireg_of a1; + let rs := get_oreg optR X0 in OK (Paddiw rd rs n :: k) + | OEaddiw (Some SP_S) n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + if Int.eq n Int.zero then + OK (Paddw rd SP rs :: k) + else Error (msg "Asmgen.transl_op") + | OEaddiw optR n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + let rs' := get_oreg optR rs in + OK (Paddiw rd rs' n :: k) | OEandiw n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -902,10 +916,21 @@ Definition transl_op | OEluil n, nil => do rd <- ireg_of res; OK (Pluil rd n :: k) - | OEaddil n, a1 :: nil => + | OEaddil optR n, nil => do rd <- ireg_of res; - do rs <- ireg_of a1; + let rs := get_oreg optR X0 in OK (Paddil rd rs n :: k) + | OEaddil (Some SP_S) n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + if Int64.eq n Int64.zero then + OK (Paddl rd SP rs :: k) + else Error (msg "Asmgen.transl_op") + | OEaddil optR n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + let rs' := get_oreg optR rs in + OK (Paddil rd rs' n :: k) | OEandil n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -947,6 +972,13 @@ Definition transl_op do r1 <- freg_of f1; do r2 <- freg_of f2; OK (Pfles rd r1 r2 :: k) + | OEmayundef _, a1 :: a2 :: nil => + do rd <- ireg_of res; + do r2 <- ireg_of a2; + if ireg_eq rd r2 then + OK (Pnop :: k) + else + OK (Pmv rd r2 :: k) | Obits_of_single, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 101bfa9c..bf9ede7f 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -308,7 +308,8 @@ Opaque Int.eq. - apply opimm64_label; intros; exact I. - destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. - eapply transl_cond_op_label; eauto. -- destruct opi; simpl; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. - destruct optR as [[]|]; simpl in *; TailNoLabel. - destruct optR as [[]|]; simpl in *; TailNoLabel. - destruct optR as [[]|]; simpl in *; TailNoLabel. diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 1e17c4e2..cbe68577 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -529,31 +529,37 @@ Proof. - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. - destruct optR as [[]|]; @@ -591,31 +597,37 @@ Proof. - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); eexists; eexists; eauto; split; constructor; simpl in *; try rewrite EVAL'; auto. Qed. @@ -1262,12 +1274,7 @@ Opaque Int.eq. { exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. } (* Expanded instructions from RTL *) - { unfold get_opimmR0; destruct opi; simpl; - econstructor; split; try apply exec_straight_one; simpl; eauto; - split; intros; Simpl. - try rewrite Int.add_commut; auto. - try rewrite Int64.add_commut; auto. } - 7,8,9,16,17,18: + 8,9,17,18: econstructor; split; try apply exec_straight_one; simpl; eauto; split; intros; Simpl; try destruct (rs x0); try rewrite Int64.add_commut; @@ -1276,12 +1283,41 @@ Opaque Int.eq. try rewrite Int.and_commut; auto; try rewrite Int64.or_commut; try rewrite Int.or_commut; auto. - 1-12: - destruct optR as [[]|]; unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; inv EQ3; + 1-14: + destruct optR as [[]|]; try discriminate; + try (ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl); + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; try inv EQ3; try inv EQ2; + try destruct (Int.eq _ _) eqn:A; try inv H0; + try destruct (Int64.eq _ _) eqn:A; try inv H1; econstructor; split; try apply exec_straight_one; simpl; eauto; split; intros; Simpl; - destruct (rs x0); auto; - destruct (rs x1); auto. + try apply Int.same_if_eq in A; subst; + try apply Int64.same_if_eq in A; subst; + unfold get_sp; + try destruct (rs x0); auto; + try destruct (rs x1); auto; + try destruct (rs X2); auto; + try destruct Archi.ptr64 eqn:B; + try fold (Val.add (Vint Int.zero) (get_sp (rs X2))); + try fold (Val.addl (Vlong Int64.zero) (get_sp (rs X2))); + try rewrite Val.add_commut; auto; + try rewrite Val.addl_commut; auto; + try rewrite Int.add_commut; auto; + try rewrite Int64.add_commut; auto; + replace (Ptrofs.of_int Int.zero) with (Ptrofs.zero) by auto; + replace (Ptrofs.of_int64 Int64.zero) with (Ptrofs.zero) by auto; + try rewrite Ptrofs.add_zero; auto. + (* mayundef *) + { destruct (ireg_eq x x0); inv EQ2; + econstructor; split; + try apply exec_straight_one; simpl; eauto; + split; unfold eval_may_undef; + destruct mu eqn:EQMU; simpl; intros; Simpl; auto. + all: + destruct (rs (preg_of m0)) eqn:EQM0; simpl; auto; + destruct (rs x0); simpl; auto; Simpl; + try destruct (Int.ltu _ _); simpl; + Simpl; auto. } (* select *) { econstructor; split. apply exec_straight_one. simpl; eauto. auto. split; intros; Simpl. diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 16f1ee4b..e0c9b9b2 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -17,15 +17,19 @@ open Maps open RTL open Op open Asmgen -open DebugPrint open RTLpath open! Integers open Camlcoq open Option +open AST +open Printf -type sop = Sop of operation * P.t list +(** Mini CSE (a dynamic numbering is applied during expansion. + The CSE algorithm is inspired by the "static" one used in backend/CSE.v *) -type sval = Si of RTL.instruction | Sr of P.t +let exp_debug = false + +(** Managing virtual registers and node index *) let reg = ref 1 @@ -45,6 +49,181 @@ let n2pi () = node := !node + 1; n2p () +(** Below are the types for rhs and equations *) + +type rhs = Sop of operation * int list | Smove + +type seq = Seq of int * rhs + +(** This is a mini abstraction to have a simpler representation during expansion + - Snop will be converted to Inop + - (Sr r) is inserted if the value was found in register r + - (Sexp dest rhs args succ) represent an instruction + (succesor may not be defined at this point, hence the use of type option) + - (Sfinalcond cond args succ1 succ2 info) represents a condition (which must + always be the last instruction in expansion list *) + +type expl = + | Snop of P.t + | Sr of P.t + | Sexp of P.t * rhs * P.t list * node option + | Sfinalcond of condition * P.t list * node * node * bool option + +(** Record used during the "dynamic" value numbering *) + +type numb = { + mutable nnext : int; (** Next unusued value number *) + mutable seqs : seq list; (** equations *) + mutable nreg : (P.t, int) Hashtbl.t; (** mapping registers to values *) + mutable nval : (int, P.t list) Hashtbl.t; + (** reverse mapping values to registers containing it *) +} + +let print_list_pos l = + if exp_debug then eprintf "["; + List.iter (fun i -> if exp_debug then eprintf "%d;" (p2i i)) l; + if exp_debug then eprintf "]\n" + +let empty_numbering () = + { nnext = 1; seqs = []; nreg = Hashtbl.create 100; nval = Hashtbl.create 100 } + +let rec get_nvalues vn = function + | [] -> [] + | r :: rs -> + let v = + match Hashtbl.find_opt !vn.nreg r with + | Some v -> + if exp_debug then eprintf "getnval r=%d |-> v=%d\n" (p2i r) v; + v + | None -> + let n = !vn.nnext in + if exp_debug then eprintf "getnval r=%d |-> v=%d\n" (p2i r) n; + !vn.nnext <- !vn.nnext + 1; + Hashtbl.replace !vn.nreg r n; + Hashtbl.replace !vn.nval n [ r ]; + n + in + let vs = get_nvalues vn rs in + v :: vs + +let get_nval_ornil vn v = + match Hashtbl.find_opt !vn.nval v with None -> [] | Some l -> l + +let forget_reg vn rd = + match Hashtbl.find_opt !vn.nreg rd with + | Some v -> + if exp_debug then eprintf "forget_reg: r=%d |-> v=%d\n" (p2i rd) v; + let old_regs = get_nval_ornil vn v in + if exp_debug then eprintf "forget_reg: old_regs are:\n"; + print_list_pos old_regs; + Hashtbl.replace !vn.nval v + (List.filter (fun n -> not (P.eq n rd)) old_regs) + | None -> + if exp_debug then eprintf "forget_reg: no mapping for r=%d\n" (p2i rd) + +let update_reg vn rd v = + if exp_debug then eprintf "update_reg: update v=%d with r=%d\n" v (p2i rd); + forget_reg vn rd; + let old_regs = get_nval_ornil vn v in + Hashtbl.replace !vn.nval v (rd :: old_regs) + +let rec find_valnum_rhs rh = function + | [] -> None + | Seq (v, rh') :: tl -> if rh = rh' then Some v else find_valnum_rhs rh tl + +let set_unknown vn rd = + if exp_debug then eprintf "set_unknown: rd=%d\n" (p2i rd); + forget_reg vn rd; + Hashtbl.remove !vn.nreg rd + +let set_res_unknown vn res = match res with BR r -> set_unknown vn r | _ -> () + +let addrhs vn rd rh = + match find_valnum_rhs rh !vn.seqs with + | Some vres -> + if exp_debug then eprintf "addrhs: Some v=%d\n" vres; + Hashtbl.replace !vn.nreg rd vres; + update_reg vn rd vres + | None -> + let n = !vn.nnext in + if exp_debug then eprintf "addrhs: None v=%d\n" n; + !vn.nnext <- !vn.nnext + 1; + !vn.seqs <- Seq (n, rh) :: !vn.seqs; + update_reg vn rd n; + Hashtbl.replace !vn.nreg rd n + +let addsop vn v op rd = + if exp_debug then eprintf "addsop\n"; + if op = Omove then ( + update_reg vn rd (List.hd v); + Hashtbl.replace !vn.nreg rd (List.hd v)) + else addrhs vn rd (Sop (op, v)) + +let rec kill_mem_operations = function + | (Seq (v, Sop (op, vl)) as eq) :: tl -> + if op_depends_on_memory op then kill_mem_operations tl + else eq :: kill_mem_operations tl + | [] -> [] + | eq :: tl -> eq :: kill_mem_operations tl + +let reg_valnum vn v = + if exp_debug then eprintf "reg_valnum: trying to find a mapping for v=%d\n" v; + match Hashtbl.find !vn.nval v with + | [] -> None + | r :: rs -> + if exp_debug then eprintf "reg_valnum: found a mapping r=%d\n" (p2i r); + Some r + +let rec reg_valnums vn = function + | [] -> Some [] + | v :: vs -> ( + match (reg_valnum vn v, reg_valnums vn vs) with + | Some r, Some rs -> Some (r :: rs) + | _, _ -> None) + +let find_rhs vn rh = + match find_valnum_rhs rh !vn.seqs with + | None -> None + | Some vres -> reg_valnum vn vres + +(** Functions to perform the dynamic reduction during CSE *) + +let extract_arg l = + if List.length l > 0 then + match List.hd l with + | Sr r -> (r, List.tl l) + | Sexp (rd, _, _, _) -> (rd, l) + | _ -> failwith "extract_arg: final instruction arg can not be extracted" + else failwith "extract_arg: trying to extract on an empty list" + +let extract_final vn fl fdest succ = + if List.length fl > 0 then + match List.hd fl with + | Sr r -> + if not (P.eq r fdest) then ( + let v = get_nvalues vn [ r ] in + addsop vn v Omove fdest; + Sexp (fdest, Smove, [ r ], Some succ) :: List.tl fl) + else Snop succ :: List.tl fl + | Sexp (rd, rh, args, None) -> + assert (rd = fdest); + Sexp (fdest, rh, args, Some succ) :: List.tl fl + | _ -> fl + else failwith "extract_final: trying to extract on an empty list" + +let addinst vn op args rd = + let v = get_nvalues vn args in + let rh = Sop (op, v) in + match find_rhs vn rh with + | Some r -> + if exp_debug then eprintf "addinst: rhs found with r=%d\n" (p2i r); + Sr r + | None -> + addsop vn v op rd; + Sexp (rd, rh, args, None) + +(** Expansion functions *) + type immt = | Addiw | Addil @@ -59,152 +238,109 @@ type immt = | Sltil | Sltiul -let find_or_addnmove op args rd succ map_consts not_final = - let sop = Sop (op, args) in - match Hashtbl.find_opt map_consts sop with - | Some r -> - if not_final then node := !node - 1; - Sr (P.of_int r) - | None -> - if (not (List.exists (fun a -> a = rd) args)) && not_final then - Hashtbl.add map_consts sop (p2i rd); - Si (Iop (op, args, rd, succ)) - -let build_head_tuple head sv = - match sv with Si i -> (head @ [ i ], None) | Sr r -> (head, Some r) - -let unzip_head_tuple ht r = match ht with l, Some r' -> r' | l, None -> r - -let unzip_head_tuple_move ht r succ = - match ht with - | l, Some r' -> - if r' != r then [ Iop (Omove, [ r' ], r, succ) ] else [ Inop succ ] - | l, None -> l - -let build_full_ilist op args dest succ hd k map_consts = - let sv = find_or_addnmove op args dest succ map_consts false in - let ht = build_head_tuple hd sv in - unzip_head_tuple_move ht dest succ @ k - -let load_hilo32 dest hi lo succ map_consts not_final = +let load_hilo32 vn dest hi lo = let op1 = OEluiw hi in - if Int.eq lo Int.zero then - let sv = find_or_addnmove op1 [] dest succ map_consts not_final in - build_head_tuple [] sv + if Int.eq lo Int.zero then [ addinst vn op1 [] dest ] else let r = r2pi () in - let sv1 = find_or_addnmove op1 [] r (n2pi ()) map_consts not_final in - let ht1 = build_head_tuple [] sv1 in - let r' = unzip_head_tuple ht1 r in - let op2 = OEaddiw lo in - let sv2 = find_or_addnmove op2 [ r' ] dest succ map_consts not_final in - build_head_tuple (fst ht1) sv2 - -let load_hilo64 dest hi lo succ map_consts not_final = + let op2 = OEaddiw (None, lo) in + let i1 = addinst vn op1 [] r in + let r', l = extract_arg [ i1 ] in + let i2 = addinst vn op2 [ r' ] dest in + i2 :: l + +let load_hilo64 vn dest hi lo = let op1 = OEluil hi in - if Int64.eq lo Int64.zero then - let sv = find_or_addnmove op1 [] dest succ map_consts not_final in - build_head_tuple [] sv + if Int64.eq lo Int64.zero then [ addinst vn op1 [] dest ] else let r = r2pi () in - let sv1 = find_or_addnmove op1 [] r (n2pi ()) map_consts not_final in - let ht1 = build_head_tuple [] sv1 in - let r' = unzip_head_tuple ht1 r in - let op2 = OEaddil lo in - let sv2 = find_or_addnmove op2 [ r' ] dest succ map_consts not_final in - build_head_tuple (fst ht1) sv2 - -let loadimm32 dest n succ map_consts not_final = + let op2 = OEaddil (None, lo) in + let i1 = addinst vn op1 [] r in + let r', l = extract_arg [ i1 ] in + let i2 = addinst vn op2 [ r' ] dest in + i2 :: l + +let loadimm32 vn dest n = match make_immed32 n with | Imm32_single imm -> - let op1 = OEimmR0 (OPimmADD imm) in - let sv = find_or_addnmove op1 [] dest succ map_consts not_final in - build_head_tuple [] sv - | Imm32_pair (hi, lo) -> load_hilo32 dest hi lo succ map_consts not_final + let op1 = OEaddiw (Some X0_R, imm) in + [ addinst vn op1 [] dest ] + | Imm32_pair (hi, lo) -> load_hilo32 vn dest hi lo -let loadimm64 dest n succ map_consts not_final = +let loadimm64 vn dest n = match make_immed64 n with | Imm64_single imm -> - let op1 = OEimmR0 (OPimmADDL imm) in - let sv = find_or_addnmove op1 [] dest succ map_consts not_final in - build_head_tuple [] sv - | Imm64_pair (hi, lo) -> load_hilo64 dest hi lo succ map_consts not_final + let op1 = OEaddil (Some X0_R, imm) in + [ addinst vn op1 [] dest ] + | Imm64_pair (hi, lo) -> load_hilo64 vn dest hi lo | Imm64_large imm -> let op1 = OEloadli imm in - let sv = find_or_addnmove op1 [] dest succ map_consts not_final in - build_head_tuple [] sv + [ addinst vn op1 [] dest ] -let get_opimm imm = function - | Addiw -> OEaddiw imm +let get_opimm optR imm = function + | Addiw -> OEaddiw (optR, imm) | Andiw -> OEandiw imm | Oriw -> OEoriw imm | Xoriw -> OExoriw imm | Sltiw -> OEsltiw imm | Sltiuw -> OEsltiuw imm - | Addil -> OEaddil imm + | Addil -> OEaddil (optR, imm) | Andil -> OEandil imm | Oril -> OEoril imm | Xoril -> OExoril imm | Sltil -> OEsltil imm | Sltiul -> OEsltiul imm -let opimm32 a1 dest n succ k op opimm map_consts = +let opimm32 vn a1 dest n optR op opimm = match make_immed32 n with - | Imm32_single imm -> - build_full_ilist (get_opimm imm opimm) [ a1 ] dest succ [] k map_consts + | Imm32_single imm -> [ addinst vn (get_opimm optR imm opimm) [ a1 ] dest ] | Imm32_pair (hi, lo) -> let r = r2pi () in - let ht = load_hilo32 r hi lo (n2pi ()) map_consts true in - let r' = unzip_head_tuple ht r in - build_full_ilist op [ a1; r' ] dest succ (fst ht) k map_consts + let l = load_hilo32 vn r hi lo in + let r', l' = extract_arg l in + let i = addinst vn op [ a1; r' ] dest in + i :: l' -let opimm64 a1 dest n succ k op opimm map_consts = +let opimm64 vn a1 dest n optR op opimm = match make_immed64 n with - | Imm64_single imm -> - build_full_ilist (get_opimm imm opimm) [ a1 ] dest succ [] k map_consts + | Imm64_single imm -> [ addinst vn (get_opimm optR imm opimm) [ a1 ] dest ] | Imm64_pair (hi, lo) -> let r = r2pi () in - let ht = load_hilo64 r hi lo (n2pi ()) map_consts true in - let r' = unzip_head_tuple ht r in - build_full_ilist op [ a1; r' ] dest succ (fst ht) k map_consts + let l = load_hilo64 vn r hi lo in + let r', l' = extract_arg l in + let i = addinst vn op [ a1; r' ] dest in + i :: l' | Imm64_large imm -> let r = r2pi () in let op1 = OEloadli imm in - let inode = n2pi () in - let sv = find_or_addnmove op1 [] r inode map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in - build_full_ilist op [ a1; r' ] dest succ (fst ht) k map_consts + let i1 = addinst vn op1 [] r in + let r', l' = extract_arg [ i1 ] in + let i2 = addinst vn op [ a1; r' ] dest in + i2 :: l' -let addimm32 a1 dest n succ k map_consts = - opimm32 a1 dest n succ k Oadd Addiw map_consts +let addimm32 vn a1 dest n optR = opimm32 vn a1 dest n optR Oadd Addiw -let andimm32 a1 dest n succ k map_consts = - opimm32 a1 dest n succ k Oand Andiw map_consts +let andimm32 vn a1 dest n = opimm32 vn a1 dest n None Oand Andiw -let orimm32 a1 dest n succ k map_consts = - opimm32 a1 dest n succ k Oor Oriw map_consts +let orimm32 vn a1 dest n = opimm32 vn a1 dest n None Oor Oriw -let xorimm32 a1 dest n succ k map_consts = - opimm32 a1 dest n succ k Oxor Xoriw map_consts +let xorimm32 vn a1 dest n = opimm32 vn a1 dest n None Oxor Xoriw -let sltimm32 a1 dest n succ k map_consts = - opimm32 a1 dest n succ k (OEsltw None) Sltiw map_consts +let sltimm32 vn a1 dest n = opimm32 vn a1 dest n None (OEsltw None) Sltiw -let sltuimm32 a1 dest n succ k map_consts = - opimm32 a1 dest n succ k (OEsltuw None) Sltiuw map_consts +let sltuimm32 vn a1 dest n = opimm32 vn a1 dest n None (OEsltuw None) Sltiuw -let addimm64 a1 dest n succ k = opimm64 a1 dest n succ k Oaddl Addil +let addimm64 vn a1 dest n optR = opimm64 vn a1 dest n optR Oaddl Addil -let andimm64 a1 dest n succ k = opimm64 a1 dest n succ k Oandl Andil +let andimm64 vn a1 dest n = opimm64 vn a1 dest n None Oandl Andil -let orimm64 a1 dest n succ k = opimm64 a1 dest n succ k Oorl Oril +let orimm64 vn a1 dest n = opimm64 vn a1 dest n None Oorl Oril -let xorimm64 a1 dest n succ k = opimm64 a1 dest n succ k Oxorl Xoril +let xorimm64 vn a1 dest n = opimm64 vn a1 dest n None Oxorl Xoril -let sltimm64 a1 dest n succ k = opimm64 a1 dest n succ k (OEsltl None) Sltil +let sltimm64 vn a1 dest n = opimm64 vn a1 dest n None (OEsltl None) Sltil -let sltuimm64 a1 dest n succ k = opimm64 a1 dest n succ k (OEsltul None) Sltiul +let sltuimm64 vn a1 dest n = opimm64 vn a1 dest n None (OEsltul None) Sltiul let is_inv_cmp = function Cle | Cgt -> true | _ -> false @@ -214,276 +350,288 @@ let make_optR is_x0 is_inv = let cbranch_int32s is_x0 cmp a1 a2 info succ1 succ2 k = let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Icond (CEbeqw optR, [ a1; a2 ], succ1, succ2, info) :: k - | Cne -> Icond (CEbnew optR, [ a1; a2 ], succ1, succ2, info) :: k - | Clt -> Icond (CEbltw optR, [ a1; a2 ], succ1, succ2, info) :: k - | Cle -> Icond (CEbgew optR, [ a2; a1 ], succ1, succ2, info) :: k - | Cgt -> Icond (CEbltw optR, [ a2; a1 ], succ1, succ2, info) :: k - | Cge -> Icond (CEbgew optR, [ a1; a2 ], succ1, succ2, info) :: k + | Ceq -> Sfinalcond (CEbeqw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Sfinalcond (CEbnew optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Sfinalcond (CEbltw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Sfinalcond (CEbgew optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Sfinalcond (CEbltw optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Sfinalcond (CEbgew optR, [ a1; a2 ], succ1, succ2, info) :: k let cbranch_int32u is_x0 cmp a1 a2 info succ1 succ2 k = let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Icond (CEbequw optR, [ a1; a2 ], succ1, succ2, info) :: k - | Cne -> Icond (CEbneuw optR, [ a1; a2 ], succ1, succ2, info) :: k - | Clt -> Icond (CEbltuw optR, [ a1; a2 ], succ1, succ2, info) :: k - | Cle -> Icond (CEbgeuw optR, [ a2; a1 ], succ1, succ2, info) :: k - | Cgt -> Icond (CEbltuw optR, [ a2; a1 ], succ1, succ2, info) :: k - | Cge -> Icond (CEbgeuw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Ceq -> Sfinalcond (CEbequw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Sfinalcond (CEbneuw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Sfinalcond (CEbltuw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Sfinalcond (CEbgeuw optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Sfinalcond (CEbltuw optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Sfinalcond (CEbgeuw optR, [ a1; a2 ], succ1, succ2, info) :: k let cbranch_int64s is_x0 cmp a1 a2 info succ1 succ2 k = let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Icond (CEbeql optR, [ a1; a2 ], succ1, succ2, info) :: k - | Cne -> Icond (CEbnel optR, [ a1; a2 ], succ1, succ2, info) :: k - | Clt -> Icond (CEbltl optR, [ a1; a2 ], succ1, succ2, info) :: k - | Cle -> Icond (CEbgel optR, [ a2; a1 ], succ1, succ2, info) :: k - | Cgt -> Icond (CEbltl optR, [ a2; a1 ], succ1, succ2, info) :: k - | Cge -> Icond (CEbgel optR, [ a1; a2 ], succ1, succ2, info) :: k + | Ceq -> Sfinalcond (CEbeql optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Sfinalcond (CEbnel optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Sfinalcond (CEbltl optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Sfinalcond (CEbgel optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Sfinalcond (CEbltl optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Sfinalcond (CEbgel optR, [ a1; a2 ], succ1, succ2, info) :: k let cbranch_int64u is_x0 cmp a1 a2 info succ1 succ2 k = let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Icond (CEbequl optR, [ a1; a2 ], succ1, succ2, info) :: k - | Cne -> Icond (CEbneul optR, [ a1; a2 ], succ1, succ2, info) :: k - | Clt -> Icond (CEbltul optR, [ a1; a2 ], succ1, succ2, info) :: k - | Cle -> Icond (CEbgeul optR, [ a2; a1 ], succ1, succ2, info) :: k - | Cgt -> Icond (CEbltul optR, [ a2; a1 ], succ1, succ2, info) :: k - | Cge -> Icond (CEbgeul optR, [ a1; a2 ], succ1, succ2, info) :: k - -let cond_int32s is_x0 cmp a1 a2 dest tmp_reg succ map_consts = + | Ceq -> Sfinalcond (CEbequl optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Sfinalcond (CEbneul optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Sfinalcond (CEbltul optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Sfinalcond (CEbgeul optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Sfinalcond (CEbltul optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Sfinalcond (CEbgeul optR, [ a1; a2 ], succ1, succ2, info) :: k + +let cond_int32s vn is_x0 cmp a1 a2 dest = let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> [ Iop (OEseqw optR, [ a1; a2 ], dest, succ) ] - | Cne -> [ Iop (OEsnew optR, [ a1; a2 ], dest, succ) ] - | Clt -> [ Iop (OEsltw optR, [ a1; a2 ], dest, succ) ] + | Ceq -> [ addinst vn (OEseqw optR) [ a1; a2 ] dest ] + | Cne -> [ addinst vn (OEsnew optR) [ a1; a2 ] dest ] + | Clt -> [ addinst vn (OEsltw optR) [ a1; a2 ] dest ] | Cle -> let r = r2pi () in let op = OEsltw optR in - let sv = find_or_addnmove op [ a2; a1 ] r (get tmp_reg) map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in - fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] - | Cgt -> [ Iop (OEsltw optR, [ a2; a1 ], dest, succ) ] + let i1 = addinst vn op [ a2; a1 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + | Cgt -> [ addinst vn (OEsltw optR) [ a2; a1 ] dest ] | Cge -> let r = r2pi () in let op = OEsltw optR in - let sv = find_or_addnmove op [ a1; a2 ] r (get tmp_reg) map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in - fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] + let i1 = addinst vn op [ a1; a2 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l -let cond_int32u is_x0 cmp a1 a2 dest tmp_reg succ map_consts = +let cond_int32u vn is_x0 cmp a1 a2 dest = let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> [ Iop (OEsequw optR, [ a1; a2 ], dest, succ) ] - | Cne -> [ Iop (OEsneuw optR, [ a1; a2 ], dest, succ) ] - | Clt -> [ Iop (OEsltuw optR, [ a1; a2 ], dest, succ) ] + | Ceq -> [ addinst vn (OEsequw optR) [ a1; a2 ] dest ] + | Cne -> [ addinst vn (OEsneuw optR) [ a1; a2 ] dest ] + | Clt -> [ addinst vn (OEsltuw optR) [ a1; a2 ] dest ] | Cle -> let r = r2pi () in let op = OEsltuw optR in - let sv = find_or_addnmove op [ a2; a1 ] r (get tmp_reg) map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in - fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] - | Cgt -> [ Iop (OEsltuw optR, [ a2; a1 ], dest, succ) ] + let i1 = addinst vn op [ a2; a1 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + | Cgt -> [ addinst vn (OEsltuw optR) [ a2; a1 ] dest ] | Cge -> let r = r2pi () in let op = OEsltuw optR in - let sv = find_or_addnmove op [ a1; a2 ] r (get tmp_reg) map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in - fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] + let i1 = addinst vn op [ a1; a2 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l -let cond_int64s is_x0 cmp a1 a2 dest tmp_reg succ map_consts = +let cond_int64s vn is_x0 cmp a1 a2 dest = let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> [ Iop (OEseql optR, [ a1; a2 ], dest, succ) ] - | Cne -> [ Iop (OEsnel optR, [ a1; a2 ], dest, succ) ] - | Clt -> [ Iop (OEsltl optR, [ a1; a2 ], dest, succ) ] + | Ceq -> [ addinst vn (OEseql optR) [ a1; a2 ] dest ] + | Cne -> [ addinst vn (OEsnel optR) [ a1; a2 ] dest ] + | Clt -> [ addinst vn (OEsltl optR) [ a1; a2 ] dest ] | Cle -> let r = r2pi () in let op = OEsltl optR in - let sv = find_or_addnmove op [ a2; a1 ] r (get tmp_reg) map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in - fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] - | Cgt -> [ Iop (OEsltl optR, [ a2; a1 ], dest, succ) ] + let i1 = addinst vn op [ a2; a1 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + | Cgt -> [ addinst vn (OEsltl optR) [ a2; a1 ] dest ] | Cge -> let r = r2pi () in let op = OEsltl optR in - let sv = find_or_addnmove op [ a1; a2 ] r (get tmp_reg) map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in - fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] + let i1 = addinst vn op [ a1; a2 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l -let cond_int64u is_x0 cmp a1 a2 dest tmp_reg succ map_consts = +let cond_int64u vn is_x0 cmp a1 a2 dest = let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> [ Iop (OEsequl optR, [ a1; a2 ], dest, succ) ] - | Cne -> [ Iop (OEsneul optR, [ a1; a2 ], dest, succ) ] - | Clt -> [ Iop (OEsltul optR, [ a1; a2 ], dest, succ) ] + | Ceq -> [ addinst vn (OEsequl optR) [ a1; a2 ] dest ] + | Cne -> [ addinst vn (OEsneul optR) [ a1; a2 ] dest ] + | Clt -> [ addinst vn (OEsltul optR) [ a1; a2 ] dest ] | Cle -> let r = r2pi () in let op = OEsltul optR in - let sv = find_or_addnmove op [ a2; a1 ] r (get tmp_reg) map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in - fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] - | Cgt -> [ Iop (OEsltul optR, [ a2; a1 ], dest, succ) ] + let i1 = addinst vn op [ a2; a1 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + | Cgt -> [ addinst vn (OEsltul optR) [ a2; a1 ] dest ] | Cge -> let r = r2pi () in let op = OEsltul optR in - let sv = find_or_addnmove op [ a1; a2 ] r (get tmp_reg) map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in - fst ht @ [ Iop (OExoriw Int.one, [ r' ], dest, succ) ] + let i1 = addinst vn op [ a1; a2 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l let is_normal_cmp = function Cne -> false | _ -> true -let cond_float cmp f1 f2 dest succ map_consts = +let cond_float vn cmp f1 f2 dest = match cmp with - | Ceq -> [ Iop (OEfeqd, [ f1; f2 ], dest, succ) ] - | Cne -> [ Iop (OEfeqd, [ f1; f2 ], dest, succ) ] - | Clt -> [ Iop (OEfltd, [ f1; f2 ], dest, succ) ] - | Cle -> [ Iop (OEfled, [ f1; f2 ], dest, succ) ] - | Cgt -> [ Iop (OEfltd, [ f2; f1 ], dest, succ) ] - | Cge -> [ Iop (OEfled, [ f2; f1 ], dest, succ) ] - -let cond_single cmp f1 f2 dest succ map_consts = + | Ceq -> [ addinst vn OEfeqd [ f1; f2 ] dest ] + | Cne -> [ addinst vn OEfeqd [ f1; f2 ] dest ] + | Clt -> [ addinst vn OEfltd [ f1; f2 ] dest ] + | Cle -> [ addinst vn OEfled [ f1; f2 ] dest ] + | Cgt -> [ addinst vn OEfltd [ f2; f1 ] dest ] + | Cge -> [ addinst vn OEfled [ f2; f1 ] dest ] + +let cond_single vn cmp f1 f2 dest = match cmp with - | Ceq -> [ Iop (OEfeqs, [ f1; f2 ], dest, succ) ] - | Cne -> [ Iop (OEfeqs, [ f1; f2 ], dest, succ) ] - | Clt -> [ Iop (OEflts, [ f1; f2 ], dest, succ) ] - | Cle -> [ Iop (OEfles, [ f1; f2 ], dest, succ) ] - | Cgt -> [ Iop (OEflts, [ f2; f1 ], dest, succ) ] - | Cge -> [ Iop (OEfles, [ f2; f1 ], dest, succ) ] - -let expanse_cbranchimm_int32s cmp a1 n info succ1 succ2 k map_consts = - if Int.eq n Int.zero then cbranch_int32s true cmp a1 a1 info succ1 succ2 k + | Ceq -> [ addinst vn OEfeqs [ f1; f2 ] dest ] + | Cne -> [ addinst vn OEfeqs [ f1; f2 ] dest ] + | Clt -> [ addinst vn OEflts [ f1; f2 ] dest ] + | Cle -> [ addinst vn OEfles [ f1; f2 ] dest ] + | Cgt -> [ addinst vn OEflts [ f2; f1 ] dest ] + | Cge -> [ addinst vn OEfles [ f2; f1 ] dest ] + +let expanse_cbranchimm_int32s vn cmp a1 n info succ1 succ2 = + if Int.eq n Int.zero then cbranch_int32s true cmp a1 a1 info succ1 succ2 [] else let r = r2pi () in - let ht = loadimm32 r n (n2pi ()) map_consts true in - let r' = unzip_head_tuple ht r in - fst ht @ cbranch_int32s false cmp a1 r' info succ1 succ2 k + let l = loadimm32 vn r n in + let r', l' = extract_arg l in + cbranch_int32s false cmp a1 r' info succ1 succ2 l' -let expanse_cbranchimm_int32u cmp a1 n info succ1 succ2 k map_consts = - if Int.eq n Int.zero then cbranch_int32u true cmp a1 a1 info succ1 succ2 k +let expanse_cbranchimm_int32u vn cmp a1 n info succ1 succ2 = + if Int.eq n Int.zero then cbranch_int32u true cmp a1 a1 info succ1 succ2 [] else let r = r2pi () in - let ht = loadimm32 r n (n2pi ()) map_consts true in - let r' = unzip_head_tuple ht r in - fst ht @ cbranch_int32u false cmp a1 r' info succ1 succ2 k + let l = loadimm32 vn r n in + let r', l' = extract_arg l in + cbranch_int32u false cmp a1 r' info succ1 succ2 l' -let expanse_cbranchimm_int64s cmp a1 n info succ1 succ2 k map_consts = - if Int64.eq n Int64.zero then cbranch_int64s true cmp a1 a1 info succ1 succ2 k +let expanse_cbranchimm_int64s vn cmp a1 n info succ1 succ2 = + if Int64.eq n Int64.zero then + cbranch_int64s true cmp a1 a1 info succ1 succ2 [] else let r = r2pi () in - let ht = loadimm64 r n (n2pi ()) map_consts true in - let r' = unzip_head_tuple ht r in - fst ht @ cbranch_int64s false cmp a1 r' info succ1 succ2 k + let l = loadimm64 vn r n in + let r', l' = extract_arg l in + cbranch_int64s false cmp a1 r' info succ1 succ2 l' -let expanse_cbranchimm_int64u cmp a1 n info succ1 succ2 k map_consts = - if Int64.eq n Int64.zero then cbranch_int64u true cmp a1 a1 info succ1 succ2 k +let expanse_cbranchimm_int64u vn cmp a1 n info succ1 succ2 = + if Int64.eq n Int64.zero then + cbranch_int64u true cmp a1 a1 info succ1 succ2 [] else let r = r2pi () in - let ht = loadimm64 r n (n2pi ()) map_consts true in - let r' = unzip_head_tuple ht r in - fst ht @ cbranch_int64u false cmp a1 r' info succ1 succ2 k - -let get_tmp_reg = function Cle | Cge -> Some (n2pi ()) | _ -> None + let l = loadimm64 vn r n in + let r', l' = extract_arg l in + cbranch_int64u false cmp a1 r' info succ1 succ2 l' -let expanse_condimm_int32s cmp a1 n dest succ map_consts = - if Int.eq n Int.zero then - let tmp_reg = get_tmp_reg cmp in - cond_int32s true cmp a1 a1 dest tmp_reg succ map_consts +let expanse_condimm_int32s vn cmp a1 n dest = + if Int.eq n Int.zero then cond_int32s vn true cmp a1 a1 dest else match cmp with | Ceq | Cne -> let r = r2pi () in - xorimm32 a1 r n (n2pi ()) - (cond_int32s true cmp r r dest None succ map_consts) - map_consts - | Clt -> sltimm32 a1 dest n succ [] map_consts + let l = xorimm32 vn a1 r n in + let r', l' = extract_arg l in + cond_int32s vn true cmp r' r' dest @ l' + | Clt -> sltimm32 vn a1 dest n | Cle -> if Int.eq n (Int.repr Int.max_signed) then - let ht = loadimm32 dest Int.one succ map_consts false in - fst ht - else sltimm32 a1 dest (Int.add n Int.one) succ [] map_consts + let l = loadimm32 vn dest Int.one in + let r, l' = extract_arg l in + addinst vn (OEmayundef MUint) [ a1; r ] dest :: l' + else sltimm32 vn a1 dest (Int.add n Int.one) | _ -> let r = r2pi () in - let tmp_reg = get_tmp_reg cmp in - let ht = loadimm32 r n (n2pi ()) map_consts true in - let r' = unzip_head_tuple ht r in - fst ht @ cond_int32s false cmp a1 r' dest tmp_reg succ map_consts - -let expanse_condimm_int32u cmp a1 n dest succ map_consts = - let tmp_reg = get_tmp_reg cmp in - if Int.eq n Int.zero then - cond_int32u true cmp a1 a1 dest tmp_reg succ map_consts + let l = loadimm32 vn r n in + let r', l' = extract_arg l in + cond_int32s vn false cmp a1 r' dest @ l' + +let expanse_condimm_int32u vn cmp a1 n dest = + if Int.eq n Int.zero then cond_int32u vn true cmp a1 a1 dest else match cmp with - | Clt -> sltuimm32 a1 dest n succ [] map_consts + | Clt -> sltuimm32 vn a1 dest n | _ -> let r = r2pi () in - let ht = loadimm32 r n (n2pi ()) map_consts true in - let r' = unzip_head_tuple ht r in - fst ht @ cond_int32u false cmp a1 r' dest tmp_reg succ map_consts + let l = loadimm32 vn r n in + let r', l' = extract_arg l in + cond_int32u vn false cmp a1 r' dest @ l' -let expanse_condimm_int64s cmp a1 n dest succ map_consts = - if Int64.eq n Int64.zero then - let tmp_reg = get_tmp_reg cmp in - cond_int64s true cmp a1 a1 dest tmp_reg succ map_consts +let expanse_condimm_int64s vn cmp a1 n dest = + if Int64.eq n Int64.zero then cond_int64s vn true cmp a1 a1 dest else match cmp with | Ceq | Cne -> let r = r2pi () in - xorimm64 a1 r n (n2pi ()) - (cond_int64s true cmp r r dest None succ map_consts) - map_consts - | Clt -> sltimm64 a1 dest n succ [] map_consts + let l = xorimm64 vn a1 r n in + let r', l' = extract_arg l in + cond_int64s vn true cmp r' r' dest @ l' + | Clt -> sltimm64 vn a1 dest n | Cle -> if Int64.eq n (Int64.repr Int64.max_signed) then - let ht = loadimm32 dest Int.one succ map_consts false in - fst ht - else sltimm64 a1 dest (Int64.add n Int64.one) succ [] map_consts + let l = loadimm32 vn dest Int.one in + let r, l' = extract_arg l in + addinst vn (OEmayundef MUlong) [ a1; r ] dest :: l' + else sltimm64 vn a1 dest (Int64.add n Int64.one) | _ -> let r = r2pi () in - let tmp_reg = get_tmp_reg cmp in - let ht = loadimm64 r n (n2pi ()) map_consts true in - let r' = unzip_head_tuple ht r in - fst ht @ cond_int64s false cmp a1 r' dest tmp_reg succ map_consts + let l = loadimm64 vn r n in + let r', l' = extract_arg l in + cond_int64s vn false cmp a1 r' dest @ l' -let expanse_condimm_int64u cmp a1 n dest succ map_consts = - let tmp_reg = get_tmp_reg cmp in - if Int64.eq n Int64.zero then - cond_int64u true cmp a1 a1 dest tmp_reg succ map_consts +let expanse_condimm_int64u vn cmp a1 n dest = + if Int64.eq n Int64.zero then cond_int64u vn true cmp a1 a1 dest else match cmp with - | Clt -> sltuimm64 a1 dest n succ [] map_consts + | Clt -> sltuimm64 vn a1 dest n | _ -> let r = r2pi () in - let ht = loadimm64 r n (n2pi ()) map_consts true in - let r' = unzip_head_tuple ht r in - fst ht @ cond_int64u false cmp a1 r' dest tmp_reg succ map_consts + let l = loadimm64 vn r n in + let r', l' = extract_arg l in + cond_int64u vn false cmp a1 r' dest @ l' -let expanse_cond_fp cnot fn_cond cmp f1 f2 dest succ map_consts = +let expanse_cond_fp vn cnot fn_cond cmp f1 f2 dest = let normal = is_normal_cmp cmp in let normal' = if cnot then not normal else normal in - let succ' = if normal' then succ else n2pi () in - let insn = fn_cond cmp f1 f2 dest succ' map_consts in + let insn = fn_cond vn cmp f1 f2 dest in if normal' then insn - else build_full_ilist (OExoriw Int.one) [ dest ] dest succ insn [] map_consts + else + let r', l = extract_arg insn in + addinst vn (OExoriw Int.one) [ r' ] dest :: l -let expanse_cbranch_fp cnot fn_cond cmp f1 f2 info succ1 succ2 map_consts = +let expanse_cbranch_fp vn cnot fn_cond cmp f1 f2 info succ1 succ2 = let r = r2pi () in let normal = is_normal_cmp cmp in let normal' = if cnot then not normal else normal in - let insn = List.hd (fn_cond cmp f1 f2 r (n2pi ()) map_consts) in - insn - :: - (if normal' then [ Icond (CEbnew (Some X0_R), [ r; r ], succ1, succ2, info) ] - else [ Icond (CEbeqw (Some X0_R), [ r; r ], succ1, succ2, info) ]) + let insn = fn_cond vn cmp f1 f2 r in + let r', l = extract_arg insn in + if normal' then + Sfinalcond (CEbnew (Some X0_R), [ r'; r' ], succ1, succ2, info) :: l + else Sfinalcond (CEbeqw (Some X0_R), [ r'; r' ], succ1, succ2, info) :: l + +let addptrofs vn n dest = + if Ptrofs.eq_dec n Ptrofs.zero then [ addinst vn OEmoveSP [] dest ] + else if Archi.ptr64 then + match make_immed64 (Ptrofs.to_int64 n) with + | Imm64_single imm -> [ addinst vn (OEaddil (Some SP_S, imm)) [] dest ] + | Imm64_pair (hi, lo) -> + let r = r2pi () in + let l = load_hilo64 vn r hi lo in + let r', l' = extract_arg l in + addinst vn (OEaddil (Some SP_S, Int64.zero)) [ r' ] dest :: l' + | Imm64_large imm -> + let r = r2pi () in + let op1 = OEloadli imm in + let i1 = addinst vn op1 [] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OEaddil (Some SP_S, Int64.zero)) [ r' ] dest :: l + else + match make_immed32 (Ptrofs.to_int n) with + | Imm32_single imm -> [ addinst vn (OEaddiw (Some SP_S, imm)) [] dest ] + | Imm32_pair (hi, lo) -> + let r = r2pi () in + let l = load_hilo32 vn r hi lo in + let r', l' = extract_arg l in + addinst vn (OEaddiw (Some SP_S, Int.zero)) [ r' ] dest :: l' + +(** Form a list containing both sources and destination regs of an instruction *) let get_regindent = function Coq_inr _ -> [] | Coq_inl r -> [ r ] @@ -501,11 +649,11 @@ let get_regs_inst = function | Ireturn (Some r) -> [ r ] | _ -> [] -let write_initial_node initial code' new_order = - code' := PTree.set initial (Inop (n2p ())) !code'; - new_order := initial :: !new_order +(** Modify pathmap according to the size of the expansion list *) let write_pathmap initial esize pm' = + if exp_debug then + eprintf "write_pathmap: initial=%d, esize=%d\n" (p2i initial) esize; let path = get_some @@ PTree.get initial !pm' in let npsize = Camlcoq.Nat.of_int (esize + Camlcoq.Nat.to_int path.psize) in let path' = @@ -518,22 +666,51 @@ let write_pathmap initial esize pm' = in pm' := PTree.set initial path' !pm' -let rec write_tree exp initial current code' new_order fturn = - (*Printf.eprintf "wt: node is %d\n" !node;*) +(** Write a single instruction in the tree and update order *) + +let write_inst target_node inst code' new_order = + code' := PTree.set (P.of_int target_node) inst !code'; + new_order := P.of_int target_node :: !new_order + +(** Return olds args if the CSE numbering is empty *) + +let get_arguments vn vals args = + match reg_valnums vn vals with Some args' -> args' | None -> args + +(** Update the code tree with the expansion list *) + +let rec write_tree vn exp initial current code' new_order fturn = + if exp_debug then eprintf "wt: node is %d\n" !node; let target_node, next_node = if fturn then (P.to_int initial, current) else (current, current - 1) in match exp with - | inst :: k -> - (*let open PrintRTL in*) - (*print_instruction stderr (target_node, inst);*) - code' := PTree.set (P.of_int target_node) inst !code'; - new_order := P.of_int target_node :: !new_order; - write_tree k initial next_node code' new_order false + | Sr r :: _ -> + failwith "write_tree: there are still some symbolic values in the list" + | Sexp (rd, Sop (op, vals), args, None) :: k -> + let args = get_arguments vn vals args in + let inst = Iop (op, args, rd, P.of_int next_node) in + write_inst target_node inst code' new_order; + write_tree vn k initial next_node code' new_order false + | [ Snop succ ] -> + let inst = Inop succ in + write_inst target_node inst code' new_order + | [ Sexp (rd, Sop (op, vals), args, Some succ) ] -> + let args = get_arguments vn vals args in + let inst = Iop (op, args, rd, succ) in + write_inst target_node inst code' new_order + | [ Sexp (rd, Smove, args, Some succ) ] -> + let inst = Iop (Omove, args, rd, succ) in + write_inst target_node inst code' new_order + | [ Sfinalcond (cond, args, succ1, succ2, info) ] -> + let inst = Icond (cond, args, succ1, succ2, info) in + write_inst target_node inst code' new_order | [] -> () + | _ -> failwith "write_tree: invalid list" +(** Main expansion function - TODO gourdinl to split? *) let expanse (sb : superblock) code pm = - (*debug_flag := true;*) + if exp_debug then eprintf "#### New superblock for expansion oracle\n"; let new_order = ref [] in let liveins = ref sb.liveins in let exp = ref [] in @@ -541,336 +718,342 @@ let expanse (sb : superblock) code pm = let was_exp = ref false in let code' = ref code in let pm' = ref pm in - let map_consts = Hashtbl.create 100 in + let vn = ref (empty_numbering ()) in Array.iter (fun n -> was_branch := false; was_exp := false; let inst = get_some @@ PTree.get n code in + if exp_debug then eprintf "We are checking node %d\n" (p2i n); (if !Clflags.option_fexpanse_rtlcond then match inst with (* Expansion of conditions - Ocmp *) | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccomp\n"; - let tmp_reg = get_tmp_reg c in - exp := cond_int32s false c a1 a2 dest tmp_reg succ map_consts; + if exp_debug then eprintf "Iop/Ccomp\n"; + exp := cond_int32s vn false c a1 a2 dest; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompu c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccompu\n"; - let tmp_reg = get_tmp_reg c in - exp := cond_int32u false c a1 a2 dest tmp_reg succ map_consts; + if exp_debug then eprintf "Iop/Ccompu\n"; + exp := cond_int32u vn false c a1 a2 dest; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccompimm\n"; - exp := expanse_condimm_int32s c a1 imm dest succ map_consts; + if exp_debug then eprintf "Iop/Ccompimm\n"; + exp := expanse_condimm_int32s vn c a1 imm dest; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompuimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccompuimm\n"; - exp := expanse_condimm_int32u c a1 imm dest succ map_consts; + if exp_debug then eprintf "Iop/Ccompuimm\n"; + exp := expanse_condimm_int32u vn c a1 imm dest; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompl c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccompl\n"; - let tmp_reg = get_tmp_reg c in - exp := cond_int64s false c a1 a2 dest tmp_reg succ map_consts; + if exp_debug then eprintf "Iop/Ccompl\n"; + exp := cond_int64s vn false c a1 a2 dest; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccomplu c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccomplu\n"; - let tmp_reg = get_tmp_reg c in - exp := cond_int64u false c a1 a2 dest tmp_reg succ map_consts; + if exp_debug then eprintf "Iop/Ccomplu\n"; + exp := cond_int64u vn false c a1 a2 dest; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccomplimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccomplimm\n"; - exp := expanse_condimm_int64s c a1 imm dest succ map_consts; + if exp_debug then eprintf "Iop/Ccomplimm\n"; + exp := expanse_condimm_int64s vn c a1 imm dest; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompluimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccompluimm\n"; - exp := expanse_condimm_int64u c a1 imm dest succ map_consts; + if exp_debug then eprintf "Iop/Ccompluimm\n"; + exp := expanse_condimm_int64u vn c a1 imm dest; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompf c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Ccompf\n"; - exp := expanse_cond_fp false cond_float c f1 f2 dest succ map_consts; + if exp_debug then eprintf "Iop/Ccompf\n"; + exp := expanse_cond_fp vn false cond_float c f1 f2 dest; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Cnotcompf c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Cnotcompf\n"; - exp := expanse_cond_fp true cond_float c f1 f2 dest succ map_consts; + if exp_debug then eprintf "Iop/Cnotcompf\n"; + exp := expanse_cond_fp vn true cond_float c f1 f2 dest; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompfs c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Ccompfs\n"; - exp := expanse_cond_fp false cond_single c f1 f2 dest succ map_consts; + if exp_debug then eprintf "Iop/Ccompfs\n"; + exp := expanse_cond_fp vn false cond_single c f1 f2 dest; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Cnotcompfs c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Cnotcompfs\n"; - exp := expanse_cond_fp true cond_single c f1 f2 dest succ map_consts; + if exp_debug then eprintf "Iop/Cnotcompfs\n"; + exp := expanse_cond_fp vn true cond_single c f1 f2 dest; + exp := extract_final vn !exp dest succ; was_exp := true (* Expansion of branches - Ccomp *) | Icond (Ccomp c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccomp\n"; + if exp_debug then eprintf "Icond/Ccomp\n"; exp := cbranch_int32s false c a1 a2 info succ1 succ2 []; was_branch := true; was_exp := true | Icond (Ccompu c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompu\n"; + if exp_debug then eprintf "Icond/Ccompu\n"; exp := cbranch_int32u false c a1 a2 info succ1 succ2 []; was_branch := true; was_exp := true | Icond (Ccompimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompimm\n"; - exp := - expanse_cbranchimm_int32s c a1 imm info succ1 succ2 [] map_consts; + if exp_debug then eprintf "Icond/Ccompimm\n"; + exp := expanse_cbranchimm_int32s vn c a1 imm info succ1 succ2; was_branch := true; was_exp := true | Icond (Ccompuimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompuimm\n"; - exp := - expanse_cbranchimm_int32u c a1 imm info succ1 succ2 [] map_consts; + if exp_debug then eprintf "Icond/Ccompuimm\n"; + exp := expanse_cbranchimm_int32u vn c a1 imm info succ1 succ2; was_branch := true; was_exp := true | Icond (Ccompl c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompl\n"; + if exp_debug then eprintf "Icond/Ccompl\n"; exp := cbranch_int64s false c a1 a2 info succ1 succ2 []; was_branch := true; was_exp := true | Icond (Ccomplu c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccomplu\n"; + if exp_debug then eprintf "Icond/Ccomplu\n"; exp := cbranch_int64u false c a1 a2 info succ1 succ2 []; was_branch := true; was_exp := true | Icond (Ccomplimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccomplimm\n"; - exp := - expanse_cbranchimm_int64s c a1 imm info succ1 succ2 [] map_consts; + if exp_debug then eprintf "Icond/Ccomplimm\n"; + exp := expanse_cbranchimm_int64s vn c a1 imm info succ1 succ2; was_branch := true; was_exp := true | Icond (Ccompluimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompluimm\n"; - exp := - expanse_cbranchimm_int64u c a1 imm info succ1 succ2 [] map_consts; + if exp_debug then eprintf "Icond/Ccompluimm\n"; + exp := expanse_cbranchimm_int64u vn c a1 imm info succ1 succ2; was_branch := true; was_exp := true | Icond (Ccompf c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompf\n"; + if exp_debug then eprintf "Icond/Ccompf\n"; exp := - expanse_cbranch_fp false cond_float c f1 f2 info succ1 succ2 - map_consts; + expanse_cbranch_fp vn false cond_float c f1 f2 info succ1 succ2; was_branch := true; was_exp := true | Icond (Cnotcompf c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Cnotcompf\n"; - exp := - expanse_cbranch_fp true cond_float c f1 f2 info succ1 succ2 - map_consts; + if exp_debug then eprintf "Icond/Cnotcompf\n"; + exp := expanse_cbranch_fp vn true cond_float c f1 f2 info succ1 succ2; was_branch := true; was_exp := true | Icond (Ccompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompfs\n"; + if exp_debug then eprintf "Icond/Ccompfs\n"; exp := - expanse_cbranch_fp false cond_single c f1 f2 info succ1 succ2 - map_consts; + expanse_cbranch_fp vn false cond_single c f1 f2 info succ1 succ2; was_branch := true; was_exp := true | Icond (Cnotcompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Cnotcompfs\n"; + if exp_debug then eprintf "Icond/Cnotcompfs\n"; exp := - expanse_cbranch_fp true cond_single c f1 f2 info succ1 succ2 - map_consts; + expanse_cbranch_fp vn true cond_single c f1 f2 info succ1 succ2; was_branch := true; was_exp := true | _ -> ()); (if !Clflags.option_fexpanse_others && not !was_exp then match inst with - (* Expansion of fp constants *) | Iop (Ofloatconst f, nil, dest, succ) -> - debug "Iop/Ofloatconst\n"; + if exp_debug then eprintf "Iop/Ofloatconst\n"; let r = r2pi () in - let ht = - loadimm64 r (Floats.Float.to_bits f) (n2pi ()) map_consts true - in - let r' = unzip_head_tuple ht r in - exp := - build_full_ilist Ofloat_of_bits [ r' ] dest succ (fst ht) [] - map_consts; + let l = loadimm64 vn r (Floats.Float.to_bits f) in + let r', l' = extract_arg l in + exp := addinst vn Ofloat_of_bits [ r' ] dest :: l'; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Osingleconst f, nil, dest, succ) -> - debug "Iop/Osingleconst\n"; + if exp_debug then eprintf "Iop/Osingleconst\n"; let r = r2pi () in - let ht = - loadimm32 r (Floats.Float32.to_bits f) (n2pi ()) map_consts true - in - let r' = unzip_head_tuple ht r in - exp := - build_full_ilist Osingle_of_bits [ r' ] dest succ (fst ht) [] - map_consts; + let l = loadimm32 vn r (Floats.Float32.to_bits f) in + let r', l' = extract_arg l in + exp := addinst vn Osingle_of_bits [ r' ] dest :: l'; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ointconst n, nil, dest, succ) -> - debug "Iop/Ointconst\n"; - let ht = loadimm32 dest n succ map_consts false in - exp := unzip_head_tuple_move ht dest succ; + if exp_debug then eprintf "Iop/Ointconst\n"; + exp := loadimm32 vn dest n; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Olongconst n, nil, dest, succ) -> - debug "Iop/Olongconst\n"; - let ht = loadimm64 dest n succ map_consts false in - exp := unzip_head_tuple_move ht dest succ; + if exp_debug then eprintf "Iop/Olongconst\n"; + exp := loadimm64 vn dest n; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oaddimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oaddimm\n"; - exp := addimm32 a1 dest n succ [] map_consts; + if exp_debug then eprintf "Iop/Oaddimm\n"; + exp := addimm32 vn a1 dest n None; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oaddlimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oaddlimm\n"; - exp := addimm64 a1 dest n succ [] map_consts; + if exp_debug then eprintf "Iop/Oaddlimm\n"; + exp := addimm64 vn a1 dest n None; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oandimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oandimm\n"; - exp := andimm32 a1 dest n succ [] map_consts; + if exp_debug then eprintf "Iop/Oandimm\n"; + exp := andimm32 vn a1 dest n; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oandlimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oandlimm\n"; - exp := andimm64 a1 dest n succ [] map_consts; + if exp_debug then eprintf "Iop/Oandlimm\n"; + exp := andimm64 vn a1 dest n; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oorimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oorimm\n"; - exp := orimm32 a1 dest n succ [] map_consts; + if exp_debug then eprintf "Iop/Oorimm\n"; + exp := orimm32 vn a1 dest n; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oorlimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oorlimm\n"; - exp := orimm64 a1 dest n succ [] map_consts; + if exp_debug then eprintf "Iop/Oorlimm\n"; + exp := orimm64 vn a1 dest n; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocast8signed, a1 :: nil, dest, succ) -> - debug "Iop/cast8signed"; + if exp_debug then eprintf "Iop/cast8signed\n"; let op = Oshlimm (Int.repr (Z.of_sint 24)) in let r = r2pi () in - let sv = find_or_addnmove op [ a1 ] r (n2pi ()) map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in + let i1 = addinst vn op [ a1 ] r in + let r', l = extract_arg [ i1 ] in exp := - build_full_ilist - (Oshrimm (Int.repr (Z.of_sint 24))) - [ r' ] dest succ (fst ht) [] map_consts; + addinst vn (Oshrimm (Int.repr (Z.of_sint 24))) [ r' ] dest :: l; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocast16signed, a1 :: nil, dest, succ) -> - debug "Iop/cast8signed"; + if exp_debug then eprintf "Iop/cast16signed\n"; let op = Oshlimm (Int.repr (Z.of_sint 16)) in let r = r2pi () in - let sv = find_or_addnmove op [ a1 ] r (n2pi ()) map_consts true in - let ht = build_head_tuple [] sv in - let r' = unzip_head_tuple ht r in + let i1 = addinst vn op [ a1 ] r in + let r', l = extract_arg [ i1 ] in exp := - build_full_ilist - (Oshrimm (Int.repr (Z.of_sint 16))) - [ r' ] dest succ (fst ht) [] map_consts; + addinst vn (Oshrimm (Int.repr (Z.of_sint 16))) [ r' ] dest :: l; + exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocast32unsigned, a1 :: nil, dest, succ) -> - debug "Iop/Ocast32unsigned"; - let n2 = n2pi () in - let n1 = n2pi () in + if exp_debug then eprintf "Iop/Ocast32unsigned\n"; let r1 = r2pi () in let r2 = r2pi () in let op1 = Ocast32signed in - let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in - let ht1 = build_head_tuple [] sv1 in - let r1' = unzip_head_tuple ht1 r1 in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in let op2 = Oshllimm (Int.repr (Z.of_sint 32)) in - let sv2 = find_or_addnmove op2 [ r1' ] r2 n2 map_consts true in - let ht2 = build_head_tuple (fst ht1) sv2 in - let r2' = unzip_head_tuple ht2 r2 in + let i2 = addinst vn op2 [ r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in let op3 = Oshrluimm (Int.repr (Z.of_sint 32)) in - exp := build_full_ilist op3 [ r2' ] dest succ (fst ht2) [] map_consts + exp := addinst vn op3 [ r2' ] dest :: l2; + exp := extract_final vn !exp dest succ; + was_exp := true | Iop (Oshrximm n, a1 :: nil, dest, succ) -> - debug "Iop/Oshrximm"; - if Int.eq n Int.zero then exp := [ Iop (Omove, [ a1 ], dest, succ) ] - else if Int.eq n Int.one then - let n2 = n2pi () in - let n1 = n2pi () in + if Int.eq n Int.zero then ( + if exp_debug then eprintf "Iop/Oshrximm1\n"; + exp := [ addinst vn (OEmayundef (MUshrx n)) [ a1; a1 ] dest ]) + else if Int.eq n Int.one then ( + if exp_debug then eprintf "Iop/Oshrximm2\n"; let r1 = r2pi () in let r2 = r2pi () in let op1 = Oshruimm (Int.repr (Z.of_sint 31)) in - let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in - let ht1 = build_head_tuple [] sv1 in - let r1' = unzip_head_tuple ht1 r1 in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in let op2 = Oadd in - let sv2 = find_or_addnmove op2 [ a1; r1' ] r2 n2 map_consts true in - let ht2 = build_head_tuple (fst ht1) sv2 in - let r2' = unzip_head_tuple ht2 r2 in + let i2 = addinst vn op2 [ a1; r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in let op3 = Oshrimm Int.one in - exp := - build_full_ilist op3 [ r2' ] dest succ (fst ht2) [] map_consts - else - let n3 = n2pi () in - let n2 = n2pi () in - let n1 = n2pi () in + let i3 = addinst vn op3 [ r2' ] dest in + let r3, l3 = extract_arg (i3 :: l2) in + exp := addinst vn (OEmayundef (MUshrx n)) [ r3; r3 ] dest :: l3) + else ( + if exp_debug then eprintf "Iop/Oshrximm3\n"; let r1 = r2pi () in let r2 = r2pi () in let r3 = r2pi () in let op1 = Oshrimm (Int.repr (Z.of_sint 31)) in - let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in - let ht1 = build_head_tuple [] sv1 in - let r1' = unzip_head_tuple ht1 r1 in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in let op2 = Oshruimm (Int.sub Int.iwordsize n) in - let sv2 = find_or_addnmove op2 [ r1' ] r2 n2 map_consts true in - let ht2 = build_head_tuple (fst ht1) sv2 in - let r2' = unzip_head_tuple ht2 r2 in + let i2 = addinst vn op2 [ r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in let op3 = Oadd in - let sv3 = find_or_addnmove op3 [ a1; r2' ] r3 n3 map_consts true in - let ht3 = build_head_tuple (fst ht2) sv3 in - let r3' = unzip_head_tuple ht3 r3 in + let i3 = addinst vn op3 [ a1; r2' ] r3 in + let r3', l3 = extract_arg (i3 :: l2) in let op4 = Oshrimm n in - exp := - build_full_ilist op4 [ r3' ] dest succ (fst ht3) [] map_consts + let i4 = addinst vn op4 [ r3' ] dest in + let r4, l4 = extract_arg (i4 :: l3) in + exp := addinst vn (OEmayundef (MUshrx n)) [ r4; r4 ] dest :: l4); + exp := extract_final vn !exp dest succ; + was_exp := true | Iop (Oshrxlimm n, a1 :: nil, dest, succ) -> - debug "Iop/Oshrxlimm"; - if Int.eq n Int.zero then exp := [ Iop (Omove, [ a1 ], dest, succ) ] - else if Int.eq n Int.one then - let n2 = n2pi () in - let n1 = n2pi () in + if Int.eq n Int.zero then ( + if exp_debug then eprintf "Iop/Oshrxlimm1\n"; + exp := [ addinst vn (OEmayundef (MUshrxl n)) [ a1; a1 ] dest ]) + else if Int.eq n Int.one then ( + if exp_debug then eprintf "Iop/Oshrxlimm2\n"; let r1 = r2pi () in let r2 = r2pi () in let op1 = Oshrluimm (Int.repr (Z.of_sint 63)) in - let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in - let ht1 = build_head_tuple [] sv1 in - let r1' = unzip_head_tuple ht1 r1 in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in let op2 = Oaddl in - let sv2 = find_or_addnmove op2 [ a1; r1' ] r2 n2 map_consts true in - let ht2 = build_head_tuple (fst ht1) sv2 in - let r2' = unzip_head_tuple ht2 r2 in + let i2 = addinst vn op2 [ a1; r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in let op3 = Oshrlimm Int.one in - exp := - build_full_ilist op3 [ r2' ] dest succ (fst ht2) [] map_consts - else - let n3 = n2pi () in - let n2 = n2pi () in - let n1 = n2pi () in + let i3 = addinst vn op3 [ r2' ] dest in + let r3, l3 = extract_arg (i3 :: l2) in + exp := addinst vn (OEmayundef (MUshrxl n)) [ r3; r3 ] dest :: l3) + else ( + if exp_debug then eprintf "Iop/Oshrxlimm3\n"; let r1 = r2pi () in let r2 = r2pi () in let r3 = r2pi () in let op1 = Oshrlimm (Int.repr (Z.of_sint 63)) in - let sv1 = find_or_addnmove op1 [ a1 ] r1 n1 map_consts true in - let ht1 = build_head_tuple [] sv1 in - let r1' = unzip_head_tuple ht1 r1 in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in let op2 = Oshrluimm (Int.sub Int64.iwordsize' n) in - let sv2 = find_or_addnmove op2 [ r1' ] r2 n2 map_consts true in - let ht2 = build_head_tuple (fst ht1) sv2 in - let r2' = unzip_head_tuple ht2 r2 in + let i2 = addinst vn op2 [ r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in let op3 = Oaddl in - let sv3 = find_or_addnmove op3 [ a1; r2' ] r3 n3 map_consts true in - let ht3 = build_head_tuple (fst ht2) sv3 in - let r3' = unzip_head_tuple ht3 r3 in + let i3 = addinst vn op3 [ a1; r2' ] r3 in + let r3', l3 = extract_arg (i3 :: l2) in let op4 = Oshrlimm n in - exp := - build_full_ilist op4 [ r3' ] dest succ (fst ht3) [] map_consts + let i4 = addinst vn op4 [ r3' ] dest in + let r4, l4 = extract_arg (i4 :: l3) in + exp := addinst vn (OEmayundef (MUshrxl n)) [ r4; r4 ] dest :: l4); + exp := extract_final vn !exp dest succ; + was_exp := true + (*| Iop (Oaddrstack n, nil, dest, succ) ->*) + (*if exp_debug then eprintf "Iop/Oaddrstack\n";*) + (*exp := addptrofs vn n dest;*) + (*exp := extract_final vn !exp dest succ;*) + (*was_exp := true*) | _ -> ()); + (* Update the CSE numbering *) + (if not !was_exp then + match inst with + | Iop (op, args, dest, succ) -> + let v = get_nvalues vn args in + addsop vn v op dest + | Iload (_, _, _, _, dst, _) -> set_unknown vn dst + | Istore (chk, addr, args, src, s) -> + !vn.seqs <- kill_mem_operations !vn.seqs + | Icall (_, _, _, _, _) | Itailcall (_, _, _) | Ibuiltin (_, _, _, _) -> + vn := empty_numbering () + | _ -> ()); + (* Update code, liveins, pathmap, and order of the superblock for one expansion *) if !was_exp then ( + node := !node + List.length !exp - 1; (if !was_branch && List.length !exp > 1 then let lives = PTree.get n !liveins in match lives with @@ -880,14 +1063,15 @@ let expanse (sb : superblock) code pm = liveins := PTree.remove n !liveins | _ -> ()); write_pathmap sb.instructions.(0) (List.length !exp - 1) pm'; - write_tree !exp n !node code' new_order true) + write_tree vn (List.rev !exp) n !node code' new_order true) else new_order := n :: !new_order) sb.instructions; sb.instructions <- Array.of_list (List.rev !new_order); sb.liveins <- !liveins; - (*debug_flag := false;*) (!code', !pm') +(** Compute the last used node and reg indexs *) + let rec find_last_node_reg = function | [] -> () | (pc, i) :: k -> diff --git a/riscV/NeedOp.v b/riscV/NeedOp.v index 715951a0..d0ca5bb2 100644 --- a/riscV/NeedOp.v +++ b/riscV/NeedOp.v @@ -87,7 +87,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv) | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) | Ocmp c => needs_of_condition c - | OEimmR0 _ => op1 (default nv) + | OEmoveSP => nil | OEseqw _ => op2 (default nv) | OEsnew _ => op2 (default nv) | OEsequw _ => op2 (default nv) @@ -98,7 +98,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | OEsltiuw _ => op1 (default nv) | OExoriw _ => op1 (bitwise nv) | OEluiw _ => op1 (default nv) - | OEaddiw _ => op1 (default nv) + | OEaddiw _ _ => op1 (default nv) | OEandiw n => op1 (andimm nv n) | OEoriw n => op1 (orimm nv n) | OEseql _ => op2 (default nv) @@ -111,7 +111,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | OEsltiul _ => op1 (default nv) | OExoril _ => op1 (default nv) | OEluil _ => op1 (default nv) - | OEaddil _ => op1 (default nv) + | OEaddil _ _ => op1 (default nv) | OEandil _ => op1 (default nv) | OEoril _ => op1 (default nv) | OEloadli _ => op1 (default nv) diff --git a/riscV/Op.v b/riscV/Op.v index a8ff3666..9d1826ac 100644 --- a/riscV/Op.v +++ b/riscV/Op.v @@ -38,10 +38,12 @@ Set Implicit Arguments. (** Conditions (boolean-valued operators). *) -(* Type to modelize the use of a special register in arith operations *) +(** Type to modelize the use of a special register in arith operations *) + Inductive oreg: Type := | X0_L: oreg - | X0_R: oreg. + | X0_R: oreg + | SP_S: oreg. Inductive condition : Type := | Ccomp (c: comparison) (**r signed integer comparison *) @@ -75,17 +77,13 @@ Inductive condition : Type := | CEbgeul (optR: option oreg). (**r branch-if-greater-or-equal unsigned *) (* This type will define the eval function of a OEmayundef operation. *) + Inductive mayundef: Type := | MUint: mayundef | MUlong: mayundef | MUshrx: int -> mayundef | MUshrxl: int -> mayundef. -(* Type for allowing a single RTL constructor to perform an arith operation between an immediate and X0 *) -Inductive opimm: Type := - | OPimmADD: int -> opimm - | OPimmADDL: int64 -> opimm. - (** Arithmetic and logical operations. In the descriptions, [rd] is the result of the operation and [r1], [r2], etc, are the arguments. *) @@ -189,41 +187,41 @@ Inductive operation : Type := (*c Boolean tests: *) | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) (* Expansed conditions *) - | OEimmR0 (opi: opimm) + | OEmoveSP | OEseqw (optR: option oreg) (**r [rd <- rs1 == rs2] signed *) | OEsnew (optR: option oreg) (**r [rd <- rs1 != rs2] signed *) | OEsequw (optR: option oreg) (**r [rd <- rs1 == rs2] unsigned *) | OEsneuw (optR: option oreg) (**r [rd <- rs1 != rs2] unsigned *) | OEsltw (optR: option oreg) (**r set-less-than *) | OEsltuw (optR: option oreg) (**r set-less-than unsigned *) - | OEsltiw (n: int) (**r set-less-than immediate *) - | OEsltiuw (n: int) (**r set-less-than unsigned immediate *) - | OEaddiw (n: int) (**r add immediate *) - | OEandiw (n: int) (**r and immediate *) - | OEoriw (n: int) (**r or immediate *) - | OExoriw (n: int) (**r xor immediate *) - | OEluiw (n: int) (**r load upper-immediate *) + | OEsltiw (n: int) (**r set-less-than immediate *) + | OEsltiuw (n: int) (**r set-less-than unsigned immediate *) + | OEaddiw (optR: option oreg) (n: int) (**r add immediate *) + | OEandiw (n: int) (**r and immediate *) + | OEoriw (n: int) (**r or immediate *) + | OExoriw (n: int) (**r xor immediate *) + | OEluiw (n: int) (**r load upper-immediate *) | OEseql (optR: option oreg) (**r [rd <- rs1 == rs2] signed *) | OEsnel (optR: option oreg) (**r [rd <- rs1 != rs2] signed *) | OEsequl (optR: option oreg) (**r [rd <- rs1 == rs2] unsigned *) | OEsneul (optR: option oreg) (**r [rd <- rs1 != rs2] unsigned *) | OEsltl (optR: option oreg) (**r set-less-than *) | OEsltul (optR: option oreg) (**r set-less-than unsigned *) - | OEsltil (n: int64) (**r set-less-than immediate *) - | OEsltiul (n: int64) (**r set-less-than unsigned immediate *) - | OEaddil (n: int64) (**r add immediate *) - | OEandil (n: int64) (**r and immediate *) - | OEoril (n: int64) (**r or immediate *) - | OExoril (n: int64) (**r xor immediate *) - | OEluil (n: int64) (**r load upper-immediate *) - | OEloadli (n: int64) (**r load an immediate int64 *) + | OEsltil (n: int64) (**r set-less-than immediate *) + | OEsltiul (n: int64) (**r set-less-than unsigned immediate *) + | OEaddil (optR: option oreg) (n: int64) (**r add immediate *) + | OEandil (n: int64) (**r and immediate *) + | OEoril (n: int64) (**r or immediate *) + | OExoril (n: int64) (**r xor immediate *) + | OEluil (n: int64) (**r load upper-immediate *) + | OEloadli (n: int64) (**r load an immediate int64 *) | OEmayundef (mu: mayundef) - | OEfeqd (**r compare equal *) - | OEfltd (**r compare less-than *) - | OEfled (**r compare less-than/equal *) - | OEfeqs (**r compare equal *) - | OEflts (**r compare less-than *) - | OEfles (**r compare less-than/equal *) + | OEfeqd (**r compare equal *) + | OEfltd (**r compare less-than *) + | OEfled (**r compare less-than/equal *) + | OEfeqs (**r compare equal *) + | OEflts (**r compare less-than *) + | OEfles (**r compare less-than/equal *) | Obits_of_single | Obits_of_float | Osingle_of_bits @@ -277,47 +275,46 @@ Defined. *) Global Opaque eq_condition eq_addressing eq_operation. + +(** Generic function to evaluate an instruction according to the given specific register *) Definition zero32 := (Vint Int.zero). Definition zero64 := (Vlong Int64.zero). -Definition apply_bin_oreg {B} (optR: option oreg) (sem: val -> val -> B) (v1 v2 vz: val): B := +Definition apply_bin_oreg {B} (optR: option oreg) (sem: val -> val -> B) (v1 v2 vz sp: val): B := match optR with | None => sem v1 v2 | Some X0_L => sem vz v1 | Some X0_R => sem v1 vz + | Some SP_S => sem v1 sp end. +(** Mayundef evaluation according to the above defined type *) + Definition eval_may_undef (mu: mayundef) (v1 v2: val): val := match mu with - | MUint => match v1 with - | Vint _ => v2 - | _ => Vundef + | MUint => match v1, v2 with + | Vint _, Vint _ => v2 + | _, _ => Vundef end - | MUlong => match v1 with - | Vlong _ => v2 - | _ => Vundef + | MUlong => match v1, v2 with + | Vlong _, Vint _ => v2 + | _, _ => Vundef end | MUshrx i => - match v1 with - | Vint _ => - if Int.ltu i (Int.repr 31) then v1 else Vundef - | _ => Vundef + match v1, v2 with + | Vint _, Vint _ => + if Int.ltu i (Int.repr 31) then v2 else Vundef + | _, _ => Vundef end | MUshrxl i => - match v1 with - | Vlong _ => - if Int.ltu i (Int.repr 63) then v1 else Vundef - | _ => Vundef + match v1, v2 with + | Vlong _, Vlong _ => + if Int.ltu i (Int.repr 63) then v2 else Vundef + | _, _ => Vundef end end. -Definition eval_opimmR0 (opi: opimm): val := - match opi with - | OPimmADD i => Val.add (Vint i) zero32 - | OPimmADDL i => Val.addl (Vlong i) zero64 - end. - (** * Evaluation functions *) (** Evaluation of conditions, operators and addressing modes applied @@ -340,25 +337,33 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2 | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) (* Expansed branches *) - | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Ceq) v1 v2 zero32 - | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cne) v1 v2 zero32 - | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero32 - | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cne) v1 v2 zero32 - | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Clt) v1 v2 zero32 - | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Clt) v1 v2 zero32 - | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cge) v1 v2 zero32 - | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cge) v1 v2 zero32 - | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Ceq) v1 v2 zero64 - | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cne) v1 v2 zero64 - | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero64 - | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cne) v1 v2 zero64 - | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Clt) v1 v2 zero64 - | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Clt) v1 v2 zero64 - | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cge) v1 v2 zero64 - | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cge) v1 v2 zero64 + | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Ceq) v1 v2 zero32 Vundef + | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cne) v1 v2 zero32 Vundef + | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero32 Vundef + | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cne) v1 v2 zero32 Vundef + | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Clt) v1 v2 zero32 Vundef + | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Clt) v1 v2 zero32 Vundef + | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cge) v1 v2 zero32 Vundef + | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cge) v1 v2 zero32 Vundef + | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Ceq) v1 v2 zero64 Vundef + | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cne) v1 v2 zero64 Vundef + | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero64 Vundef + | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cne) v1 v2 zero64 Vundef + | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Clt) v1 v2 zero64 Vundef + | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Clt) v1 v2 zero64 Vundef + | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cge) v1 v2 zero64 Vundef + | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cge) v1 v2 zero64 Vundef | _, _ => None end. +(** Assert sp is a pointer *) + +Definition get_sp sp := + match sp with + | Vptr _ _ => sp + | _ => Vundef + end. + Definition eval_operation (F V: Type) (genv: Genv.t F V) (sp: val) (op: operation) (vl: list val) (m: mem): option val := @@ -461,31 +466,41 @@ Definition eval_operation | Ofloat_of_bits, v1::nil => Some (ExtValues.float_of_bits v1) | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) (* Expansed conditions *) - | OEimmR0 opi, nil => Some (eval_opimmR0 opi) - | OEseqw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Ceq) v1 v2 zero32) - | OEsnew optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Cne) v1 v2 zero32) - | OEsequw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Ceq) v1 v2 zero32) - | OEsneuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Cne) v1 v2 zero32) - | OEsltw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Clt) v1 v2 zero32) - | OEsltuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Clt) v1 v2 zero32) + | OEmoveSP, nil => Some (get_sp sp) + | OEseqw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Ceq) v1 v2 zero32 Vundef) + | OEsnew optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Cne) v1 v2 zero32 Vundef) + | OEsequw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Ceq) v1 v2 zero32 Vundef) + | OEsneuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Cne) v1 v2 zero32 Vundef) + | OEsltw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Clt) v1 v2 zero32 Vundef) + | OEsltuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Clt) v1 v2 zero32 Vundef) | OEsltiw n, v1::nil => Some (Val.cmp Clt v1 (Vint n)) | OEsltiuw n, v1::nil => Some (Val.cmpu (Mem.valid_pointer m) Clt v1 (Vint n)) | OExoriw n, v1::nil => Some (Val.xor v1 (Vint n)) | OEluiw n, nil => Some (Val.shl (Vint n) (Vint (Int.repr 12))) - | OEaddiw n, v1::nil => Some (Val.add (Vint n) v1) + | OEaddiw optR n, nil => Some (apply_bin_oreg optR Val.add (Vint n) Vundef zero32 Vundef) + | OEaddiw ((Some SP_S) as optR) n, v1::nil => + let sp' := Val.add (Vint n) (get_sp sp) in + Some (apply_bin_oreg optR Val.add v1 Vundef Vundef sp') + | OEaddiw optR n, v1::nil => + Some (apply_bin_oreg optR Val.add v1 (Vint n) Vundef (get_sp sp)) | OEandiw n, v1::nil => Some (Val.and (Vint n) v1) | OEoriw n, v1::nil => Some (Val.or (Vint n) v1) - | OEseql optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Ceq) v1 v2 zero64)) - | OEsnel optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Cne) v1 v2 zero64)) - | OEsequl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Ceq) v1 v2 zero64)) - | OEsneul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Cne) v1 v2 zero64)) - | OEsltl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Clt) v1 v2 zero64)) - | OEsltul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Clt) v1 v2 zero64)) + | OEseql optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Ceq) v1 v2 zero64 Vundef)) + | OEsnel optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Cne) v1 v2 zero64 Vundef)) + | OEsequl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Ceq) v1 v2 zero64 Vundef)) + | OEsneul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Cne) v1 v2 zero64 Vundef)) + | OEsltl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Clt) v1 v2 zero64 Vundef)) + | OEsltul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Clt) v1 v2 zero64 Vundef)) | OEsltil n, v1::nil => Some (Val.maketotal (Val.cmpl Clt v1 (Vlong n))) | OEsltiul n, v1::nil => Some (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 (Vlong n))) | OExoril n, v1::nil => Some (Val.xorl v1 (Vlong n)) | OEluil n, nil => Some (Vlong (Int64.sign_ext 32 (Int64.shl n (Int64.repr 12)))) - | OEaddil n, v1::nil => Some (Val.addl (Vlong n) v1) + | OEaddil optR n, nil => Some (apply_bin_oreg optR Val.addl (Vlong n) Vundef zero64 Vundef) + | OEaddil ((Some SP_S) as optR) n, v1::nil => + let sp' := Val.addl (Vlong n) (get_sp sp) in + Some (apply_bin_oreg optR Val.addl v1 Vundef Vundef sp') + | OEaddil optR n, v1::nil => + Some (apply_bin_oreg optR Val.addl v1 (Vlong n) Vundef (get_sp sp)) | OEandil n, v1::nil => Some (Val.andl (Vlong n) v1) | OEoril n, v1::nil => Some (Val.orl (Vlong n) v1) | OEloadli n, nil => Some (Vlong n) @@ -574,12 +589,23 @@ Definition type_of_condition (c: condition) : list typ := | CEbgeul _ => Tlong :: Tlong :: nil end. -Definition type_of_opimmR0 (opi: opimm) : typ := - match opi with - | OPimmADD _ => Tint - | OPimmADDL _ => Tlong +(** The type of mayundef and addsp is dynamic *) + +Definition type_of_mayundef mu := + match mu with + | MUint | MUshrx _ => (Tint :: Tint :: nil, Tint) + | MUlong => (Tlong :: Tint :: nil, Tint) + | MUshrxl _ => (Tlong :: Tlong :: nil, Tlong) end. +Definition type_addsp (is_long: bool): list typ * typ := + if Archi.ptr64 then ( + if is_long then (Tlong :: nil, Tptr) + else (nil, Tint)) + else ( + if is_long then (nil, Tlong) + else (Tint :: nil, Tptr)). + Definition type_of_operation (op: operation) : list typ * typ := match op with | Omove => (nil, Tint) (* treated specially *) @@ -675,7 +701,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Osingleoflong => (Tlong :: nil, Tsingle) | Osingleoflongu => (Tlong :: nil, Tsingle) | Ocmp c => (type_of_condition c, Tint) - | OEimmR0 opi => (nil, type_of_opimmR0 opi) + | OEmoveSP => (nil, Tptr) | OEseqw _ => (Tint :: Tint :: nil, Tint) | OEsnew _ => (Tint :: Tint :: nil, Tint) | OEsequw _ => (Tint :: Tint :: nil, Tint) @@ -686,7 +712,9 @@ Definition type_of_operation (op: operation) : list typ * typ := | OEsltiuw _ => (Tint :: nil, Tint) | OExoriw _ => (Tint :: nil, Tint) | OEluiw _ => (nil, Tint) - | OEaddiw _ => (Tint :: nil, Tint) + | OEaddiw None _ => (Tint :: nil, Tint) + | OEaddiw (Some SP_S) _ => type_addsp false + | OEaddiw (Some _) _ => (nil, Tint) | OEandiw _ => (Tint :: nil, Tint) | OEoriw _ => (Tint :: nil, Tint) | OEseql _ => (Tlong :: Tlong :: nil, Tint) @@ -701,9 +729,11 @@ Definition type_of_operation (op: operation) : list typ * typ := | OEoril _ => (Tlong :: nil, Tlong) | OExoril _ => (Tlong :: nil, Tlong) | OEluil _ => (nil, Tlong) - | OEaddil _ => (Tlong :: nil, Tlong) + | OEaddil None _ => (Tlong :: nil, Tlong) + | OEaddil (Some SP_S) _ => type_addsp true + | OEaddil (Some _) _ => (nil, Tlong) | OEloadli _ => (nil, Tlong) - | OEmayundef _ => (Tany64 :: Tany64 :: nil, Tany64) + | OEmayundef mu => type_of_mayundef mu | OEfeqd => (Tfloat :: Tfloat :: nil, Tint) | OEfltd => (Tfloat :: Tfloat :: nil, Tint) | OEfled => (Tfloat :: Tfloat :: nil, Tint) @@ -746,7 +776,7 @@ Proof. Qed. Remark type_mayundef: - forall mu v1 v2, Val.has_type (eval_may_undef mu v1 v2) Tany64. + forall mu v1 v2, Val.has_type (eval_may_undef mu v1 v2) (snd (type_of_mayundef mu)). Proof. intros. unfold eval_may_undef. destruct mu eqn:EQMU, v1, v2; simpl; auto. @@ -762,7 +792,7 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). intros. destruct op; simpl; simpl in H0; FuncInv; subst; simpl. (* move *) - - congruence. + - simpl in H; congruence. (* intconst, longconst, floatconst, singleconst *) - exact I. - exact I. @@ -929,8 +959,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; cbn; trivial. (* cmp *) - destruct (eval_condition cond vl m)... destruct b... - (* OEimmR0 *) - - destruct opi; unfold eval_opimmR0; simpl; auto. + (* OEmoveSP *) + - destruct sp; unfold Tptr; destruct Archi.ptr64 eqn:?; + simpl; trivial. (* OEseqw *) - destruct optR as [[]|]; simpl; unfold Val.cmp; destruct Val.cmp_bool... all: destruct b... @@ -955,7 +986,12 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* OEsltiuw *) - unfold Val.cmpu; destruct Val.cmpu_bool... destruct b... (* OEaddiw *) - - fold (Val.add (Vint n) v0); apply type_add. + - destruct optR as [[]|]; simpl in *; trivial; + destruct vl; inv H0; simpl; trivial; + destruct vl; inv H2; simpl; trivial; + destruct v0; simpl; trivial; + destruct (get_sp sp); destruct Archi.ptr64 eqn:HA; simpl; trivial; + unfold type_addsp, Tptr; try rewrite HA; simpl; trivial. (* OEandiw *) - destruct v0... (* OEoriw *) @@ -988,7 +1024,12 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* OEsltiul *) - unfold Val.cmplu; destruct Val.cmplu_bool... destruct b... (* OEaddil *) - - fold (Val.addl (Vlong n) v0); apply type_addl. + - destruct optR as [[]|]; simpl in *; trivial; + destruct vl; inv H0; simpl; trivial; + destruct vl; inv H2; simpl; trivial; + destruct v0; simpl; trivial; + destruct (get_sp sp); destruct Archi.ptr64 eqn:HA; simpl; trivial; + unfold type_addsp, Tptr; try rewrite HA; simpl; trivial. (* OEandil *) - destruct v0... (* OEoril *) @@ -1052,11 +1093,15 @@ Lemma is_trapping_op_sound: eval_operation genv sp op vl m <> None. Proof. unfold args_of_operation. - destruct op; destruct eq_operation; intros; simpl in *; try congruence. + destruct op eqn:E; destruct eq_operation; intros; simpl in *; try congruence. all: try (destruct vl as [ | vh1 vl1]; try discriminate). all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). + all: try destruct optR as [[]|]; simpl in H0; try discriminate. + all: unfold type_addsp in *; simpl in *. + all: try destruct Archi.ptr64; simpl in *; try discriminate. + all: try destruct mu; simpl in *; try discriminate. Qed. End SOUNDNESS. @@ -1181,6 +1226,9 @@ Definition shift_stack_addressing (delta: Z) (addr: addressing) := Definition shift_stack_operation (delta: Z) (op: operation) := match op with | Oaddrstack ofs => Oaddrstack (Ptrofs.add ofs (Ptrofs.repr delta)) + | OEmoveSP => Oaddrstack (Ptrofs.add Ptrofs.zero (Ptrofs.repr delta)) + | OEaddiw (Some SP_S) n => OEaddiw (Some SP_S) (Ptrofs.to_int (Ptrofs.add (Ptrofs.of_int n) (Ptrofs.repr delta))) + | OEaddil (Some SP_S) n => OEaddil (Some SP_S) (Ptrofs.to_int64 (Ptrofs.add (Ptrofs.of_int64 n) (Ptrofs.repr delta))) | _ => op end. @@ -1193,7 +1241,8 @@ 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. + intros. destruct op; auto; + try destruct optR as [[]|]; simpl; auto. Qed. Lemma eval_shift_stack_addressing: @@ -1210,8 +1259,21 @@ Lemma eval_shift_stack_operation: eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m = eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m. Proof. - intros. destruct op; simpl; auto. destruct vl; auto. - rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. + intros. destruct op eqn:E; simpl; auto; destruct vl; auto. + - rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. + - rewrite !Ptrofs.add_zero_l; auto. + - destruct optR as [[]|]; simpl; auto. + - destruct vl, optR as [[]|]; auto; unfold apply_bin_oreg; simpl; auto. + destruct v, Archi.ptr64 eqn:EA; simpl; try rewrite EA; simpl; auto. + rewrite Ptrofs.add_zero_l; auto. + rewrite Ptrofs.of_int_to_int; auto. + rewrite (Ptrofs.add_commut (Ptrofs.of_int n) (Ptrofs.repr delta)); reflexivity. + - destruct optR as [[]|]; simpl; auto. + - destruct vl, optR as [[]|]; auto; unfold apply_bin_oreg; simpl; auto. + destruct Archi.ptr64 eqn:EA; auto. + rewrite Ptrofs.add_zero_l; auto. + rewrite Ptrofs.of_int64_to_int64; auto. + rewrite (Ptrofs.add_commut (Ptrofs.of_int64 n) (Ptrofs.repr delta)); reflexivity. Qed. (** Offset an addressing mode [addr] by a quantity [delta], so that @@ -1471,8 +1533,8 @@ Qed. Lemma eval_cmpu_bool_inj_opt: forall c v v' v0 v'0 optR, Val.inject f v v' -> Val.inject f v0 v'0 -> - Val.inject f (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m1) c) v v0 zero32) - (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m2) c) v' v'0 zero32). + Val.inject f (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m1) c) v v0 zero32 Vundef) + (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m2) c) v' v'0 zero32 Vundef). Proof. intros until optR. intros HV1 HV2. destruct optR as [[]|]; simpl; unfold zero32, Val.cmpu; @@ -1482,6 +1544,9 @@ Proof. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + exploit eval_cmpu_bool_inj'. eapply HV1. eapply HVI. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + + exploit eval_cmpu_bool_inj'. eapply HV1. do 2 instantiate (1:=Vundef). + eauto. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + exploit eval_cmpu_bool_inj'. eapply HV1. eapply HV2. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. Qed. @@ -1512,8 +1577,8 @@ Qed. Lemma eval_cmplu_bool_inj_opt: forall c v v' v0 v'0 optR, Val.inject f v v' -> Val.inject f v0 v'0 -> - Val.inject f (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m1) c) v v0 zero64)) - (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m2) c) v' v'0 zero64)). + Val.inject f (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m1) c) v v0 zero64 Vundef)) + (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m2) c) v' v'0 zero64 Vundef)). Proof. intros until optR. intros HV1 HV2. destruct optR as [[]|]; simpl; unfold zero64, Val.cmplu; @@ -1523,6 +1588,9 @@ Proof. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + exploit eval_cmplu_bool_inj'. eapply HV1. eapply HVI. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + + exploit eval_cmplu_bool_inj'. eapply HV1. do 2 instantiate (1:=Vundef). + eauto. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + exploit eval_cmplu_bool_inj'. eapply HV1. eapply HV2. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. Qed. @@ -1789,8 +1857,9 @@ Proof. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. destruct b; simpl; constructor. simpl; constructor. - (* OEimmR0 *) - - destruct opi; unfold eval_opimmR0; simpl; auto. + (* moveSP *) + - unfold get_sp; inv H; auto. + econstructor; eauto. (* OEseqw *) - destruct optR as [[]|]; simpl; unfold zero32, Val.cmp; inv H4; inv H2; simpl; try destruct (Int.eq _ _); simpl; cbn; auto; @@ -1814,9 +1883,14 @@ Proof. (* OEsltiuw *) - apply eval_cmpu_bool_inj; auto. (* OEaddiw *) - - fold (Val.add (Vint n) v); - fold (Val.add (Vint n) v'); + - destruct optR as [[]|]; auto; simpl; FuncInv; InvInject; TrivialExists; + try fold (Val.add (Vint n) (get_sp sp1)); + try fold (Val.add (Vint n) (get_sp sp2)); + (*try destruct (get_sp sp1), (get_sp sp2);*) apply Val.add_inject; auto. + apply Val.add_inject; auto. + destruct sp1, sp2; simpl; auto; + inv H. (* OEandiw *) - inv H4; cbn; auto. (* OEoriw *) @@ -1848,9 +1922,13 @@ Proof. (* OEsltiul *) - apply eval_cmplu_bool_inj; auto. (* OEaddil *) - - fold (Val.addl (Vlong n) v); - fold (Val.addl (Vlong n) v'); + - destruct optR as [[]|]; auto; simpl; FuncInv; InvInject; TrivialExists; + try fold (Val.addl (Vlong n) (get_sp sp1)); + try fold (Val.addl (Vlong n) (get_sp sp2)); + apply Val.addl_inject; auto. apply Val.addl_inject; auto. + destruct sp1, sp2; simpl; auto; + inv H. (* OEandil *) - inv H4; cbn; auto. (* OEoril *) diff --git a/riscV/PrintOp.ml b/riscV/PrintOp.ml index e18d31f6..53730a1b 100644 --- a/riscV/PrintOp.ml +++ b/riscV/PrintOp.ml @@ -36,14 +36,16 @@ let mu_name pp = function | MUshrx i -> fprintf pp "MUshrx(%ld)" (camlint_of_coqint i) | MUshrxl i -> fprintf pp "MUshrxl(%ld)" (camlint_of_coqint i) -let get_immR0 pp = function - | OPimmADD i -> fprintf pp "OPimmADD(%ld)" (camlint_of_coqint i) - | OPimmADDL i -> fprintf pp "OPimmADDL(%ld)" (camlint_of_coqint i) - let get_optR_s c reg pp r1 r2 = function | None -> fprintf pp "(%a %s %a)" reg r1 (comparison_name c) reg r2 | Some X0_L -> fprintf pp "(X0 %s %a)" (comparison_name c) reg r1 | Some X0_R -> fprintf pp "(%a %s X0)" reg r1 (comparison_name c) + | Some SP_S -> failwith "PrintOp: SP_S in get_optR_s instruction (problem with RTL expansions?)" + +let get_optR_a pp = function + | None -> failwith "PrintOp: None in get_optR_a instruction (problem with RTL expansions?)" + | Some X0_L | Some X0_R -> fprintf pp "X0" + | Some SP_S -> fprintf pp "SP" let print_condition reg pp = function | (Ccomp c, [r1;r2]) -> @@ -203,7 +205,6 @@ let print_operation reg pp = function | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 | Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1 | Ocmp c, args -> print_condition reg pp (c, args) - | OEimmR0 opi, [] -> fprintf pp "OEimmR0(%a)" get_immR0 opi | OEseqw optR, [r1;r2] -> fprintf pp "OEseqw"; (get_optR_s Ceq reg pp r1 r2 optR) | OEsnew optR, [r1;r2] -> fprintf pp "OEsnew"; (get_optR_s Cne reg pp r1 r2 optR) | OEsequw optR, [r1;r2] -> fprintf pp "OEsequw"; (get_optR_s Ceq reg pp r1 r2 optR) @@ -214,7 +215,8 @@ let print_operation reg pp = function | OEsltiuw n, [r1] -> fprintf pp "OEsltiuw(%a,%ld)" reg r1 (camlint_of_coqint n) | OExoriw n, [r1] -> fprintf pp "OExoriw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEluiw n, _ -> fprintf pp "OEluiw(%ld)" (camlint_of_coqint n) - | OEaddiw n, [r1] -> fprintf pp "OEaddiw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEaddiw (optR, n), [] -> fprintf pp "OEaddiw(%a,%ld)" get_optR_a optR (camlint_of_coqint n) + | OEaddiw (optR, n), [r1] -> fprintf pp "OEaddiw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEandiw n, [r1] -> fprintf pp "OEandiw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEoriw n, [r1] -> fprintf pp "OEoriw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEseql optR, [r1;r2] -> fprintf pp "OEseql"; (get_optR_s Ceq reg pp r1 r2 optR) @@ -227,7 +229,8 @@ let print_operation reg pp = function | OEsltiul n, [r1] -> fprintf pp "OEsltiul(%a,%ld)" reg r1 (camlint_of_coqint n) | OExoril n, [r1] -> fprintf pp "OExoril(%a,%ld)" reg r1 (camlint_of_coqint n) | OEluil n, _ -> fprintf pp "OEluil(%ld)" (camlint_of_coqint n) - | OEaddil n, [r1] -> fprintf pp "OEaddil(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEaddil (optR, n), [] -> fprintf pp "OEaddil(%a,%ld)" get_optR_a optR (camlint_of_coqint n) + | OEaddil (optR, n), [r1] -> fprintf pp "OEaddil(%a,%ld)" reg r1 (camlint_of_coqint n) | OEandil n, [r1] -> fprintf pp "OEandil(%a,%ld)" reg r1 (camlint_of_coqint n) | OEoril n, [r1] -> fprintf pp "OEoril(%a,%ld)" reg r1 (camlint_of_coqint n) | OEloadli n, _ -> fprintf pp "OEloadli(%ld)" (camlint_of_coqint n) diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index 5b44caba..c453dfb8 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -30,9 +30,9 @@ Definition make_lhsv_cmp (is_inv: bool) (hv1 hv2: hsval) : list_hsval := Definition make_lhsv_single (hvs: hsval) : list_hsval := fScons hvs fSnil. -(** Expansion functions *) +(** * Expansion functions *) -(* Immediate loads *) +(** ** Immediate loads *) Definition load_hilo32 (hi lo: int) := if Int.eq lo Int.zero then @@ -40,7 +40,7 @@ Definition load_hilo32 (hi lo: int) := else let hvs := fSop (OEluiw hi) fSnil in let hl := make_lhsv_single hvs in - fSop (OEaddiw lo) hl. + fSop (OEaddiw None lo) hl. Definition load_hilo64 (hi lo: int64) := if Int64.eq lo Int64.zero then @@ -48,19 +48,19 @@ Definition load_hilo64 (hi lo: int64) := else let hvs := fSop (OEluil hi) fSnil in let hl := make_lhsv_single hvs in - fSop (OEaddil lo) hl. + fSop (OEaddil None lo) hl. Definition loadimm32 (n: int) := match make_immed32 n with | Imm32_single imm => - fSop (OEimmR0 (OPimmADD imm)) fSnil + fSop (OEaddiw (Some X0_R) imm) fSnil | Imm32_pair hi lo => load_hilo32 hi lo end. Definition loadimm64 (n: int64) := match make_immed64 n with | Imm64_single imm => - fSop (OEimmR0 (OPimmADDL imm)) fSnil + fSop (OEaddil (Some X0_R) imm) fSnil | Imm64_pair hi lo => load_hilo64 hi lo | Imm64_large imm => fSop (OEloadli imm) fSnil end. @@ -91,20 +91,20 @@ Definition opimm64 (hv1: hsval) (n: int64) (op: operation) (opimm: int64 -> oper fSop op hl end. -Definition addimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oadd OEaddiw. +Definition addimm32 (hv1: hsval) (n: int) (or: option oreg) := opimm32 hv1 n Oadd (OEaddiw or). Definition andimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oand OEandiw. Definition orimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oor OEoriw. Definition xorimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oxor OExoriw. Definition sltimm32 (hv1: hsval) (n: int) := opimm32 hv1 n (OEsltw None) OEsltiw. Definition sltuimm32 (hv1: hsval) (n: int) := opimm32 hv1 n (OEsltuw None) OEsltiuw. -Definition addimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oaddl OEaddil. +Definition addimm64 (hv1: hsval) (n: int64) (or: option oreg) := opimm64 hv1 n Oaddl (OEaddil or). Definition andimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oandl OEandil. Definition orimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oorl OEoril. Definition xorimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oxorl OExoril. Definition sltimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltl None) OEsltil. Definition sltuimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltul None) OEsltiul. -(* Comparisons intructions *) +(** ** Comparisons intructions *) Definition cond_int32s (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := match cmp with @@ -260,7 +260,7 @@ Definition expanse_cond_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) := let hl := make_lhsv_single hvs in if normal' then hvs else fSop (OExoriw Int.one) hl. -(* Branches instructions *) +(** ** Branches instructions *) Definition transl_cbranch_int32s (cmp: comparison) (optR: option oreg) := match cmp with @@ -309,18 +309,37 @@ Definition expanse_cbranch_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) : (con let hl := make_lhsv_cmp false hvs hvs in if normal' then ((CEbnew (Some X0_R)), hl) else ((CEbeqw (Some X0_R)), hl). -(** Add pointer expansion *) +(** ** Add pointer expansion *) -(*Definition addptrofs (hv1: hsval) (n: ptrofs) :=*) - (*if Ptrofs.eq_dec n Ptrofs.zero then*) - (*let lhsv := make_lhsv_single hv1 in*) - (*fSop Omove lhsv*) - (*else*) - (*if Archi.ptr64*) - (*then addimm64 hv1 (Ptrofs.to_int64 n)*) - (*else addimm32 hv1 (Ptrofs.to_int n).*) - -(** Target op simplifications using "fake" values *) +Definition addptrofs (n: ptrofs) := + if Ptrofs.eq_dec n Ptrofs.zero then + fSop OEmoveSP fSnil + else + if Archi.ptr64 + then ( + match make_immed64 (Ptrofs.to_int64 n) with + | Imm64_single imm => + fSop (OEaddil (Some SP_S) imm) fSnil + | Imm64_pair hi lo => + let hvs := load_hilo64 hi lo in + let hl := make_lhsv_single hvs in + fSop (OEaddil (Some SP_S) Int64.zero) hl + | Imm64_large imm => + let hvs := fSop (OEloadli imm) fSnil in + let hl := make_lhsv_single hvs in + fSop (OEaddil (Some SP_S) Int64.zero) hl + end) + else ( + match make_immed32 (Ptrofs.to_int n) with + | Imm32_single imm => + fSop (OEaddiw (Some SP_S) imm) fSnil + | Imm32_pair hi lo => + let hvs := load_hilo32 hi lo in + let hl := make_lhsv_single hvs in + fSop (OEaddiw (Some SP_S) Int.zero) hl + end). + +(** * Target simplifications using "fake" values *) Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_local): option hsval := match op, lr with @@ -402,10 +421,10 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca Some (loadimm64 n) | Oaddimm n, a1 :: nil => let hv1 := fsi_sreg_get hst a1 in - Some (addimm32 hv1 n) + Some (addimm32 hv1 n None) | Oaddlimm n, a1 :: nil => let hv1 := fsi_sreg_get hst a1 in - Some (addimm64 hv1 n) + Some (addimm64 hv1 n None) | Oandimm n, a1 :: nil => let hv1 := fsi_sreg_get hst a1 in Some (andimm32 hv1 n) @@ -442,9 +461,8 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let hv1 := fsi_sreg_get hst a1 in let hl := make_lhsv_single hv1 in if Int.eq n Int.zero then - let move_s := fSop Omove hl in - let move_l := make_lhsv_cmp false move_s move_s in - Some (fSop (OEmayundef (MUshrx n)) move_l) + let lhl := make_lhsv_cmp false hv1 hv1 in + Some (fSop (OEmayundef (MUshrx n)) lhl) else if Int.eq n Int.one then let srliw_s := fSop (Oshruimm (Int.repr 31)) hl in @@ -468,9 +486,8 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let hv1 := fsi_sreg_get hst a1 in let hl := make_lhsv_single hv1 in if Int.eq n Int.zero then - let move_s := fSop Omove hl in - let move_l := make_lhsv_cmp false move_s move_s in - Some (fSop (OEmayundef (MUshrxl n)) move_l) + let lhl := make_lhsv_cmp false hv1 hv1 in + Some (fSop (OEmayundef (MUshrxl n)) lhl) else if Int.eq n Int.one then let srlil_s := fSop (Oshrluimm (Int.repr 63)) hl in @@ -490,9 +507,8 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let srail_s' := fSop (Oshrlimm n) addl_l in let srail_l' := make_lhsv_cmp false srail_s' srail_s' in Some (fSop (OEmayundef (MUshrxl n)) srail_l') - (*| Oaddrstack n, nil =>*) - (*let hv1 := fsi_sreg_get hst a1 in*) - (*OK (addptrofs hv1 n)*) + (* TODO gourdinl | Oaddrstack n, nil =>*) + (*Some (addptrofs n)*) | _, _ => None end. @@ -601,9 +617,9 @@ Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args | _, _ => None end. -(** Auxiliary lemmas on comparisons *) +(** * Auxiliary lemmas on comparisons *) -(* Signed ints *) +(** ** Signed ints *) Lemma xor_neg_ltle_cmp: forall v1 v2, Some (Val.xor (Val.cmp Clt v1 v2) (Vint Int.one)) = @@ -618,7 +634,7 @@ Proof. auto. Qed. -(* Unsigned ints *) +(** ** Unsigned ints *) Lemma xor_neg_ltle_cmpu: forall mptr v1 v2, Some (Val.xor (Val.cmpu (Mem.valid_pointer mptr) Clt v1 v2) (Vint Int.one)) = @@ -652,7 +668,7 @@ Proof. rewrite !Int.unsigned_repr; try cbn; try omega. Qed. -(* Signed longs *) +(** ** Signed longs *) Lemma xor_neg_ltle_cmpl: forall v1 v2, Some (Val.xor (Val.maketotal (Val.cmpl Clt v1 v2)) (Vint Int.one)) = @@ -748,7 +764,7 @@ Proof. apply Z.le_ge. trivial. Qed. -(* Unsigned longs *) +(** ** Unsigned longs *) Lemma xor_neg_ltle_cmplu: forall mptr v1 v2, Some (Val.xor (Val.maketotal (Val.cmplu (Mem.valid_pointer mptr) Clt v1 v2)) (Vint Int.one)) = @@ -794,7 +810,7 @@ Proof. repeat destruct (_ && _); simpl; auto. Qed. -(* Floats *) +(** ** Floats *) Lemma xor_neg_eqne_cmpf: forall v1 v2, Some (Val.xor (Val.cmpf Ceq v1 v2) (Vint Int.one)) = @@ -807,7 +823,7 @@ Proof. destruct (Float.cmp _ _ _); simpl; auto. Qed. -(* Singles *) +(** ** Singles *) Lemma xor_neg_eqne_cmpfs: forall v1 v2, Some (Val.xor (Val.cmpfs Ceq v1 v2) (Vint Int.one)) = @@ -820,7 +836,7 @@ Proof. destruct (Float32.cmp _ _ _); simpl; auto. Qed. -(* More useful lemmas *) +(** ** More useful lemmas *) Lemma xor_neg_optb: forall v, Some (Val.xor (Val.of_optbool (option_map negb v)) @@ -863,7 +879,7 @@ Proof. destruct x; destruct y; simpl; auto. rewrite Float32.cmp_swap. auto. Qed. -(* Intermediates lemmas on each expansed instruction *) +(** * Intermediates lemmas on each expanded instruction *) Lemma simplify_ccomp_correct ge sp hst st c r r0 rs0 m0 v v0: forall (SREG: forall r: positive, @@ -1026,7 +1042,6 @@ Proof. try rewrite EQIMM; try destruct (Archi.ptr64) eqn:EQARCH; simpl; try rewrite ltu_12_wordsize; trivial; try rewrite Int.add_commut, Int.add_zero_l in *; - try rewrite Int.add_commut; try rewrite Int.add_zero_l; try destruct (Int.ltu _ _) eqn:EQLTU; simpl; try rewrite EQLTU; simpl; try rewrite EQIMM; @@ -1149,25 +1164,21 @@ Proof. 1,2,3,4,5,6,7,8,9,10,11,12: try rewrite <- optbool_mktotal; trivial; try rewrite Int64.add_commut, Int64.add_zero_l in *; - try rewrite Int64.add_commut; - try rewrite Int64.add_zero_l; try fold (Val.cmpl Clt (Vlong i) (Vlong imm)); try fold (Val.cmpl Clt (Vlong i) (Vlong (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))))); try fold (Val.cmpl Clt (Vlong i) (Vlong (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo))); try rewrite xor_neg_ltge_cmpl; trivial; try rewrite xor_neg_ltle_cmpl; trivial. 6: - try rewrite Int64.add_commut; rewrite <- H; try apply cmpl_ltle_add_one; auto. all: try rewrite <- H; try apply cmpl_ltle_add_one; auto; + try rewrite <- cmpl_ltle_add_one; auto; try rewrite ltu_12_wordsize; try rewrite Int.add_commut, Int.add_zero_l in *; try rewrite Int64.add_commut, Int64.add_zero_l in *; - try rewrite Int.add_commut; - try rewrite Int64.add_commut; try rewrite Int64.add_zero_l; simpl; try rewrite lt_maxsgn_false_long; try (rewrite <- H; trivial; fail); @@ -1216,7 +1227,6 @@ Proof. unfold Val.cmplu, eval_may_undef, zero64, Val.addl; try apply Int64.same_if_eq in EQLO; subst; try rewrite Int64.add_commut, Int64.add_zero_l in *; trivial; - try rewrite Int64.add_commut; try rewrite Int64.add_zero_l; try (rewrite <- xor_neg_ltle_cmplu; unfold Val.cmplu; trivial; fail); @@ -1362,8 +1372,7 @@ Proof. - apply Int64.same_if_eq in EQLO; subst. try rewrite Int64.add_commut, Int64.add_zero_l in H. rewrite <- H; try rewrite Float.of_to_bits; trivial. - - try rewrite Int64.add_commut; - rewrite <- H; try rewrite Float.of_to_bits; trivial. + - rewrite <- H; try rewrite Float.of_to_bits; trivial. - rewrite <- H; try rewrite Float.of_to_bits; trivial. Qed. @@ -1392,7 +1401,6 @@ Proof. all: try apply Int.same_if_eq in EQLO; subst; try rewrite Int.add_commut, Int.add_zero_l in H; simpl; - try rewrite Int.add_commut in H; rewrite ltu_12_wordsize; simpl; try rewrite <- H; try rewrite Float32.of_to_bits; trivial. Qed. @@ -1403,7 +1411,7 @@ Lemma simplify_addimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall seval_sval ge sp (si_sreg st r) rs0 m0) (H : match lr with | nil => None - | a1 :: nil => Some (addimm32 (fsi_sreg_get hst a1) n) + | a1 :: nil => Some (addimm32 (fsi_sreg_get hst a1) n None) | a1 :: _ :: _ => None end = Some fsv) (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), @@ -1423,7 +1431,6 @@ Proof. all: try apply Int.same_if_eq in EQLO; subst; try rewrite Int.add_commut, Int.add_zero_l; - try rewrite Int.add_commut; try rewrite ltu_12_wordsize; trivial. Qed. @@ -1433,7 +1440,7 @@ Lemma simplify_addlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall seval_sval ge sp (si_sreg st r) rs0 m0) (H : match lr with | nil => None - | a1 :: nil => Some (addimm64 (fsi_sreg_get hst a1) n) + | a1 :: nil => Some (addimm64 (fsi_sreg_get hst a1) n None) | a1 :: _ :: _ => None end = Some fsv) (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), @@ -1483,7 +1490,6 @@ Proof. all: try apply Int.same_if_eq in EQLO; subst; try rewrite Int.add_commut, Int.add_zero_l; - try rewrite Int.add_commut; try rewrite ltu_12_wordsize; trivial. Qed. @@ -1543,7 +1549,6 @@ Proof. all: try apply Int.same_if_eq in EQLO; subst; try rewrite Int.add_commut, Int.add_zero_l; - try rewrite Int.add_commut; try rewrite ltu_12_wordsize; trivial. Qed. @@ -1595,7 +1600,6 @@ Proof. try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; try apply Int.same_if_eq in EQLO; subst; try rewrite Int.add_commut, Int.add_zero_l; - try rewrite Int.add_commut; try rewrite ltu_12_wordsize; try rewrite H; trivial. Qed. @@ -1690,9 +1694,8 @@ Lemma simplify_shrximm_correct ge sp rs0 m0 lr hst fsv st args m n: forall then Some (fSop (OEmayundef (MUshrx n)) - (make_lhsv_cmp false - (fSop Omove (make_lhsv_single (fsi_sreg_get hst a1))) - (fSop Omove (make_lhsv_single (fsi_sreg_get hst a1))))) + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fsi_sreg_get hst a1))) else if Int.eq n Int.one then @@ -1794,9 +1797,8 @@ Lemma simplify_shrxlimm_correct ge sp rs0 m0 lr hst fsv st args m n: forall then Some (fSop (OEmayundef (MUshrxl n)) - (make_lhsv_cmp false - (fSop Omove (make_lhsv_single (fsi_sreg_get hst a1))) - (fSop Omove (make_lhsv_single (fsi_sreg_get hst a1))))) + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fsi_sreg_get hst a1))) else if Int.eq n Int.one then @@ -1885,7 +1887,7 @@ Proof. destruct Int.ltu eqn:EQN2 in TOTAL; try discriminate. rewrite !EQN2. rewrite EQN0. reflexivity. - Qed. +Qed. Lemma simplify_cast32unsigned_correct ge sp rs0 m0 lr hst fsv st args m: forall (SREG: forall r: positive, @@ -1924,7 +1926,7 @@ Proof. rewrite Int64.shru'_zero. reflexivity. Qed. -(* Main proof of simplification *) +(** * Main proof of simplification *) Lemma target_op_simplify_correct op lr hst fsv ge sp rs0 m0 st args m: forall (H: target_op_simplify op lr hst = Some fsv) @@ -1937,28 +1939,22 @@ Proof. unfold target_op_simplify; simpl. intros H (LREF & SREF & SREG & SMEM) ? ? ?. destruct op; try congruence. - (* int and long constants *) eapply simplify_intconst_correct; eauto. eapply simplify_longconst_correct; eauto. - (* FP const expansions *) eapply simplify_floatconst_correct; eauto. eapply simplify_singleconst_correct; eauto. - (* cast 8/16 operations *) + (* TODO gourdinl*) + (*admit.*) eapply simplify_cast8signed_correct; eauto. eapply simplify_cast16signed_correct; eauto. - (* Immediate int operations *) eapply simplify_addimm_correct; eauto. eapply simplify_andimm_correct; eauto. eapply simplify_orimm_correct; eauto. - (* Shrx imm int operation *) eapply simplify_shrximm_correct; eauto. - (* cast 32u operation *) eapply simplify_cast32unsigned_correct; eauto. - (* Immediate long operations *) eapply simplify_addlimm_correct; eauto. eapply simplify_andlimm_correct; eauto. eapply simplify_orlimm_correct; eauto. - (* Shrx imm long operation *) eapply simplify_shrxlimm_correct; eauto. (* Ocmp expansions *) destruct cond; repeat (destruct lr; simpl; try congruence); @@ -1966,31 +1962,20 @@ Proof. try (destruct (seval_sval ge sp (si_sreg st r) rs0 m0) eqn:OKv1; try congruence); try (destruct (seval_sval ge sp (si_sreg st r0) rs0 m0) eqn:OKv2; try congruence); inv H; inv OK1. - (* Ccomp *) - eapply simplify_ccomp_correct; eauto. - (* Ccompu *) - eapply simplify_ccompu_correct; eauto. - (* Ccompimm *) - eapply simplify_ccompimm_correct; eauto. - (* Ccompuimm *) - eapply simplify_ccompuimm_correct; eauto. - (* Ccompl *) - eapply simplify_ccompl_correct; eauto. - (* Ccomplu *) - eapply simplify_ccomplu_correct; eauto. - (* Ccomplimm *) - eapply simplify_ccomplimm_correct; eauto. - (* Ccompluimm *) - eapply simplify_ccompluimm_correct; eauto. - (* Ccompf *) - eapply simplify_ccompf_correct; eauto. - (* Cnotcompf *) - eapply simplify_cnotcompf_correct; eauto. - (* Ccompfs *) - eapply simplify_ccompfs_correct; eauto. - (* Cnotcompfs *) - eapply simplify_cnotcompfs_correct; eauto. Qed. +(*Admitted.*) Lemma target_cbranch_expanse_correct hst c l ge sp rs0 m0 st c' l': forall (TARGET: target_cbranch_expanse hst c l = Some (c', l')) @@ -2042,7 +2027,6 @@ Proof. try destruct v; try rewrite H; try rewrite ltu_12_wordsize; try rewrite EQLO; try rewrite Int.add_commut, Int.add_zero_l; - try rewrite Int.add_commut; try rewrite Int64.add_commut, Int64.add_zero_l; try rewrite Int64.add_commut; try rewrite Int.add_zero_l; try rewrite Int64.add_zero_l; diff --git a/riscV/ValueAOp.v b/riscV/ValueAOp.v index e48c4a5b..3ba2732d 100644 --- a/riscV/ValueAOp.v +++ b/riscV/ValueAOp.v @@ -19,44 +19,41 @@ Require Import Zbits. Definition zero32 := (I Int.zero). Definition zero64 := (L Int64.zero). - -Definition apply_bin_oreg {B} (optR: option oreg) (sem: aval -> aval -> B) (v1 v2 vz: aval): B := + +(** Functions to select a special register (see Op.v) *) + +Definition apply_bin_oreg {B} (optR: option oreg) (sem: aval -> aval -> B) (v1 v2 vz sp: aval): B := match optR with | None => sem v1 v2 | Some X0_L => sem vz v1 | Some X0_R => sem v1 vz + | Some SP_S => sem v1 sp end. Definition eval_may_undef (mu: mayundef) (v1 v2: aval): aval := match mu with - | MUint => match v1 with - | I _ => v2 - | _ => Ifptr Ptop + | MUint => match v1, v2 with + | I _, I _ => v2 + | _, _ => Ifptr Ptop end - | MUlong => match v1 with - | L _ => v2 - | _ => Ifptr Ptop + | MUlong => match v1, v2 with + | L _, I _ => v2 + | _, _ => Ifptr Ptop end | MUshrx i => - match v1 with - | I _ => - if Int.ltu i (Int.repr 31) then v1 else Ifptr Ptop - | _ => Ifptr Ptop + match v1, v2 with + | I _, I _ => + if Int.ltu i (Int.repr 31) then v2 else Ifptr Ptop + | _, _ => Ifptr Ptop end | MUshrxl i => - match v1 with - | L _ => - if Int.ltu i (Int.repr 63) then v1 else Ifptr Ptop - | _ => Ifptr Ptop + match v1, v2 with + | L _, L _ => + if Int.ltu i (Int.repr 63) then v2 else Ifptr Ptop + | _, _ => Ifptr Ptop end end. -Definition eval_opimmR0 (opi: opimm): aval := - match opi with - | OPimmADD i => add (I i) zero32 - | OPimmADDL i => addl (L i) zero64 - end. - Definition eval_static_condition (cond: condition) (vl: list aval): abool := match cond, vl with | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2 @@ -71,22 +68,22 @@ Definition eval_static_condition (cond: condition) (vl: list aval): abool := | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2) | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2 | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2) - | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32 - | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32 - | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32 - | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32 - | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32 - | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32 - | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cge) v1 v2 zero32 - | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cge) v1 v2 zero32 - | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64 - | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64 - | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64 - | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64 - | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64 - | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64 - | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cge) v1 v2 zero64 - | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cge) v1 v2 zero64 + | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32 (Ifptr Ptop) + | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32 (Ifptr Ptop) + | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32 (Ifptr Ptop) + | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32 (Ifptr Ptop) + | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32 (Ifptr Ptop) + | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32 (Ifptr Ptop) + | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cge) v1 v2 zero32 (Ifptr Ptop) + | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cge) v1 v2 zero32 (Ifptr Ptop) + | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64 (Ifptr Ptop) + | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64 (Ifptr Ptop) + | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64 (Ifptr Ptop) + | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64 (Ifptr Ptop) + | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64 (Ifptr Ptop) + | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64 (Ifptr Ptop) + | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cge) v1 v2 zero64 (Ifptr Ptop) + | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cge) v1 v2 zero64 (Ifptr Ptop) | _, _ => Bnone end. @@ -226,33 +223,35 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoflong, v1::nil => singleoflong v1 | Osingleoflongu, v1::nil => singleoflongu v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) - | OEimmR0 opi, nil => eval_opimmR0 opi - | OEseqw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32) - | OEsnew optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32) - | OEsequw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32) - | OEsneuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32) - | OEsltw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32) - | OEsltuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32) + | OEmoveSP, nil => Ptr Stack + | OEseqw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32 (Ifptr Ptop)) + | OEsnew optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32 (Ifptr Ptop)) + | OEsequw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32 (Ifptr Ptop)) + | OEsneuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32 (Ifptr Ptop)) + | OEsltw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32 (Ifptr Ptop)) + | OEsltuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32 (Ifptr Ptop)) | OEsltiw n, v1::nil => of_optbool (cmp_bool Clt v1 (I n)) | OEsltiuw n, v1::nil => of_optbool (cmpu_bool Clt v1 (I n)) | OExoriw n, v1::nil => xor v1 (I n) | OEluiw n, nil => shl (I n) (I (Int.repr 12)) - | OEaddiw n, v1::nil => add (I n) v1 + | OEaddiw optR n, nil => apply_bin_oreg optR add (I n) (Ifptr Ptop) zero32 (Ifptr Ptop) + | OEaddiw optR n, v1::nil => apply_bin_oreg optR add v1 (Ifptr Ptop) (Ifptr Ptop) (Ptr Stack) | OEandiw n, v1::nil => and (I n) v1 | OEoriw n, v1::nil => or (I n) v1 - | OEseql optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64) - | OEsnel optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64) - | OEsequl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64) - | OEsneul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64) - | OEsltl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64) - | OEsltul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64) + | OEseql optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64 (Ifptr Ptop)) + | OEsnel optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64 (Ifptr Ptop)) + | OEsequl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64 (Ifptr Ptop)) + | OEsneul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64 (Ifptr Ptop)) + | OEsltl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64 (Ifptr Ptop)) + | OEsltul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64 (Ifptr Ptop)) | OEsltil n, v1::nil => of_optbool (cmpl_bool Clt v1 (L n)) | OEsltiul n, v1::nil => of_optbool (cmplu_bool Clt v1 (L n)) | OEandil n, v1::nil => andl (L n) v1 | OEoril n, v1::nil => orl (L n) v1 | OExoril n, v1::nil => xorl v1 (L n) | OEluil n, nil => sign_ext 32 (shll (L n) (L (Int64.repr 12))) - | OEaddil n, v1::nil => addl (L n) v1 + | OEaddil optR n, nil => apply_bin_oreg optR addl (L n) (Ifptr Ptop) zero64 (Ifptr Ptop) + | OEaddil optR n, v1::nil => apply_bin_oreg optR addl v1 (Ifptr Ptop) (Ifptr Ptop) (Ptr Stack) | OEloadli n, nil => L (n) | OEmayundef mu, v1 :: v2 :: nil => eval_may_undef mu v1 v2 | OEfeqd, v1::v2::nil => of_optbool (cmpf_bool Ceq v1 v2) @@ -419,8 +418,8 @@ Lemma eval_cmpu_sound c: forall a1 b1 a0 b0 optR m, c = Ceq \/ c = Cne \/ c = Clt-> vmatch bc a1 b1 -> vmatch bc a0 b0 -> - vmatch bc (Op.apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) c) a1 a0 Op.zero32) - (of_optbool (apply_bin_oreg optR (cmpu_bool c) b1 b0 zero32)). + vmatch bc (Op.apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) c) a1 a0 Op.zero32 Vundef) + (of_optbool (apply_bin_oreg optR (cmpu_bool c) b1 b0 zero32 (Ifptr Ptop))). Proof. intros. destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; @@ -434,8 +433,8 @@ Lemma eval_cmplu_sound c: forall a1 b1 a0 b0 optR m, vmatch bc (Val.maketotal (Op.apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) c) a1 a0 - Op.zero64)) - (of_optbool (apply_bin_oreg optR (cmplu_bool c) b1 b0 zero64)). + Op.zero64 Vundef)) + (of_optbool (apply_bin_oreg optR (cmplu_bool c) b1 b0 zero64 (Ifptr Ptop))). Proof. intros. destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; @@ -445,8 +444,8 @@ Qed. Lemma eval_cmp_sound: forall a1 b1 a0 b0 optR cmp, vmatch bc a1 b1 -> vmatch bc a0 b0 -> - vmatch bc (Op.apply_bin_oreg optR (Val.cmp cmp) a1 a0 Op.zero32) - (of_optbool (apply_bin_oreg optR (cmp_bool cmp) b1 b0 zero32)). + vmatch bc (Op.apply_bin_oreg optR (Val.cmp cmp) a1 a0 Op.zero32 Vundef) + (of_optbool (apply_bin_oreg optR (cmp_bool cmp) b1 b0 zero32 (Ifptr Ptop))). Proof. intros. destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; @@ -457,8 +456,8 @@ Lemma eval_cmpl_sound: forall a1 b1 a0 b0 optR cmp, vmatch bc a1 b1 -> vmatch bc a0 b0 -> vmatch bc - (Val.maketotal (Op.apply_bin_oreg optR (Val.cmpl cmp) a1 a0 Op.zero64)) - (of_optbool (apply_bin_oreg optR (cmpl_bool cmp) b1 b0 zero64)). + (Val.maketotal (Op.apply_bin_oreg optR (Val.cmpl cmp) a1 a0 Op.zero64 Vundef)) + (of_optbool (apply_bin_oreg optR (cmpl_bool cmp) b1 b0 zero64 (Ifptr Ptop))). Proof. intros. destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; @@ -478,19 +477,23 @@ Proof. rewrite Ptrofs.add_zero_l; eauto with va. apply of_optbool_sound. eapply eval_static_condition_sound; eauto. - unfold Op.eval_opimmR0, eval_opimmR0, Op.zero32, zero32, Op.zero64, zero64; - destruct opi; eauto with va. 3,4,6: apply eval_cmpu_sound; auto. 1,2,3: apply eval_cmp_sound; auto. unfold Val.cmp; apply of_optbool_sound; eauto with va. unfold Val.cmpu; apply of_optbool_sound; eauto with va. - { fold (Val.add (Vint n) a1); eauto with va. } + { destruct optR as [[]|]; simpl; eauto with va; + InvHyps; eauto with va; + destruct Archi.ptr64 eqn:A; simpl; + inv H1; simpl; try rewrite A; simpl; eauto with va. } { fold (Val.and (Vint n) a1); eauto with va. } { fold (Val.or (Vint n) a1); eauto with va. } { simpl; try destruct (Int.ltu _ _); eauto with va; unfold ntop1; try apply vmatch_ifptr_undef. } - 9: { fold (Val.addl (Vlong n) a1); eauto with va. } + 9: { destruct optR as [[]|]; simpl; eauto with va; + InvHyps; eauto with va; + destruct Archi.ptr64 eqn:A; simpl; + inv H1; simpl; try rewrite A; simpl; eauto with va. } 9: { fold (Val.andl (Vlong n) a1); eauto with va. } 9: { fold (Val.orl (Vlong n) a1); eauto with va. } 9: { simpl; unfold ntop1, sign_ext, Int64.sign_ext, sgn; simpl; -- cgit From 2f2e7b1da225aa3bf066c2fc689a08fab9851a53 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Thu, 8 Apr 2021 20:47:38 +0200 Subject: bugfix --- riscV/ExpansionOracle.ml | 4 ++-- riscV/OpWeights.ml | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index e0c9b9b2..b54bd5e1 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -1053,15 +1053,15 @@ let expanse (sb : superblock) code pm = | _ -> ()); (* Update code, liveins, pathmap, and order of the superblock for one expansion *) if !was_exp then ( - node := !node + List.length !exp - 1; (if !was_branch && List.length !exp > 1 then let lives = PTree.get n !liveins in match lives with | Some lives -> - let new_branch_pc = n2p () in + let new_branch_pc = P.of_int (!node + 1) in liveins := PTree.set new_branch_pc lives !liveins; liveins := PTree.remove n !liveins | _ -> ()); + node := !node + List.length !exp - 1; write_pathmap sb.instructions.(0) (List.length !exp - 1) pm'; write_tree vn (List.rev !exp) n !node code' new_order true) else new_order := n :: !new_order) diff --git a/riscV/OpWeights.ml b/riscV/OpWeights.ml index 23fbd4fc..0a1d9ad4 100644 --- a/riscV/OpWeights.ml +++ b/riscV/OpWeights.ml @@ -63,6 +63,7 @@ module Rocket = struct 1 | Ccompf _ | Cnotcompf _ -> 2 | Ccompfs _ | Cnotcompfs _ -> 2) + | OEmayundef _ -> 0 | _ -> 1 let resources_of_op (op : operation) (nargs : int) = resource_bounds -- cgit From b7720bc5973e9890e7c320bb34b784e2e2b2da69 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Fri, 9 Apr 2021 11:02:52 +0200 Subject: Removing addptrofs draft, next will be merging --- riscV/Asmgen.v | 14 ---- riscV/Asmgenproof.v | 2 - riscV/Asmgenproof1.v | 5 +- riscV/ExpansionOracle.ml | 30 -------- riscV/NeedOp.v | 1 - riscV/Op.v | 171 +++++++++++++++------------------------------ riscV/PrintOp.ml | 2 - riscV/RTLpathSE_simplify.v | 35 ---------- riscV/ValueAOp.v | 98 +++++++++++++------------- 9 files changed, 104 insertions(+), 254 deletions(-) (limited to 'riscV') diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index ff5d1a6e..3e84e950 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -212,12 +212,10 @@ Definition apply_bin_oreg_ireg0 (optR: option oreg) (r1 r2: ireg0): (ireg0 * ire | None => (r1, r2) | Some X0_L => (X0, r1) | Some X0_R => (r1, X0) - | Some SP_S => (X SP, r1) end. Definition get_oreg (optR: option oreg) (r: ireg0) := match optR with - | Some SP_S => X SP | Some X0_L | Some X0_R => X0 | _ => r end. @@ -846,12 +844,6 @@ Definition transl_op do rd <- ireg_of res; let rs := get_oreg optR X0 in OK (Paddiw rd rs n :: k) - | OEaddiw (Some SP_S) n, a1 :: nil => - do rd <- ireg_of res; - do rs <- ireg_of a1; - if Int.eq n Int.zero then - OK (Paddw rd SP rs :: k) - else Error (msg "Asmgen.transl_op") | OEaddiw optR n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -920,12 +912,6 @@ Definition transl_op do rd <- ireg_of res; let rs := get_oreg optR X0 in OK (Paddil rd rs n :: k) - | OEaddil (Some SP_S) n, a1 :: nil => - do rd <- ireg_of res; - do rs <- ireg_of a1; - if Int64.eq n Int64.zero then - OK (Paddl rd SP rs :: k) - else Error (msg "Asmgen.transl_op") | OEaddil optR n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index bf9ede7f..509eac94 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -320,8 +320,6 @@ Opaque Int.eq. - destruct optR as [[]|]; simpl in *; TailNoLabel. - destruct optR as [[]|]; simpl in *; TailNoLabel. - destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. Qed. Remark indexed_memory_access_label: diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index cbe68577..2293e001 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -1274,7 +1274,7 @@ Opaque Int.eq. { exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. } (* Expanded instructions from RTL *) - 8,9,17,18: + 9,10,19,20: econstructor; split; try apply exec_straight_one; simpl; eauto; split; intros; Simpl; try destruct (rs x0); try rewrite Int64.add_commut; @@ -1283,9 +1283,8 @@ Opaque Int.eq. try rewrite Int.and_commut; auto; try rewrite Int64.or_commut; try rewrite Int.or_commut; auto. - 1-14: + 1-16: destruct optR as [[]|]; try discriminate; - try (ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl); unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; try inv EQ3; try inv EQ2; try destruct (Int.eq _ _) eqn:A; try inv H0; try destruct (Int64.eq _ _) eqn:A; try inv H1; diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index b54bd5e1..092bf0d1 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -606,31 +606,6 @@ let expanse_cbranch_fp vn cnot fn_cond cmp f1 f2 info succ1 succ2 = Sfinalcond (CEbnew (Some X0_R), [ r'; r' ], succ1, succ2, info) :: l else Sfinalcond (CEbeqw (Some X0_R), [ r'; r' ], succ1, succ2, info) :: l -let addptrofs vn n dest = - if Ptrofs.eq_dec n Ptrofs.zero then [ addinst vn OEmoveSP [] dest ] - else if Archi.ptr64 then - match make_immed64 (Ptrofs.to_int64 n) with - | Imm64_single imm -> [ addinst vn (OEaddil (Some SP_S, imm)) [] dest ] - | Imm64_pair (hi, lo) -> - let r = r2pi () in - let l = load_hilo64 vn r hi lo in - let r', l' = extract_arg l in - addinst vn (OEaddil (Some SP_S, Int64.zero)) [ r' ] dest :: l' - | Imm64_large imm -> - let r = r2pi () in - let op1 = OEloadli imm in - let i1 = addinst vn op1 [] r in - let r', l = extract_arg [ i1 ] in - addinst vn (OEaddil (Some SP_S, Int64.zero)) [ r' ] dest :: l - else - match make_immed32 (Ptrofs.to_int n) with - | Imm32_single imm -> [ addinst vn (OEaddiw (Some SP_S, imm)) [] dest ] - | Imm32_pair (hi, lo) -> - let r = r2pi () in - let l = load_hilo32 vn r hi lo in - let r', l' = extract_arg l in - addinst vn (OEaddiw (Some SP_S, Int.zero)) [ r' ] dest :: l' - (** Form a list containing both sources and destination regs of an instruction *) let get_regindent = function Coq_inr _ -> [] | Coq_inl r -> [ r ] @@ -1033,11 +1008,6 @@ let expanse (sb : superblock) code pm = exp := addinst vn (OEmayundef (MUshrxl n)) [ r4; r4 ] dest :: l4); exp := extract_final vn !exp dest succ; was_exp := true - (*| Iop (Oaddrstack n, nil, dest, succ) ->*) - (*if exp_debug then eprintf "Iop/Oaddrstack\n";*) - (*exp := addptrofs vn n dest;*) - (*exp := extract_final vn !exp dest succ;*) - (*was_exp := true*) | _ -> ()); (* Update the CSE numbering *) (if not !was_exp then diff --git a/riscV/NeedOp.v b/riscV/NeedOp.v index d0ca5bb2..7d66cbb8 100644 --- a/riscV/NeedOp.v +++ b/riscV/NeedOp.v @@ -87,7 +87,6 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv) | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) | Ocmp c => needs_of_condition c - | OEmoveSP => nil | OEseqw _ => op2 (default nv) | OEsnew _ => op2 (default nv) | OEsequw _ => op2 (default nv) diff --git a/riscV/Op.v b/riscV/Op.v index 9d1826ac..9f94828f 100644 --- a/riscV/Op.v +++ b/riscV/Op.v @@ -42,8 +42,7 @@ Set Implicit Arguments. Inductive oreg: Type := | X0_L: oreg - | X0_R: oreg - | SP_S: oreg. + | X0_R: oreg. Inductive condition : Type := | Ccomp (c: comparison) (**r signed integer comparison *) @@ -187,7 +186,6 @@ Inductive operation : Type := (*c Boolean tests: *) | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) (* Expansed conditions *) - | OEmoveSP | OEseqw (optR: option oreg) (**r [rd <- rs1 == rs2] signed *) | OEsnew (optR: option oreg) (**r [rd <- rs1 != rs2] signed *) | OEsequw (optR: option oreg) (**r [rd <- rs1 == rs2] unsigned *) @@ -281,12 +279,11 @@ Global Opaque eq_condition eq_addressing eq_operation. Definition zero32 := (Vint Int.zero). Definition zero64 := (Vlong Int64.zero). -Definition apply_bin_oreg {B} (optR: option oreg) (sem: val -> val -> B) (v1 v2 vz sp: val): B := +Definition apply_bin_oreg {B} (optR: option oreg) (sem: val -> val -> B) (v1 v2 vz: val): B := match optR with | None => sem v1 v2 | Some X0_L => sem vz v1 | Some X0_R => sem v1 vz - | Some SP_S => sem v1 sp end. (** Mayundef evaluation according to the above defined type *) @@ -337,22 +334,22 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2 | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) (* Expansed branches *) - | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Ceq) v1 v2 zero32 Vundef - | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cne) v1 v2 zero32 Vundef - | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero32 Vundef - | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cne) v1 v2 zero32 Vundef - | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Clt) v1 v2 zero32 Vundef - | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Clt) v1 v2 zero32 Vundef - | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cge) v1 v2 zero32 Vundef - | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cge) v1 v2 zero32 Vundef - | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Ceq) v1 v2 zero64 Vundef - | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cne) v1 v2 zero64 Vundef - | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero64 Vundef - | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cne) v1 v2 zero64 Vundef - | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Clt) v1 v2 zero64 Vundef - | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Clt) v1 v2 zero64 Vundef - | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cge) v1 v2 zero64 Vundef - | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cge) v1 v2 zero64 Vundef + | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Ceq) v1 v2 zero32 + | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cne) v1 v2 zero32 + | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero32 + | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cne) v1 v2 zero32 + | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Clt) v1 v2 zero32 + | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Clt) v1 v2 zero32 + | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cge) v1 v2 zero32 + | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cge) v1 v2 zero32 + | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Ceq) v1 v2 zero64 + | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cne) v1 v2 zero64 + | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero64 + | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cne) v1 v2 zero64 + | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Clt) v1 v2 zero64 + | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Clt) v1 v2 zero64 + | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cge) v1 v2 zero64 + | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cge) v1 v2 zero64 | _, _ => None end. @@ -466,41 +463,32 @@ Definition eval_operation | Ofloat_of_bits, v1::nil => Some (ExtValues.float_of_bits v1) | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) (* Expansed conditions *) - | OEmoveSP, nil => Some (get_sp sp) - | OEseqw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Ceq) v1 v2 zero32 Vundef) - | OEsnew optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Cne) v1 v2 zero32 Vundef) - | OEsequw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Ceq) v1 v2 zero32 Vundef) - | OEsneuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Cne) v1 v2 zero32 Vundef) - | OEsltw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Clt) v1 v2 zero32 Vundef) - | OEsltuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Clt) v1 v2 zero32 Vundef) + | OEseqw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Ceq) v1 v2 zero32) + | OEsnew optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Cne) v1 v2 zero32) + | OEsequw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Ceq) v1 v2 zero32) + | OEsneuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Cne) v1 v2 zero32) + | OEsltw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Clt) v1 v2 zero32) + | OEsltuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Clt) v1 v2 zero32) | OEsltiw n, v1::nil => Some (Val.cmp Clt v1 (Vint n)) | OEsltiuw n, v1::nil => Some (Val.cmpu (Mem.valid_pointer m) Clt v1 (Vint n)) | OExoriw n, v1::nil => Some (Val.xor v1 (Vint n)) | OEluiw n, nil => Some (Val.shl (Vint n) (Vint (Int.repr 12))) - | OEaddiw optR n, nil => Some (apply_bin_oreg optR Val.add (Vint n) Vundef zero32 Vundef) - | OEaddiw ((Some SP_S) as optR) n, v1::nil => - let sp' := Val.add (Vint n) (get_sp sp) in - Some (apply_bin_oreg optR Val.add v1 Vundef Vundef sp') - | OEaddiw optR n, v1::nil => - Some (apply_bin_oreg optR Val.add v1 (Vint n) Vundef (get_sp sp)) + | OEaddiw optR n, nil => Some (apply_bin_oreg optR Val.add (Vint n) Vundef zero32) + | OEaddiw optR n, v1::nil => Some (apply_bin_oreg optR Val.add v1 (Vint n) Vundef) | OEandiw n, v1::nil => Some (Val.and (Vint n) v1) | OEoriw n, v1::nil => Some (Val.or (Vint n) v1) - | OEseql optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Ceq) v1 v2 zero64 Vundef)) - | OEsnel optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Cne) v1 v2 zero64 Vundef)) - | OEsequl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Ceq) v1 v2 zero64 Vundef)) - | OEsneul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Cne) v1 v2 zero64 Vundef)) - | OEsltl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Clt) v1 v2 zero64 Vundef)) - | OEsltul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Clt) v1 v2 zero64 Vundef)) + | OEseql optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Ceq) v1 v2 zero64)) + | OEsnel optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Cne) v1 v2 zero64)) + | OEsequl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Ceq) v1 v2 zero64)) + | OEsneul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Cne) v1 v2 zero64)) + | OEsltl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Clt) v1 v2 zero64)) + | OEsltul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Clt) v1 v2 zero64)) | OEsltil n, v1::nil => Some (Val.maketotal (Val.cmpl Clt v1 (Vlong n))) | OEsltiul n, v1::nil => Some (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 (Vlong n))) | OExoril n, v1::nil => Some (Val.xorl v1 (Vlong n)) | OEluil n, nil => Some (Vlong (Int64.sign_ext 32 (Int64.shl n (Int64.repr 12)))) - | OEaddil optR n, nil => Some (apply_bin_oreg optR Val.addl (Vlong n) Vundef zero64 Vundef) - | OEaddil ((Some SP_S) as optR) n, v1::nil => - let sp' := Val.addl (Vlong n) (get_sp sp) in - Some (apply_bin_oreg optR Val.addl v1 Vundef Vundef sp') - | OEaddil optR n, v1::nil => - Some (apply_bin_oreg optR Val.addl v1 (Vlong n) Vundef (get_sp sp)) + | OEaddil optR n, nil => Some (apply_bin_oreg optR Val.addl (Vlong n) Vundef zero64) + | OEaddil optR n, v1::nil => Some (apply_bin_oreg optR Val.addl v1 (Vlong n) Vundef) | OEandil n, v1::nil => Some (Val.andl (Vlong n) v1) | OEoril n, v1::nil => Some (Val.orl (Vlong n) v1) | OEloadli n, nil => Some (Vlong n) @@ -598,14 +586,6 @@ Definition type_of_mayundef mu := | MUshrxl _ => (Tlong :: Tlong :: nil, Tlong) end. -Definition type_addsp (is_long: bool): list typ * typ := - if Archi.ptr64 then ( - if is_long then (Tlong :: nil, Tptr) - else (nil, Tint)) - else ( - if is_long then (nil, Tlong) - else (Tint :: nil, Tptr)). - Definition type_of_operation (op: operation) : list typ * typ := match op with | Omove => (nil, Tint) (* treated specially *) @@ -701,7 +681,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | Osingleoflong => (Tlong :: nil, Tsingle) | Osingleoflongu => (Tlong :: nil, Tsingle) | Ocmp c => (type_of_condition c, Tint) - | OEmoveSP => (nil, Tptr) | OEseqw _ => (Tint :: Tint :: nil, Tint) | OEsnew _ => (Tint :: Tint :: nil, Tint) | OEsequw _ => (Tint :: Tint :: nil, Tint) @@ -713,7 +692,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | OExoriw _ => (Tint :: nil, Tint) | OEluiw _ => (nil, Tint) | OEaddiw None _ => (Tint :: nil, Tint) - | OEaddiw (Some SP_S) _ => type_addsp false | OEaddiw (Some _) _ => (nil, Tint) | OEandiw _ => (Tint :: nil, Tint) | OEoriw _ => (Tint :: nil, Tint) @@ -730,7 +708,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | OExoril _ => (Tlong :: nil, Tlong) | OEluil _ => (nil, Tlong) | OEaddil None _ => (Tlong :: nil, Tlong) - | OEaddil (Some SP_S) _ => type_addsp true | OEaddil (Some _) _ => (nil, Tlong) | OEloadli _ => (nil, Tlong) | OEmayundef mu => type_of_mayundef mu @@ -959,9 +936,6 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; cbn; trivial. (* cmp *) - destruct (eval_condition cond vl m)... destruct b... - (* OEmoveSP *) - - destruct sp; unfold Tptr; destruct Archi.ptr64 eqn:?; - simpl; trivial. (* OEseqw *) - destruct optR as [[]|]; simpl; unfold Val.cmp; destruct Val.cmp_bool... all: destruct b... @@ -986,12 +960,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* OEsltiuw *) - unfold Val.cmpu; destruct Val.cmpu_bool... destruct b... (* OEaddiw *) + - destruct optR as [[]|]; simpl in *; trivial. - destruct optR as [[]|]; simpl in *; trivial; - destruct vl; inv H0; simpl; trivial; - destruct vl; inv H2; simpl; trivial; - destruct v0; simpl; trivial; - destruct (get_sp sp); destruct Archi.ptr64 eqn:HA; simpl; trivial; - unfold type_addsp, Tptr; try rewrite HA; simpl; trivial. + apply type_add. (* OEandiw *) - destruct v0... (* OEoriw *) @@ -1024,12 +995,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* OEsltiul *) - unfold Val.cmplu; destruct Val.cmplu_bool... destruct b... (* OEaddil *) + - destruct optR as [[]|]; simpl in *; trivial. - destruct optR as [[]|]; simpl in *; trivial; - destruct vl; inv H0; simpl; trivial; - destruct vl; inv H2; simpl; trivial; - destruct v0; simpl; trivial; - destruct (get_sp sp); destruct Archi.ptr64 eqn:HA; simpl; trivial; - unfold type_addsp, Tptr; try rewrite HA; simpl; trivial. + apply type_addl. (* OEandil *) - destruct v0... (* OEoril *) @@ -1099,7 +1067,6 @@ Proof. all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). all: try destruct optR as [[]|]; simpl in H0; try discriminate. - all: unfold type_addsp in *; simpl in *. all: try destruct Archi.ptr64; simpl in *; try discriminate. all: try destruct mu; simpl in *; try discriminate. Qed. @@ -1226,9 +1193,6 @@ Definition shift_stack_addressing (delta: Z) (addr: addressing) := Definition shift_stack_operation (delta: Z) (op: operation) := match op with | Oaddrstack ofs => Oaddrstack (Ptrofs.add ofs (Ptrofs.repr delta)) - | OEmoveSP => Oaddrstack (Ptrofs.add Ptrofs.zero (Ptrofs.repr delta)) - | OEaddiw (Some SP_S) n => OEaddiw (Some SP_S) (Ptrofs.to_int (Ptrofs.add (Ptrofs.of_int n) (Ptrofs.repr delta))) - | OEaddil (Some SP_S) n => OEaddil (Some SP_S) (Ptrofs.to_int64 (Ptrofs.add (Ptrofs.of_int64 n) (Ptrofs.repr delta))) | _ => op end. @@ -1260,20 +1224,7 @@ Lemma eval_shift_stack_operation: eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m. Proof. intros. destruct op eqn:E; simpl; auto; destruct vl; auto. - - rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. - - rewrite !Ptrofs.add_zero_l; auto. - - destruct optR as [[]|]; simpl; auto. - - destruct vl, optR as [[]|]; auto; unfold apply_bin_oreg; simpl; auto. - destruct v, Archi.ptr64 eqn:EA; simpl; try rewrite EA; simpl; auto. - rewrite Ptrofs.add_zero_l; auto. - rewrite Ptrofs.of_int_to_int; auto. - rewrite (Ptrofs.add_commut (Ptrofs.of_int n) (Ptrofs.repr delta)); reflexivity. - - destruct optR as [[]|]; simpl; auto. - - destruct vl, optR as [[]|]; auto; unfold apply_bin_oreg; simpl; auto. - destruct Archi.ptr64 eqn:EA; auto. - rewrite Ptrofs.add_zero_l; auto. - rewrite Ptrofs.of_int64_to_int64; auto. - rewrite (Ptrofs.add_commut (Ptrofs.of_int64 n) (Ptrofs.repr delta)); reflexivity. + rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. Qed. (** Offset an addressing mode [addr] by a quantity [delta], so that @@ -1533,8 +1484,8 @@ Qed. Lemma eval_cmpu_bool_inj_opt: forall c v v' v0 v'0 optR, Val.inject f v v' -> Val.inject f v0 v'0 -> - Val.inject f (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m1) c) v v0 zero32 Vundef) - (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m2) c) v' v'0 zero32 Vundef). + Val.inject f (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m1) c) v v0 zero32) + (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m2) c) v' v'0 zero32). Proof. intros until optR. intros HV1 HV2. destruct optR as [[]|]; simpl; unfold zero32, Val.cmpu; @@ -1544,11 +1495,9 @@ Proof. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + exploit eval_cmpu_bool_inj'. eapply HV1. eapply HVI. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. - + exploit eval_cmpu_bool_inj'. eapply HV1. do 2 instantiate (1:=Vundef). + + exploit eval_cmpu_bool_inj'. eapply HV1. instantiate (1:=v'0). eauto. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. - + exploit eval_cmpu_bool_inj'. eapply HV1. eapply HV2. eapply Heqo. - intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. Qed. Lemma eval_cmplu_bool_inj': forall b c v v' v0 v0', @@ -1577,8 +1526,8 @@ Qed. Lemma eval_cmplu_bool_inj_opt: forall c v v' v0 v'0 optR, Val.inject f v v' -> Val.inject f v0 v'0 -> - Val.inject f (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m1) c) v v0 zero64 Vundef)) - (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m2) c) v' v'0 zero64 Vundef)). + Val.inject f (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m1) c) v v0 zero64)) + (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m2) c) v' v'0 zero64)). Proof. intros until optR. intros HV1 HV2. destruct optR as [[]|]; simpl; unfold zero64, Val.cmplu; @@ -1588,11 +1537,9 @@ Proof. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + exploit eval_cmplu_bool_inj'. eapply HV1. eapply HVI. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. - + exploit eval_cmplu_bool_inj'. eapply HV1. do 2 instantiate (1:=Vundef). + + exploit eval_cmplu_bool_inj'. eapply HV1. instantiate (1:=v'0). eauto. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. - + exploit eval_cmplu_bool_inj'. eapply HV1. eapply HV2. eapply Heqo. - intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. Qed. Lemma eval_condition_inj: @@ -1857,9 +1804,6 @@ Proof. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. destruct b; simpl; constructor. simpl; constructor. - (* moveSP *) - - unfold get_sp; inv H; auto. - econstructor; eauto. (* OEseqw *) - destruct optR as [[]|]; simpl; unfold zero32, Val.cmp; inv H4; inv H2; simpl; try destruct (Int.eq _ _); simpl; cbn; auto; @@ -1883,14 +1827,11 @@ Proof. (* OEsltiuw *) - apply eval_cmpu_bool_inj; auto. (* OEaddiw *) - - destruct optR as [[]|]; auto; simpl; FuncInv; InvInject; TrivialExists; - try fold (Val.add (Vint n) (get_sp sp1)); - try fold (Val.add (Vint n) (get_sp sp2)); - (*try destruct (get_sp sp1), (get_sp sp2);*) - apply Val.add_inject; auto. - apply Val.add_inject; auto. - destruct sp1, sp2; simpl; auto; - inv H. + - destruct optR as [[]|]; auto; simpl. + rewrite Int.add_zero_l; auto. + rewrite Int.add_commut, Int.add_zero_l; auto. + - destruct optR as [[]|]; auto; simpl; + eapply Val.add_inject; auto. (* OEandiw *) - inv H4; cbn; auto. (* OEoriw *) @@ -1922,13 +1863,11 @@ Proof. (* OEsltiul *) - apply eval_cmplu_bool_inj; auto. (* OEaddil *) - - destruct optR as [[]|]; auto; simpl; FuncInv; InvInject; TrivialExists; - try fold (Val.addl (Vlong n) (get_sp sp1)); - try fold (Val.addl (Vlong n) (get_sp sp2)); - apply Val.addl_inject; auto. - apply Val.addl_inject; auto. - destruct sp1, sp2; simpl; auto; - inv H. + - destruct optR as [[]|]; auto; simpl. + rewrite Int64.add_zero_l; auto. + rewrite Int64.add_commut, Int64.add_zero_l; auto. + - destruct optR as [[]|]; auto; simpl; + eapply Val.addl_inject; auto. (* OEandil *) - inv H4; cbn; auto. (* OEoril *) diff --git a/riscV/PrintOp.ml b/riscV/PrintOp.ml index 53730a1b..0d47192a 100644 --- a/riscV/PrintOp.ml +++ b/riscV/PrintOp.ml @@ -40,12 +40,10 @@ let get_optR_s c reg pp r1 r2 = function | None -> fprintf pp "(%a %s %a)" reg r1 (comparison_name c) reg r2 | Some X0_L -> fprintf pp "(X0 %s %a)" (comparison_name c) reg r1 | Some X0_R -> fprintf pp "(%a %s X0)" reg r1 (comparison_name c) - | Some SP_S -> failwith "PrintOp: SP_S in get_optR_s instruction (problem with RTL expansions?)" let get_optR_a pp = function | None -> failwith "PrintOp: None in get_optR_a instruction (problem with RTL expansions?)" | Some X0_L | Some X0_R -> fprintf pp "X0" - | Some SP_S -> fprintf pp "SP" let print_condition reg pp = function | (Ccomp c, [r1;r2]) -> diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index c453dfb8..d55d94ad 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -309,36 +309,6 @@ Definition expanse_cbranch_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) : (con let hl := make_lhsv_cmp false hvs hvs in if normal' then ((CEbnew (Some X0_R)), hl) else ((CEbeqw (Some X0_R)), hl). -(** ** Add pointer expansion *) - -Definition addptrofs (n: ptrofs) := - if Ptrofs.eq_dec n Ptrofs.zero then - fSop OEmoveSP fSnil - else - if Archi.ptr64 - then ( - match make_immed64 (Ptrofs.to_int64 n) with - | Imm64_single imm => - fSop (OEaddil (Some SP_S) imm) fSnil - | Imm64_pair hi lo => - let hvs := load_hilo64 hi lo in - let hl := make_lhsv_single hvs in - fSop (OEaddil (Some SP_S) Int64.zero) hl - | Imm64_large imm => - let hvs := fSop (OEloadli imm) fSnil in - let hl := make_lhsv_single hvs in - fSop (OEaddil (Some SP_S) Int64.zero) hl - end) - else ( - match make_immed32 (Ptrofs.to_int n) with - | Imm32_single imm => - fSop (OEaddiw (Some SP_S) imm) fSnil - | Imm32_pair hi lo => - let hvs := load_hilo32 hi lo in - let hl := make_lhsv_single hvs in - fSop (OEaddiw (Some SP_S) Int.zero) hl - end). - (** * Target simplifications using "fake" values *) Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_local): option hsval := @@ -507,8 +477,6 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let srail_s' := fSop (Oshrlimm n) addl_l in let srail_l' := make_lhsv_cmp false srail_s' srail_s' in Some (fSop (OEmayundef (MUshrxl n)) srail_l') - (* TODO gourdinl | Oaddrstack n, nil =>*) - (*Some (addptrofs n)*) | _, _ => None end. @@ -1943,8 +1911,6 @@ Proof. eapply simplify_longconst_correct; eauto. eapply simplify_floatconst_correct; eauto. eapply simplify_singleconst_correct; eauto. - (* TODO gourdinl*) - (*admit.*) eapply simplify_cast8signed_correct; eauto. eapply simplify_cast16signed_correct; eauto. eapply simplify_addimm_correct; eauto. @@ -1975,7 +1941,6 @@ Proof. - eapply simplify_ccompfs_correct; eauto. - eapply simplify_cnotcompfs_correct; eauto. Qed. -(*Admitted.*) Lemma target_cbranch_expanse_correct hst c l ge sp rs0 m0 st c' l': forall (TARGET: target_cbranch_expanse hst c l = Some (c', l')) diff --git a/riscV/ValueAOp.v b/riscV/ValueAOp.v index 3ba2732d..d29180e4 100644 --- a/riscV/ValueAOp.v +++ b/riscV/ValueAOp.v @@ -22,12 +22,11 @@ Definition zero64 := (L Int64.zero). (** Functions to select a special register (see Op.v) *) -Definition apply_bin_oreg {B} (optR: option oreg) (sem: aval -> aval -> B) (v1 v2 vz sp: aval): B := +Definition apply_bin_oreg {B} (optR: option oreg) (sem: aval -> aval -> B) (v1 v2 vz: aval): B := match optR with | None => sem v1 v2 | Some X0_L => sem vz v1 | Some X0_R => sem v1 vz - | Some SP_S => sem v1 sp end. Definition eval_may_undef (mu: mayundef) (v1 v2: aval): aval := @@ -68,22 +67,22 @@ Definition eval_static_condition (cond: condition) (vl: list aval): abool := | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2) | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2 | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2) - | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32 (Ifptr Ptop) - | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32 (Ifptr Ptop) - | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32 (Ifptr Ptop) - | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32 (Ifptr Ptop) - | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32 (Ifptr Ptop) - | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32 (Ifptr Ptop) - | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cge) v1 v2 zero32 (Ifptr Ptop) - | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cge) v1 v2 zero32 (Ifptr Ptop) - | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64 (Ifptr Ptop) - | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64 (Ifptr Ptop) - | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64 (Ifptr Ptop) - | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64 (Ifptr Ptop) - | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64 (Ifptr Ptop) - | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64 (Ifptr Ptop) - | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cge) v1 v2 zero64 (Ifptr Ptop) - | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cge) v1 v2 zero64 (Ifptr Ptop) + | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32 + | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32 + | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32 + | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32 + | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32 + | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32 + | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cge) v1 v2 zero32 + | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cge) v1 v2 zero32 + | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64 + | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64 + | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64 + | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64 + | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64 + | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64 + | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cge) v1 v2 zero64 + | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cge) v1 v2 zero64 | _, _ => Bnone end. @@ -223,35 +222,34 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoflong, v1::nil => singleoflong v1 | Osingleoflongu, v1::nil => singleoflongu v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) - | OEmoveSP, nil => Ptr Stack - | OEseqw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32 (Ifptr Ptop)) - | OEsnew optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32 (Ifptr Ptop)) - | OEsequw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32 (Ifptr Ptop)) - | OEsneuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32 (Ifptr Ptop)) - | OEsltw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32 (Ifptr Ptop)) - | OEsltuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32 (Ifptr Ptop)) + | OEseqw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32) + | OEsnew optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32) + | OEsequw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32) + | OEsneuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32) + | OEsltw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32) + | OEsltuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32) | OEsltiw n, v1::nil => of_optbool (cmp_bool Clt v1 (I n)) | OEsltiuw n, v1::nil => of_optbool (cmpu_bool Clt v1 (I n)) | OExoriw n, v1::nil => xor v1 (I n) | OEluiw n, nil => shl (I n) (I (Int.repr 12)) - | OEaddiw optR n, nil => apply_bin_oreg optR add (I n) (Ifptr Ptop) zero32 (Ifptr Ptop) - | OEaddiw optR n, v1::nil => apply_bin_oreg optR add v1 (Ifptr Ptop) (Ifptr Ptop) (Ptr Stack) + | OEaddiw optR n, nil => apply_bin_oreg optR add (I n) (Ifptr Ptop) zero32 + | OEaddiw optR n, v1::nil => apply_bin_oreg optR add v1 (I n) (Ifptr Ptop) | OEandiw n, v1::nil => and (I n) v1 | OEoriw n, v1::nil => or (I n) v1 - | OEseql optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64 (Ifptr Ptop)) - | OEsnel optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64 (Ifptr Ptop)) - | OEsequl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64 (Ifptr Ptop)) - | OEsneul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64 (Ifptr Ptop)) - | OEsltl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64 (Ifptr Ptop)) - | OEsltul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64 (Ifptr Ptop)) + | OEseql optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64) + | OEsnel optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64) + | OEsequl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64) + | OEsneul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64) + | OEsltl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64) + | OEsltul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64) | OEsltil n, v1::nil => of_optbool (cmpl_bool Clt v1 (L n)) | OEsltiul n, v1::nil => of_optbool (cmplu_bool Clt v1 (L n)) | OEandil n, v1::nil => andl (L n) v1 | OEoril n, v1::nil => orl (L n) v1 | OExoril n, v1::nil => xorl v1 (L n) | OEluil n, nil => sign_ext 32 (shll (L n) (L (Int64.repr 12))) - | OEaddil optR n, nil => apply_bin_oreg optR addl (L n) (Ifptr Ptop) zero64 (Ifptr Ptop) - | OEaddil optR n, v1::nil => apply_bin_oreg optR addl v1 (Ifptr Ptop) (Ifptr Ptop) (Ptr Stack) + | OEaddil optR n, nil => apply_bin_oreg optR addl (L n) (Ifptr Ptop) zero64 + | OEaddil optR n, v1::nil => apply_bin_oreg optR addl v1 (L n) (Ifptr Ptop) | OEloadli n, nil => L (n) | OEmayundef mu, v1 :: v2 :: nil => eval_may_undef mu v1 v2 | OEfeqd, v1::v2::nil => of_optbool (cmpf_bool Ceq v1 v2) @@ -418,8 +416,8 @@ Lemma eval_cmpu_sound c: forall a1 b1 a0 b0 optR m, c = Ceq \/ c = Cne \/ c = Clt-> vmatch bc a1 b1 -> vmatch bc a0 b0 -> - vmatch bc (Op.apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) c) a1 a0 Op.zero32 Vundef) - (of_optbool (apply_bin_oreg optR (cmpu_bool c) b1 b0 zero32 (Ifptr Ptop))). + vmatch bc (Op.apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) c) a1 a0 Op.zero32) + (of_optbool (apply_bin_oreg optR (cmpu_bool c) b1 b0 zero32)). Proof. intros. destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; @@ -433,8 +431,8 @@ Lemma eval_cmplu_sound c: forall a1 b1 a0 b0 optR m, vmatch bc (Val.maketotal (Op.apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) c) a1 a0 - Op.zero64 Vundef)) - (of_optbool (apply_bin_oreg optR (cmplu_bool c) b1 b0 zero64 (Ifptr Ptop))). + Op.zero64)) + (of_optbool (apply_bin_oreg optR (cmplu_bool c) b1 b0 zero64)). Proof. intros. destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; @@ -444,8 +442,8 @@ Qed. Lemma eval_cmp_sound: forall a1 b1 a0 b0 optR cmp, vmatch bc a1 b1 -> vmatch bc a0 b0 -> - vmatch bc (Op.apply_bin_oreg optR (Val.cmp cmp) a1 a0 Op.zero32 Vundef) - (of_optbool (apply_bin_oreg optR (cmp_bool cmp) b1 b0 zero32 (Ifptr Ptop))). + vmatch bc (Op.apply_bin_oreg optR (Val.cmp cmp) a1 a0 Op.zero32) + (of_optbool (apply_bin_oreg optR (cmp_bool cmp) b1 b0 zero32)). Proof. intros. destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; @@ -456,8 +454,8 @@ Lemma eval_cmpl_sound: forall a1 b1 a0 b0 optR cmp, vmatch bc a1 b1 -> vmatch bc a0 b0 -> vmatch bc - (Val.maketotal (Op.apply_bin_oreg optR (Val.cmpl cmp) a1 a0 Op.zero64 Vundef)) - (of_optbool (apply_bin_oreg optR (cmpl_bool cmp) b1 b0 zero64 (Ifptr Ptop))). + (Val.maketotal (Op.apply_bin_oreg optR (Val.cmpl cmp) a1 a0 Op.zero64)) + (of_optbool (apply_bin_oreg optR (cmpl_bool cmp) b1 b0 zero64)). Proof. intros. destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; @@ -482,18 +480,16 @@ Proof. unfold Val.cmp; apply of_optbool_sound; eauto with va. unfold Val.cmpu; apply of_optbool_sound; eauto with va. - { destruct optR as [[]|]; simpl; eauto with va; - InvHyps; eauto with va; - destruct Archi.ptr64 eqn:A; simpl; - inv H1; simpl; try rewrite A; simpl; eauto with va. } + { destruct optR as [[]|]; simpl; eauto with va. } + { destruct optR as [[]|]; + unfold apply_bin_oreg, Op.apply_bin_oreg; eauto with va. } { fold (Val.and (Vint n) a1); eauto with va. } { fold (Val.or (Vint n) a1); eauto with va. } { simpl; try destruct (Int.ltu _ _); eauto with va; unfold ntop1; try apply vmatch_ifptr_undef. } - 9: { destruct optR as [[]|]; simpl; eauto with va; - InvHyps; eauto with va; - destruct Archi.ptr64 eqn:A; simpl; - inv H1; simpl; try rewrite A; simpl; eauto with va. } + 9: { destruct optR as [[]|]; simpl; eauto with va. } + 9: { destruct optR as [[]|]; + unfold apply_bin_oreg, Op.apply_bin_oreg; eauto with va. } 9: { fold (Val.andl (Vlong n) a1); eauto with va. } 9: { fold (Val.orl (Vlong n) a1); eauto with va. } 9: { simpl; unfold ntop1, sign_ext, Int64.sign_ext, sgn; simpl; -- cgit From 18312f0470cfb96e44ae1a26a24710cc1df3440d Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Fri, 9 Apr 2021 15:15:57 +0200 Subject: Removing expansions from Asmgen --- riscV/Asmexpand.ml | 9 +- riscV/Asmgen.v | 344 ----------------- riscV/Asmgenproof.v | 162 +------- riscV/Asmgenproof1.v | 919 ++------------------------------------------- riscV/RTLpathSE_simplify.v | 10 + 5 files changed, 43 insertions(+), 1401 deletions(-) (limited to 'riscV') diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index c5cd6817..3f9d3359 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -23,6 +23,7 @@ open Asm open Asmexpandaux open AST open Camlcoq +open Asmgen open! Integers exception Error of string @@ -44,11 +45,13 @@ let align n a = (n + a - 1) land (-a) (* Emit instruction sequences that set or offset a register by a constant. *) let expand_loadimm32 dst n = - List.iter emit (Asmgen.loadimm32 dst n []) + match make_immed32 n with + | Imm32_single imm -> emit (Paddiw (dst, X0, imm)) + | Imm32_pair (hi, lo) -> List.iter emit (load_hilo32 dst hi lo []) let expand_addptrofs dst src n = - List.iter emit (Asmgen.addptrofs dst src n []) + List.iter emit (addptrofs dst src n []) let expand_storeind_ptr src base ofs = - List.iter emit (Asmgen.storeind_ptr src base ofs []) + List.iter emit (storeind_ptr src base ofs []) (* Built-ins. They come in two flavors: - annotation statements: take their arguments in registers or stack diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index 3e84e950..da6c0101 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -86,12 +86,6 @@ Definition make_immed64 (val: int64) := Definition load_hilo32 (r: ireg) (hi lo: int) k := if Int.eq lo Int.zero then Pluiw r hi :: k else Pluiw r hi :: Paddiw r r lo :: k. - -Definition loadimm32 (r: ireg) (n: int) (k: code) := - match make_immed32 n with - | Imm32_single imm => Paddiw r X0 imm :: k - | Imm32_pair hi lo => load_hilo32 r hi lo k - end. Definition opimm32 (op: ireg -> ireg0 -> ireg0 -> instruction) (opimm: ireg -> ireg0 -> int -> instruction) @@ -102,23 +96,11 @@ Definition opimm32 (op: ireg -> ireg0 -> ireg0 -> instruction) end. Definition addimm32 := opimm32 Paddw Paddiw. -Definition andimm32 := opimm32 Pandw Pandiw. -Definition orimm32 := opimm32 Porw Poriw. -Definition xorimm32 := opimm32 Pxorw Pxoriw. -Definition sltimm32 := opimm32 Psltw Psltiw. -Definition sltuimm32 := opimm32 Psltuw Psltiuw. Definition load_hilo64 (r: ireg) (hi lo: int64) k := if Int64.eq lo Int64.zero then Pluil r hi :: k else Pluil r hi :: Paddil r r lo :: k. -Definition loadimm64 (r: ireg) (n: int64) (k: code) := - match make_immed64 n with - | Imm64_single imm => Paddil r X0 imm :: k - | Imm64_pair hi lo => load_hilo64 r hi lo k - | Imm64_large imm => Ploadli r imm :: k - end. - Definition opimm64 (op: ireg -> ireg0 -> ireg0 -> instruction) (opimm: ireg -> ireg0 -> int64 -> instruction) (rd rs: ireg) (n: int64) (k: code) := @@ -129,11 +111,6 @@ Definition opimm64 (op: ireg -> ireg0 -> ireg0 -> instruction) end. Definition addimm64 := opimm64 Paddl Paddil. -Definition andimm64 := opimm64 Pandl Pandil. -Definition orimm64 := opimm64 Porl Poril. -Definition xorimm64 := opimm64 Pxorl Pxoril. -Definition sltimm64 := opimm64 Psltl Psltil. -Definition sltuimm64 := opimm64 Psltul Psltiul. Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := if Ptrofs.eq_dec n Ptrofs.zero then @@ -143,68 +120,6 @@ Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := then addimm64 rd rs (Ptrofs.to_int64 n) k else addimm32 rd rs (Ptrofs.to_int n) k. -(** Translation of conditional branches. *) - -Definition transl_cbranch_int32s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := - match cmp with - | Ceq => Pbeqw r1 r2 lbl - | Cne => Pbnew r1 r2 lbl - | Clt => Pbltw r1 r2 lbl - | Cle => Pbgew r2 r1 lbl - | Cgt => Pbltw r2 r1 lbl - | Cge => Pbgew r1 r2 lbl - end. - -Definition transl_cbranch_int32u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := - match cmp with - | Ceq => Pbeqw r1 r2 lbl - | Cne => Pbnew r1 r2 lbl - | Clt => Pbltuw r1 r2 lbl - | Cle => Pbgeuw r2 r1 lbl - | Cgt => Pbltuw r2 r1 lbl - | Cge => Pbgeuw r1 r2 lbl - end. - -Definition transl_cbranch_int64s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := - match cmp with - | Ceq => Pbeql r1 r2 lbl - | Cne => Pbnel r1 r2 lbl - | Clt => Pbltl r1 r2 lbl - | Cle => Pbgel r2 r1 lbl - | Cgt => Pbltl r2 r1 lbl - | Cge => Pbgel r1 r2 lbl - end. - -Definition transl_cbranch_int64u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := - match cmp with - | Ceq => Pbeql r1 r2 lbl - | Cne => Pbnel r1 r2 lbl - | Clt => Pbltul r1 r2 lbl - | Cle => Pbgeul r2 r1 lbl - | Cgt => Pbltul r2 r1 lbl - | Cge => Pbgeul r1 r2 lbl - end. - -Definition transl_cond_float (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := - match cmp with - | Ceq => (Pfeqd rd fs1 fs2, true) - | Cne => (Pfeqd rd fs1 fs2, false) - | Clt => (Pfltd rd fs1 fs2, true) - | Cle => (Pfled rd fs1 fs2, true) - | Cgt => (Pfltd rd fs2 fs1, true) - | Cge => (Pfled rd fs2 fs1, true) - end. - -Definition transl_cond_single (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := - match cmp with - | Ceq => (Pfeqs rd fs1 fs2, true) - | Cne => (Pfeqs rd fs1 fs2, false) - | Clt => (Pflts rd fs1 fs2, true) - | Cle => (Pfles rd fs1 fs2, true) - | Cgt => (Pflts rd fs2 fs1, true) - | Cge => (Pfles rd fs2 fs1, true) - end. - (** Functions to select a special register according to the op "oreg" argument from RTL *) Definition apply_bin_oreg_ireg0 (optR: option oreg) (r1 r2: ireg0): (ireg0 * ireg0) := @@ -223,59 +138,6 @@ Definition get_oreg (optR: option oreg) (r: ireg0) := Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) := match cond, args with - | Ccomp c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cbranch_int32s c r1 r2 lbl :: k) - | Ccompu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cbranch_int32u c r1 r2 lbl :: k) - | Ccompimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int.eq n Int.zero then - transl_cbranch_int32s c r1 X0 lbl :: k - else - loadimm32 X31 n (transl_cbranch_int32s c r1 X31 lbl :: k)) - | Ccompuimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int.eq n Int.zero then - transl_cbranch_int32u c r1 X0 lbl :: k - else - loadimm32 X31 n (transl_cbranch_int32u c r1 X31 lbl :: k)) - | Ccompl c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cbranch_int64s c r1 r2 lbl :: k) - | Ccomplu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cbranch_int64u c r1 r2 lbl :: k) - | Ccomplimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int64.eq n Int64.zero then - transl_cbranch_int64s c r1 X0 lbl :: k - else - loadimm64 X31 n (transl_cbranch_int64s c r1 X31 lbl :: k)) - | Ccompluimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int64.eq n Int64.zero then - transl_cbranch_int64u c r1 X0 lbl :: k - else - loadimm64 X31 n (transl_cbranch_int64u c r1 X31 lbl :: k)) - | Ccompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c X31 r1 r2 in - OK (insn :: (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) :: k) - | Cnotcompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c X31 r1 r2 in - OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) - | Ccompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c X31 r1 r2 in - OK (insn :: (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) :: k) - | Cnotcompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c X31 r1 r2 in - OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) - | CEbeqw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in @@ -344,133 +206,6 @@ Definition transl_cbranch Error(msg "Asmgen.transl_cond_branch") end. -(** Translation of a condition operator. The generated code sets the - [rd] target register to 0 or 1 depending on the truth value of the - condition. *) - -Definition transl_cond_int32s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := - match cmp with - | Ceq => Pseqw rd r1 r2 :: k - | Cne => Psnew rd r1 r2 :: k - | Clt => Psltw rd r1 r2 :: k - | Cle => Psltw rd r2 r1 :: Pxoriw rd rd Int.one :: k - | Cgt => Psltw rd r2 r1 :: k - | Cge => Psltw rd r1 r2 :: Pxoriw rd rd Int.one :: k - end. - -Definition transl_cond_int32u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := - match cmp with - | Ceq => Pseqw rd r1 r2 :: k - | Cne => Psnew rd r1 r2 :: k - | Clt => Psltuw rd r1 r2 :: k - | Cle => Psltuw rd r2 r1 :: Pxoriw rd rd Int.one :: k - | Cgt => Psltuw rd r2 r1 :: k - | Cge => Psltuw rd r1 r2 :: Pxoriw rd rd Int.one :: k - end. - -Definition transl_cond_int64s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := - match cmp with - | Ceq => Pseql rd r1 r2 :: k - | Cne => Psnel rd r1 r2 :: k - | Clt => Psltl rd r1 r2 :: k - | Cle => Psltl rd r2 r1 :: Pxoriw rd rd Int.one :: k - | Cgt => Psltl rd r2 r1 :: k - | Cge => Psltl rd r1 r2 :: Pxoriw rd rd Int.one :: k - end. - -Definition transl_cond_int64u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := - match cmp with - | Ceq => Pseql rd r1 r2 :: k - | Cne => Psnel rd r1 r2 :: k - | Clt => Psltul rd r1 r2 :: k - | Cle => Psltul rd r2 r1 :: Pxoriw rd rd Int.one :: k - | Cgt => Psltul rd r2 r1 :: k - | Cge => Psltul rd r1 r2 :: Pxoriw rd rd Int.one :: k - end. - -Definition transl_condimm_int32s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := - if Int.eq n Int.zero then transl_cond_int32s cmp rd r1 X0 k else - match cmp with - | Ceq | Cne => xorimm32 rd r1 n (transl_cond_int32s cmp rd rd X0 k) - | Clt => sltimm32 rd r1 n k - | Cle => if Int.eq n (Int.repr Int.max_signed) - then loadimm32 rd Int.one k - else sltimm32 rd r1 (Int.add n Int.one) k - | _ => loadimm32 X31 n (transl_cond_int32s cmp rd r1 X31 k) - end. - -Definition transl_condimm_int32u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := - if Int.eq n Int.zero then transl_cond_int32u cmp rd r1 X0 k else - match cmp with - | Clt => sltuimm32 rd r1 n k - | _ => loadimm32 X31 n (transl_cond_int32u cmp rd r1 X31 k) - end. - -Definition transl_condimm_int64s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := - if Int64.eq n Int64.zero then transl_cond_int64s cmp rd r1 X0 k else - match cmp with - | Ceq | Cne => xorimm64 rd r1 n (transl_cond_int64s cmp rd rd X0 k) - | Clt => sltimm64 rd r1 n k - | Cle => if Int64.eq n (Int64.repr Int64.max_signed) - then loadimm32 rd Int.one k - else sltimm64 rd r1 (Int64.add n Int64.one) k - | _ => loadimm64 X31 n (transl_cond_int64s cmp rd r1 X31 k) - end. - -Definition transl_condimm_int64u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := - if Int64.eq n Int64.zero then transl_cond_int64u cmp rd r1 X0 k else - match cmp with - | Clt => sltuimm64 rd r1 n k - | _ => loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k) - end. - -Definition transl_cond_op - (cond: condition) (rd: ireg) (args: list mreg) (k: code) := - match cond, args with - | Ccomp c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int32s c rd r1 r2 k) - | Ccompu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int32u c rd r1 r2 k) - | Ccompimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int32s c rd r1 n k) - | Ccompuimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int32u c rd r1 n k) - | Ccompl c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int64s c rd r1 r2 k) - | Ccomplu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int64u c rd r1 r2 k) - | Ccomplimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int64s c rd r1 n k) - | Ccompluimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int64u c rd r1 n k) - | Ccompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c rd r1 r2 in - OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) - | Cnotcompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c rd r1 r2 in - OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) - | Ccompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c rd r1 r2 in - OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) - | Cnotcompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c rd r1 r2 in - OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) - | _, _ => - Error(msg "Asmgen.transl_cond_op") - end. - (** Translation of the arithmetic operation [r <- op(args)]. The corresponding instructions are prepended to [k]. *) @@ -483,22 +218,6 @@ Definition transl_op | FR r, FR a => OK (Pfmv r a :: k) | _ , _ => Error(msg "Asmgen.Omove") end - | Ointconst n, nil => - do rd <- ireg_of res; - OK (loadimm32 rd n k) - | Olongconst n, nil => - do rd <- ireg_of res; - OK (loadimm64 rd n k) - | Ofloatconst f, nil => - do rd <- freg_of res; - OK (if Float.eq_dec f Float.zero - then Pfcvtdw rd X0 :: k - else Ploadfi rd f :: k) - | Osingleconst f, nil => - do rd <- freg_of res; - OK (if Float32.eq_dec f Float32.zero - then Pfcvtsw rd X0 :: k - else Ploadsi rd f :: k) | Oaddrsymbol s ofs, nil => do rd <- ireg_of res; OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) @@ -508,18 +227,9 @@ Definition transl_op do rd <- ireg_of res; OK (addptrofs rd SP n k) - | Ocast8signed, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs (Int.repr 24) :: Psraiw rd rd (Int.repr 24) :: k) - | Ocast16signed, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs (Int.repr 16) :: Psraiw rd rd (Int.repr 16) :: k) | Oadd, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Paddw rd rs1 rs2 :: k) - | Oaddimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (addimm32 rd rs n k) | Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psubw rd X0 rs :: k) @@ -550,21 +260,12 @@ Definition transl_op | Oand, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandw rd rs1 rs2 :: k) - | Oandimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (andimm32 rd rs n k) | Oor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porw rd rs1 rs2 :: k) - | Oorimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (orimm32 rd rs n k) | Oxor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pxorw rd rs1 rs2 :: k) - | Oxorimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (xorimm32 rd rs n k) | Oshl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psllw rd rs1 rs2 :: k) @@ -583,19 +284,6 @@ Definition transl_op | Oshruimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrliw rd rs n :: k) - | Oshrximm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (if Int.eq n Int.zero - then Pmv rd rs :: k - else if Int.eq n Int.one - then Psrliw X31 rs (Int.repr 31) :: - Paddw X31 rs X31 :: - Psraiw rd X31 Int.one :: k - else Psraiw X31 rs (Int.repr 31) :: - Psrliw X31 X31 (Int.sub Int.iwordsize n) :: - Paddw X31 rs X31 :: - Psraiw rd X31 n :: k) - (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -604,16 +292,9 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; assertion (ireg_eq rd rs); OK (Pcvtw2l rd :: k) - | Ocast32unsigned, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - assertion (ireg_eq rd rs); - OK (Pcvtw2l rd :: Psllil rd rd (Int.repr 32) :: Psrlil rd rd (Int.repr 32) :: k) | Oaddl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Paddl rd rs1 rs2 :: k) - | Oaddlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (addimm64 rd rs n k) | Onegl, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psubl rd X0 rs :: k) @@ -644,21 +325,12 @@ Definition transl_op | Oandl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandl rd rs1 rs2 :: k) - | Oandlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (andimm64 rd rs n k) | Oorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porl rd rs1 rs2 :: k) - | Oorlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (orimm64 rd rs n k) | Oxorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pxorl rd rs1 rs2 :: k) - | Oxorlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (xorimm64 rd rs n k) | Oshll, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pslll rd rs1 rs2 :: k) @@ -677,19 +349,6 @@ Definition transl_op | Oshrluimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrlil rd rs n :: k) - | Oshrxlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (if Int.eq n Int.zero - then Pmv rd rs :: k - else if Int.eq n Int.one - then Psrlil X31 rs (Int.repr 63) :: - Paddl X31 rs X31 :: - Psrail rd X31 Int.one :: k - else Psrail X31 rs (Int.repr 63) :: - Psrlil X31 X31 (Int.sub Int64.iwordsize' n) :: - Paddl X31 rs X31 :: - Psrail rd X31 n :: k) - | Onegf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfnegd rd rs :: k) @@ -784,9 +443,6 @@ Definition transl_op | Osingleoflongu, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfcvtslu rd rs :: k) - | Ocmp cmp, _ => - do rd <- ireg_of res; - transl_cond_op cmp rd args k (* Instructions expanded in RTL *) | OEseqw optR, a1 :: a2 :: nil => diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 509eac94..4af8352c 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -115,14 +115,6 @@ Qed. Section TRANSL_LABEL. -Remark loadimm32_label: - forall r n k, tail_nolabel k (loadimm32 r n k). -Proof. - intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel. - unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel. -Qed. -Hint Resolve loadimm32_label: labels. - Remark opimm32_label: forall op opimm r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> @@ -134,14 +126,6 @@ Proof. Qed. Hint Resolve opimm32_label: labels. -Remark loadimm64_label: - forall r n k, tail_nolabel k (loadimm64 r n k). -Proof. - intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel. - unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel. -Qed. -Hint Resolve loadimm64_label: labels. - Remark opimm64_label: forall op opimm r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> @@ -161,165 +145,25 @@ Proof. Qed. Hint Resolve addptrofs_label: labels. -Remark transl_cond_float_nolabel: - forall c r1 r2 r3 insn normal, - transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn. -Proof. - unfold transl_cond_float; intros. destruct c; inv H; exact I. -Qed. - -Remark transl_cond_single_nolabel: - forall c r1 r2 r3 insn normal, - transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn. -Proof. - unfold transl_cond_single; intros. destruct c; inv H; exact I. - Qed. - Remark transl_cbranch_label: forall cond args lbl k c, transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. Proof. intros. unfold transl_cbranch in H; destruct cond; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct (Int.eq n Int.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int32s c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct (Int.eq n Int.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int32u c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct (Int64.eq n Int64.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int64s c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct (Int64.eq n Int64.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int64u c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. + all: destruct optR as [[]|]; simpl in *; TailNoLabel. Qed. -Remark transl_cond_op_label: - forall cond args r k c, - transl_cond_op cond r args k = OK c -> tail_nolabel k c. -Proof. - intros. unfold transl_cond_op in H; destruct cond; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int32s. - destruct (Int.eq n Int.zero). -+ destruct c0; simpl; TailNoLabel. -+ destruct c0; simpl. -* eapply tail_nolabel_trans; [apply opimm32_label; intros; exact I | TailNoLabel]. -* eapply tail_nolabel_trans; [apply opimm32_label; intros; exact I | TailNoLabel]. -* apply opimm32_label; intros; exact I. -* destruct (Int.eq n (Int.repr Int.max_signed)). apply loadimm32_label. apply opimm32_label; intros; exact I. -* eapply tail_nolabel_trans. apply loadimm32_label. TailNoLabel. -* eapply tail_nolabel_trans. apply loadimm32_label. TailNoLabel. -- unfold transl_condimm_int32u. - destruct (Int.eq n Int.zero). -+ destruct c0; simpl; TailNoLabel. -+ destruct c0; simpl; - try (eapply tail_nolabel_trans; [apply loadimm32_label | TailNoLabel]). - apply opimm32_label; intros; exact I. -- destruct c0; simpl; TailNoLabel. - - destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int64s. - destruct (Int64.eq n Int64.zero). -+ destruct c0; simpl; TailNoLabel. -+ destruct c0; simpl. -* eapply tail_nolabel_trans; [apply opimm64_label; intros; exact I | TailNoLabel]. -* eapply tail_nolabel_trans; [apply opimm64_label; intros; exact I | TailNoLabel]. -* apply opimm64_label; intros; exact I. -* destruct (Int64.eq n (Int64.repr Int64.max_signed)). apply loadimm32_label. apply opimm64_label; intros; exact I. -* eapply tail_nolabel_trans. apply loadimm64_label. TailNoLabel. -* eapply tail_nolabel_trans. apply loadimm64_label. TailNoLabel. -- unfold transl_condimm_int64u. - destruct (Int64.eq n Int64.zero). -+ destruct c0; simpl; TailNoLabel. -+ destruct c0; simpl; - try (eapply tail_nolabel_trans; [apply loadimm64_label | TailNoLabel]). - apply opimm64_label; intros; exact I. -- destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. - Qed. - Remark transl_op_label: forall op args r k c, transl_op op args r k = OK c -> tail_nolabel k c. Proof. Opaque Int.eq. - unfold transl_op; intros; destruct op; TailNoLabel. + unfold transl_op; intros; destruct op; TailNoLabel; + try (destruct optR as [[]|]; simpl in *; TailNoLabel). - destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. -- destruct (Float.eq_dec n Float.zero); TailNoLabel. -- destruct (Float32.eq_dec n Float32.zero); TailNoLabel. - destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). + eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel. + TailNoLabel. -- apply opimm32_label; intros; exact I. -- apply opimm32_label; intros; exact I. -- apply opimm32_label; intros; exact I. -- apply opimm32_label; intros; exact I. -- destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. -- apply opimm64_label; intros; exact I. -- apply opimm64_label; intros; exact I. -- apply opimm64_label; intros; exact I. -- apply opimm64_label; intros; exact I. -- destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. -- eapply transl_cond_op_label; eauto. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. -- destruct optR as [[]|]; simpl in *; TailNoLabel. Qed. Remark indexed_memory_access_label: diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 2293e001..faa066b0 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -129,22 +129,6 @@ Proof. intros; Simpl. Qed. -Lemma loadimm32_correct: - forall rd n k rs m, - exists rs', - exec_straight ge fn (loadimm32 rd n k) rs m k rs' m - /\ rs'#rd = Vint n - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold loadimm32; intros. generalize (make_immed32_sound n); intros E. - destruct (make_immed32 n). -- subst imm. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. rewrite Int.add_zero_l; Simpl. - intros; Simpl. -- rewrite E. apply load_hilo32_correct. -Qed. - Lemma opimm32_correct: forall (op: ireg -> ireg0 -> ireg0 -> instruction) (opi: ireg -> ireg0 -> int -> instruction) @@ -195,27 +179,6 @@ Proof. intros; Simpl. Qed. -Lemma loadimm64_correct: - forall rd n k rs m, - exists rs', - exec_straight ge fn (loadimm64 rd n k) rs m k rs' m - /\ rs'#rd = Vlong n - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. -Proof. - unfold loadimm64; intros. generalize (make_immed64_sound n); intros E. - destruct (make_immed64 n). -- subst imm. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. rewrite Int64.add_zero_l; Simpl. - intros; Simpl. -- exploit load_hilo64_correct; eauto. intros (rs' & A & B & C). - rewrite E. exists rs'; eauto. -- subst imm. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. - intros; Simpl. -Qed. - Lemma opimm64_correct: forall (op: ireg -> ireg0 -> ireg0 -> instruction) (opi: ireg -> ireg0 -> int64 -> instruction) @@ -290,102 +253,6 @@ Proof. rewrite H0 in B. inv B. auto. Qed. -(** Translation of conditional branches *) - -Lemma transl_cbranch_int32s_correct: - forall cmp r1 r2 lbl (rs: regset) m b, - Val.cmp_bool cmp rs##r1 rs##r2 = Some b -> - exec_instr ge fn (transl_cbranch_int32s cmp r1 r2 lbl) rs m = - eval_branch fn lbl rs m (Some b). -Proof. - intros. destruct cmp; simpl; rewrite ? H. -- destruct rs##r1; simpl in H; try discriminate. destruct rs##r2; inv H. - simpl; auto. -- destruct rs##r1; simpl in H; try discriminate. destruct rs##r2; inv H. - simpl; auto. -- auto. -- rewrite <- Val.swap_cmp_bool. simpl. rewrite H; auto. -- rewrite <- Val.swap_cmp_bool. simpl. rewrite H; auto. -- auto. -Qed. - -Lemma transl_cbranch_int32u_correct: - forall cmp r1 r2 lbl (rs: regset) m b, - Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2 = Some b -> - exec_instr ge fn (transl_cbranch_int32u cmp r1 r2 lbl) rs m = - eval_branch fn lbl rs m (Some b). -Proof. - intros. destruct cmp; simpl; rewrite ? H; auto. -- rewrite <- Val.swap_cmpu_bool. simpl. rewrite H; auto. -- rewrite <- Val.swap_cmpu_bool. simpl. rewrite H; auto. -Qed. - -Lemma transl_cbranch_int64s_correct: - forall cmp r1 r2 lbl (rs: regset) m b, - Val.cmpl_bool cmp rs###r1 rs###r2 = Some b -> - exec_instr ge fn (transl_cbranch_int64s cmp r1 r2 lbl) rs m = - eval_branch fn lbl rs m (Some b). -Proof. - intros. destruct cmp; simpl; rewrite ? H. -- destruct rs###r1; simpl in H; try discriminate. destruct rs###r2; inv H. - simpl; auto. -- destruct rs###r1; simpl in H; try discriminate. destruct rs###r2; inv H. - simpl; auto. -- auto. -- rewrite <- Val.swap_cmpl_bool. simpl. rewrite H; auto. -- rewrite <- Val.swap_cmpl_bool. simpl. rewrite H; auto. -- auto. -Qed. - -Lemma transl_cbranch_int64u_correct: - forall cmp r1 r2 lbl (rs: regset) m b, - Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2 = Some b -> - exec_instr ge fn (transl_cbranch_int64u cmp r1 r2 lbl) rs m = - eval_branch fn lbl rs m (Some b). -Proof. - intros. destruct cmp; simpl; rewrite ? H; auto. -- rewrite <- Val.swap_cmplu_bool. simpl. rewrite H; auto. -- rewrite <- Val.swap_cmplu_bool. simpl. rewrite H; auto. -Qed. - -Lemma transl_cond_float_correct: - forall (rs: regset) m cmp rd r1 r2 insn normal v, - transl_cond_float cmp rd r1 r2 = (insn, normal) -> - v = (if normal then Val.cmpf cmp rs#r1 rs#r2 else Val.notbool (Val.cmpf cmp rs#r1 rs#r2)) -> - exec_instr ge fn insn rs m = Next (nextinstr (rs#rd <- v)) m. -Proof. - intros. destruct cmp; simpl in H; inv H; auto. -- rewrite Val.negate_cmpf_eq. auto. -- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpf, Val.cmpf_bool. - rewrite <- Float.cmp_swap. auto. -- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpf, Val.cmpf_bool. - rewrite <- Float.cmp_swap. auto. -Qed. - -Lemma transl_cond_single_correct: - forall (rs: regset) m cmp rd r1 r2 insn normal v, - transl_cond_single cmp rd r1 r2 = (insn, normal) -> - v = (if normal then Val.cmpfs cmp rs#r1 rs#r2 else Val.notbool (Val.cmpfs cmp rs#r1 rs#r2)) -> - exec_instr ge fn insn rs m = Next (nextinstr (rs#rd <- v)) m. -Proof. - intros. destruct cmp; simpl in H; inv H; auto. -- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. - rewrite Float32.cmp_ne_eq. destruct (Float32.cmp Ceq f0 f); auto. -- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. - rewrite <- Float32.cmp_swap. auto. -- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. - rewrite <- Float32.cmp_swap. auto. - Qed. - -(* TODO gourdinl UNUSUED ? Remark branch_on_X31: - forall normal lbl (rs: regset) m b, - rs#X31 = Val.of_bool (eqb normal b) -> - exec_instr ge fn (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) rs m = - eval_branch fn lbl rs m (Some b). -Proof. - intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity. - Qed.*) - Ltac ArgsInv := repeat (match goal with | [ H: Error _ = OK _ |- _ ] => discriminate @@ -417,219 +284,46 @@ Proof. { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } clear EVAL MEXT AG. destruct cond; simpl in TRANSL; ArgsInv. - - exists rs, (transl_cbranch_int32s c0 x x0 lbl). - intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. -- exists rs, (transl_cbranch_int32u c0 x x0 lbl). - intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. -- predSpec Int.eq Int.eq_spec n Int.zero. -+ subst n. exists rs, (transl_cbranch_int32s c0 x X0 lbl). - intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. -+ exploit (loadimm32_correct X31 n); eauto. intros (rs' & A & B & C). - exists rs', (transl_cbranch_int32s c0 x X31 lbl). - split. constructor; eexact A. split; auto. - apply transl_cbranch_int32s_correct; auto. - simpl; rewrite B, C; eauto with asmgen. -- predSpec Int.eq Int.eq_spec n Int.zero. -+ subst n. exists rs, (transl_cbranch_int32u c0 x X0 lbl). - intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. -+ exploit (loadimm32_correct X31 n); eauto. intros (rs' & A & B & C). - exists rs', (transl_cbranch_int32u c0 x X31 lbl). - split. constructor; eexact A. split; auto. - apply transl_cbranch_int32u_correct; auto. - simpl; rewrite B, C; eauto with asmgen. -- exists rs, (transl_cbranch_int64s c0 x x0 lbl). - intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. -- exists rs, (transl_cbranch_int64u c0 x x0 lbl). - intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. -- predSpec Int64.eq Int64.eq_spec n Int64.zero. -+ subst n. exists rs, (transl_cbranch_int64s c0 x X0 lbl). - intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. -+ exploit (loadimm64_correct X31 n); eauto. intros (rs' & A & B & C). - exists rs', (transl_cbranch_int64s c0 x X31 lbl). - split. constructor; eexact A. split; auto. - apply transl_cbranch_int64s_correct; auto. - simpl; rewrite B, C; eauto with asmgen. -- predSpec Int64.eq Int64.eq_spec n Int64.zero. -+ subst n. exists rs, (transl_cbranch_int64u c0 x X0 lbl). - intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. -+ exploit (loadimm64_correct X31 n); eauto. intros (rs' & A & B & C). - exists rs', (transl_cbranch_int64u c0 x X31 lbl). - split. constructor; eexact A. split; auto. - apply transl_cbranch_int64u_correct; auto. - simpl; rewrite B, C; eauto with asmgen. -- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. - set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). - assert (V: v = Val.of_bool (eqb normal b)). - { unfold v, Val.cmpf. rewrite EVAL'. destruct normal, b; reflexivity. } - econstructor; econstructor. - split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. - split. rewrite V; destruct normal, b; reflexivity. - intros; Simpl. -- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. - assert (EVAL'': Val.cmpf_bool c0 (rs x) (rs x0) = Some (negb b)). - { destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } - set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). - assert (V: v = Val.of_bool (xorb normal b)). - { unfold v, Val.cmpf. rewrite EVAL''. destruct normal, b; reflexivity. } - econstructor; econstructor. - split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. - split. rewrite V; destruct normal, b; reflexivity. - intros; Simpl. -- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. - set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). - assert (V: v = Val.of_bool (eqb normal b)). - { unfold v, Val.cmpfs. rewrite EVAL'. destruct normal, b; reflexivity. } - econstructor; econstructor. - split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. - split. rewrite V; destruct normal, b; reflexivity. - intros; Simpl. -- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. - assert (EVAL'': Val.cmpfs_bool c0 (rs x) (rs x0) = Some (negb b)). - { destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } - set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). - assert (V: v = Val.of_bool (xorb normal b)). - { unfold v, Val.cmpfs. rewrite EVAL''. destruct normal, b; reflexivity. } - econstructor; econstructor. - split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. - split. rewrite V; destruct normal, b; reflexivity. - intros; Simpl. - -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32 in *; - destruct (rs x) eqn:EQRS; simpl in *; try congruence; - inv EQ2; eexists; eexists; eauto; split; constructor; auto; - simpl in *. - + rewrite EQRS; - assert (HB: (Int.eq Int.zero i) = b) by congruence. + all: + destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; + unfold zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + try (eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto; fail). + all: + destruct (rs x) eqn:EQRS; simpl in *; try congruence; + eexists; eexists; eauto; split; constructor; auto; + simpl in *; rewrite EQRS. + - assert (HB: (Int.eq Int.zero i) = b) by congruence; rewrite HB; destruct b; simpl; auto. - + rewrite EQRS; - assert (HB: (Int.eq i Int.zero) = b) by congruence. + - assert (HB: (Int.eq i Int.zero) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - + rewrite EQRS; - destruct (rs x0); try congruence. + - destruct (rs x0); try congruence. assert (HB: (Int.eq i i0) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32 in *; - destruct (rs x) eqn:EQRS; simpl in *; try congruence; - inv EQ2; eexists; eexists; eauto; split; constructor; auto; - simpl in *. - + rewrite EQRS; - assert (HB: negb (Int.eq Int.zero i) = b) by congruence. + - assert (HB: negb (Int.eq Int.zero i) = b) by congruence. rewrite HB; destruct b; simpl; auto. - + rewrite EQRS; - assert (HB: negb (Int.eq i Int.zero) = b) by congruence. + - assert (HB: negb (Int.eq i Int.zero) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - + rewrite EQRS; - destruct (rs x0); try congruence. + - destruct (rs x0); try congruence. assert (HB: negb (Int.eq i i0) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32 in *; inv EQ2; - destruct (rs x) eqn:EQRS; simpl in *; try congruence; - eexists; eexists; eauto; split; constructor; - simpl in *; auto. - + rewrite EQRS; - assert (HB: (Int64.eq Int64.zero i) = b) by congruence. + - assert (HB: (Int64.eq Int64.zero i) = b) by congruence. rewrite HB; destruct b; simpl; auto. - + rewrite EQRS; - assert (HB: (Int64.eq i Int64.zero) = b) by congruence. + - assert (HB: (Int64.eq i Int64.zero) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - + rewrite EQRS; - destruct (rs x0); try congruence. + - destruct (rs x0); try congruence. assert (HB: (Int64.eq i i0) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32 in *; inv EQ2; - destruct (rs x) eqn:EQRS; simpl in *; try congruence; - eexists; eexists; eauto; split; constructor; - simpl in *; auto. - + rewrite EQRS; - assert (HB: negb (Int64.eq Int64.zero i) = b) by congruence. + - assert (HB: negb (Int64.eq Int64.zero i) = b) by congruence. rewrite HB; destruct b; simpl; auto. - + rewrite EQRS; - assert (HB: negb (Int64.eq i Int64.zero) = b) by congruence. + - assert (HB: negb (Int64.eq i Int64.zero) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - + rewrite EQRS; - destruct (rs x0); try congruence. + - destruct (rs x0); try congruence. assert (HB: negb (Int64.eq i i0) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. -- destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. Qed. Lemma transl_cbranch_correct_true: @@ -663,417 +357,6 @@ Proof. intros; Simpl. Qed. -(** Translation of condition operators *) - -Lemma transl_cond_int32s_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge fn (transl_cond_int32s cmp rd r1 r2 k) rs m k rs' m - /\ Val.lessdef (Val.cmp cmp rs##r1 rs##r2) rs'#rd - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. destruct (rs##r1); auto. destruct (rs##r2); auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. destruct (rs##r1); auto. destruct (rs##r2); auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmp. rewrite <- Val.swap_cmp_bool. - simpl. rewrite (Val.negate_cmp_bool Clt). - destruct (Val.cmp_bool Clt rs##r2 rs##r1) as [[]|]; auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. unfold Val.cmp. rewrite <- Val.swap_cmp_bool. auto. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmp. rewrite (Val.negate_cmp_bool Clt). - destruct (Val.cmp_bool Clt rs##r1 rs##r2) as [[]|]; auto. -Qed. - -Lemma transl_cond_int32u_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge fn (transl_cond_int32u cmp rd r1 r2 k) rs m k rs' m - /\ rs'#rd = Val.cmpu (Mem.valid_pointer m) cmp rs##r1 rs##r2 - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmpu. rewrite <- Val.swap_cmpu_bool. - simpl. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Cle). - destruct (Val.cmpu_bool (Mem.valid_pointer m) Cle rs##r1 rs##r2) as [[]|]; auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. unfold Val.cmpu. rewrite <- Val.swap_cmpu_bool. auto. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmpu. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Clt). - destruct (Val.cmpu_bool (Mem.valid_pointer m) Clt rs##r1 rs##r2) as [[]|]; auto. -Qed. - -Lemma transl_cond_int64s_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge fn (transl_cond_int64s cmp rd r1 r2 k) rs m k rs' m - /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs###r1 rs###r2)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. destruct (rs###r1); auto. destruct (rs###r2); auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. destruct (rs###r1); auto. destruct (rs###r2); auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmpl. rewrite <- Val.swap_cmpl_bool. - simpl. rewrite (Val.negate_cmpl_bool Clt). - destruct (Val.cmpl_bool Clt rs###r2 rs###r1) as [[]|]; auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. unfold Val.cmpl. rewrite <- Val.swap_cmpl_bool. auto. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmpl. rewrite (Val.negate_cmpl_bool Clt). - destruct (Val.cmpl_bool Clt rs###r1 rs###r2) as [[]|]; auto. -Qed. - -Lemma transl_cond_int64u_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge fn (transl_cond_int64u cmp rd r1 r2 k) rs m k rs' m - /\ rs'#rd = Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs###r1 rs###r2) - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmplu. rewrite <- Val.swap_cmplu_bool. - simpl. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Cle). - destruct (Val.cmplu_bool (Mem.valid_pointer m) Cle rs###r1 rs###r2) as [[]|]; auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. unfold Val.cmplu. rewrite <- Val.swap_cmplu_bool. auto. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmplu. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Clt). - destruct (Val.cmplu_bool (Mem.valid_pointer m) Clt rs###r1 rs###r2) as [[]|]; auto. -Qed. - -Lemma transl_condimm_int32s_correct: - forall cmp rd r1 n k rs m, - r1 <> X31 -> - exists rs', - exec_straight ge fn (transl_condimm_int32s cmp rd r1 n k) rs m k rs' m - /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. -Proof. - intros. unfold transl_condimm_int32s. - predSpec Int.eq Int.eq_spec n Int.zero. -- subst n. exploit transl_cond_int32s_correct. intros (rs' & A & B & C). - exists rs'; eauto. -- assert (DFL: - exists rs', - exec_straight ge fn (loadimm32 X31 n (transl_cond_int32s cmp rd r1 X31 k)) rs m k rs' m - /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). - { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. auto. - intros; transitivity (rs1 r); auto. } - destruct cmp. -+ unfold xorimm32. - exploit (opimm32_correct Pxorw Pxoriw Val.xor); eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. - unfold Val.cmp in B2; simpl in B2; rewrite Int.xor_is_zero in B2. exact B2. - intros; transitivity (rs1 r); auto. -+ unfold xorimm32. - exploit (opimm32_correct Pxorw Pxoriw Val.xor); eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. - unfold Val.cmp in B2; simpl in B2; rewrite Int.xor_is_zero in B2. exact B2. - intros; transitivity (rs1 r); auto. -+ exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. rewrite B1; auto. -+ predSpec Int.eq Int.eq_spec n (Int.repr Int.max_signed). -* subst n. exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. - unfold Val.cmp; destruct (rs#r1); simpl; auto. rewrite B1. - unfold Int.lt. rewrite zlt_false. auto. - change (Int.signed (Int.repr Int.max_signed)) with Int.max_signed. - generalize (Int.signed_range i); omega. -* exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. - rewrite B1. unfold Val.cmp; simpl; destruct (rs#r1); simpl; auto. - unfold Int.lt. replace (Int.signed (Int.add n Int.one)) with (Int.signed n + 1). - destruct (zlt (Int.signed n) (Int.signed i)). - rewrite zlt_false by omega. auto. - rewrite zlt_true by omega. auto. - rewrite Int.add_signed. symmetry; apply Int.signed_repr. - assert (Int.signed n <> Int.max_signed). - { red; intros E. elim H1. rewrite <- (Int.repr_signed n). rewrite E. auto. } - generalize (Int.signed_range n); omega. -+ apply DFL. -+ apply DFL. -Qed. - -Lemma transl_condimm_int32u_correct: - forall cmp rd r1 n k rs m, - r1 <> X31 -> - exists rs', - exec_straight ge fn (transl_condimm_int32u cmp rd r1 n k) rs m k rs' m - /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. -Proof. - intros. unfold transl_condimm_int32u. - predSpec Int.eq Int.eq_spec n Int.zero. -- subst n. exploit transl_cond_int32u_correct. intros (rs' & A & B & C). - exists rs'; split. eexact A. split; auto. rewrite B; auto. -- assert (DFL: - exists rs', - exec_straight ge fn (loadimm32 X31 n (transl_cond_int32u cmp rd r1 X31 k)) rs m k rs' m - /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). - { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int32u_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. rewrite B2; auto. - intros; transitivity (rs1 r); auto. } - destruct cmp. -+ apply DFL. -+ apply DFL. -+ exploit (opimm32_correct Psltuw Psltiuw (Val.cmpu (Mem.valid_pointer m) Clt) m); eauto. - intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. rewrite B1; auto. -+ apply DFL. -+ apply DFL. -+ apply DFL. -Qed. - -Lemma transl_condimm_int64s_correct: - forall cmp rd r1 n k rs m, - r1 <> X31 -> - exists rs', - exec_straight ge fn (transl_condimm_int64s cmp rd r1 n k) rs m k rs' m - /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. -Proof. - intros. unfold transl_condimm_int64s. - predSpec Int64.eq Int64.eq_spec n Int64.zero. -- subst n. exploit transl_cond_int64s_correct. intros (rs' & A & B & C). - exists rs'; eauto. -- assert (DFL: - exists rs', - exec_straight ge fn (loadimm64 X31 n (transl_cond_int64s cmp rd r1 X31 k)) rs m k rs' m - /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). - { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. auto. - intros; transitivity (rs1 r); auto. } - destruct cmp. -+ unfold xorimm64. - exploit (opimm64_correct Pxorl Pxoril Val.xorl); eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. - unfold Val.cmpl in B2; simpl in B2; rewrite Int64.xor_is_zero in B2. exact B2. - intros; transitivity (rs1 r); auto. -+ unfold xorimm64. - exploit (opimm64_correct Pxorl Pxoril Val.xorl); eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. - unfold Val.cmpl in B2; simpl in B2; rewrite Int64.xor_is_zero in B2. exact B2. - intros; transitivity (rs1 r); auto. -+ exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. rewrite B1; auto. -+ predSpec Int64.eq Int64.eq_spec n (Int64.repr Int64.max_signed). -* subst n. exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. - unfold Val.cmpl; destruct (rs#r1); simpl; auto. rewrite B1. - unfold Int64.lt. rewrite zlt_false. auto. - change (Int64.signed (Int64.repr Int64.max_signed)) with Int64.max_signed. - generalize (Int64.signed_range i); omega. -* exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. - rewrite B1. unfold Val.cmpl; simpl; destruct (rs#r1); simpl; auto. - unfold Int64.lt. replace (Int64.signed (Int64.add n Int64.one)) with (Int64.signed n + 1). - destruct (zlt (Int64.signed n) (Int64.signed i)). - rewrite zlt_false by omega. auto. - rewrite zlt_true by omega. auto. - rewrite Int64.add_signed. symmetry; apply Int64.signed_repr. - assert (Int64.signed n <> Int64.max_signed). - { red; intros E. elim H1. rewrite <- (Int64.repr_signed n). rewrite E. auto. } - generalize (Int64.signed_range n); omega. -+ apply DFL. -+ apply DFL. -Qed. - -Lemma transl_condimm_int64u_correct: - forall cmp rd r1 n k rs m, - r1 <> X31 -> - exists rs', - exec_straight ge fn (transl_condimm_int64u cmp rd r1 n k) rs m k rs' m - /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. -Proof. - intros. unfold transl_condimm_int64u. - predSpec Int64.eq Int64.eq_spec n Int64.zero. -- subst n. exploit transl_cond_int64u_correct. intros (rs' & A & B & C). - exists rs'; split. eexact A. split; auto. rewrite B; auto. -- assert (DFL: - exists rs', - exec_straight ge fn (loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k)) rs m k rs' m - /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). - { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int64u_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. rewrite B2; auto. - intros; transitivity (rs1 r); auto. } - destruct cmp. -+ apply DFL. -+ apply DFL. -+ exploit (opimm64_correct Psltul Psltiul (fun v1 v2 => Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 v2)) m); eauto. - intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. rewrite B1; auto. -+ apply DFL. -+ apply DFL. -+ apply DFL. - Qed. - -Lemma transl_cond_op_correct: - forall cond rd args k c rs m, - transl_cond_op cond rd args k = OK c -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. -Proof. - assert (MKTOT: forall ob, Val.of_optbool ob = Val.maketotal (option_map Val.of_bool ob)). - { destruct ob as [[]|]; reflexivity. } - intros until m; intros TR. - destruct cond; simpl in TR; ArgsInv. -+ (* cmp *) - exploit transl_cond_int32s_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. -+ (* cmpu *) - exploit transl_cond_int32u_correct; eauto. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite B; auto. -+ (* cmpimm *) - apply transl_condimm_int32s_correct; eauto with asmgen. -+ (* cmpuimm *) - apply transl_condimm_int32u_correct; eauto with asmgen. -+ (* cmpl *) - exploit transl_cond_int64s_correct; eauto. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite MKTOT; eauto. -+ (* cmplu *) - exploit transl_cond_int64u_correct; eauto. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. -+ (* cmplimm *) - exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite MKTOT; eauto. -+ (* cmpluimm *) - exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite MKTOT; eauto. -+ (* cmpf *) - destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. - fold (Val.cmpf c0 (rs x) (rs x0)). - set (v := Val.cmpf c0 (rs x) (rs x0)). - destruct normal; inv EQ2. -* econstructor; split. - apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. - split; intros; Simpl. -* econstructor; split. - eapply exec_straight_two. - eapply transl_cond_float_correct with (v := Val.notbool v); eauto. - simpl; reflexivity. - auto. auto. - split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto. -+ (* notcmpf *) - destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. - rewrite Val.notbool_negb_3. fold (Val.cmpf c0 (rs x) (rs x0)). - set (v := Val.cmpf c0 (rs x) (rs x0)). - destruct normal; inv EQ2. -* econstructor; split. - eapply exec_straight_two. - eapply transl_cond_float_correct with (v := v); eauto. - simpl; reflexivity. - auto. auto. - split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto. -* econstructor; split. - apply exec_straight_one. eapply transl_cond_float_correct with (v := Val.notbool v); eauto. auto. - split; intros; Simpl. -+ (* cmpfs *) - destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR. - fold (Val.cmpfs c0 (rs x) (rs x0)). - set (v := Val.cmpfs c0 (rs x) (rs x0)). - destruct normal; inv EQ2. -* econstructor; split. - apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. - split; intros; Simpl. -* econstructor; split. - eapply exec_straight_two. - eapply transl_cond_single_correct with (v := Val.notbool v); eauto. - simpl; reflexivity. - auto. auto. - split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto. -+ (* notcmpfs *) - destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR. - rewrite Val.notbool_negb_3. fold (Val.cmpfs c0 (rs x) (rs x0)). - set (v := Val.cmpfs c0 (rs x) (rs x0)). - destruct normal; inv EQ2. -* econstructor; split. - eapply exec_straight_two. - eapply transl_cond_single_correct with (v := v); eauto. - simpl; reflexivity. - auto. auto. - split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto. -* econstructor; split. - apply exec_straight_one. eapply transl_cond_single_correct with (v := Val.notbool v); eauto. auto. - split; intros; Simpl. - Qed. - -(** Some arithmetic properties. *) - -Remark cast32unsigned_from_cast32signed: - forall i, Int64.repr (Int.unsigned i) = Int64.zero_ext 32 (Int64.repr (Int.signed i)). -Proof. - intros. apply Int64.same_bits_eq; intros. - rewrite Int64.bits_zero_ext, !Int64.testbit_repr by tauto. - rewrite Int.bits_signed by tauto. fold (Int.testbit i i0). - change Int.zwordsize with 32. - destruct (zlt i0 32). auto. apply Int.bits_above. auto. -Qed. - (* Translation of arithmetic operations *) Ltac SimplEval H := @@ -1103,28 +386,6 @@ Opaque Int.eq. unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. (* move *) { destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. } - (* intconst *) - { exploit loadimm32_correct; eauto. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* longconst *) - { exploit loadimm64_correct; eauto. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* floatconst *) - { destruct (Float.eq_dec n Float.zero). - + subst n. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. - + econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. } - (* singleconst *) - { destruct (Float32.eq_dec n Float32.zero). - + subst n. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. - + econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. } (* addrsymbol *) { destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). + set (rs1 := nextinstr (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). @@ -1141,138 +402,6 @@ Opaque Int.eq. (* stackoffset *) { exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. auto with asmgen. } - (* cast8signed *) - { econstructor; split. - eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. - split; intros; Simpl. - assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. - destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. } - (* cast16signed *) - { econstructor; split. - eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. - split; intros; Simpl. - assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. - destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. } - (* addimm *) - { exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* andimm *) - { exploit (opimm32_correct Pandw Pandiw Val.and); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* orimm *) - exploit (opimm32_correct Porw Poriw Val.or); auto. instantiate (1 := x0); eauto with asmgen. - { intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* xorimm *) - { exploit (opimm32_correct Pxorw Pxoriw Val.xor); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* shrximm *) - { destruct (Val.shrx (rs x0) (Vint n)) eqn:TOTAL; cbn. - { - exploit Val.shrx_shr_3; eauto. intros E; subst v. - destruct (Int.eq n Int.zero). - + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. - + destruct (Int.eq n Int.one). - * econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - } - destruct (Int.eq n Int.zero). - + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. - + destruct (Int.eq n Int.one). - * econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. } - (* longofintu *) - { econstructor; split. - eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. - split; intros; Simpl. destruct (rs x0); auto. simpl. - assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. - rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. - rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. } - (* addlimm *) - { exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* andimm *) - { exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* orimm *) - { exploit (opimm64_correct Porl Poril Val.orl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* xorimm *) - { exploit (opimm64_correct Pxorl Pxoril Val.xorl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* shrxlimm *) - { destruct (Val.shrxl (rs x0) (Vint n)) eqn:TOTAL. - { - exploit Val.shrxl_shrl_3; eauto. intros E; subst v. - destruct (Int.eq n Int.zero). - + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. - + destruct (Int.eq n Int.one). - * econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - - * change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - } - destruct (Int.eq n Int.zero). - + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. - + destruct (Int.eq n Int.one). - * econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - - * change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. } - (* cond *) - { exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). - exists rs'; split. eexact A. eauto with asmgen. } (* Expanded instructions from RTL *) 9,10,19,20: econstructor; split; try apply exec_straight_one; simpl; eauto; diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index d55d94ad..33e2db61 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -847,6 +847,16 @@ Proof. destruct x; destruct y; simpl; auto. rewrite Float32.cmp_swap. auto. Qed. +Remark cast32unsigned_from_cast32signed: + forall i, Int64.repr (Int.unsigned i) = Int64.zero_ext 32 (Int64.repr (Int.signed i)). +Proof. + intros. apply Int64.same_bits_eq; intros. + rewrite Int64.bits_zero_ext, !Int64.testbit_repr by tauto. + rewrite Int.bits_signed by tauto. fold (Int.testbit i i0). + change Int.zwordsize with 32. + destruct (zlt i0 32). auto. apply Int.bits_above. auto. +Qed. + (** * Intermediates lemmas on each expanded instruction *) Lemma simplify_ccomp_correct ge sp hst st c r r0 rs0 m0 v v0: forall -- cgit From b0252257587f375408c4521dab1ca1396e96ab79 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Fri, 9 Apr 2021 15:19:27 +0200 Subject: Remove flags --- riscV/ExpansionOracle.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 092bf0d1..b8a7f6e7 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -700,8 +700,7 @@ let expanse (sb : superblock) code pm = was_exp := false; let inst = get_some @@ PTree.get n code in if exp_debug then eprintf "We are checking node %d\n" (p2i n); - (if !Clflags.option_fexpanse_rtlcond then - match inst with + (match inst with (* Expansion of conditions - Ocmp *) | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> if exp_debug then eprintf "Iop/Ccomp\n"; @@ -828,7 +827,7 @@ let expanse (sb : superblock) code pm = was_branch := true; was_exp := true | _ -> ()); - (if !Clflags.option_fexpanse_others && not !was_exp then + (if not !was_exp then match inst with | Iop (Ofloatconst f, nil, dest, succ) -> if exp_debug then eprintf "Iop/Ofloatconst\n"; -- cgit From 77f3fd97849ad7daa0c6e29c1d7d511d94fb4455 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Fri, 9 Apr 2021 16:57:27 +0200 Subject: adding missing xorimm exp --- riscV/ExpansionOracle.ml | 10 +++++++ riscV/RTLpathSE_simplify.v | 67 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 77 insertions(+) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index b8a7f6e7..4f67b9af 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -885,6 +885,16 @@ let expanse (sb : superblock) code pm = exp := orimm64 vn a1 dest n; exp := extract_final vn !exp dest succ; was_exp := true + | Iop (Oxorimm n, a1 :: nil, dest, succ) -> + if exp_debug then eprintf "Iop/Oxorimm\n"; + exp := xorimm32 vn a1 dest n; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oxorlimm n, a1 :: nil, dest, succ) -> + if exp_debug then eprintf "Iop/Oxorlimm\n"; + exp := xorimm64 vn a1 dest n; + exp := extract_final vn !exp dest succ; + was_exp := true | Iop (Ocast8signed, a1 :: nil, dest, succ) -> if exp_debug then eprintf "Iop/cast8signed\n"; let op = Oshlimm (Int.repr (Z.of_sint 24)) in diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index 33e2db61..7aca1772 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -407,6 +407,12 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca | Oorlimm n, a1 :: nil => let hv1 := fsi_sreg_get hst a1 in Some (orimm64 hv1 n) + | Oxorimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (xorimm32 hv1 n) + | Oxorlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (xorimm64 hv1 n) | Ocast8signed, a1 :: nil => let hv1 := fsi_sreg_get hst a1 in let hl := make_lhsv_single hv1 in @@ -1560,6 +1566,65 @@ Proof. try rewrite ltu_12_wordsize; trivial. Qed. +Lemma simplify_xorimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (xorimm32 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oxorimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold xorimm32, opimm32, load_hilo32, make_lhsv_cmp; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.xor (Vint imm) v); rewrite Val.xor_commut; trivial. + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_xorlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (xorimm64 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oxorlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold xorimm64, opimm64, load_hilo64, make_lhsv_cmp; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.xorl (Vlong imm) v); rewrite Val.xorl_commut; trivial. + all: + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + Lemma simplify_intconst_correct ge sp rs0 m0 args m n fsv lr st: forall (H : match lr with | nil => Some (loadimm32 n) @@ -1926,11 +1991,13 @@ Proof. eapply simplify_addimm_correct; eauto. eapply simplify_andimm_correct; eauto. eapply simplify_orimm_correct; eauto. + eapply simplify_xorimm_correct; eauto. eapply simplify_shrximm_correct; eauto. eapply simplify_cast32unsigned_correct; eauto. eapply simplify_addlimm_correct; eauto. eapply simplify_andlimm_correct; eauto. eapply simplify_orlimm_correct; eauto. + eapply simplify_xorlimm_correct; eauto. eapply simplify_shrxlimm_correct; eauto. (* Ocmp expansions *) destruct cond; repeat (destruct lr; simpl; try congruence); -- cgit From 97c9a374620a1a74116aefe09f175ae964419e6a Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Tue, 18 May 2021 19:42:31 +0200 Subject: debug prints uniformized --- riscV/ExpansionOracle.ml | 135 +++++++++++++++++++++++------------------------ 1 file changed, 66 insertions(+), 69 deletions(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 4f67b9af..5d739375 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -22,13 +22,11 @@ open! Integers open Camlcoq open Option open AST -open Printf +open DebugPrint (** Mini CSE (a dynamic numbering is applied during expansion. The CSE algorithm is inspired by the "static" one used in backend/CSE.v *) -let exp_debug = false - (** Managing virtual registers and node index *) let reg = ref 1 @@ -80,9 +78,9 @@ type numb = { } let print_list_pos l = - if exp_debug then eprintf "["; - List.iter (fun i -> if exp_debug then eprintf "%d;" (p2i i)) l; - if exp_debug then eprintf "]\n" + debug "["; + List.iter (fun i -> debug "%d;" (p2i i)) l; + debug "]\n" let empty_numbering () = { nnext = 1; seqs = []; nreg = Hashtbl.create 100; nval = Hashtbl.create 100 } @@ -93,11 +91,11 @@ let rec get_nvalues vn = function let v = match Hashtbl.find_opt !vn.nreg r with | Some v -> - if exp_debug then eprintf "getnval r=%d |-> v=%d\n" (p2i r) v; + debug "getnval r=%d |-> v=%d\n" (p2i r) v; v | None -> let n = !vn.nnext in - if exp_debug then eprintf "getnval r=%d |-> v=%d\n" (p2i r) n; + debug "getnval r=%d |-> v=%d\n" (p2i r) n; !vn.nnext <- !vn.nnext + 1; Hashtbl.replace !vn.nreg r n; Hashtbl.replace !vn.nval n [ r ]; @@ -112,17 +110,17 @@ let get_nval_ornil vn v = let forget_reg vn rd = match Hashtbl.find_opt !vn.nreg rd with | Some v -> - if exp_debug then eprintf "forget_reg: r=%d |-> v=%d\n" (p2i rd) v; + debug "forget_reg: r=%d |-> v=%d\n" (p2i rd) v; let old_regs = get_nval_ornil vn v in - if exp_debug then eprintf "forget_reg: old_regs are:\n"; + debug "forget_reg: old_regs are:\n"; print_list_pos old_regs; Hashtbl.replace !vn.nval v (List.filter (fun n -> not (P.eq n rd)) old_regs) | None -> - if exp_debug then eprintf "forget_reg: no mapping for r=%d\n" (p2i rd) + debug "forget_reg: no mapping for r=%d\n" (p2i rd) let update_reg vn rd v = - if exp_debug then eprintf "update_reg: update v=%d with r=%d\n" v (p2i rd); + debug "update_reg: update v=%d with r=%d\n" v (p2i rd); forget_reg vn rd; let old_regs = get_nval_ornil vn v in Hashtbl.replace !vn.nval v (rd :: old_regs) @@ -132,7 +130,7 @@ let rec find_valnum_rhs rh = function | Seq (v, rh') :: tl -> if rh = rh' then Some v else find_valnum_rhs rh tl let set_unknown vn rd = - if exp_debug then eprintf "set_unknown: rd=%d\n" (p2i rd); + debug "set_unknown: rd=%d\n" (p2i rd); forget_reg vn rd; Hashtbl.remove !vn.nreg rd @@ -141,19 +139,19 @@ let set_res_unknown vn res = match res with BR r -> set_unknown vn r | _ -> () let addrhs vn rd rh = match find_valnum_rhs rh !vn.seqs with | Some vres -> - if exp_debug then eprintf "addrhs: Some v=%d\n" vres; + debug "addrhs: Some v=%d\n" vres; Hashtbl.replace !vn.nreg rd vres; update_reg vn rd vres | None -> let n = !vn.nnext in - if exp_debug then eprintf "addrhs: None v=%d\n" n; + debug "addrhs: None v=%d\n" n; !vn.nnext <- !vn.nnext + 1; !vn.seqs <- Seq (n, rh) :: !vn.seqs; update_reg vn rd n; Hashtbl.replace !vn.nreg rd n let addsop vn v op rd = - if exp_debug then eprintf "addsop\n"; + debug "addsop\n"; if op = Omove then ( update_reg vn rd (List.hd v); Hashtbl.replace !vn.nreg rd (List.hd v)) @@ -167,11 +165,11 @@ let rec kill_mem_operations = function | eq :: tl -> eq :: kill_mem_operations tl let reg_valnum vn v = - if exp_debug then eprintf "reg_valnum: trying to find a mapping for v=%d\n" v; + debug "reg_valnum: trying to find a mapping for v=%d\n" v; match Hashtbl.find !vn.nval v with | [] -> None | r :: rs -> - if exp_debug then eprintf "reg_valnum: found a mapping r=%d\n" (p2i r); + debug "reg_valnum: found a mapping r=%d\n" (p2i r); Some r let rec reg_valnums vn = function @@ -216,7 +214,7 @@ let addinst vn op args rd = let rh = Sop (op, v) in match find_rhs vn rh with | Some r -> - if exp_debug then eprintf "addinst: rhs found with r=%d\n" (p2i r); + debug "addinst: rhs found with r=%d\n" (p2i r); Sr r | None -> addsop vn v op rd; @@ -627,8 +625,7 @@ let get_regs_inst = function (** Modify pathmap according to the size of the expansion list *) let write_pathmap initial esize pm' = - if exp_debug then - eprintf "write_pathmap: initial=%d, esize=%d\n" (p2i initial) esize; + debug "write_pathmap: initial=%d, esize=%d\n" (p2i initial) esize; let path = get_some @@ PTree.get initial !pm' in let npsize = Camlcoq.Nat.of_int (esize + Camlcoq.Nat.to_int path.psize) in let path' = @@ -655,7 +652,7 @@ let get_arguments vn vals args = (** Update the code tree with the expansion list *) let rec write_tree vn exp initial current code' new_order fturn = - if exp_debug then eprintf "wt: node is %d\n" !node; + debug "wt: node is %d\n" !node; let target_node, next_node = if fturn then (P.to_int initial, current) else (current, current - 1) in @@ -685,7 +682,7 @@ let rec write_tree vn exp initial current code' new_order fturn = (** Main expansion function - TODO gourdinl to split? *) let expanse (sb : superblock) code pm = - if exp_debug then eprintf "#### New superblock for expansion oracle\n"; + debug "#### New superblock for expansion oracle\n"; let new_order = ref [] in let liveins = ref sb.liveins in let exp = ref [] in @@ -699,129 +696,129 @@ let expanse (sb : superblock) code pm = was_branch := false; was_exp := false; let inst = get_some @@ PTree.get n code in - if exp_debug then eprintf "We are checking node %d\n" (p2i n); + debug "We are checking node %d\n" (p2i n); (match inst with (* Expansion of conditions - Ocmp *) | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ccomp\n"; + debug "Iop/Ccomp\n"; exp := cond_int32s vn false c a1 a2 dest; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompu c), a1 :: a2 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ccompu\n"; + debug "Iop/Ccompu\n"; exp := cond_int32u vn false c a1 a2 dest; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompimm (c, imm)), a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ccompimm\n"; + debug "Iop/Ccompimm\n"; exp := expanse_condimm_int32s vn c a1 imm dest; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompuimm (c, imm)), a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ccompuimm\n"; + debug "Iop/Ccompuimm\n"; exp := expanse_condimm_int32u vn c a1 imm dest; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompl c), a1 :: a2 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ccompl\n"; + debug "Iop/Ccompl\n"; exp := cond_int64s vn false c a1 a2 dest; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccomplu c), a1 :: a2 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ccomplu\n"; + debug "Iop/Ccomplu\n"; exp := cond_int64u vn false c a1 a2 dest; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccomplimm (c, imm)), a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ccomplimm\n"; + debug "Iop/Ccomplimm\n"; exp := expanse_condimm_int64s vn c a1 imm dest; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompluimm (c, imm)), a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ccompluimm\n"; + debug "Iop/Ccompluimm\n"; exp := expanse_condimm_int64u vn c a1 imm dest; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompf c), f1 :: f2 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ccompf\n"; + debug "Iop/Ccompf\n"; exp := expanse_cond_fp vn false cond_float c f1 f2 dest; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Cnotcompf c), f1 :: f2 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Cnotcompf\n"; + debug "Iop/Cnotcompf\n"; exp := expanse_cond_fp vn true cond_float c f1 f2 dest; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Ccompfs c), f1 :: f2 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ccompfs\n"; + debug "Iop/Ccompfs\n"; exp := expanse_cond_fp vn false cond_single c f1 f2 dest; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocmp (Cnotcompfs c), f1 :: f2 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Cnotcompfs\n"; + debug "Iop/Cnotcompfs\n"; exp := expanse_cond_fp vn true cond_single c f1 f2 dest; exp := extract_final vn !exp dest succ; was_exp := true (* Expansion of branches - Ccomp *) | Icond (Ccomp c, a1 :: a2 :: nil, succ1, succ2, info) -> - if exp_debug then eprintf "Icond/Ccomp\n"; + debug "Icond/Ccomp\n"; exp := cbranch_int32s false c a1 a2 info succ1 succ2 []; was_branch := true; was_exp := true | Icond (Ccompu c, a1 :: a2 :: nil, succ1, succ2, info) -> - if exp_debug then eprintf "Icond/Ccompu\n"; + debug "Icond/Ccompu\n"; exp := cbranch_int32u false c a1 a2 info succ1 succ2 []; was_branch := true; was_exp := true | Icond (Ccompimm (c, imm), a1 :: nil, succ1, succ2, info) -> - if exp_debug then eprintf "Icond/Ccompimm\n"; + debug "Icond/Ccompimm\n"; exp := expanse_cbranchimm_int32s vn c a1 imm info succ1 succ2; was_branch := true; was_exp := true | Icond (Ccompuimm (c, imm), a1 :: nil, succ1, succ2, info) -> - if exp_debug then eprintf "Icond/Ccompuimm\n"; + debug "Icond/Ccompuimm\n"; exp := expanse_cbranchimm_int32u vn c a1 imm info succ1 succ2; was_branch := true; was_exp := true | Icond (Ccompl c, a1 :: a2 :: nil, succ1, succ2, info) -> - if exp_debug then eprintf "Icond/Ccompl\n"; + debug "Icond/Ccompl\n"; exp := cbranch_int64s false c a1 a2 info succ1 succ2 []; was_branch := true; was_exp := true | Icond (Ccomplu c, a1 :: a2 :: nil, succ1, succ2, info) -> - if exp_debug then eprintf "Icond/Ccomplu\n"; + debug "Icond/Ccomplu\n"; exp := cbranch_int64u false c a1 a2 info succ1 succ2 []; was_branch := true; was_exp := true | Icond (Ccomplimm (c, imm), a1 :: nil, succ1, succ2, info) -> - if exp_debug then eprintf "Icond/Ccomplimm\n"; + debug "Icond/Ccomplimm\n"; exp := expanse_cbranchimm_int64s vn c a1 imm info succ1 succ2; was_branch := true; was_exp := true | Icond (Ccompluimm (c, imm), a1 :: nil, succ1, succ2, info) -> - if exp_debug then eprintf "Icond/Ccompluimm\n"; + debug "Icond/Ccompluimm\n"; exp := expanse_cbranchimm_int64u vn c a1 imm info succ1 succ2; was_branch := true; was_exp := true | Icond (Ccompf c, f1 :: f2 :: nil, succ1, succ2, info) -> - if exp_debug then eprintf "Icond/Ccompf\n"; + debug "Icond/Ccompf\n"; exp := expanse_cbranch_fp vn false cond_float c f1 f2 info succ1 succ2; was_branch := true; was_exp := true | Icond (Cnotcompf c, f1 :: f2 :: nil, succ1, succ2, info) -> - if exp_debug then eprintf "Icond/Cnotcompf\n"; + debug "Icond/Cnotcompf\n"; exp := expanse_cbranch_fp vn true cond_float c f1 f2 info succ1 succ2; was_branch := true; was_exp := true | Icond (Ccompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> - if exp_debug then eprintf "Icond/Ccompfs\n"; + debug "Icond/Ccompfs\n"; exp := expanse_cbranch_fp vn false cond_single c f1 f2 info succ1 succ2; was_branch := true; was_exp := true | Icond (Cnotcompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> - if exp_debug then eprintf "Icond/Cnotcompfs\n"; + debug "Icond/Cnotcompfs\n"; exp := expanse_cbranch_fp vn true cond_single c f1 f2 info succ1 succ2; was_branch := true; @@ -830,7 +827,7 @@ let expanse (sb : superblock) code pm = (if not !was_exp then match inst with | Iop (Ofloatconst f, nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ofloatconst\n"; + debug "Iop/Ofloatconst\n"; let r = r2pi () in let l = loadimm64 vn r (Floats.Float.to_bits f) in let r', l' = extract_arg l in @@ -838,7 +835,7 @@ let expanse (sb : superblock) code pm = exp := extract_final vn !exp dest succ; was_exp := true | Iop (Osingleconst f, nil, dest, succ) -> - if exp_debug then eprintf "Iop/Osingleconst\n"; + debug "Iop/Osingleconst\n"; let r = r2pi () in let l = loadimm32 vn r (Floats.Float32.to_bits f) in let r', l' = extract_arg l in @@ -846,57 +843,57 @@ let expanse (sb : superblock) code pm = exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ointconst n, nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ointconst\n"; + debug "Iop/Ointconst\n"; exp := loadimm32 vn dest n; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Olongconst n, nil, dest, succ) -> - if exp_debug then eprintf "Iop/Olongconst\n"; + debug "Iop/Olongconst\n"; exp := loadimm64 vn dest n; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oaddimm n, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Oaddimm\n"; + debug "Iop/Oaddimm\n"; exp := addimm32 vn a1 dest n None; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oaddlimm n, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Oaddlimm\n"; + debug "Iop/Oaddlimm\n"; exp := addimm64 vn a1 dest n None; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oandimm n, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Oandimm\n"; + debug "Iop/Oandimm\n"; exp := andimm32 vn a1 dest n; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oandlimm n, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Oandlimm\n"; + debug "Iop/Oandlimm\n"; exp := andimm64 vn a1 dest n; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oorimm n, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Oorimm\n"; + debug "Iop/Oorimm\n"; exp := orimm32 vn a1 dest n; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oorlimm n, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Oorlimm\n"; + debug "Iop/Oorlimm\n"; exp := orimm64 vn a1 dest n; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oxorimm n, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Oxorimm\n"; + debug "Iop/Oxorimm\n"; exp := xorimm32 vn a1 dest n; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Oxorlimm n, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Oxorlimm\n"; + debug "Iop/Oxorlimm\n"; exp := xorimm64 vn a1 dest n; exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocast8signed, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/cast8signed\n"; + debug "Iop/cast8signed\n"; let op = Oshlimm (Int.repr (Z.of_sint 24)) in let r = r2pi () in let i1 = addinst vn op [ a1 ] r in @@ -906,7 +903,7 @@ let expanse (sb : superblock) code pm = exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocast16signed, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/cast16signed\n"; + debug "Iop/cast16signed\n"; let op = Oshlimm (Int.repr (Z.of_sint 16)) in let r = r2pi () in let i1 = addinst vn op [ a1 ] r in @@ -916,7 +913,7 @@ let expanse (sb : superblock) code pm = exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocast32unsigned, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ocast32unsigned\n"; + debug "Iop/Ocast32unsigned\n"; let r1 = r2pi () in let r2 = r2pi () in let op1 = Ocast32signed in @@ -933,10 +930,10 @@ let expanse (sb : superblock) code pm = was_exp := true | Iop (Oshrximm n, a1 :: nil, dest, succ) -> if Int.eq n Int.zero then ( - if exp_debug then eprintf "Iop/Oshrximm1\n"; + debug "Iop/Oshrximm1\n"; exp := [ addinst vn (OEmayundef (MUshrx n)) [ a1; a1 ] dest ]) else if Int.eq n Int.one then ( - if exp_debug then eprintf "Iop/Oshrximm2\n"; + debug "Iop/Oshrximm2\n"; let r1 = r2pi () in let r2 = r2pi () in let op1 = Oshruimm (Int.repr (Z.of_sint 31)) in @@ -952,7 +949,7 @@ let expanse (sb : superblock) code pm = let r3, l3 = extract_arg (i3 :: l2) in exp := addinst vn (OEmayundef (MUshrx n)) [ r3; r3 ] dest :: l3) else ( - if exp_debug then eprintf "Iop/Oshrximm3\n"; + debug "Iop/Oshrximm3\n"; let r1 = r2pi () in let r2 = r2pi () in let r3 = r2pi () in @@ -976,10 +973,10 @@ let expanse (sb : superblock) code pm = was_exp := true | Iop (Oshrxlimm n, a1 :: nil, dest, succ) -> if Int.eq n Int.zero then ( - if exp_debug then eprintf "Iop/Oshrxlimm1\n"; + debug "Iop/Oshrxlimm1\n"; exp := [ addinst vn (OEmayundef (MUshrxl n)) [ a1; a1 ] dest ]) else if Int.eq n Int.one then ( - if exp_debug then eprintf "Iop/Oshrxlimm2\n"; + debug "Iop/Oshrxlimm2\n"; let r1 = r2pi () in let r2 = r2pi () in let op1 = Oshrluimm (Int.repr (Z.of_sint 63)) in @@ -995,7 +992,7 @@ let expanse (sb : superblock) code pm = let r3, l3 = extract_arg (i3 :: l2) in exp := addinst vn (OEmayundef (MUshrxl n)) [ r3; r3 ] dest :: l3) else ( - if exp_debug then eprintf "Iop/Oshrxlimm3\n"; + debug "Iop/Oshrxlimm3\n"; let r1 = r2pi () in let r2 = r2pi () in let r3 = r2pi () in -- cgit From be8d929aef8e86c2e22e32c525093c6bfe56a300 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Wed, 19 May 2021 18:17:31 +0200 Subject: Adding both RV expansion methods in kvx-work --- riscV/Asmexpand.ml | 9 +- riscV/Asmgen.v | 344 +++++++++++++++++ riscV/Asmgenproof.v | 162 +++++++- riscV/Asmgenproof1.v | 919 +++++++++++++++++++++++++++++++++++++++++++-- riscV/ExpansionOracle.ml | 10 +- riscV/RTLpathSE_simplify.v | 10 - 6 files changed, 1406 insertions(+), 48 deletions(-) (limited to 'riscV') diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index 3f9d3359..c5cd6817 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -23,7 +23,6 @@ open Asm open Asmexpandaux open AST open Camlcoq -open Asmgen open! Integers exception Error of string @@ -45,13 +44,11 @@ let align n a = (n + a - 1) land (-a) (* Emit instruction sequences that set or offset a register by a constant. *) let expand_loadimm32 dst n = - match make_immed32 n with - | Imm32_single imm -> emit (Paddiw (dst, X0, imm)) - | Imm32_pair (hi, lo) -> List.iter emit (load_hilo32 dst hi lo []) + List.iter emit (Asmgen.loadimm32 dst n []) let expand_addptrofs dst src n = - List.iter emit (addptrofs dst src n []) + List.iter emit (Asmgen.addptrofs dst src n []) let expand_storeind_ptr src base ofs = - List.iter emit (storeind_ptr src base ofs []) + List.iter emit (Asmgen.storeind_ptr src base ofs []) (* Built-ins. They come in two flavors: - annotation statements: take their arguments in registers or stack diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index da6c0101..3e84e950 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -86,6 +86,12 @@ Definition make_immed64 (val: int64) := Definition load_hilo32 (r: ireg) (hi lo: int) k := if Int.eq lo Int.zero then Pluiw r hi :: k else Pluiw r hi :: Paddiw r r lo :: k. + +Definition loadimm32 (r: ireg) (n: int) (k: code) := + match make_immed32 n with + | Imm32_single imm => Paddiw r X0 imm :: k + | Imm32_pair hi lo => load_hilo32 r hi lo k + end. Definition opimm32 (op: ireg -> ireg0 -> ireg0 -> instruction) (opimm: ireg -> ireg0 -> int -> instruction) @@ -96,11 +102,23 @@ Definition opimm32 (op: ireg -> ireg0 -> ireg0 -> instruction) end. Definition addimm32 := opimm32 Paddw Paddiw. +Definition andimm32 := opimm32 Pandw Pandiw. +Definition orimm32 := opimm32 Porw Poriw. +Definition xorimm32 := opimm32 Pxorw Pxoriw. +Definition sltimm32 := opimm32 Psltw Psltiw. +Definition sltuimm32 := opimm32 Psltuw Psltiuw. Definition load_hilo64 (r: ireg) (hi lo: int64) k := if Int64.eq lo Int64.zero then Pluil r hi :: k else Pluil r hi :: Paddil r r lo :: k. +Definition loadimm64 (r: ireg) (n: int64) (k: code) := + match make_immed64 n with + | Imm64_single imm => Paddil r X0 imm :: k + | Imm64_pair hi lo => load_hilo64 r hi lo k + | Imm64_large imm => Ploadli r imm :: k + end. + Definition opimm64 (op: ireg -> ireg0 -> ireg0 -> instruction) (opimm: ireg -> ireg0 -> int64 -> instruction) (rd rs: ireg) (n: int64) (k: code) := @@ -111,6 +129,11 @@ Definition opimm64 (op: ireg -> ireg0 -> ireg0 -> instruction) end. Definition addimm64 := opimm64 Paddl Paddil. +Definition andimm64 := opimm64 Pandl Pandil. +Definition orimm64 := opimm64 Porl Poril. +Definition xorimm64 := opimm64 Pxorl Pxoril. +Definition sltimm64 := opimm64 Psltl Psltil. +Definition sltuimm64 := opimm64 Psltul Psltiul. Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := if Ptrofs.eq_dec n Ptrofs.zero then @@ -120,6 +143,68 @@ Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := then addimm64 rd rs (Ptrofs.to_int64 n) k else addimm32 rd rs (Ptrofs.to_int n) k. +(** Translation of conditional branches. *) + +Definition transl_cbranch_int32s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeqw r1 r2 lbl + | Cne => Pbnew r1 r2 lbl + | Clt => Pbltw r1 r2 lbl + | Cle => Pbgew r2 r1 lbl + | Cgt => Pbltw r2 r1 lbl + | Cge => Pbgew r1 r2 lbl + end. + +Definition transl_cbranch_int32u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeqw r1 r2 lbl + | Cne => Pbnew r1 r2 lbl + | Clt => Pbltuw r1 r2 lbl + | Cle => Pbgeuw r2 r1 lbl + | Cgt => Pbltuw r2 r1 lbl + | Cge => Pbgeuw r1 r2 lbl + end. + +Definition transl_cbranch_int64s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeql r1 r2 lbl + | Cne => Pbnel r1 r2 lbl + | Clt => Pbltl r1 r2 lbl + | Cle => Pbgel r2 r1 lbl + | Cgt => Pbltl r2 r1 lbl + | Cge => Pbgel r1 r2 lbl + end. + +Definition transl_cbranch_int64u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeql r1 r2 lbl + | Cne => Pbnel r1 r2 lbl + | Clt => Pbltul r1 r2 lbl + | Cle => Pbgeul r2 r1 lbl + | Cgt => Pbltul r2 r1 lbl + | Cge => Pbgeul r1 r2 lbl + end. + +Definition transl_cond_float (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := + match cmp with + | Ceq => (Pfeqd rd fs1 fs2, true) + | Cne => (Pfeqd rd fs1 fs2, false) + | Clt => (Pfltd rd fs1 fs2, true) + | Cle => (Pfled rd fs1 fs2, true) + | Cgt => (Pfltd rd fs2 fs1, true) + | Cge => (Pfled rd fs2 fs1, true) + end. + +Definition transl_cond_single (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := + match cmp with + | Ceq => (Pfeqs rd fs1 fs2, true) + | Cne => (Pfeqs rd fs1 fs2, false) + | Clt => (Pflts rd fs1 fs2, true) + | Cle => (Pfles rd fs1 fs2, true) + | Cgt => (Pflts rd fs2 fs1, true) + | Cge => (Pfles rd fs2 fs1, true) + end. + (** Functions to select a special register according to the op "oreg" argument from RTL *) Definition apply_bin_oreg_ireg0 (optR: option oreg) (r1 r2: ireg0): (ireg0 * ireg0) := @@ -138,6 +223,59 @@ Definition get_oreg (optR: option oreg) (r: ireg0) := Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) := match cond, args with + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cbranch_int32s c r1 r2 lbl :: k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cbranch_int32u c r1 r2 lbl :: k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int.eq n Int.zero then + transl_cbranch_int32s c r1 X0 lbl :: k + else + loadimm32 X31 n (transl_cbranch_int32s c r1 X31 lbl :: k)) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int.eq n Int.zero then + transl_cbranch_int32u c r1 X0 lbl :: k + else + loadimm32 X31 n (transl_cbranch_int32u c r1 X31 lbl :: k)) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cbranch_int64s c r1 r2 lbl :: k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cbranch_int64u c r1 r2 lbl :: k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int64.eq n Int64.zero then + transl_cbranch_int64s c r1 X0 lbl :: k + else + loadimm64 X31 n (transl_cbranch_int64s c r1 X31 lbl :: k)) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int64.eq n Int64.zero then + transl_cbranch_int64u c r1 X0 lbl :: k + else + loadimm64 X31 n (transl_cbranch_int64u c r1 X31 lbl :: k)) + | Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c X31 r1 r2 in + OK (insn :: (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c X31 r1 r2 in + OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c X31 r1 r2 in + OK (insn :: (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c X31 r1 r2 in + OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) + | CEbeqw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in @@ -206,6 +344,133 @@ Definition transl_cbranch Error(msg "Asmgen.transl_cond_branch") end. +(** Translation of a condition operator. The generated code sets the + [rd] target register to 0 or 1 depending on the truth value of the + condition. *) + +Definition transl_cond_int32s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseqw rd r1 r2 :: k + | Cne => Psnew rd r1 r2 :: k + | Clt => Psltw rd r1 r2 :: k + | Cle => Psltw rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltw rd r2 r1 :: k + | Cge => Psltw rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_cond_int32u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseqw rd r1 r2 :: k + | Cne => Psnew rd r1 r2 :: k + | Clt => Psltuw rd r1 r2 :: k + | Cle => Psltuw rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltuw rd r2 r1 :: k + | Cge => Psltuw rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_cond_int64s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseql rd r1 r2 :: k + | Cne => Psnel rd r1 r2 :: k + | Clt => Psltl rd r1 r2 :: k + | Cle => Psltl rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltl rd r2 r1 :: k + | Cge => Psltl rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_cond_int64u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseql rd r1 r2 :: k + | Cne => Psnel rd r1 r2 :: k + | Clt => Psltul rd r1 r2 :: k + | Cle => Psltul rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltul rd r2 r1 :: k + | Cge => Psltul rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_condimm_int32s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := + if Int.eq n Int.zero then transl_cond_int32s cmp rd r1 X0 k else + match cmp with + | Ceq | Cne => xorimm32 rd r1 n (transl_cond_int32s cmp rd rd X0 k) + | Clt => sltimm32 rd r1 n k + | Cle => if Int.eq n (Int.repr Int.max_signed) + then loadimm32 rd Int.one k + else sltimm32 rd r1 (Int.add n Int.one) k + | _ => loadimm32 X31 n (transl_cond_int32s cmp rd r1 X31 k) + end. + +Definition transl_condimm_int32u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := + if Int.eq n Int.zero then transl_cond_int32u cmp rd r1 X0 k else + match cmp with + | Clt => sltuimm32 rd r1 n k + | _ => loadimm32 X31 n (transl_cond_int32u cmp rd r1 X31 k) + end. + +Definition transl_condimm_int64s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := + if Int64.eq n Int64.zero then transl_cond_int64s cmp rd r1 X0 k else + match cmp with + | Ceq | Cne => xorimm64 rd r1 n (transl_cond_int64s cmp rd rd X0 k) + | Clt => sltimm64 rd r1 n k + | Cle => if Int64.eq n (Int64.repr Int64.max_signed) + then loadimm32 rd Int.one k + else sltimm64 rd r1 (Int64.add n Int64.one) k + | _ => loadimm64 X31 n (transl_cond_int64s cmp rd r1 X31 k) + end. + +Definition transl_condimm_int64u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := + if Int64.eq n Int64.zero then transl_cond_int64u cmp rd r1 X0 k else + match cmp with + | Clt => sltuimm64 rd r1 n k + | _ => loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k) + end. + +Definition transl_cond_op + (cond: condition) (rd: ireg) (args: list mreg) (k: code) := + match cond, args with + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32s c rd r1 r2 k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32u c rd r1 r2 k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32s c rd r1 n k) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32u c rd r1 n k) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64s c rd r1 r2 k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64u c rd r1 r2 k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64s c rd r1 n k) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64u c rd r1 n k) + | Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | _, _ => + Error(msg "Asmgen.transl_cond_op") + end. + (** Translation of the arithmetic operation [r <- op(args)]. The corresponding instructions are prepended to [k]. *) @@ -218,6 +483,22 @@ Definition transl_op | FR r, FR a => OK (Pfmv r a :: k) | _ , _ => Error(msg "Asmgen.Omove") end + | Ointconst n, nil => + do rd <- ireg_of res; + OK (loadimm32 rd n k) + | Olongconst n, nil => + do rd <- ireg_of res; + OK (loadimm64 rd n k) + | Ofloatconst f, nil => + do rd <- freg_of res; + OK (if Float.eq_dec f Float.zero + then Pfcvtdw rd X0 :: k + else Ploadfi rd f :: k) + | Osingleconst f, nil => + do rd <- freg_of res; + OK (if Float32.eq_dec f Float32.zero + then Pfcvtsw rd X0 :: k + else Ploadsi rd f :: k) | Oaddrsymbol s ofs, nil => do rd <- ireg_of res; OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) @@ -227,9 +508,18 @@ Definition transl_op do rd <- ireg_of res; OK (addptrofs rd SP n k) + | Ocast8signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs (Int.repr 24) :: Psraiw rd rd (Int.repr 24) :: k) + | Ocast16signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs (Int.repr 16) :: Psraiw rd rd (Int.repr 16) :: k) | Oadd, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Paddw rd rs1 rs2 :: k) + | Oaddimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (addimm32 rd rs n k) | Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psubw rd X0 rs :: k) @@ -260,12 +550,21 @@ Definition transl_op | Oand, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandw rd rs1 rs2 :: k) + | Oandimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (andimm32 rd rs n k) | Oor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porw rd rs1 rs2 :: k) + | Oorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (orimm32 rd rs n k) | Oxor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pxorw rd rs1 rs2 :: k) + | Oxorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm32 rd rs n k) | Oshl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psllw rd rs1 rs2 :: k) @@ -284,6 +583,19 @@ Definition transl_op | Oshruimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrliw rd rs n :: k) + | Oshrximm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (if Int.eq n Int.zero + then Pmv rd rs :: k + else if Int.eq n Int.one + then Psrliw X31 rs (Int.repr 31) :: + Paddw X31 rs X31 :: + Psraiw rd X31 Int.one :: k + else Psraiw X31 rs (Int.repr 31) :: + Psrliw X31 X31 (Int.sub Int.iwordsize n) :: + Paddw X31 rs X31 :: + Psraiw rd X31 n :: k) + (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -292,9 +604,16 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; assertion (ireg_eq rd rs); OK (Pcvtw2l rd :: k) + | Ocast32unsigned, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + assertion (ireg_eq rd rs); + OK (Pcvtw2l rd :: Psllil rd rd (Int.repr 32) :: Psrlil rd rd (Int.repr 32) :: k) | Oaddl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Paddl rd rs1 rs2 :: k) + | Oaddlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (addimm64 rd rs n k) | Onegl, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psubl rd X0 rs :: k) @@ -325,12 +644,21 @@ Definition transl_op | Oandl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandl rd rs1 rs2 :: k) + | Oandlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (andimm64 rd rs n k) | Oorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porl rd rs1 rs2 :: k) + | Oorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (orimm64 rd rs n k) | Oxorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pxorl rd rs1 rs2 :: k) + | Oxorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm64 rd rs n k) | Oshll, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pslll rd rs1 rs2 :: k) @@ -349,6 +677,19 @@ Definition transl_op | Oshrluimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrlil rd rs n :: k) + | Oshrxlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (if Int.eq n Int.zero + then Pmv rd rs :: k + else if Int.eq n Int.one + then Psrlil X31 rs (Int.repr 63) :: + Paddl X31 rs X31 :: + Psrail rd X31 Int.one :: k + else Psrail X31 rs (Int.repr 63) :: + Psrlil X31 X31 (Int.sub Int64.iwordsize' n) :: + Paddl X31 rs X31 :: + Psrail rd X31 n :: k) + | Onegf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfnegd rd rs :: k) @@ -443,6 +784,9 @@ Definition transl_op | Osingleoflongu, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfcvtslu rd rs :: k) + | Ocmp cmp, _ => + do rd <- ireg_of res; + transl_cond_op cmp rd args k (* Instructions expanded in RTL *) | OEseqw optR, a1 :: a2 :: nil => diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 4af8352c..509eac94 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -115,6 +115,14 @@ Qed. Section TRANSL_LABEL. +Remark loadimm32_label: + forall r n k, tail_nolabel k (loadimm32 r n k). +Proof. + intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel. + unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel. +Qed. +Hint Resolve loadimm32_label: labels. + Remark opimm32_label: forall op opimm r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> @@ -126,6 +134,14 @@ Proof. Qed. Hint Resolve opimm32_label: labels. +Remark loadimm64_label: + forall r n k, tail_nolabel k (loadimm64 r n k). +Proof. + intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel. + unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel. +Qed. +Hint Resolve loadimm64_label: labels. + Remark opimm64_label: forall op opimm r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> @@ -145,25 +161,165 @@ Proof. Qed. Hint Resolve addptrofs_label: labels. +Remark transl_cond_float_nolabel: + forall c r1 r2 r3 insn normal, + transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn. +Proof. + unfold transl_cond_float; intros. destruct c; inv H; exact I. +Qed. + +Remark transl_cond_single_nolabel: + forall c r1 r2 r3 insn normal, + transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn. +Proof. + unfold transl_cond_single; intros. destruct c; inv H; exact I. + Qed. + Remark transl_cbranch_label: forall cond args lbl k c, transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. Proof. intros. unfold transl_cbranch in H; destruct cond; TailNoLabel. - all: destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct (Int.eq n Int.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int32s c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (Int.eq n Int.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int32u c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int64s c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int64u c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. Qed. +Remark transl_cond_op_label: + forall cond args r k c, + transl_cond_op cond r args k = OK c -> tail_nolabel k c. +Proof. + intros. unfold transl_cond_op in H; destruct cond; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int32s. + destruct (Int.eq n Int.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl. +* eapply tail_nolabel_trans; [apply opimm32_label; intros; exact I | TailNoLabel]. +* eapply tail_nolabel_trans; [apply opimm32_label; intros; exact I | TailNoLabel]. +* apply opimm32_label; intros; exact I. +* destruct (Int.eq n (Int.repr Int.max_signed)). apply loadimm32_label. apply opimm32_label; intros; exact I. +* eapply tail_nolabel_trans. apply loadimm32_label. TailNoLabel. +* eapply tail_nolabel_trans. apply loadimm32_label. TailNoLabel. +- unfold transl_condimm_int32u. + destruct (Int.eq n Int.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl; + try (eapply tail_nolabel_trans; [apply loadimm32_label | TailNoLabel]). + apply opimm32_label; intros; exact I. +- destruct c0; simpl; TailNoLabel. + - destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int64s. + destruct (Int64.eq n Int64.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl. +* eapply tail_nolabel_trans; [apply opimm64_label; intros; exact I | TailNoLabel]. +* eapply tail_nolabel_trans; [apply opimm64_label; intros; exact I | TailNoLabel]. +* apply opimm64_label; intros; exact I. +* destruct (Int64.eq n (Int64.repr Int64.max_signed)). apply loadimm32_label. apply opimm64_label; intros; exact I. +* eapply tail_nolabel_trans. apply loadimm64_label. TailNoLabel. +* eapply tail_nolabel_trans. apply loadimm64_label. TailNoLabel. +- unfold transl_condimm_int64u. + destruct (Int64.eq n Int64.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl; + try (eapply tail_nolabel_trans; [apply loadimm64_label | TailNoLabel]). + apply opimm64_label; intros; exact I. +- destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. + Qed. + Remark transl_op_label: forall op args r k c, transl_op op args r k = OK c -> tail_nolabel k c. Proof. Opaque Int.eq. - unfold transl_op; intros; destruct op; TailNoLabel; - try (destruct optR as [[]|]; simpl in *; TailNoLabel). + unfold transl_op; intros; destruct op; TailNoLabel. - destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. +- destruct (Float.eq_dec n Float.zero); TailNoLabel. +- destruct (Float32.eq_dec n Float32.zero); TailNoLabel. - destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). + eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel. + TailNoLabel. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. +- eapply transl_cond_op_label; eauto. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. Qed. Remark indexed_memory_access_label: diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index faa066b0..2293e001 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -129,6 +129,22 @@ Proof. intros; Simpl. Qed. +Lemma loadimm32_correct: + forall rd n k rs m, + exists rs', + exec_straight ge fn (loadimm32 rd n k) rs m k rs' m + /\ rs'#rd = Vint n + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm32; intros. generalize (make_immed32_sound n); intros E. + destruct (make_immed32 n). +- subst imm. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. rewrite Int.add_zero_l; Simpl. + intros; Simpl. +- rewrite E. apply load_hilo32_correct. +Qed. + Lemma opimm32_correct: forall (op: ireg -> ireg0 -> ireg0 -> instruction) (opi: ireg -> ireg0 -> int -> instruction) @@ -179,6 +195,27 @@ Proof. intros; Simpl. Qed. +Lemma loadimm64_correct: + forall rd n k rs m, + exists rs', + exec_straight ge fn (loadimm64 rd n k) rs m k rs' m + /\ rs'#rd = Vlong n + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + unfold loadimm64; intros. generalize (make_immed64_sound n); intros E. + destruct (make_immed64 n). +- subst imm. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. rewrite Int64.add_zero_l; Simpl. + intros; Simpl. +- exploit load_hilo64_correct; eauto. intros (rs' & A & B & C). + rewrite E. exists rs'; eauto. +- subst imm. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. +Qed. + Lemma opimm64_correct: forall (op: ireg -> ireg0 -> ireg0 -> instruction) (opi: ireg -> ireg0 -> int64 -> instruction) @@ -253,6 +290,102 @@ Proof. rewrite H0 in B. inv B. auto. Qed. +(** Translation of conditional branches *) + +Lemma transl_cbranch_int32s_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmp_bool cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (transl_cbranch_int32s cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H. +- destruct rs##r1; simpl in H; try discriminate. destruct rs##r2; inv H. + simpl; auto. +- destruct rs##r1; simpl in H; try discriminate. destruct rs##r2; inv H. + simpl; auto. +- auto. +- rewrite <- Val.swap_cmp_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmp_bool. simpl. rewrite H; auto. +- auto. +Qed. + +Lemma transl_cbranch_int32u_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (transl_cbranch_int32u cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H; auto. +- rewrite <- Val.swap_cmpu_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmpu_bool. simpl. rewrite H; auto. +Qed. + +Lemma transl_cbranch_int64s_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmpl_bool cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (transl_cbranch_int64s cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H. +- destruct rs###r1; simpl in H; try discriminate. destruct rs###r2; inv H. + simpl; auto. +- destruct rs###r1; simpl in H; try discriminate. destruct rs###r2; inv H. + simpl; auto. +- auto. +- rewrite <- Val.swap_cmpl_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmpl_bool. simpl. rewrite H; auto. +- auto. +Qed. + +Lemma transl_cbranch_int64u_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (transl_cbranch_int64u cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H; auto. +- rewrite <- Val.swap_cmplu_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmplu_bool. simpl. rewrite H; auto. +Qed. + +Lemma transl_cond_float_correct: + forall (rs: regset) m cmp rd r1 r2 insn normal v, + transl_cond_float cmp rd r1 r2 = (insn, normal) -> + v = (if normal then Val.cmpf cmp rs#r1 rs#r2 else Val.notbool (Val.cmpf cmp rs#r1 rs#r2)) -> + exec_instr ge fn insn rs m = Next (nextinstr (rs#rd <- v)) m. +Proof. + intros. destruct cmp; simpl in H; inv H; auto. +- rewrite Val.negate_cmpf_eq. auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpf, Val.cmpf_bool. + rewrite <- Float.cmp_swap. auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpf, Val.cmpf_bool. + rewrite <- Float.cmp_swap. auto. +Qed. + +Lemma transl_cond_single_correct: + forall (rs: regset) m cmp rd r1 r2 insn normal v, + transl_cond_single cmp rd r1 r2 = (insn, normal) -> + v = (if normal then Val.cmpfs cmp rs#r1 rs#r2 else Val.notbool (Val.cmpfs cmp rs#r1 rs#r2)) -> + exec_instr ge fn insn rs m = Next (nextinstr (rs#rd <- v)) m. +Proof. + intros. destruct cmp; simpl in H; inv H; auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. + rewrite Float32.cmp_ne_eq. destruct (Float32.cmp Ceq f0 f); auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. + rewrite <- Float32.cmp_swap. auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. + rewrite <- Float32.cmp_swap. auto. + Qed. + +(* TODO gourdinl UNUSUED ? Remark branch_on_X31: + forall normal lbl (rs: regset) m b, + rs#X31 = Val.of_bool (eqb normal b) -> + exec_instr ge fn (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity. + Qed.*) + Ltac ArgsInv := repeat (match goal with | [ H: Error _ = OK _ |- _ ] => discriminate @@ -284,46 +417,219 @@ Proof. { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } clear EVAL MEXT AG. destruct cond; simpl in TRANSL; ArgsInv. - all: - destruct optR as [[]|]; - unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; - unfold zero32, Op.zero32 in *; - unfold zero64, Op.zero64 in *; inv EQ2; - try (destruct (rs x); simpl in EVAL'; discriminate; fail); - try (eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto; fail). - all: - destruct (rs x) eqn:EQRS; simpl in *; try congruence; - eexists; eexists; eauto; split; constructor; auto; - simpl in *; rewrite EQRS. - - assert (HB: (Int.eq Int.zero i) = b) by congruence; + - exists rs, (transl_cbranch_int32s c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. +- exists rs, (transl_cbranch_int32u c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. +- predSpec Int.eq Int.eq_spec n Int.zero. ++ subst n. exists rs, (transl_cbranch_int32s c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. ++ exploit (loadimm32_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int32s c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int32s_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- predSpec Int.eq Int.eq_spec n Int.zero. ++ subst n. exists rs, (transl_cbranch_int32u c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. ++ exploit (loadimm32_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int32u c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int32u_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- exists rs, (transl_cbranch_int64s c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. +- exists rs, (transl_cbranch_int64u c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. +- predSpec Int64.eq Int64.eq_spec n Int64.zero. ++ subst n. exists rs, (transl_cbranch_int64s c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. ++ exploit (loadimm64_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int64s c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int64s_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- predSpec Int64.eq Int64.eq_spec n Int64.zero. ++ subst n. exists rs, (transl_cbranch_int64u c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. ++ exploit (loadimm64_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int64u c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int64u_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (eqb normal b)). + { unfold v, Val.cmpf. rewrite EVAL'. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + assert (EVAL'': Val.cmpf_bool c0 (rs x) (rs x0) = Some (negb b)). + { destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } + set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (xorb normal b)). + { unfold v, Val.cmpf. rewrite EVAL''. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (eqb normal b)). + { unfold v, Val.cmpfs. rewrite EVAL'. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + assert (EVAL'': Val.cmpfs_bool c0 (rs x) (rs x0) = Some (negb b)). + { destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } + set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (xorb normal b)). + { unfold v, Val.cmpfs. rewrite EVAL''. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. + +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; + destruct (rs x) eqn:EQRS; simpl in *; try congruence; + inv EQ2; eexists; eexists; eauto; split; constructor; auto; + simpl in *. + + rewrite EQRS; + assert (HB: (Int.eq Int.zero i) = b) by congruence. rewrite HB; destruct b; simpl; auto. - - assert (HB: (Int.eq i Int.zero) = b) by congruence. + + rewrite EQRS; + assert (HB: (Int.eq i Int.zero) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - - destruct (rs x0); try congruence. + + rewrite EQRS; + destruct (rs x0); try congruence. assert (HB: (Int.eq i i0) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - - assert (HB: negb (Int.eq Int.zero i) = b) by congruence. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; + destruct (rs x) eqn:EQRS; simpl in *; try congruence; + inv EQ2; eexists; eexists; eauto; split; constructor; auto; + simpl in *. + + rewrite EQRS; + assert (HB: negb (Int.eq Int.zero i) = b) by congruence. rewrite HB; destruct b; simpl; auto. - - assert (HB: negb (Int.eq i Int.zero) = b) by congruence. + + rewrite EQRS; + assert (HB: negb (Int.eq i Int.zero) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - - destruct (rs x0); try congruence. + + rewrite EQRS; + destruct (rs x0); try congruence. assert (HB: negb (Int.eq i i0) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - - assert (HB: (Int64.eq Int64.zero i) = b) by congruence. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + destruct (rs x) eqn:EQRS; simpl in *; try congruence; + eexists; eexists; eauto; split; constructor; + simpl in *; auto. + + rewrite EQRS; + assert (HB: (Int64.eq Int64.zero i) = b) by congruence. rewrite HB; destruct b; simpl; auto. - - assert (HB: (Int64.eq i Int64.zero) = b) by congruence. + + rewrite EQRS; + assert (HB: (Int64.eq i Int64.zero) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - - destruct (rs x0); try congruence. + + rewrite EQRS; + destruct (rs x0); try congruence. assert (HB: (Int64.eq i i0) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - - assert (HB: negb (Int64.eq Int64.zero i) = b) by congruence. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + destruct (rs x) eqn:EQRS; simpl in *; try congruence; + eexists; eexists; eauto; split; constructor; + simpl in *; auto. + + rewrite EQRS; + assert (HB: negb (Int64.eq Int64.zero i) = b) by congruence. rewrite HB; destruct b; simpl; auto. - - assert (HB: negb (Int64.eq i Int64.zero) = b) by congruence. + + rewrite EQRS; + assert (HB: negb (Int64.eq i Int64.zero) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - - destruct (rs x0); try congruence. + + rewrite EQRS; + destruct (rs x0); try congruence. assert (HB: negb (Int64.eq i i0) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. Qed. Lemma transl_cbranch_correct_true: @@ -357,6 +663,417 @@ Proof. intros; Simpl. Qed. +(** Translation of condition operators *) + +Lemma transl_cond_int32s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int32s cmp rd r1 r2 k) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs##r1 rs##r2) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs##r1); auto. destruct (rs##r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs##r1); auto. destruct (rs##r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmp. rewrite <- Val.swap_cmp_bool. + simpl. rewrite (Val.negate_cmp_bool Clt). + destruct (Val.cmp_bool Clt rs##r2 rs##r1) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmp. rewrite <- Val.swap_cmp_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmp. rewrite (Val.negate_cmp_bool Clt). + destruct (Val.cmp_bool Clt rs##r1 rs##r2) as [[]|]; auto. +Qed. + +Lemma transl_cond_int32u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int32u cmp rd r1 r2 k) rs m k rs' m + /\ rs'#rd = Val.cmpu (Mem.valid_pointer m) cmp rs##r1 rs##r2 + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpu. rewrite <- Val.swap_cmpu_bool. + simpl. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Cle). + destruct (Val.cmpu_bool (Mem.valid_pointer m) Cle rs##r1 rs##r2) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmpu. rewrite <- Val.swap_cmpu_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpu. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Clt). + destruct (Val.cmpu_bool (Mem.valid_pointer m) Clt rs##r1 rs##r2) as [[]|]; auto. +Qed. + +Lemma transl_cond_int64s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int64s cmp rd r1 r2 k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs###r1 rs###r2)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs###r1); auto. destruct (rs###r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs###r1); auto. destruct (rs###r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpl. rewrite <- Val.swap_cmpl_bool. + simpl. rewrite (Val.negate_cmpl_bool Clt). + destruct (Val.cmpl_bool Clt rs###r2 rs###r1) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmpl. rewrite <- Val.swap_cmpl_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpl. rewrite (Val.negate_cmpl_bool Clt). + destruct (Val.cmpl_bool Clt rs###r1 rs###r2) as [[]|]; auto. +Qed. + +Lemma transl_cond_int64u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int64u cmp rd r1 r2 k) rs m k rs' m + /\ rs'#rd = Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs###r1 rs###r2) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmplu. rewrite <- Val.swap_cmplu_bool. + simpl. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Cle). + destruct (Val.cmplu_bool (Mem.valid_pointer m) Cle rs###r1 rs###r2) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmplu. rewrite <- Val.swap_cmplu_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmplu. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Clt). + destruct (Val.cmplu_bool (Mem.valid_pointer m) Clt rs###r1 rs###r2) as [[]|]; auto. +Qed. + +Lemma transl_condimm_int32s_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int32s cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int32s. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. exploit transl_cond_int32s_correct. intros (rs' & A & B & C). + exists rs'; eauto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm32 X31 n (transl_cond_int32s cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ unfold xorimm32. + exploit (opimm32_correct Pxorw Pxoriw Val.xor); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmp in B2; simpl in B2; rewrite Int.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ unfold xorimm32. + exploit (opimm32_correct Pxorw Pxoriw Val.xor); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmp in B2; simpl in B2; rewrite Int.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ predSpec Int.eq Int.eq_spec n (Int.repr Int.max_signed). +* subst n. exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + unfold Val.cmp; destruct (rs#r1); simpl; auto. rewrite B1. + unfold Int.lt. rewrite zlt_false. auto. + change (Int.signed (Int.repr Int.max_signed)) with Int.max_signed. + generalize (Int.signed_range i); omega. +* exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + rewrite B1. unfold Val.cmp; simpl; destruct (rs#r1); simpl; auto. + unfold Int.lt. replace (Int.signed (Int.add n Int.one)) with (Int.signed n + 1). + destruct (zlt (Int.signed n) (Int.signed i)). + rewrite zlt_false by omega. auto. + rewrite zlt_true by omega. auto. + rewrite Int.add_signed. symmetry; apply Int.signed_repr. + assert (Int.signed n <> Int.max_signed). + { red; intros E. elim H1. rewrite <- (Int.repr_signed n). rewrite E. auto. } + generalize (Int.signed_range n); omega. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_condimm_int32u_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int32u cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int32u. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. exploit transl_cond_int32u_correct. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. rewrite B; auto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm32 X31 n (transl_cond_int32u cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32u_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. rewrite B2; auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ apply DFL. ++ apply DFL. ++ exploit (opimm32_correct Psltuw Psltiuw (Val.cmpu (Mem.valid_pointer m) Clt) m); eauto. + intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ apply DFL. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_condimm_int64s_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int64s cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int64s. + predSpec Int64.eq Int64.eq_spec n Int64.zero. +- subst n. exploit transl_cond_int64s_correct. intros (rs' & A & B & C). + exists rs'; eauto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm64 X31 n (transl_cond_int64s cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ unfold xorimm64. + exploit (opimm64_correct Pxorl Pxoril Val.xorl); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmpl in B2; simpl in B2; rewrite Int64.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ unfold xorimm64. + exploit (opimm64_correct Pxorl Pxoril Val.xorl); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmpl in B2; simpl in B2; rewrite Int64.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ predSpec Int64.eq Int64.eq_spec n (Int64.repr Int64.max_signed). +* subst n. exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + unfold Val.cmpl; destruct (rs#r1); simpl; auto. rewrite B1. + unfold Int64.lt. rewrite zlt_false. auto. + change (Int64.signed (Int64.repr Int64.max_signed)) with Int64.max_signed. + generalize (Int64.signed_range i); omega. +* exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + rewrite B1. unfold Val.cmpl; simpl; destruct (rs#r1); simpl; auto. + unfold Int64.lt. replace (Int64.signed (Int64.add n Int64.one)) with (Int64.signed n + 1). + destruct (zlt (Int64.signed n) (Int64.signed i)). + rewrite zlt_false by omega. auto. + rewrite zlt_true by omega. auto. + rewrite Int64.add_signed. symmetry; apply Int64.signed_repr. + assert (Int64.signed n <> Int64.max_signed). + { red; intros E. elim H1. rewrite <- (Int64.repr_signed n). rewrite E. auto. } + generalize (Int64.signed_range n); omega. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_condimm_int64u_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int64u cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int64u. + predSpec Int64.eq Int64.eq_spec n Int64.zero. +- subst n. exploit transl_cond_int64u_correct. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. rewrite B; auto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64u_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. rewrite B2; auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ apply DFL. ++ apply DFL. ++ exploit (opimm64_correct Psltul Psltiul (fun v1 v2 => Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 v2)) m); eauto. + intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ apply DFL. ++ apply DFL. ++ apply DFL. + Qed. + +Lemma transl_cond_op_correct: + forall cond rd args k c rs m, + transl_cond_op cond rd args k = OK c -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + assert (MKTOT: forall ob, Val.of_optbool ob = Val.maketotal (option_map Val.of_bool ob)). + { destruct ob as [[]|]; reflexivity. } + intros until m; intros TR. + destruct cond; simpl in TR; ArgsInv. ++ (* cmp *) + exploit transl_cond_int32s_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. ++ (* cmpu *) + exploit transl_cond_int32u_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite B; auto. ++ (* cmpimm *) + apply transl_condimm_int32s_correct; eauto with asmgen. ++ (* cmpuimm *) + apply transl_condimm_int32u_correct; eauto with asmgen. ++ (* cmpl *) + exploit transl_cond_int64s_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmplu *) + exploit transl_cond_int64u_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. ++ (* cmplimm *) + exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmpluimm *) + exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmpf *) + destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. + fold (Val.cmpf c0 (rs x) (rs x0)). + set (v := Val.cmpf c0 (rs x) (rs x0)). + destruct normal; inv EQ2. +* econstructor; split. + apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. + split; intros; Simpl. +* econstructor; split. + eapply exec_straight_two. + eapply transl_cond_float_correct with (v := Val.notbool v); eauto. + simpl; reflexivity. + auto. auto. + split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto. ++ (* notcmpf *) + destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. + rewrite Val.notbool_negb_3. fold (Val.cmpf c0 (rs x) (rs x0)). + set (v := Val.cmpf c0 (rs x) (rs x0)). + destruct normal; inv EQ2. +* econstructor; split. + eapply exec_straight_two. + eapply transl_cond_float_correct with (v := v); eauto. + simpl; reflexivity. + auto. auto. + split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto. +* econstructor; split. + apply exec_straight_one. eapply transl_cond_float_correct with (v := Val.notbool v); eauto. auto. + split; intros; Simpl. ++ (* cmpfs *) + destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR. + fold (Val.cmpfs c0 (rs x) (rs x0)). + set (v := Val.cmpfs c0 (rs x) (rs x0)). + destruct normal; inv EQ2. +* econstructor; split. + apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. + split; intros; Simpl. +* econstructor; split. + eapply exec_straight_two. + eapply transl_cond_single_correct with (v := Val.notbool v); eauto. + simpl; reflexivity. + auto. auto. + split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto. ++ (* notcmpfs *) + destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR. + rewrite Val.notbool_negb_3. fold (Val.cmpfs c0 (rs x) (rs x0)). + set (v := Val.cmpfs c0 (rs x) (rs x0)). + destruct normal; inv EQ2. +* econstructor; split. + eapply exec_straight_two. + eapply transl_cond_single_correct with (v := v); eauto. + simpl; reflexivity. + auto. auto. + split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto. +* econstructor; split. + apply exec_straight_one. eapply transl_cond_single_correct with (v := Val.notbool v); eauto. auto. + split; intros; Simpl. + Qed. + +(** Some arithmetic properties. *) + +Remark cast32unsigned_from_cast32signed: + forall i, Int64.repr (Int.unsigned i) = Int64.zero_ext 32 (Int64.repr (Int.signed i)). +Proof. + intros. apply Int64.same_bits_eq; intros. + rewrite Int64.bits_zero_ext, !Int64.testbit_repr by tauto. + rewrite Int.bits_signed by tauto. fold (Int.testbit i i0). + change Int.zwordsize with 32. + destruct (zlt i0 32). auto. apply Int.bits_above. auto. +Qed. + (* Translation of arithmetic operations *) Ltac SimplEval H := @@ -386,6 +1103,28 @@ Opaque Int.eq. unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. (* move *) { destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. } + (* intconst *) + { exploit loadimm32_correct; eauto. intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* longconst *) + { exploit loadimm64_correct; eauto. intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* floatconst *) + { destruct (Float.eq_dec n Float.zero). + + subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + + econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. } + (* singleconst *) + { destruct (Float32.eq_dec n Float32.zero). + + subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + + econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. } (* addrsymbol *) { destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). + set (rs1 := nextinstr (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). @@ -402,6 +1141,138 @@ Opaque Int.eq. (* stackoffset *) { exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. auto with asmgen. } + (* cast8signed *) + { econstructor; split. + eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. + split; intros; Simpl. + assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. + destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. } + (* cast16signed *) + { econstructor; split. + eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. + split; intros; Simpl. + assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. + destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. } + (* addimm *) + { exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* andimm *) + { exploit (opimm32_correct Pandw Pandiw Val.and); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* orimm *) + exploit (opimm32_correct Porw Poriw Val.or); auto. instantiate (1 := x0); eauto with asmgen. + { intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* xorimm *) + { exploit (opimm32_correct Pxorw Pxoriw Val.xor); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* shrximm *) + { destruct (Val.shrx (rs x0) (Vint n)) eqn:TOTAL; cbn. + { + exploit Val.shrx_shr_3; eauto. intros E; subst v. + destruct (Int.eq n Int.zero). + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + + destruct (Int.eq n Int.one). + * econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + } + destruct (Int.eq n Int.zero). + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + + destruct (Int.eq n Int.one). + * econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. } + (* longofintu *) + { econstructor; split. + eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. + split; intros; Simpl. destruct (rs x0); auto. simpl. + assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. + rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. + rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. } + (* addlimm *) + { exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* andimm *) + { exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* orimm *) + { exploit (opimm64_correct Porl Poril Val.orl); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* xorimm *) + { exploit (opimm64_correct Pxorl Pxoril Val.xorl); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* shrxlimm *) + { destruct (Val.shrxl (rs x0) (Vint n)) eqn:TOTAL. + { + exploit Val.shrxl_shrl_3; eauto. intros E; subst v. + destruct (Int.eq n Int.zero). + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + + destruct (Int.eq n Int.one). + * econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + + * change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + } + destruct (Int.eq n Int.zero). + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + + destruct (Int.eq n Int.one). + * econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + + * change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. } + (* cond *) + { exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. eauto with asmgen. } (* Expanded instructions from RTL *) 9,10,19,20: econstructor; split; try apply exec_straight_one; simpl; eauto; diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 5d739375..1384b9b3 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -116,8 +116,7 @@ let forget_reg vn rd = print_list_pos old_regs; Hashtbl.replace !vn.nval v (List.filter (fun n -> not (P.eq n rd)) old_regs) - | None -> - debug "forget_reg: no mapping for r=%d\n" (p2i rd) + | None -> debug "forget_reg: no mapping for r=%d\n" (p2i rd) let update_reg vn rd v = debug "update_reg: update v=%d with r=%d\n" v (p2i rd); @@ -696,8 +695,9 @@ let expanse (sb : superblock) code pm = was_branch := false; was_exp := false; let inst = get_some @@ PTree.get n code in - debug "We are checking node %d\n" (p2i n); - (match inst with + (if !Clflags.option_fexpanse_rtlcond then + debug "We are checking node %d\n" (p2i n); + match inst with (* Expansion of conditions - Ocmp *) | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> debug "Iop/Ccomp\n"; @@ -824,7 +824,7 @@ let expanse (sb : superblock) code pm = was_branch := true; was_exp := true | _ -> ()); - (if not !was_exp then + (if !Clflags.option_fexpanse_others && not !was_exp then match inst with | Iop (Ofloatconst f, nil, dest, succ) -> debug "Iop/Ofloatconst\n"; diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index 7aca1772..ca049962 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -853,16 +853,6 @@ Proof. destruct x; destruct y; simpl; auto. rewrite Float32.cmp_swap. auto. Qed. -Remark cast32unsigned_from_cast32signed: - forall i, Int64.repr (Int.unsigned i) = Int64.zero_ext 32 (Int64.repr (Int.signed i)). -Proof. - intros. apply Int64.same_bits_eq; intros. - rewrite Int64.bits_zero_ext, !Int64.testbit_repr by tauto. - rewrite Int.bits_signed by tauto. fold (Int.testbit i i0). - change Int.zwordsize with 32. - destruct (zlt i0 32). auto. apply Int.bits_above. auto. -Qed. - (** * Intermediates lemmas on each expanded instruction *) Lemma simplify_ccomp_correct ge sp hst st c r r0 rs0 m0 v v0: forall -- cgit From 25a3de1e003f02012eefe427ea24c875972c5c22 Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Sat, 29 May 2021 23:09:08 +0200 Subject: just remove a debug print --- riscV/ExpansionOracle.ml | 1 - 1 file changed, 1 deletion(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 1384b9b3..b3f1f8ce 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -696,7 +696,6 @@ let expanse (sb : superblock) code pm = was_exp := false; let inst = get_some @@ PTree.get n code in (if !Clflags.option_fexpanse_rtlcond then - debug "We are checking node %d\n" (p2i n); match inst with (* Expansion of conditions - Ocmp *) | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> -- cgit From c44fc24eb6111c177d1d6fc973a366ebf646202b Mon Sep 17 00:00:00 2001 From: Léo Gourdin Date: Tue, 1 Jun 2021 11:18:59 +0200 Subject: removing some Expansion when loading float/single constants --- riscV/ExpansionOracle.ml | 38 ++++++++++++++++++++++---------------- 1 file changed, 22 insertions(+), 16 deletions(-) (limited to 'riscV') diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index b3f1f8ce..68d4e4d2 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -825,22 +825,28 @@ let expanse (sb : superblock) code pm = | _ -> ()); (if !Clflags.option_fexpanse_others && not !was_exp then match inst with - | Iop (Ofloatconst f, nil, dest, succ) -> - debug "Iop/Ofloatconst\n"; - let r = r2pi () in - let l = loadimm64 vn r (Floats.Float.to_bits f) in - let r', l' = extract_arg l in - exp := addinst vn Ofloat_of_bits [ r' ] dest :: l'; - exp := extract_final vn !exp dest succ; - was_exp := true - | Iop (Osingleconst f, nil, dest, succ) -> - debug "Iop/Osingleconst\n"; - let r = r2pi () in - let l = loadimm32 vn r (Floats.Float32.to_bits f) in - let r', l' = extract_arg l in - exp := addinst vn Osingle_of_bits [ r' ] dest :: l'; - exp := extract_final vn !exp dest succ; - was_exp := true + | Iop (Ofloatconst f, nil, dest, succ) -> ( + match make_immed64 (Floats.Float.to_bits f) with + | Imm64_single _ | Imm64_large _ -> () + | Imm64_pair (hi, lo) -> + debug "Iop/Ofloatconst\n"; + let r = r2pi () in + let l = load_hilo64 vn r hi lo in + let r', l' = extract_arg l in + exp := addinst vn Ofloat_of_bits [ r' ] dest :: l'; + exp := extract_final vn !exp dest succ; + was_exp := true) + | Iop (Osingleconst f, nil, dest, succ) -> ( + match make_immed32 (Floats.Float32.to_bits f) with + | Imm32_single imm -> () + | Imm32_pair (hi, lo) -> + debug "Iop/Osingleconst\n"; + let r = r2pi () in + let l = load_hilo32 vn r hi lo in + let r', l' = extract_arg l in + exp := addinst vn Osingle_of_bits [ r' ] dest :: l'; + exp := extract_final vn !exp dest succ; + was_exp := true) | Iop (Ointconst n, nil, dest, succ) -> debug "Iop/Ointconst\n"; exp := loadimm32 vn dest n; -- cgit