From a82c9c0e4a0b8e37c9c3ea5ae99714982563606f Mon Sep 17 00:00:00 2001 From: xleroy Date: Sat, 14 Jan 2012 14:23:26 +0000 Subject: Merge of the nonstrict-ops branch: - Most RTL operators now evaluate to Some Vundef instead of None when undefined behavior occurs. - More aggressive instruction selection. - "Bertotization" of pattern-matchings now implemented by a proper preprocessor. - Cast optimization moved to cfrontend/Cminorgen; removed backend/CastOptim. git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1790 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- ia32/Asm.v | 39 +- ia32/Asmgenproof.v | 13 +- ia32/Asmgenproof1.v | 721 ++++++++++++++++----------- ia32/ConstpropOp.v | 1261 ++++++++++++++++++++--------------------------- ia32/ConstpropOpproof.v | 554 +++++++++------------ ia32/Op.v | 1242 +++++++++++++++++++++------------------------- ia32/SelectOp.v | 839 ------------------------------- ia32/SelectOp.vp | 416 ++++++++++++++++ ia32/SelectOpproof.v | 1136 +++++++++++++++++------------------------- 9 files changed, 2677 insertions(+), 3544 deletions(-) delete mode 100644 ia32/SelectOp.v create mode 100644 ia32/SelectOp.vp (limited to 'ia32') diff --git a/ia32/Asm.v b/ia32/Asm.v index 4fc38ba..63149aa 100644 --- a/ia32/Asm.v +++ b/ia32/Asm.v @@ -295,9 +295,9 @@ Definition eval_addrmode (a: addrmode) (rs: regset) : val := SOF is (morally) the XOR of the SF and OF flags of the processor. *) -Definition compare_ints (x y: val) (rs: regset) : regset := - rs #ZF <- (Val.cmp Ceq x y) - #CF <- (Val.cmpu Clt x y) +Definition compare_ints (x y: val) (rs: regset) (m: mem): regset := + rs #ZF <- (Val.cmpu (Mem.valid_pointer m) Ceq x y) + #CF <- (Val.cmpu (Mem.valid_pointer m) Clt x y) #SOF <- (Val.cmp Clt x y) #PF <- Vundef. @@ -512,9 +512,9 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pcvtsd2ss_mf a r1 => exec_store Mfloat32 m a rs r1 | Pcvttsd2si_rf rd r1 => - Next (nextinstr (rs#rd <- (Val.intoffloat rs#r1))) m + Next (nextinstr (rs#rd <- (Val.maketotal (Val.intoffloat rs#r1)))) m | Pcvtsi2sd_fr rd r1 => - Next (nextinstr (rs#rd <- (Val.floatofint rs#r1))) m + Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofint rs#r1)))) m (** Integer arithmetic *) | Plea rd a => Next (nextinstr (rs#rd <- (eval_addrmode a rs))) m @@ -527,11 +527,17 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pimul_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.mul rs#rd (Vint n)))) m | Pdiv r1 => - Next (nextinstr_nf (rs#EAX <- (Val.divu rs#EAX (rs#EDX <- Vundef)#r1) - #EDX <- (Val.modu rs#EAX (rs#EDX <- Vundef)#r1))) m + let vn := rs#EAX in let vd := (rs#EDX <- Vundef)#r1 in + match Val.divu vn vd, Val.modu vn vd with + | Some vq, Some vr => Next (nextinstr_nf (rs#EAX <- vq #EDX <- vr)) m + | _, _ => Stuck + end | Pidiv r1 => - Next (nextinstr_nf (rs#EAX <- (Val.divs rs#EAX (rs#EDX <- Vundef)#r1) - #EDX <- (Val.mods rs#EAX (rs#EDX <- Vundef)#r1))) m + let vn := rs#EAX in let vd := (rs#EDX <- Vundef)#r1 in + match Val.divs vn vd, Val.mods vn vd with + | Some vq, Some vr => Next (nextinstr_nf (rs#EAX <- vq #EDX <- vr)) m + | _, _ => Stuck + end | Pand_rr rd r1 => Next (nextinstr_nf (rs#rd <- (Val.and rs#rd rs#r1))) m | Pand_ri rd n => @@ -561,24 +567,21 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome | Pror_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.ror rs#rd (Vint n)))) m | Pcmp_rr r1 r2 => - Next (nextinstr (compare_ints (rs r1) (rs r2) rs)) m + Next (nextinstr (compare_ints (rs r1) (rs r2) rs m)) m | Pcmp_ri r1 n => - Next (nextinstr (compare_ints (rs r1) (Vint n) rs)) m + Next (nextinstr (compare_ints (rs r1) (Vint n) rs m)) m | Ptest_rr r1 r2 => - Next (nextinstr (compare_ints (Val.and (rs r1) (rs r2)) Vzero rs)) m + Next (nextinstr (compare_ints (Val.and (rs r1) (rs r2)) Vzero rs m)) m | Ptest_ri r1 n => - Next (nextinstr (compare_ints (Val.and (rs r1) (Vint n)) Vzero rs)) m + Next (nextinstr (compare_ints (Val.and (rs r1) (Vint n)) Vzero rs m)) m | Pcmov c rd r1 => match eval_testcond c rs with | Some true => Next (nextinstr (rs#rd <- (rs#r1))) m | Some false => Next (nextinstr rs) m - | None => Stuck + | None => Next (nextinstr (rs#rd <- Vundef)) m end | Psetcc c rd => - match eval_testcond c rs with - | Some b => Next (nextinstr (rs#ECX <- Vundef #rd <- (Val.of_bool b))) m - | None => Stuck - end + Next (nextinstr (rs#ECX <- Vundef #rd <- (Val.of_optbool (eval_testcond c rs)))) m (** Arithmetic operations over floats *) | Paddd_ff rd r1 => Next (nextinstr (rs#rd <- (Val.addf rs#rd rs#r1))) m diff --git a/ia32/Asmgenproof.v b/ia32/Asmgenproof.v index e8c6757..a49a7ff 100644 --- a/ia32/Asmgenproof.v +++ b/ia32/Asmgenproof.v @@ -844,8 +844,9 @@ Proof. intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. left; eapply exec_straight_steps; eauto; intros. simpl in H1. exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + assert (S: Val.lessdef v (rs2 (preg_of res))) by (eapply Val.lessdef_trans; eauto). exists rs2; split. eauto. - split. rewrite <- Q in B. + split. unfold undef_op. destruct op; try (eapply agree_set_undef_mreg; eauto). eapply agree_set_undef_move_mreg; eauto. @@ -1119,8 +1120,10 @@ Proof. intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0. exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. left; eapply exec_straight_steps_goto; eauto. - intros. simpl in H2. - exploit transl_cond_correct; eauto. intros [rs' [A [B C]]]. + intros. simpl in H2. + destruct (transl_cond_correct tge tf cond args _ _ rs m' H2) + as [rs' [A [B C]]]. + unfold PregEq.t in B; rewrite EC in B. destruct (testcond_for_condition cond); simpl in *. (* simple jcc *) exists (Pjcc c1 lbl); exists k; exists rs'. @@ -1165,7 +1168,9 @@ Proof. intros; red; intros; inv MS. exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. left; eapply exec_straight_steps; eauto. intros. simpl in H0. - exploit transl_cond_correct; eauto. intros [rs' [A [B C]]]. + destruct (transl_cond_correct tge tf cond args _ _ rs m' H0) + as [rs' [A [B C]]]. + unfold PregEq.t in B; rewrite EC in B. destruct (testcond_for_condition cond); simpl in *. (* simple jcc *) econstructor; split. diff --git a/ia32/Asmgenproof1.v b/ia32/Asmgenproof1.v index be40f3d..5749a0b 100644 --- a/ia32/Asmgenproof1.v +++ b/ia32/Asmgenproof1.v @@ -625,26 +625,37 @@ Qed. (** Smart constructor for division *) Lemma mk_div_correct: - forall mkinstr dsem msem r1 r2 k c rs1 m, + forall mkinstr dsem msem r1 r2 k c (rs1: regset) m vq vr, mk_div mkinstr r1 r2 k = OK c -> (forall r c rs m, exec_instr ge c (mkinstr r) rs m = - Next (nextinstr_nf (rs#EAX <- (dsem rs#EAX (rs#EDX <- Vundef)#r) - #EDX <- (msem rs#EAX (rs#EDX <- Vundef)#r))) m) -> + let vn := rs#EAX in let vd := (rs#EDX <- Vundef)#r in + match dsem vn vd, msem vn vd with + | Some vq, Some vr => Next (nextinstr_nf (rs#EAX <- vq #EDX <- vr)) m + | _, _ => Stuck + end) -> + dsem rs1#r1 rs1#r2 = Some vq -> + msem rs1#r1 rs1#r2 = Some vr -> exists rs2, exec_straight c rs1 m k rs2 m - /\ rs2#r1 = dsem rs1#r1 rs1#r2 + /\ rs2#r1 = vq /\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r. Proof. unfold mk_div; intros. destruct (ireg_eq r1 EAX). destruct (ireg_eq r2 EDX); monadInv H. (* r1=EAX r2=EDX *) - econstructor. split. eapply exec_straight_two. simpl; eauto. apply H0. auto. auto. + econstructor. split. eapply exec_straight_two. simpl; eauto. + rewrite H0. + change (nextinstr rs1 # ECX <- (rs1 EDX) EAX) with (rs1#EAX). + change ((nextinstr rs1 # ECX <- (rs1 EDX)) # EDX <- Vundef ECX) with (rs1#EDX). + rewrite H1. rewrite H2. eauto. auto. auto. split. SRes. - intros. repeat SOther. + intros. repeat SOther. (* r1=EAX r2<>EDX *) - econstructor. split. eapply exec_straight_one. apply H0. auto. - split. repeat SRes. decEq. apply Pregmap.gso. congruence. + econstructor. split. eapply exec_straight_one. rewrite H0. + replace (rs1 # EDX <- Vundef r2) with (rs1 r2). rewrite H1; rewrite H2. eauto. + symmetry. SOther. auto. + split. SRes. intros. repeat SOther. (* r1 <> EAX *) monadInv H. @@ -654,9 +665,12 @@ Proof. econstructor; split. apply exec_straight_step with rs2 m; auto. eapply exec_straight_trans. eexact A. - eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. + eapply exec_straight_three. + rewrite H0. replace (rs3 EAX) with (rs1 r1). replace (rs3 # EDX <- Vundef ECX) with (rs1 r2). + rewrite H1; rewrite H2. eauto. + simpl; eauto. simpl; eauto. auto. auto. auto. - split. repeat SRes. decEq. rewrite B; unfold rs2; SRes. SOther. + split. repeat SRes. intros. destruct (preg_eq r EAX). subst. repeat SRes. rewrite D; auto with ppcgen. repeat SOther. rewrite D; auto with ppcgen. unfold rs2; repeat SOther. @@ -665,27 +679,42 @@ Qed. (** Smart constructor for modulus *) Lemma mk_mod_correct: - forall mkinstr dsem msem r1 r2 k c rs1 m, + forall mkinstr dsem msem r1 r2 k c (rs1: regset) m vq vr, mk_mod mkinstr r1 r2 k = OK c -> (forall r c rs m, exec_instr ge c (mkinstr r) rs m = - Next (nextinstr_nf (rs#EAX <- (dsem rs#EAX (rs#EDX <- Vundef)#r) - #EDX <- (msem rs#EAX (rs#EDX <- Vundef)#r))) m) -> + let vn := rs#EAX in let vd := (rs#EDX <- Vundef)#r in + match dsem vn vd, msem vn vd with + | Some vq, Some vr => Next (nextinstr_nf (rs#EAX <- vq #EDX <- vr)) m + | _, _ => Stuck + end) -> + dsem rs1#r1 rs1#r2 = Some vq -> + msem rs1#r1 rs1#r2 = Some vr -> exists rs2, exec_straight c rs1 m k rs2 m - /\ rs2#r1 = msem rs1#r1 rs1#r2 + /\ rs2#r1 = vr /\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r. Proof. unfold mk_mod; intros. destruct (ireg_eq r1 EAX). destruct (ireg_eq r2 EDX); monadInv H. (* r1=EAX r2=EDX *) econstructor. split. eapply exec_straight_three. - simpl; eauto. apply H0. simpl; eauto. auto. auto. auto. + simpl; eauto. + rewrite H0. + change (nextinstr rs1 # ECX <- (rs1 EDX) EAX) with (rs1#EAX). + change ((nextinstr rs1 # ECX <- (rs1 EDX)) # EDX <- Vundef ECX) with (rs1#EDX). + rewrite H1. rewrite H2. eauto. + simpl; eauto. + auto. auto. auto. split. SRes. - intros. repeat SOther. + intros. repeat SOther. (* r1=EAX r2<>EDX *) - econstructor. split. eapply exec_straight_two. apply H0. simpl; eauto. auto. auto. - split. repeat SRes. decEq. apply Pregmap.gso. congruence. + econstructor. split. eapply exec_straight_two. rewrite H0. + replace (rs1 # EDX <- Vundef r2) with (rs1 r2). rewrite H1; rewrite H2. eauto. + symmetry. SOther. + simpl; eauto. + auto. auto. + split. SRes. intros. repeat SOther. (* r1 <> EAX *) monadInv H. @@ -695,57 +724,79 @@ Proof. econstructor; split. apply exec_straight_step with rs2 m; auto. eapply exec_straight_trans. eexact A. - eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. + eapply exec_straight_three. + rewrite H0. replace (rs3 EAX) with (rs1 r1). replace (rs3 # EDX <- Vundef ECX) with (rs1 r2). + rewrite H1; rewrite H2. eauto. + simpl; eauto. simpl; eauto. auto. auto. auto. - split. repeat SRes. decEq. rewrite B; unfold rs2; SRes. SOther. + split. repeat SRes. intros. destruct (preg_eq r EAX). subst. repeat SRes. rewrite D; auto with ppcgen. repeat SOther. rewrite D; auto with ppcgen. unfold rs2; repeat SOther. Qed. +Remark divs_mods_exist: + forall v1 v2, + match Val.divs v1 v2, Val.mods v1 v2 with + | Some _, Some _ => True + | None, None => True + | _, _ => False + end. +Proof. + intros. unfold Val.divs, Val.mods. destruct v1; auto. destruct v2; auto. + destruct (Int.eq i0 Int.zero); auto. +Qed. + +Remark divu_modu_exist: + forall v1 v2, + match Val.divu v1 v2, Val.modu v1 v2 with + | Some _, Some _ => True + | None, None => True + | _, _ => False + end. +Proof. + intros. unfold Val.divu, Val.modu. destruct v1; auto. destruct v2; auto. + destruct (Int.eq i0 Int.zero); auto. +Qed. + (** Smart constructor for [shrx] *) Lemma mk_shrximm_correct: - forall r1 n k c (rs1: regset) x m, + forall r1 n k c (rs1: regset) v m, mk_shrximm r1 n k = OK c -> - rs1#r1 = Vint x -> - Int.ltu n (Int.repr 31) = true -> + Val.shrx (rs1#r1) (Vint n) = Some v -> exists rs2, exec_straight c rs1 m k rs2 m - /\ rs2#r1 = Vint (Int.shrx x n) + /\ rs2#r1 = v /\ forall r, nontemp_preg r = true -> r <> r1 -> rs2#r = rs1#r. Proof. unfold mk_shrximm; intros. inv H. + exploit Val.shrx_shr; eauto. intros [x [y [A [B C]]]]. + inversion B; clear B; subst y; subst v; clear H0. set (tmp := if ireg_eq r1 ECX then EDX else ECX). assert (TMP1: tmp <> r1). unfold tmp; destruct (ireg_eq r1 ECX); congruence. assert (TMP2: nontemp_preg tmp = false). unfold tmp; destruct (ireg_eq r1 ECX); auto. - rewrite Int.shrx_shr; auto. set (tnm1 := Int.sub (Int.shl Int.one n) Int.one). set (x' := Int.add x tnm1). - set (rs2 := nextinstr (compare_ints (Vint x) (Vint Int.zero) rs1)). + set (rs2 := nextinstr (compare_ints (Vint x) (Vint Int.zero) rs1 m)). set (rs3 := nextinstr (rs2#tmp <- (Vint x'))). set (rs4 := nextinstr (if Int.lt x Int.zero then rs3#r1 <- (Vint x') else rs3)). set (rs5 := nextinstr_nf (rs4#r1 <- (Val.shr rs4#r1 (Vint n)))). assert (rs3#r1 = Vint x). unfold rs3. SRes. SRes. assert (rs3#tmp = Vint x'). unfold rs3. SRes. SRes. exists rs5. split. - apply exec_straight_step with rs2 m. simpl. rewrite H0. simpl. rewrite Int.and_idem. auto. auto. + apply exec_straight_step with rs2 m. simpl. rewrite A. simpl. rewrite Int.and_idem. auto. auto. apply exec_straight_step with rs3 m. simpl. - change (rs2 r1) with (rs1 r1). rewrite H0. simpl. + change (rs2 r1) with (rs1 r1). rewrite A. simpl. rewrite (Int.add_commut Int.zero tnm1). rewrite Int.add_zero. auto. auto. apply exec_straight_step with rs4 m. simpl. change (rs3 SOF) with (rs2 SOF). unfold rs2. rewrite nextinstr_inv; auto with ppcgen. - unfold compare_ints. rewrite Pregmap.gso; auto with ppcgen. rewrite Pregmap.gss. - simpl. unfold rs4. destruct (Int.lt x Int.zero); auto. rewrite H2; auto. - unfold rs4. destruct (Int.lt x Int.zero); auto. + unfold compare_ints. rewrite Pregmap.gso; auto with ppcgen. rewrite Pregmap.gss. + unfold Val.cmp. simpl. unfold rs4. destruct (Int.lt x Int.zero); simpl; auto. rewrite H0; auto. + unfold rs4. destruct (Int.lt x Int.zero); simpl; auto. apply exec_straight_one. auto. auto. split. unfold rs5. SRes. SRes. unfold rs4. rewrite nextinstr_inv; auto with ppcgen. - assert (Int.ltu n Int.iwordsize = true). - unfold Int.ltu in *. change (Int.unsigned (Int.repr 31)) with 31 in H1. - destruct (zlt (Int.unsigned n) 31); try discriminate. - change (Int.unsigned Int.iwordsize) with 32. apply zlt_true. omega. - destruct (Int.lt x Int.zero). rewrite Pregmap.gss. unfold Val.shr. rewrite H3. auto. - rewrite H. unfold Val.shr. rewrite H3. auto. + destruct (Int.lt x Int.zero). rewrite Pregmap.gss. rewrite A; auto. rewrite A; rewrite H; auto. intros. unfold rs5. repeat SOther. unfold rs4. SOther. transitivity (rs3#r). destruct (Int.lt x Int.zero). SOther. auto. unfold rs3. repeat SOther. unfold rs2. repeat SOther. @@ -904,58 +955,55 @@ Lemma transl_addressing_mode_correct: forall addr args am (rs: regset) v, transl_addressing addr args = OK am -> eval_addressing ge (rs ESP) addr (List.map rs (List.map preg_of args)) = Some v -> - eval_addrmode ge am rs = v. + Val.lessdef v (eval_addrmode ge am rs). Proof. assert (A: forall n, Int.add Int.zero n = n). intros. rewrite Int.add_commut. apply Int.add_zero. assert (B: forall n i, (if Int.eq i Int.one then Vint n else Vint (Int.mul n i)) = Vint (Int.mul n i)). - intros. generalize (Int.eq_spec i Int.one); destruct (Int.eq i Int.one); intros. + intros. predSpec Int.eq Int.eq_spec i Int.one. subst i. rewrite Int.mul_one. auto. auto. + assert (C: forall v i, + Val.lessdef (Val.mul v (Vint i)) + (if Int.eq i Int.one then v else Val.mul v (Vint i))). + intros. predSpec Int.eq Int.eq_spec i Int.one. + subst i. destruct v; simpl; auto. rewrite Int.mul_one; auto. + destruct v; simpl; auto. unfold transl_addressing; intros. - destruct addr; repeat (destruct args; try discriminate); simpl in H0. + destruct addr; repeat (destruct args; try discriminate); simpl in H0; inv H0. (* indexed *) - monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0. simpl. - destruct (rs x); inv H0; simpl. rewrite A; auto. rewrite A; auto. + monadInv H. rewrite (ireg_of_eq _ _ EQ). simpl. rewrite A; auto. (* indexed2 *) - monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0; rewrite (ireg_of_eq _ _ EQ1) in H0. simpl. - destruct (rs x); try discriminate; destruct (rs x0); inv H0; simpl. - rewrite Int.add_assoc; auto. - repeat rewrite Int.add_assoc. decEq. decEq. apply Int.add_commut. - rewrite Int.add_assoc; auto. + monadInv H. rewrite (ireg_of_eq _ _ EQ); rewrite (ireg_of_eq _ _ EQ1). simpl. + rewrite Val.add_assoc; auto. (* scaled *) - monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0. simpl. - destruct (rs x); inv H0; simpl. - rewrite B. simpl. rewrite A. auto. + monadInv H. rewrite (ireg_of_eq _ _ EQ). unfold eval_addrmode. + rewrite Val.add_permut. simpl. rewrite A. apply Val.add_lessdef; auto. (* indexed2scaled *) - monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0; rewrite (ireg_of_eq _ _ EQ1) in H0. simpl. - destruct (rs x); try discriminate; destruct (rs x0); inv H0; simpl. - rewrite B. simpl. auto. - rewrite B. simpl. auto. + monadInv H. rewrite (ireg_of_eq _ _ EQ); rewrite (ireg_of_eq _ _ EQ1); simpl. + apply Val.add_lessdef; auto. apply Val.add_lessdef; auto. (* global *) - inv H. simpl. unfold symbol_offset. destruct (Genv.find_symbol ge i); inv H0. - repeat rewrite Int.add_zero. auto. + inv H. simpl. unfold symbol_address, symbol_offset. + destruct (Genv.find_symbol ge i); simpl; auto. repeat rewrite Int.add_zero. auto. (* based *) - monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0. simpl. - destruct (rs x); inv H0; simpl. - unfold symbol_offset. destruct (Genv.find_symbol ge i); inv H1. - rewrite Int.add_zero; auto. + monadInv H. rewrite (ireg_of_eq _ _ EQ). simpl. + unfold symbol_address, symbol_offset. destruct (Genv.find_symbol ge i); simpl; auto. + rewrite Int.add_zero. rewrite Val.add_commut. auto. (* basedscaled *) - monadInv H. rewrite (ireg_of_eq _ _ EQ) in H0. simpl. - destruct (rs x); inv H0; simpl. - rewrite B. unfold symbol_offset. destruct (Genv.find_symbol ge i0); inv H1. - simpl. rewrite Int.add_zero. auto. + monadInv H. rewrite (ireg_of_eq _ _ EQ). unfold eval_addrmode. + rewrite (Val.add_commut Vzero). rewrite Val.add_assoc. rewrite Val.add_permut. + apply Val.add_lessdef; auto. destruct (rs x); simpl; auto. rewrite B. simpl. + rewrite Int.add_zero. auto. (* instack *) - inv H; simpl. unfold offset_sp in H0. - destruct (rs ESP); inv H0. simpl. rewrite A; auto. + inv H; simpl. rewrite A; auto. Qed. (** Processor conditions and comparisons *) Lemma compare_ints_spec: - forall rs v1 v2, - let rs' := nextinstr (compare_ints v1 v2 rs) in - rs'#ZF = Val.cmp Ceq v1 v2 - /\ rs'#CF = Val.cmpu Clt v1 v2 + forall rs v1 v2 m, + let rs' := nextinstr (compare_ints v1 v2 rs m) in + rs'#ZF = Val.cmpu (Mem.valid_pointer m) Ceq v1 v2 + /\ rs'#CF = Val.cmpu (Mem.valid_pointer m) Clt v1 v2 /\ rs'#SOF = Val.cmp Clt v1 v2 /\ (forall r, nontemp_preg r = true -> rs'#r = rs#r). Proof. @@ -1012,112 +1060,69 @@ Proof. intros. rewrite <- negb_orb. rewrite <- int_not_ltu. rewrite negb_involutive. auto. Qed. -Lemma testcond_for_signed_comparison_correct_ii: - forall c n1 n2 rs, +Lemma testcond_for_signed_comparison_correct: + forall c v1 v2 rs m b, + Val.cmp_bool c v1 v2 = Some b -> eval_testcond (testcond_for_signed_comparison c) - (nextinstr (compare_ints (Vint n1) (Vint n2) rs)) = - Some(Int.cmp c n1 n2). -Proof. - intros. generalize (compare_ints_spec rs (Vint n1) (Vint n2)). - set (rs' := nextinstr (compare_ints (Vint n1) (Vint n2) rs)). - intros [A [B [C D]]]. - unfold eval_testcond. rewrite A; rewrite B; rewrite C. - destruct c; simpl. - destruct (Int.eq n1 n2); auto. - destruct (Int.eq n1 n2); auto. - destruct (Int.lt n1 n2); auto. - rewrite int_not_lt. destruct (Int.lt n1 n2); destruct (Int.eq n1 n2); auto. - rewrite (int_lt_not n1 n2). destruct (Int.lt n1 n2); destruct (Int.eq n1 n2); auto. - destruct (Int.lt n1 n2); auto. -Qed. - -Lemma testcond_for_unsigned_comparison_correct_ii: - forall c n1 n2 rs, - eval_testcond (testcond_for_unsigned_comparison c) - (nextinstr (compare_ints (Vint n1) (Vint n2) rs)) = - Some(Int.cmpu c n1 n2). + (nextinstr (compare_ints v1 v2 rs m)) = Some b. Proof. - intros. generalize (compare_ints_spec rs (Vint n1) (Vint n2)). - set (rs' := nextinstr (compare_ints (Vint n1) (Vint n2) rs)). + intros. generalize (compare_ints_spec rs v1 v2 m). + set (rs' := nextinstr (compare_ints v1 v2 rs m)). intros [A [B [C D]]]. - unfold eval_testcond. rewrite A; rewrite B; rewrite C. + destruct v1; destruct v2; simpl in H; inv H. + unfold eval_testcond. rewrite A; rewrite B; rewrite C. unfold Val.cmp, Val.cmpu. destruct c; simpl. - destruct (Int.eq n1 n2); auto. - destruct (Int.eq n1 n2); auto. - destruct (Int.ltu n1 n2); auto. - rewrite int_not_ltu. destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto. - rewrite (int_ltu_not n1 n2). destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto. - destruct (Int.ltu n1 n2); auto. + destruct (Int.eq i i0); auto. + destruct (Int.eq i i0); auto. + destruct (Int.lt i i0); auto. + rewrite int_not_lt. destruct (Int.lt i i0); simpl; destruct (Int.eq i i0); auto. + rewrite (int_lt_not i i0). destruct (Int.lt i i0); destruct (Int.eq i i0); reflexivity. + destruct (Int.lt i i0); reflexivity. Qed. -Lemma testcond_for_unsigned_comparison_correct_pi: - forall c blk n1 n2 rs b, - eval_compare_null c n2 = Some b -> +Lemma testcond_for_unsigned_comparison_correct: + forall c v1 v2 rs m b, + Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 = Some b -> eval_testcond (testcond_for_unsigned_comparison c) - (nextinstr (compare_ints (Vptr blk n1) (Vint n2) rs)) = Some b. + (nextinstr (compare_ints v1 v2 rs m)) = Some b. Proof. - intros. - revert H. unfold eval_compare_null. - generalize (Int.eq_spec n2 Int.zero); destruct (Int.eq n2 Int.zero); intros; try discriminate. - subst n2. - generalize (compare_ints_spec rs (Vptr blk n1) (Vint Int.zero)). - set (rs' := nextinstr (compare_ints (Vptr blk n1) (Vint Int.zero) rs)). + intros. generalize (compare_ints_spec rs v1 v2 m). + set (rs' := nextinstr (compare_ints v1 v2 rs m)). intros [A [B [C D]]]. - unfold eval_testcond. rewrite A; rewrite B; rewrite C. - destruct c; simpl; try discriminate. - rewrite <- H0; auto. - rewrite <- H0; auto. -Qed. - -Lemma testcond_for_unsigned_comparison_correct_ip: - forall c blk n1 n2 rs b, - eval_compare_null c n1 = Some b -> - eval_testcond (testcond_for_unsigned_comparison c) - (nextinstr (compare_ints (Vint n1) (Vptr blk n2) rs)) = Some b. -Proof. - intros. - revert H. unfold eval_compare_null. - generalize (Int.eq_spec n1 Int.zero); destruct (Int.eq n1 Int.zero); intros; try discriminate. - subst n1. - generalize (compare_ints_spec rs (Vint Int.zero) (Vptr blk n2)). - set (rs' := nextinstr (compare_ints (Vint Int.zero) (Vptr blk n2) rs)). - intros [A [B [C D]]]. - unfold eval_testcond. rewrite A; rewrite B; rewrite C. - destruct c; simpl; try discriminate. - rewrite <- H0; auto. - rewrite <- H0; auto. -Qed. - -Lemma testcond_for_unsigned_comparison_correct_pp: - forall c b1 n1 b2 n2 rs m b, - (if Mem.valid_pointer m b1 (Int.unsigned n1) && Mem.valid_pointer m b2 (Int.unsigned n2) - then if eq_block b1 b2 then Some (Int.cmpu c n1 n2) else eval_compare_mismatch c - else None) = Some b -> - eval_testcond (testcond_for_unsigned_comparison c) - (nextinstr (compare_ints (Vptr b1 n1) (Vptr b2 n2) rs)) = - Some b. -Proof. - intros. - destruct (Mem.valid_pointer m b1 (Int.unsigned n1) && Mem.valid_pointer m b2 (Int.unsigned n2)); try discriminate. - generalize (compare_ints_spec rs (Vptr b1 n1) (Vptr b2 n2)). - set (rs' := nextinstr (compare_ints (Vptr b1 n1) (Vptr b2 n2) rs)). - intros [A [B [C D]]]. unfold eq_block in H. - unfold eval_testcond. rewrite A; rewrite B; rewrite C. - destruct c; simpl. - destruct (zeq b1 b2). inversion H. destruct (Int.eq n1 n2); auto. - rewrite <- H; auto. - destruct (zeq b1 b2). inversion H. destruct (Int.eq n1 n2); auto. - rewrite <- H; auto. - destruct (zeq b1 b2). inversion H. destruct (Int.ltu n1 n2); auto. - discriminate. - destruct (zeq b1 b2). inversion H. - rewrite int_not_ltu. destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto. - discriminate. - destruct (zeq b1 b2). inversion H. - rewrite (int_ltu_not n1 n2). destruct (Int.ltu n1 n2); destruct (Int.eq n1 n2); auto. - discriminate. - destruct (zeq b1 b2). inversion H. destruct (Int.ltu n1 n2); auto. - discriminate. + unfold eval_testcond. rewrite A; rewrite B; rewrite C. unfold Val.cmpu, Val.cmp. + destruct v1; destruct v2; simpl in H; inv H. +(* int int *) + destruct c; simpl; auto. + destruct (Int.eq i i0); reflexivity. + destruct (Int.eq i i0); auto. + destruct (Int.ltu i i0); auto. + rewrite int_not_ltu. destruct (Int.ltu i i0); simpl; destruct (Int.eq i i0); auto. + rewrite (int_ltu_not i i0). destruct (Int.ltu i i0); destruct (Int.eq i i0); reflexivity. + destruct (Int.ltu i i0); reflexivity. +(* int ptr *) + destruct (Int.eq i Int.zero) as []_eqn; try discriminate. + destruct c; simpl in *; inv H1. + rewrite Heqb1; reflexivity. + rewrite Heqb1; reflexivity. +(* ptr int *) + destruct (Int.eq i0 Int.zero) as []_eqn; try discriminate. + destruct c; simpl in *; inv H1. + rewrite Heqb1; reflexivity. + rewrite Heqb1; reflexivity. +(* ptr ptr *) + simpl. + destruct (Mem.valid_pointer m b0 (Int.unsigned i) && + Mem.valid_pointer m b1 (Int.unsigned i0)); try discriminate. + destruct (zeq b0 b1). + inversion H1. + destruct c; simpl; auto. + destruct (Int.eq i i0); reflexivity. + destruct (Int.eq i i0); auto. + destruct (Int.ltu i i0); auto. + rewrite int_not_ltu. destruct (Int.ltu i i0); simpl; destruct (Int.eq i i0); auto. + rewrite (int_ltu_not i i0). destruct (Int.ltu i i0); destruct (Int.eq i i0); reflexivity. + destruct (Int.ltu i i0); reflexivity. + destruct c; simpl in *; inv H1; reflexivity. Qed. Lemma compare_floats_spec: @@ -1151,7 +1156,113 @@ Definition eval_extcond (xc: extcond) (rs: regset) : option bool := end end. -Definition swap_floats (c: comparison) (n1 n2: float) : float := +(******* + +Definition swap_floats {A: Type} (c: comparison) (n1 n2: A) : A := + match c with + | Clt | Cle => n2 + | Ceq | Cne | Cgt | Cge => n1 + end. + +Lemma testcond_for_float_comparison_correct: + forall c v1 v2 rs b, + Val.cmpf_bool c v1 v2 = Some b -> + eval_extcond (testcond_for_condition (Ccompf c)) + (nextinstr (compare_floats (swap_floats c v1 v2) + (swap_floats c v2 v1) rs)) = Some b. +Proof. + intros. destruct v1; destruct v2; simpl in H; inv H. + assert (SWP: forall f1 f2, Vfloat (swap_floats c f1 f2) = swap_floats c (Vfloat f1) (Vfloat f2)). + destruct c; auto. + generalize (compare_floats_spec rs (swap_floats c f f0) (swap_floats c f0 f)). + repeat rewrite <- SWP. + set (rs' := nextinstr (compare_floats (Vfloat (swap_floats c f f0)) + (Vfloat (swap_floats c f0 f)) rs)). + intros [A [B [C D]]]. + unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C. + destruct c; simpl. +(* eq *) + rewrite Float.cmp_ne_eq. + destruct (Float.cmp Ceq f f0). auto. + simpl. destruct (Float.cmp Clt f f0 || Float.cmp Cgt f f0); auto. +(* ne *) + rewrite Float.cmp_ne_eq. + destruct (Float.cmp Ceq f f0). auto. + simpl. destruct (Float.cmp Clt f f0 || Float.cmp Cgt f f0); auto. +(* lt *) + rewrite <- (Float.cmp_swap Cge f f0). + rewrite <- (Float.cmp_swap Cne f f0). + simpl. + rewrite Float.cmp_ne_eq. rewrite Float.cmp_le_lt_eq. + caseEq (Float.cmp Clt f f0); intros; simpl. + caseEq (Float.cmp Ceq f f0); intros; simpl. + elimtype False. eapply Float.cmp_lt_eq_false; eauto. + auto. + destruct (Float.cmp Ceq f f0); auto. +(* le *) + rewrite <- (Float.cmp_swap Cge f f0). simpl. + destruct (Float.cmp Cle f f0); auto. +(* gt *) + rewrite Float.cmp_ne_eq. rewrite Float.cmp_ge_gt_eq. + caseEq (Float.cmp Cgt f f0); intros; simpl. + caseEq (Float.cmp Ceq f f0); intros; simpl. + elimtype False. eapply Float.cmp_gt_eq_false; eauto. + auto. + destruct (Float.cmp Ceq f f0); auto. +(* ge *) + destruct (Float.cmp Cge f f0); auto. +Qed. + +Lemma testcond_for_neg_float_comparison_correct: + forall c n1 n2 rs, + eval_extcond (testcond_for_condition (Cnotcompf c)) + (nextinstr (compare_floats (Vfloat (swap_floats c n1 n2)) + (Vfloat (swap_floats c n2 n1)) rs)) = + Some(negb(Float.cmp c n1 n2)). +Proof. + intros. + generalize (compare_floats_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)). + set (rs' := nextinstr (compare_floats (Vfloat (swap_floats c n1 n2)) + (Vfloat (swap_floats c n2 n1)) rs)). + intros [A [B [C D]]]. + unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C. + destruct c; simpl. +(* eq *) + rewrite Float.cmp_ne_eq. + caseEq (Float.cmp Ceq n1 n2); intros. + auto. + simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto. +(* ne *) + rewrite Float.cmp_ne_eq. + caseEq (Float.cmp Ceq n1 n2); intros. + auto. + simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto. +(* lt *) + rewrite <- (Float.cmp_swap Cge n1 n2). + rewrite <- (Float.cmp_swap Cne n1 n2). + simpl. + rewrite Float.cmp_ne_eq. rewrite Float.cmp_le_lt_eq. + caseEq (Float.cmp Clt n1 n2); intros; simpl. + caseEq (Float.cmp Ceq n1 n2); intros; simpl. + elimtype False. eapply Float.cmp_lt_eq_false; eauto. + auto. + destruct (Float.cmp Ceq n1 n2); auto. +(* le *) + rewrite <- (Float.cmp_swap Cge n1 n2). simpl. + destruct (Float.cmp Cle n1 n2); auto. +(* gt *) + rewrite Float.cmp_ne_eq. rewrite Float.cmp_ge_gt_eq. + caseEq (Float.cmp Cgt n1 n2); intros; simpl. + caseEq (Float.cmp Ceq n1 n2); intros; simpl. + elimtype False. eapply Float.cmp_gt_eq_false; eauto. + auto. + destruct (Float.cmp Ceq n1 n2); auto. +(* ge *) + destruct (Float.cmp Cge n1 n2); auto. +Qed. +***************) + +Definition swap_floats {A: Type} (c: comparison) (n1 n2: A) : A := match c with | Clt | Cle => n2 | Ceq | Cne | Cgt | Cge => n1 @@ -1253,81 +1364,95 @@ Proof. destruct (Float.cmp Cge n1 n2); auto. Qed. +Remark swap_floats_commut: + forall c x y, swap_floats c (Vfloat x) (Vfloat y) = Vfloat (swap_floats c x y). +Proof. + intros. destruct c; auto. +Qed. + +Remark compare_floats_inv: + forall vx vy rs r, + r <> CR ZF -> r <> CR CF -> r <> CR PF -> r <> CR SOF -> + compare_floats vx vy rs r = rs r. +Proof. + intros. + assert (DFL: undef_regs (CR ZF :: CR CF :: CR PF :: CR SOF :: nil) rs r = rs r). + simpl. repeat SOther. + unfold compare_floats; destruct vx; destruct vy; auto. repeat SOther. +Qed. + Lemma transl_cond_correct: - forall cond args k c rs m b, + forall cond args k c rs m, transl_cond cond args k = OK c -> - eval_condition cond (map rs (map preg_of args)) m = Some b -> exists rs', exec_straight c rs m k rs' m - /\ eval_extcond (testcond_for_condition cond) rs' = Some b + /\ match eval_condition cond (map rs (map preg_of args)) m with + | None => True + | Some b => eval_extcond (testcond_for_condition cond) rs' = Some b + end /\ forall r, nontemp_preg r = true -> rs'#r = rs r. Proof. unfold transl_cond; intros. destruct cond; repeat (destruct args; try discriminate); monadInv H. (* comp *) - simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. rewrite (ireg_of_eq _ _ EQ1) in H0. + simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. simpl in H0. FuncInv. - subst b. simpl. apply testcond_for_signed_comparison_correct_ii. + split. destruct (Val.cmp_bool c0 (rs x) (rs x0)) as []_eqn; auto. + eapply testcond_for_signed_comparison_correct; eauto. intros. unfold compare_ints. repeat SOther. (* compu *) - simpl map in H0. - rewrite (ireg_of_eq _ _ EQ) in H0. rewrite (ireg_of_eq _ _ EQ1) in H0. + simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. simpl in H0. FuncInv. - subst b. simpl; apply testcond_for_unsigned_comparison_correct_ii. - simpl; apply testcond_for_unsigned_comparison_correct_ip; auto. - simpl; apply testcond_for_unsigned_comparison_correct_pi; auto. - simpl; eapply testcond_for_unsigned_comparison_correct_pp; eauto. + split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) as []_eqn; auto. + eapply testcond_for_unsigned_comparison_correct; eauto. intros. unfold compare_ints. repeat SOther. (* compimm *) - simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. - exists (nextinstr (compare_ints (rs x) (Vint i) rs)). - split. destruct (Int.eq_dec i Int.zero). - apply exec_straight_one. subst i. simpl. - simpl in H0. FuncInv. simpl. rewrite Int.and_idem. auto. auto. - apply exec_straight_one; auto. - split. simpl in H0. FuncInv. - subst b. simpl; apply testcond_for_signed_comparison_correct_ii. + simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int.eq_dec i Int.zero). + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split. destruct (rs x); simpl; auto. subst. rewrite Int.and_idem. + eapply testcond_for_signed_comparison_correct; eauto. + intros. unfold compare_ints. repeat SOther. + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split. destruct (Val.cmp_bool c0 (rs x) (Vint i)) as []_eqn; auto. + eapply testcond_for_signed_comparison_correct; eauto. intros. unfold compare_ints. repeat SOther. (* compuimm *) - simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. - econstructor. split. apply exec_straight_one. simpl; eauto. auto. - split. simpl in H0. FuncInv. - subst b. simpl; apply testcond_for_unsigned_comparison_correct_ii. - simpl; apply testcond_for_unsigned_comparison_correct_pi; auto. + simpl. rewrite (ireg_of_eq _ _ EQ). + econstructor. split. apply exec_straight_one. simpl. eauto. auto. + split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (Vint i)) as []_eqn; auto. + eapply testcond_for_unsigned_comparison_correct; eauto. intros. unfold compare_ints. repeat SOther. (* compf *) - simpl map in H0. rewrite (freg_of_eq _ _ EQ) in H0. rewrite (freg_of_eq _ _ EQ1) in H0. - remember (rs x) as v1; remember (rs x0) as v2. simpl in H0. FuncInv. - exists (nextinstr (compare_floats (Vfloat (swap_floats c0 f f0)) (Vfloat (swap_floats c0 f0 f)) rs)). + simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). + exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)). split. apply exec_straight_one. - destruct c0; unfold floatcomp, exec_instr, swap_floats; congruence. - auto. - split. subst b. apply testcond_for_float_comparison_correct. - intros. unfold compare_floats. repeat SOther. + destruct c0; simpl; auto. + unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with ppcgen. + split. destruct (rs x); destruct (rs x0); simpl; auto. + repeat rewrite swap_floats_commut. apply testcond_for_float_comparison_correct. + intros. SOther. apply compare_floats_inv; auto with ppcgen. (* notcompf *) - simpl map in H0. rewrite (freg_of_eq _ _ EQ) in H0. rewrite (freg_of_eq _ _ EQ1) in H0. - remember (rs x) as v1; remember (rs x0) as v2. simpl in H0. FuncInv. - exists (nextinstr (compare_floats (Vfloat (swap_floats c0 f f0)) (Vfloat (swap_floats c0 f0 f)) rs)). + simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). + exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)). split. apply exec_straight_one. - destruct c0; unfold floatcomp, exec_instr, swap_floats; congruence. - auto. - split. subst b. apply testcond_for_neg_float_comparison_correct. - intros. unfold compare_floats. repeat SOther. + destruct c0; simpl; auto. + unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with ppcgen. + split. destruct (rs x); destruct (rs x0); simpl; auto. + repeat rewrite swap_floats_commut. apply testcond_for_neg_float_comparison_correct. + intros. SOther. apply compare_floats_inv; auto with ppcgen. (* maskzero *) - simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. + simpl. rewrite (ireg_of_eq _ _ EQ). econstructor. split. apply exec_straight_one. simpl; eauto. auto. - split. simpl in H0. FuncInv. simpl. - generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero). - intros [A B]. rewrite A. subst b. simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto. + split. destruct (rs x); simpl; auto. + generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero m). + intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto. intros. unfold compare_ints. repeat SOther. (* masknotzero *) - simpl map in H0. rewrite (ireg_of_eq _ _ EQ) in H0. + simpl. rewrite (ireg_of_eq _ _ EQ). econstructor. split. apply exec_straight_one. simpl; eauto. auto. - split. simpl in H0. FuncInv. simpl. - generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero). - intros [A B]. rewrite A. subst b. simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto. + split. destruct (rs x); simpl; auto. + generalize (compare_ints_spec rs (Vint (Int.and i0 i)) Vzero m). + intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i0 i) Int.zero); auto. intros. unfold compare_ints. repeat SOther. Qed. @@ -1344,62 +1469,83 @@ Proof. Qed. Lemma mk_setcc_correct: - forall cond rd k rs1 m b, - eval_extcond cond rs1 = Some b -> + forall cond rd k rs1 m, exists rs2, exec_straight (mk_setcc cond rd k) rs1 m k rs2 m - /\ rs2#rd = Val.of_bool b + /\ rs2#rd = Val.of_optbool(eval_extcond cond rs1) /\ forall r, nontemp_preg r = true -> r <> rd -> rs2#r = rs1#r. Proof. intros. destruct cond; simpl in *. (* base *) econstructor; split. - apply exec_straight_one. simpl; rewrite H. eauto. auto. - split. repeat SRes. - intros. repeat SOther. + apply exec_straight_one. simpl; eauto. auto. + split. SRes. SRes. + intros; repeat SOther. (* or *) - destruct (eval_testcond c1 rs1) as [b1|]_eqn; - destruct (eval_testcond c2 rs1) as [b2|]_eqn; inv H. - assert (D: Val.or (Val.of_bool b1) (Val.of_bool b2) = Val.of_bool (b1 || b2)). - destruct b1; destruct b2; auto. + assert (Val.of_optbool + match eval_testcond c1 rs1 with + | Some b1 => + match eval_testcond c2 rs1 with + | Some b2 => Some (b1 || b2) + | None => None + end + | None => None + end = + Val.or (Val.of_optbool (eval_testcond c1 rs1)) (Val.of_optbool (eval_testcond c2 rs1))). + destruct (eval_testcond c1 rs1). destruct (eval_testcond c2 rs1). + destruct b; destruct b0; auto. + destruct b; auto. + auto. + rewrite H; clear H. destruct (ireg_eq rd EDX). subst rd. econstructor; split. eapply exec_straight_three. - simpl; rewrite Heqo; eauto. - simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. rewrite Heqo0. eauto. - simpl. eauto. + simpl; eauto. + simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto. + simpl; eauto. auto. auto. auto. split. SRes. intros. repeat SOther. econstructor; split. eapply exec_straight_three. - simpl; rewrite Heqo; eauto. - simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. rewrite Heqo0. eauto. + simpl; eauto. + simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto. simpl. eauto. auto. auto. auto. - split. repeat SRes. rewrite <- D. rewrite Val.or_commut. decEq; repeat SRes. + split. repeat SRes. rewrite Val.or_commut. decEq; repeat SRes. intros. repeat SOther. (* and *) - destruct (eval_testcond c1 rs1) as [b1|]_eqn; - destruct (eval_testcond c2 rs1) as [b2|]_eqn; inv H. - assert (D: Val.and (Val.of_bool b1) (Val.of_bool b2) = Val.of_bool (b1 && b2)). - destruct b1; destruct b2; auto. + assert (Val.of_optbool + match eval_testcond c1 rs1 with + | Some b1 => + match eval_testcond c2 rs1 with + | Some b2 => Some (b1 && b2) + | None => None + end + | None => None + end = + Val.and (Val.of_optbool (eval_testcond c1 rs1)) (Val.of_optbool (eval_testcond c2 rs1))). + destruct (eval_testcond c1 rs1). destruct (eval_testcond c2 rs1). + destruct b; destruct b0; auto. + destruct b; auto. + auto. + rewrite H; clear H. destruct (ireg_eq rd EDX). subst rd. econstructor; split. eapply exec_straight_three. - simpl; rewrite Heqo; eauto. - simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. rewrite Heqo0. eauto. - simpl. eauto. + simpl; eauto. + simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto. + simpl; eauto. auto. auto. auto. split. SRes. intros. repeat SOther. econstructor; split. eapply exec_straight_three. - simpl; rewrite Heqo; eauto. - simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. rewrite Heqo0. eauto. + simpl; eauto. + simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto. simpl. eauto. auto. auto. auto. - split. repeat SRes. rewrite <- D. rewrite Val.and_commut. decEq; repeat SRes. + split. repeat SRes. rewrite Val.and_commut. decEq; repeat SRes. intros. repeat SOther. Qed. @@ -1421,70 +1567,93 @@ Ltac TranslOp := [ apply exec_straight_one; [ simpl; eauto | auto ] | split; [ repeat SRes | intros; repeat SOther ]]. + Lemma transl_op_correct: forall op args res k c (rs: regset) m v, transl_op op args res k = OK c -> eval_operation ge (rs#ESP) op (map rs (map preg_of args)) m = Some v -> exists rs', exec_straight c rs m k rs' m - /\ rs'#(preg_of res) = v + /\ Val.lessdef v rs'#(preg_of res) /\ forall r, match op with Omove => important_preg r = true /\ r <> ST0 | _ => nontemp_preg r = true end -> r <> preg_of res -> rs' r = rs r. Proof. intros until v; intros TR EV. - rewrite <- (eval_operation_weaken _ _ _ _ _ EV). - destruct op; simpl in TR; ArgsInv; try (TranslOp; fail). + assert (SAME: + (exists rs', + exec_straight c rs m k rs' m + /\ rs'#(preg_of res) = v + /\ forall r, + match op with Omove => important_preg r = true /\ r <> ST0 | _ => nontemp_preg r = true end -> + r <> preg_of res -> rs' r = rs r) -> + exists rs', + exec_straight c rs m k rs' m + /\ Val.lessdef v rs'#(preg_of res) + /\ forall r, + match op with Omove => important_preg r = true /\ r <> ST0 | _ => nontemp_preg r = true end -> + r <> preg_of res -> rs' r = rs r). + intros [rs' [A [B C]]]. subst v. exists rs'; auto. + + destruct op; simpl in TR; ArgsInv; simpl in EV; try (inv EV); try (apply SAME; TranslOp; fail). (* move *) exploit mk_mov_correct; eauto. intros [rs2 [A [B C]]]. - exists rs2. split. eauto. split. simpl. auto. intros. destruct H; auto. + apply SAME. exists rs2. split. eauto. split. simpl. auto. intros. destruct H; auto. (* intconst *) - inv EV. destruct (Int.eq_dec i Int.zero). subst i. TranslOp. TranslOp. + apply SAME. destruct (Int.eq_dec i Int.zero). subst i. TranslOp. TranslOp. (* floatconst *) - inv EV. destruct (Float.eq_dec f Float.zero). subst f. TranslOp. TranslOp. + apply SAME. destruct (Float.eq_dec f Float.zero). subst f. TranslOp. TranslOp. (* cast8signed *) - eapply mk_intconv_correct; eauto. + apply SAME. eapply mk_intconv_correct; eauto. (* cast8unsigned *) - eapply mk_intconv_correct; eauto. + apply SAME. eapply mk_intconv_correct; eauto. (* cast16signed *) - eapply mk_intconv_correct; eauto. + apply SAME. eapply mk_intconv_correct; eauto. (* cast16unsigned *) - eapply mk_intconv_correct; eauto. + apply SAME. eapply mk_intconv_correct; eauto. (* div *) - eapply mk_div_correct; eauto. intros. simpl. eauto. + apply SAME. + specialize (divs_mods_exist (rs x0) (rs x1)). rewrite H0. + destruct (Val.mods (rs x0) (rs x1)) as [vr|]_eqn; intros; try contradiction. + eapply mk_div_correct with (dsem := Val.divs) (msem := Val.mods); eauto. (* divu *) - eapply mk_div_correct; eauto. intros. simpl. eauto. + apply SAME. + specialize (divu_modu_exist (rs x0) (rs x1)). rewrite H0. + destruct (Val.modu (rs x0) (rs x1)) as [vr|]_eqn; intros; try contradiction. + eapply mk_div_correct with (dsem := Val.divu) (msem := Val.modu); eauto. (* mod *) - eapply mk_mod_correct; eauto. intros. simpl. eauto. + apply SAME. + specialize (divs_mods_exist (rs x0) (rs x1)). rewrite H0. + destruct (Val.divs (rs x0) (rs x1)) as [vq|]_eqn; intros; try contradiction. + eapply mk_mod_correct with (dsem := Val.divs) (msem := Val.mods); eauto. (* modu *) - eapply mk_mod_correct; eauto. intros. simpl. eauto. + apply SAME. + specialize (divu_modu_exist (rs x0) (rs x1)). rewrite H0. + destruct (Val.divu (rs x0) (rs x1)) as [vq|]_eqn; intros; try contradiction. + eapply mk_mod_correct with (dsem := Val.divu) (msem := Val.modu); eauto. (* shl *) - eapply mk_shift_correct; eauto. + apply SAME. eapply mk_shift_correct; eauto. (* shr *) - eapply mk_shift_correct; eauto. + apply SAME. eapply mk_shift_correct; eauto. (* shrximm *) - remember (rs x0) as v1. FuncInv. - remember (Int.ltu i (Int.repr 31)) as L. destruct L; inv EV. - simpl. replace (Int.ltu i Int.iwordsize) with true. - apply mk_shrximm_correct; auto. - unfold Int.ltu. rewrite zlt_true; auto. - generalize (Int.ltu_inv _ _ (sym_equal HeqL)). - assert (Int.unsigned (Int.repr 31) < Int.unsigned Int.iwordsize) by (compute; auto). - omega. + apply SAME. eapply mk_shrximm_correct; eauto. (* shru *) - eapply mk_shift_correct; eauto. + apply SAME. eapply mk_shift_correct; eauto. (* lea *) exploit transl_addressing_mode_correct; eauto. intros EA. - rewrite (eval_addressing_weaken _ _ _ _ EV). rewrite <- EA. - TranslOp. + TranslOp. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss; auto. +(* intoffloat *) + apply SAME. TranslOp. rewrite H0; auto. +(* floatofint *) + apply SAME. TranslOp. rewrite H0; auto. (* condition *) - remember (eval_condition c0 rs ## (preg_of ## args) m) as ob. destruct ob; inv EV. - rewrite (eval_condition_weaken _ _ _ (sym_equal Heqob)). exploit transl_cond_correct; eauto. intros [rs2 [P [Q R]]]. exploit mk_setcc_correct; eauto. intros [rs3 [S [T U]]]. exists rs3. split. eapply exec_straight_trans. eexact P. eexact S. - split. auto. + split. rewrite T. destruct (eval_condition c0 rs ## (preg_of ## args) m). + rewrite Q. auto. + simpl; auto. intros. transitivity (rs2 r); auto. Qed. @@ -1502,9 +1671,10 @@ Lemma transl_load_correct: Proof. unfold transl_load; intros. monadInv H. exploit transl_addressing_mode_correct; eauto. intro EA. + assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto. set (rs2 := nextinstr_nf (rs#(preg_of dest) <- v)). assert (exec_load ge chunk m x rs (preg_of dest) = Next rs2 m). - unfold exec_load. rewrite EA. rewrite H1. auto. + unfold exec_load. rewrite EA'. rewrite H1. auto. assert (rs2 PC = Val.add (rs PC) Vone). transitivity (Val.add ((rs#(preg_of dest) <- v) PC) Vone). auto. decEq. apply Pregmap.gso; auto with ppcgen. @@ -1524,8 +1694,9 @@ Lemma transl_store_correct: /\ forall r, nontemp_preg r = true -> rs'#r = rs#r. Proof. unfold transl_store; intros. monadInv H. - exploit transl_addressing_mode_correct; eauto. intro EA. rewrite <- EA in H1. - destruct chunk; ArgsInv. + exploit transl_addressing_mode_correct; eauto. intro EA. + assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto. + rewrite <- EA' in H1. destruct chunk; ArgsInv. (* int8signed *) eapply mk_smallstore_correct; eauto. intros. simpl. unfold exec_store. diff --git a/ia32/ConstpropOp.v b/ia32/ConstpropOp.v index 815ba0e..3d07a4d 100644 --- a/ia32/ConstpropOp.v +++ b/ia32/ConstpropOp.v @@ -32,9 +32,10 @@ Inductive approx : Type := no compile-time information is available. *) | I: int -> approx (** A known integer value. *) | F: float -> approx (** A known floating-point value. *) - | S: ident -> int -> approx. + | G: ident -> int -> approx (** The value is the address of the given global symbol plus the given integer offset. *) + | S: int -> approx. (** The value is the stack pointer plus the offset. *) (** We now define the abstract interpretations of conditions and operators over this set of approximations. For instance, the abstract interpretation @@ -44,11 +45,12 @@ Inductive approx : Type := The static approximations are defined by large pattern-matchings over the approximations of the results. We write these matchings in the - indirect style described in file [Cmconstr] to avoid excessive + indirect style described in file [SelectOp] to avoid excessive duplication of cases in proofs. *) -(* -Definition eval_static_condition (cond: condition) (vl: list approx) := +(** Original definition: +<< +Nondetfunction eval_static_condition (cond: condition) (vl: list approx) := match cond, vl with | Ccomp c, I n1 :: I n2 :: nil => Some(Int.cmp c n1 n2) | Ccompu c, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 n2) @@ -57,198 +59,175 @@ Definition eval_static_condition (cond: condition) (vl: list approx) := | Ccompf c, F n1 :: F n2 :: nil => Some(Float.cmp c n1 n2) | Cnotcompf c, F n1 :: F n2 :: nil => Some(negb(Float.cmp c n1 n2)) | Cmaskzero n, I n1 :: nil => Some(Int.eq (Int.and n1 n) Int.zero) - | Cmasknotzero n, n1::nil => Some(negb(Int.eq (Int.and n1 n) Int.zero)) + | Cmasknotzero n, I n1::nil => Some(negb(Int.eq (Int.and n1 n) Int.zero)) | _, _ => None end. +>> *) Inductive eval_static_condition_cases: forall (cond: condition) (vl: list approx), Type := - | eval_static_condition_case1: - forall c n1 n2, - eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil) - | eval_static_condition_case2: - forall c n1 n2, - eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil) - | eval_static_condition_case3: - forall c n n1, - eval_static_condition_cases (Ccompimm c n) (I n1 :: nil) - | eval_static_condition_case4: - forall c n n1, - eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil) - | eval_static_condition_case5: - forall c n1 n2, - eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil) - | eval_static_condition_case6: - forall c n1 n2, - eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil) - | eval_static_condition_case7: - forall n n1, - eval_static_condition_cases (Cmaskzero n) (I n1 :: nil) - | eval_static_condition_case8: - forall n n1, - eval_static_condition_cases (Cmasknotzero n) (I n1 :: nil) - | eval_static_condition_default: - forall (cond: condition) (vl: list approx), - eval_static_condition_cases cond vl. + | eval_static_condition_case1: forall c n1 n2, eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil) + | eval_static_condition_case2: forall c n1 n2, eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil) + | eval_static_condition_case3: forall c n n1, eval_static_condition_cases (Ccompimm c n) (I n1 :: nil) + | eval_static_condition_case4: forall c n n1, eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil) + | eval_static_condition_case5: forall c n1 n2, eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil) + | eval_static_condition_case6: forall c n1 n2, eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil) + | eval_static_condition_case7: forall n n1, eval_static_condition_cases (Cmaskzero n) (I n1 :: nil) + | eval_static_condition_case8: forall n n1, eval_static_condition_cases (Cmasknotzero n) (I n1::nil) + | eval_static_condition_default: forall (cond: condition) (vl: list approx), eval_static_condition_cases cond vl. Definition eval_static_condition_match (cond: condition) (vl: list approx) := - match cond as z1, vl as z2 return eval_static_condition_cases z1 z2 with - | Ccomp c, I n1 :: I n2 :: nil => - eval_static_condition_case1 c n1 n2 - | Ccompu c, I n1 :: I n2 :: nil => - eval_static_condition_case2 c n1 n2 - | Ccompimm c n, I n1 :: nil => - eval_static_condition_case3 c n n1 - | Ccompuimm c n, I n1 :: nil => - eval_static_condition_case4 c n n1 - | Ccompf c, F n1 :: F n2 :: nil => - eval_static_condition_case5 c n1 n2 - | Cnotcompf c, F n1 :: F n2 :: nil => - eval_static_condition_case6 c n1 n2 - | Cmaskzero n, I n1 :: nil => - eval_static_condition_case7 n n1 - | Cmasknotzero n, I n1 :: nil => - eval_static_condition_case8 n n1 - | cond, vl => - eval_static_condition_default cond vl + match cond as zz1, vl as zz2 return eval_static_condition_cases zz1 zz2 with + | Ccomp c, I n1 :: I n2 :: nil => eval_static_condition_case1 c n1 n2 + | Ccompu c, I n1 :: I n2 :: nil => eval_static_condition_case2 c n1 n2 + | Ccompimm c n, I n1 :: nil => eval_static_condition_case3 c n n1 + | Ccompuimm c n, I n1 :: nil => eval_static_condition_case4 c n n1 + | Ccompf c, F n1 :: F n2 :: nil => eval_static_condition_case5 c n1 n2 + | Cnotcompf c, F n1 :: F n2 :: nil => eval_static_condition_case6 c n1 n2 + | Cmaskzero n, I n1 :: nil => eval_static_condition_case7 n n1 + | Cmasknotzero n, I n1::nil => eval_static_condition_case8 n n1 + | cond, vl => eval_static_condition_default cond vl end. Definition eval_static_condition (cond: condition) (vl: list approx) := match eval_static_condition_match cond vl with - | eval_static_condition_case1 c n1 n2 => + | eval_static_condition_case1 c n1 n2 => (* Ccomp c, I n1 :: I n2 :: nil *) Some(Int.cmp c n1 n2) - | eval_static_condition_case2 c n1 n2 => + | eval_static_condition_case2 c n1 n2 => (* Ccompu c, I n1 :: I n2 :: nil *) Some(Int.cmpu c n1 n2) - | eval_static_condition_case3 c n n1 => + | eval_static_condition_case3 c n n1 => (* Ccompimm c n, I n1 :: nil *) Some(Int.cmp c n1 n) - | eval_static_condition_case4 c n n1 => + | eval_static_condition_case4 c n n1 => (* Ccompuimm c n, I n1 :: nil *) Some(Int.cmpu c n1 n) - | eval_static_condition_case5 c n1 n2 => + | eval_static_condition_case5 c n1 n2 => (* Ccompf c, F n1 :: F n2 :: nil *) Some(Float.cmp c n1 n2) - | eval_static_condition_case6 c n1 n2 => + | eval_static_condition_case6 c n1 n2 => (* Cnotcompf c, F n1 :: F n2 :: nil *) Some(negb(Float.cmp c n1 n2)) - | eval_static_condition_case7 n n1 => + | eval_static_condition_case7 n n1 => (* Cmaskzero n, I n1 :: nil *) Some(Int.eq (Int.and n1 n) Int.zero) - | eval_static_condition_case8 n n1 => + | eval_static_condition_case8 n n1 => (* Cmasknotzero n, I n1::nil *) Some(negb(Int.eq (Int.and n1 n) Int.zero)) | eval_static_condition_default cond vl => None end. -(* -Definition eval_static_addressing (addr: addressing) (vl: list approx) := - match op, vl with + +Definition eval_static_condition_val (cond: condition) (vl: list approx) := + match eval_static_condition cond vl with + | None => Unknown + | Some b => I(if b then Int.one else Int.zero) + end. + +Definition eval_static_intoffloat (f: float) := + match Float.intoffloat f with Some x => I x | None => Unknown end. + +(** Original definition: +<< +Nondetfunction eval_static_addressing (addr: addressing) (vl: list approx) := + match addr, vl with | Aindexed n, I n1::nil => I (Int.add n1 n) - | Aindexed n, S id ofs::nil => S id (Int.add ofs n) + | Aindexed n, G id ofs::nil => G id (Int.add ofs n) + | Aindexed n, S ofs::nil => S (Int.add ofs n) | Aindexed2 n, I n1::I n2::nil => I (Int.add (Int.add n1 n2) n) - | Aindexed2 n, S id ofs::I n2::nil => S id (Int.add (Int.add ofs n2) n) - | Aindexed2 n, I n1::S id ofs::nil => S id (Int.add (Int.add ofs n1) n) + | Aindexed2 n, G id ofs::I n2::nil => G id (Int.add (Int.add ofs n2) n) + | Aindexed2 n, I n1::G id ofs::nil => G id (Int.add (Int.add ofs n1) n) + | Aindexed2 n, S ofs::I n2::nil => S (Int.add (Int.add ofs n2) n) + | Aindexed2 n, I n1::S ofs::nil => S (Int.add (Int.add ofs n1) n) | Ascaled sc n, I n1::nil => I (Int.add (Int.mul n1 sc) n) | Aindexed2scaled sc n, I n1::I n2::nil => I (Int.add n1 (Int.add (Int.mul n2 sc) n)) - | Aindexed2scaled sc n, S id ofs::I n2::nil => S id (Int.add ofs (Int.add (Int.mul n2 sc) n)) - | Aglobal id ofs, nil => S id ofs - | Abased id ofs, I n1::nil => S id (Int.add ofs n1) - | Abasedscaled sc id ofs, I n1::nil => S id (Int.add ofs (Int.mul sc n1)) + | Aindexed2scaled sc n, G id ofs::I n2::nil => G id (Int.add ofs (Int.add (Int.mul n2 sc) n)) + | Aindexed2scaled sc n, S ofs::I n2::nil => S (Int.add ofs (Int.add (Int.mul n2 sc) n)) + | Aglobal id ofs, nil => G id ofs + | Abased id ofs, I n1::nil => G id (Int.add ofs n1) + | Abasedscaled sc id ofs, I n1::nil => G id (Int.add ofs (Int.mul sc n1)) + | Ainstack ofs, nil => S ofs | _, _ => Unknown end. +>> *) Inductive eval_static_addressing_cases: forall (addr: addressing) (vl: list approx), Type := - | eval_static_addressing_case1: - forall n n1, - eval_static_addressing_cases (Aindexed n) (I n1::nil) - | eval_static_addressing_case2: - forall n id ofs, - eval_static_addressing_cases (Aindexed n) (S id ofs::nil) - | eval_static_addressing_case3: - forall n n1 n2, - eval_static_addressing_cases (Aindexed2 n) (I n1::I n2::nil) - | eval_static_addressing_case4: - forall n id ofs n2, - eval_static_addressing_cases (Aindexed2 n) (S id ofs::I n2::nil) - | eval_static_addressing_case5: - forall n n1 id ofs, - eval_static_addressing_cases (Aindexed2 n) (I n1::S id ofs::nil) - | eval_static_addressing_case6: - forall sc n n1, - eval_static_addressing_cases (Ascaled sc n) (I n1::nil) - | eval_static_addressing_case7: - forall sc n n1 n2, - eval_static_addressing_cases (Aindexed2scaled sc n) (I n1::I n2::nil) - | eval_static_addressing_case8: - forall sc n id ofs n2, - eval_static_addressing_cases (Aindexed2scaled sc n) (S id ofs::I n2::nil) - | eval_static_addressing_case9: - forall id ofs, - eval_static_addressing_cases (Aglobal id ofs) (nil) - | eval_static_addressing_case10: - forall id ofs n1, - eval_static_addressing_cases (Abased id ofs) (I n1::nil) - | eval_static_addressing_case11: - forall sc id ofs n1, - eval_static_addressing_cases (Abasedscaled sc id ofs) (I n1::nil) - | eval_static_addressing_default: - forall (addr: addressing) (vl: list approx), - eval_static_addressing_cases addr vl. + | eval_static_addressing_case1: forall n n1, eval_static_addressing_cases (Aindexed n) (I n1::nil) + | eval_static_addressing_case2: forall n id ofs, eval_static_addressing_cases (Aindexed n) (G id ofs::nil) + | eval_static_addressing_case3: forall n ofs, eval_static_addressing_cases (Aindexed n) (S ofs::nil) + | eval_static_addressing_case4: forall n n1 n2, eval_static_addressing_cases (Aindexed2 n) (I n1::I n2::nil) + | eval_static_addressing_case5: forall n id ofs n2, eval_static_addressing_cases (Aindexed2 n) (G id ofs::I n2::nil) + | eval_static_addressing_case6: forall n n1 id ofs, eval_static_addressing_cases (Aindexed2 n) (I n1::G id ofs::nil) + | eval_static_addressing_case7: forall n ofs n2, eval_static_addressing_cases (Aindexed2 n) (S ofs::I n2::nil) + | eval_static_addressing_case8: forall n n1 ofs, eval_static_addressing_cases (Aindexed2 n) (I n1::S ofs::nil) + | eval_static_addressing_case9: forall sc n n1, eval_static_addressing_cases (Ascaled sc n) (I n1::nil) + | eval_static_addressing_case10: forall sc n n1 n2, eval_static_addressing_cases (Aindexed2scaled sc n) (I n1::I n2::nil) + | eval_static_addressing_case11: forall sc n id ofs n2, eval_static_addressing_cases (Aindexed2scaled sc n) (G id ofs::I n2::nil) + | eval_static_addressing_case12: forall sc n ofs n2, eval_static_addressing_cases (Aindexed2scaled sc n) (S ofs::I n2::nil) + | eval_static_addressing_case13: forall id ofs, eval_static_addressing_cases (Aglobal id ofs) (nil) + | eval_static_addressing_case14: forall id ofs n1, eval_static_addressing_cases (Abased id ofs) (I n1::nil) + | eval_static_addressing_case15: forall sc id ofs n1, eval_static_addressing_cases (Abasedscaled sc id ofs) (I n1::nil) + | eval_static_addressing_case16: forall ofs, eval_static_addressing_cases (Ainstack ofs) (nil) + | eval_static_addressing_default: forall (addr: addressing) (vl: list approx), eval_static_addressing_cases addr vl. Definition eval_static_addressing_match (addr: addressing) (vl: list approx) := - match addr as z1, vl as z2 return eval_static_addressing_cases z1 z2 with - | Aindexed n, I n1::nil => - eval_static_addressing_case1 n n1 - | Aindexed n, S id ofs::nil => - eval_static_addressing_case2 n id ofs - | Aindexed2 n, I n1::I n2::nil => - eval_static_addressing_case3 n n1 n2 - | Aindexed2 n, S id ofs::I n2::nil => - eval_static_addressing_case4 n id ofs n2 - | Aindexed2 n, I n1::S id ofs::nil => - eval_static_addressing_case5 n n1 id ofs - | Ascaled sc n, I n1::nil => - eval_static_addressing_case6 sc n n1 - | Aindexed2scaled sc n, I n1::I n2::nil => - eval_static_addressing_case7 sc n n1 n2 - | Aindexed2scaled sc n, S id ofs::I n2::nil => - eval_static_addressing_case8 sc n id ofs n2 - | Aglobal id ofs, nil => - eval_static_addressing_case9 id ofs - | Abased id ofs, I n1::nil => - eval_static_addressing_case10 id ofs n1 - | Abasedscaled sc id ofs, I n1::nil => - eval_static_addressing_case11 sc id ofs n1 - | addr, vl => - eval_static_addressing_default addr vl + match addr as zz1, vl as zz2 return eval_static_addressing_cases zz1 zz2 with + | Aindexed n, I n1::nil => eval_static_addressing_case1 n n1 + | Aindexed n, G id ofs::nil => eval_static_addressing_case2 n id ofs + | Aindexed n, S ofs::nil => eval_static_addressing_case3 n ofs + | Aindexed2 n, I n1::I n2::nil => eval_static_addressing_case4 n n1 n2 + | Aindexed2 n, G id ofs::I n2::nil => eval_static_addressing_case5 n id ofs n2 + | Aindexed2 n, I n1::G id ofs::nil => eval_static_addressing_case6 n n1 id ofs + | Aindexed2 n, S ofs::I n2::nil => eval_static_addressing_case7 n ofs n2 + | Aindexed2 n, I n1::S ofs::nil => eval_static_addressing_case8 n n1 ofs + | Ascaled sc n, I n1::nil => eval_static_addressing_case9 sc n n1 + | Aindexed2scaled sc n, I n1::I n2::nil => eval_static_addressing_case10 sc n n1 n2 + | Aindexed2scaled sc n, G id ofs::I n2::nil => eval_static_addressing_case11 sc n id ofs n2 + | Aindexed2scaled sc n, S ofs::I n2::nil => eval_static_addressing_case12 sc n ofs n2 + | Aglobal id ofs, nil => eval_static_addressing_case13 id ofs + | Abased id ofs, I n1::nil => eval_static_addressing_case14 id ofs n1 + | Abasedscaled sc id ofs, I n1::nil => eval_static_addressing_case15 sc id ofs n1 + | Ainstack ofs, nil => eval_static_addressing_case16 ofs + | addr, vl => eval_static_addressing_default addr vl end. Definition eval_static_addressing (addr: addressing) (vl: list approx) := match eval_static_addressing_match addr vl with - | eval_static_addressing_case1 n n1 => + | eval_static_addressing_case1 n n1 => (* Aindexed n, I n1::nil *) I (Int.add n1 n) - | eval_static_addressing_case2 n id ofs => - S id (Int.add ofs n) - | eval_static_addressing_case3 n n1 n2 => + | eval_static_addressing_case2 n id ofs => (* Aindexed n, G id ofs::nil *) + G id (Int.add ofs n) + | eval_static_addressing_case3 n ofs => (* Aindexed n, S ofs::nil *) + S (Int.add ofs n) + | eval_static_addressing_case4 n n1 n2 => (* Aindexed2 n, I n1::I n2::nil *) I (Int.add (Int.add n1 n2) n) - | eval_static_addressing_case4 n id ofs n2 => - S id (Int.add (Int.add ofs n2) n) - | eval_static_addressing_case5 n n1 id ofs => - S id (Int.add (Int.add ofs n1) n) - | eval_static_addressing_case6 sc n n1 => + | eval_static_addressing_case5 n id ofs n2 => (* Aindexed2 n, G id ofs::I n2::nil *) + G id (Int.add (Int.add ofs n2) n) + | eval_static_addressing_case6 n n1 id ofs => (* Aindexed2 n, I n1::G id ofs::nil *) + G id (Int.add (Int.add ofs n1) n) + | eval_static_addressing_case7 n ofs n2 => (* Aindexed2 n, S ofs::I n2::nil *) + S (Int.add (Int.add ofs n2) n) + | eval_static_addressing_case8 n n1 ofs => (* Aindexed2 n, I n1::S ofs::nil *) + S (Int.add (Int.add ofs n1) n) + | eval_static_addressing_case9 sc n n1 => (* Ascaled sc n, I n1::nil *) I (Int.add (Int.mul n1 sc) n) - | eval_static_addressing_case7 sc n n1 n2 => + | eval_static_addressing_case10 sc n n1 n2 => (* Aindexed2scaled sc n, I n1::I n2::nil *) I (Int.add n1 (Int.add (Int.mul n2 sc) n)) - | eval_static_addressing_case8 sc n id ofs n2 => - S id (Int.add ofs (Int.add (Int.mul n2 sc) n)) - | eval_static_addressing_case9 id ofs => - S id ofs - | eval_static_addressing_case10 id ofs n1 => - S id (Int.add ofs n1) - | eval_static_addressing_case11 sc id ofs n1 => - S id (Int.add ofs (Int.mul sc n1)) + | eval_static_addressing_case11 sc n id ofs n2 => (* Aindexed2scaled sc n, G id ofs::I n2::nil *) + G id (Int.add ofs (Int.add (Int.mul n2 sc) n)) + | eval_static_addressing_case12 sc n ofs n2 => (* Aindexed2scaled sc n, S ofs::I n2::nil *) + S (Int.add ofs (Int.add (Int.mul n2 sc) n)) + | eval_static_addressing_case13 id ofs => (* Aglobal id ofs, nil *) + G id ofs + | eval_static_addressing_case14 id ofs n1 => (* Abased id ofs, I n1::nil *) + G id (Int.add ofs n1) + | eval_static_addressing_case15 sc id ofs n1 => (* Abasedscaled sc id ofs, I n1::nil *) + G id (Int.add ofs (Int.mul sc n1)) + | eval_static_addressing_case16 ofs => (* Ainstack ofs, nil *) + S ofs | eval_static_addressing_default addr vl => Unknown end. -(* -Definition eval_static_operation (op: operation) (vl: list approx) := + +(** Original definition: +<< +Nondetfunction eval_static_operation (op: operation) (vl: list approx) := match op, vl with | Omove, v1::nil => v1 | Ointconst n, nil => I n @@ -259,7 +238,7 @@ Definition eval_static_operation (op: operation) (vl: list approx) := | Ocast16unsigned, I n1 :: nil => I(Int.zero_ext 16 n1) | Oneg, I n1 :: nil => I(Int.neg n1) | Osub, I n1 :: I n2 :: nil => I(Int.sub n1 n2) - | Osub, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 n2) + | Osub, G s1 n1 :: I n2 :: nil => G s1 (Int.sub n1 n2) | Omul, I n1 :: I n2 :: nil => I(Int.mul n1 n2) | Omulimm n, I n1 :: nil => I(Int.mul n1 n) | Odiv, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) @@ -276,7 +255,7 @@ Definition eval_static_operation (op: operation) (vl: list approx) := | Oshlimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shl n1 n) else Unknown | Oshr, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shr n1 n2) else Unknown | Oshrimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shr n1 n) else Unknown - | Oshrximm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shrx n1 n) else Unknown + | Oshrximm n, I n1 :: nil => if Int.ltu n (Int.repr 31) then I(Int.shrx n1 n) else Unknown | Oshru, I n1 :: I n2 :: nil => if Int.ltu n2 Int.iwordsize then I(Int.shru n1 n2) else Unknown | Oshruimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.shru n1 n) else Unknown | Ororimm n, I n1 :: nil => if Int.ltu n Int.iwordsize then I(Int.ror n1 n) else Unknown @@ -288,320 +267,193 @@ Definition eval_static_operation (op: operation) (vl: list approx) := | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2) | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2) | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) - | Ointoffloat, F n1 :: nil => match Float.intoffloat n1 with Some x => I x | None => Unknown end + | Ointoffloat, F n1 :: nil => eval_static_intoffloat n1 | Ofloatofint, I n1 :: nil => F(Float.floatofint n1) - | Ocmp c, vl => match eval_static_condition c vl with None => Unknown | Some b => I(if b then Int.one else Int.zero) end + | Ocmp c, vl => eval_static_condition_val c vl | _, _ => Unknown end. +>> *) Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx), Type := - | eval_static_operation_case1: - forall v1, - eval_static_operation_cases (Omove) (v1::nil) - | eval_static_operation_case2: - forall n, - eval_static_operation_cases (Ointconst n) (nil) - | eval_static_operation_case3: - forall n, - eval_static_operation_cases (Ofloatconst n) (nil) - | eval_static_operation_case4: - forall n1, - eval_static_operation_cases (Ocast8signed) (I n1 :: nil) - | eval_static_operation_case5: - forall n1, - eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil) - | eval_static_operation_case6: - forall n1, - eval_static_operation_cases (Ocast16signed) (I n1 :: nil) - | eval_static_operation_case7: - forall n1, - eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil) - | eval_static_operation_case8: - forall n1, - eval_static_operation_cases (Oneg) (I n1 :: nil) - | eval_static_operation_case9: - forall n1 n2, - eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil) - | eval_static_operation_case10: - forall s1 n1 n2, - eval_static_operation_cases (Osub) (S s1 n1 :: I n2 :: nil) - | eval_static_operation_case11: - forall n1 n2, - eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil) - | eval_static_operation_case12: - forall n n1, - eval_static_operation_cases (Omulimm n) (I n1 :: nil) - | eval_static_operation_case13: - forall n1 n2, - eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil) - | eval_static_operation_case14: - forall n1 n2, - eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil) - | eval_static_operation_case15: - forall n1 n2, - eval_static_operation_cases (Omod) (I n1 :: I n2 :: nil) - | eval_static_operation_case16: - forall n1 n2, - eval_static_operation_cases (Omodu) (I n1 :: I n2 :: nil) - | eval_static_operation_case17: - forall n1 n2, - eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil) - | eval_static_operation_case18: - forall n n1, - eval_static_operation_cases (Oandimm n) (I n1 :: nil) - | eval_static_operation_case19: - forall n1 n2, - eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil) - | eval_static_operation_case20: - forall n n1, - eval_static_operation_cases (Oorimm n) (I n1 :: nil) - | eval_static_operation_case21: - forall n1 n2, - eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil) - | eval_static_operation_case22: - forall n n1, - eval_static_operation_cases (Oxorimm n) (I n1 :: nil) - | eval_static_operation_case23: - forall n1 n2, - eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil) - | eval_static_operation_case24: - forall n n1, - eval_static_operation_cases (Oshlimm n) (I n1 :: nil) - | eval_static_operation_case25: - forall n1 n2, - eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil) - | eval_static_operation_case26: - forall n n1, - eval_static_operation_cases (Oshrimm n) (I n1 :: nil) - | eval_static_operation_case27: - forall n n1, - eval_static_operation_cases (Oshrximm n) (I n1 :: nil) - | eval_static_operation_case28: - forall n1 n2, - eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil) - | eval_static_operation_case29: - forall n n1, - eval_static_operation_cases (Oshruimm n) (I n1 :: nil) - | eval_static_operation_case30: - forall n n1, - eval_static_operation_cases (Ororimm n) (I n1 :: nil) - | eval_static_operation_case31: - forall mode vl, - eval_static_operation_cases (Olea mode) (vl) - | eval_static_operation_case32: - forall n1, - eval_static_operation_cases (Onegf) (F n1 :: nil) - | eval_static_operation_case33: - forall n1, - eval_static_operation_cases (Oabsf) (F n1 :: nil) - | eval_static_operation_case34: - forall n1 n2, - eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil) - | eval_static_operation_case35: - forall n1 n2, - eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil) - | eval_static_operation_case36: - forall n1 n2, - eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil) - | eval_static_operation_case37: - forall n1 n2, - eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil) - | eval_static_operation_case38: - forall n1, - eval_static_operation_cases (Osingleoffloat) (F n1 :: nil) - | eval_static_operation_case39: - forall n1, - eval_static_operation_cases (Ointoffloat) (F n1 :: nil) - | eval_static_operation_case41: - forall n1, - eval_static_operation_cases (Ofloatofint) (I n1 :: nil) - | eval_static_operation_case43: - forall c vl, - eval_static_operation_cases (Ocmp c) vl - | eval_static_operation_default: - forall (op: operation) (vl: list approx), - eval_static_operation_cases op vl. + | eval_static_operation_case1: forall v1, eval_static_operation_cases (Omove) (v1::nil) + | eval_static_operation_case2: forall n, eval_static_operation_cases (Ointconst n) (nil) + | eval_static_operation_case3: forall n, eval_static_operation_cases (Ofloatconst n) (nil) + | eval_static_operation_case4: forall n1, eval_static_operation_cases (Ocast8signed) (I n1 :: nil) + | eval_static_operation_case5: forall n1, eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil) + | eval_static_operation_case6: forall n1, eval_static_operation_cases (Ocast16signed) (I n1 :: nil) + | eval_static_operation_case7: forall n1, eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil) + | eval_static_operation_case8: forall n1, eval_static_operation_cases (Oneg) (I n1 :: nil) + | eval_static_operation_case9: forall n1 n2, eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil) + | eval_static_operation_case10: forall s1 n1 n2, eval_static_operation_cases (Osub) (G s1 n1 :: I n2 :: nil) + | eval_static_operation_case11: forall n1 n2, eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil) + | eval_static_operation_case12: forall n n1, eval_static_operation_cases (Omulimm n) (I n1 :: nil) + | eval_static_operation_case13: forall n1 n2, eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil) + | eval_static_operation_case14: forall n1 n2, eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil) + | eval_static_operation_case15: forall n1 n2, eval_static_operation_cases (Omod) (I n1 :: I n2 :: nil) + | eval_static_operation_case16: forall n1 n2, eval_static_operation_cases (Omodu) (I n1 :: I n2 :: nil) + | eval_static_operation_case17: forall n1 n2, eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil) + | eval_static_operation_case18: forall n n1, eval_static_operation_cases (Oandimm n) (I n1 :: nil) + | eval_static_operation_case19: forall n1 n2, eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil) + | eval_static_operation_case20: forall n n1, eval_static_operation_cases (Oorimm n) (I n1 :: nil) + | eval_static_operation_case21: forall n1 n2, eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil) + | eval_static_operation_case22: forall n n1, eval_static_operation_cases (Oxorimm n) (I n1 :: nil) + | eval_static_operation_case23: forall n1 n2, eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil) + | eval_static_operation_case24: forall n n1, eval_static_operation_cases (Oshlimm n) (I n1 :: nil) + | eval_static_operation_case25: forall n1 n2, eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil) + | eval_static_operation_case26: forall n n1, eval_static_operation_cases (Oshrimm n) (I n1 :: nil) + | eval_static_operation_case27: forall n n1, eval_static_operation_cases (Oshrximm n) (I n1 :: nil) + | eval_static_operation_case28: forall n1 n2, eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil) + | eval_static_operation_case29: forall n n1, eval_static_operation_cases (Oshruimm n) (I n1 :: nil) + | eval_static_operation_case30: forall n n1, eval_static_operation_cases (Ororimm n) (I n1 :: nil) + | eval_static_operation_case31: forall mode vl, eval_static_operation_cases (Olea mode) (vl) + | eval_static_operation_case32: forall n1, eval_static_operation_cases (Onegf) (F n1 :: nil) + | eval_static_operation_case33: forall n1, eval_static_operation_cases (Oabsf) (F n1 :: nil) + | eval_static_operation_case34: forall n1 n2, eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil) + | eval_static_operation_case35: forall n1 n2, eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil) + | eval_static_operation_case36: forall n1 n2, eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil) + | eval_static_operation_case37: forall n1 n2, eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil) + | eval_static_operation_case38: forall n1, eval_static_operation_cases (Osingleoffloat) (F n1 :: nil) + | eval_static_operation_case39: forall n1, eval_static_operation_cases (Ointoffloat) (F n1 :: nil) + | eval_static_operation_case40: forall n1, eval_static_operation_cases (Ofloatofint) (I n1 :: nil) + | eval_static_operation_case41: forall c vl, eval_static_operation_cases (Ocmp c) (vl) + | eval_static_operation_default: forall (op: operation) (vl: list approx), eval_static_operation_cases op vl. Definition eval_static_operation_match (op: operation) (vl: list approx) := - match op as z1, vl as z2 return eval_static_operation_cases z1 z2 with - | Omove, v1::nil => - eval_static_operation_case1 v1 - | Ointconst n, nil => - eval_static_operation_case2 n - | Ofloatconst n, nil => - eval_static_operation_case3 n - | Ocast8signed, I n1 :: nil => - eval_static_operation_case4 n1 - | Ocast8unsigned, I n1 :: nil => - eval_static_operation_case5 n1 - | Ocast16signed, I n1 :: nil => - eval_static_operation_case6 n1 - | Ocast16unsigned, I n1 :: nil => - eval_static_operation_case7 n1 - | Oneg, I n1 :: nil => - eval_static_operation_case8 n1 - | Osub, I n1 :: I n2 :: nil => - eval_static_operation_case9 n1 n2 - | Osub, S s1 n1 :: I n2 :: nil => - eval_static_operation_case10 s1 n1 n2 - | Omul, I n1 :: I n2 :: nil => - eval_static_operation_case11 n1 n2 - | Omulimm n, I n1 :: nil => - eval_static_operation_case12 n n1 - | Odiv, I n1 :: I n2 :: nil => - eval_static_operation_case13 n1 n2 - | Odivu, I n1 :: I n2 :: nil => - eval_static_operation_case14 n1 n2 - | Omod, I n1 :: I n2 :: nil => - eval_static_operation_case15 n1 n2 - | Omodu, I n1 :: I n2 :: nil => - eval_static_operation_case16 n1 n2 - | Oand, I n1 :: I n2 :: nil => - eval_static_operation_case17 n1 n2 - | Oandimm n, I n1 :: nil => - eval_static_operation_case18 n n1 - | Oor, I n1 :: I n2 :: nil => - eval_static_operation_case19 n1 n2 - | Oorimm n, I n1 :: nil => - eval_static_operation_case20 n n1 - | Oxor, I n1 :: I n2 :: nil => - eval_static_operation_case21 n1 n2 - | Oxorimm n, I n1 :: nil => - eval_static_operation_case22 n n1 - | Oshl, I n1 :: I n2 :: nil => - eval_static_operation_case23 n1 n2 - | Oshlimm n, I n1 :: nil => - eval_static_operation_case24 n n1 - | Oshr, I n1 :: I n2 :: nil => - eval_static_operation_case25 n1 n2 - | Oshrimm n, I n1 :: nil => - eval_static_operation_case26 n n1 - | Oshrximm n, I n1 :: nil => - eval_static_operation_case27 n n1 - | Oshru, I n1 :: I n2 :: nil => - eval_static_operation_case28 n1 n2 - | Oshruimm n, I n1 :: nil => - eval_static_operation_case29 n n1 - | Ororimm n, I n1 :: nil => - eval_static_operation_case30 n n1 - | Olea mode, vl => - eval_static_operation_case31 mode vl - | Onegf, F n1 :: nil => - eval_static_operation_case32 n1 - | Oabsf, F n1 :: nil => - eval_static_operation_case33 n1 - | Oaddf, F n1 :: F n2 :: nil => - eval_static_operation_case34 n1 n2 - | Osubf, F n1 :: F n2 :: nil => - eval_static_operation_case35 n1 n2 - | Omulf, F n1 :: F n2 :: nil => - eval_static_operation_case36 n1 n2 - | Odivf, F n1 :: F n2 :: nil => - eval_static_operation_case37 n1 n2 - | Osingleoffloat, F n1 :: nil => - eval_static_operation_case38 n1 - | Ointoffloat, F n1 :: nil => - eval_static_operation_case39 n1 - | Ofloatofint, I n1 :: nil => - eval_static_operation_case41 n1 - | Ocmp c, vl => - eval_static_operation_case43 c vl - | op, vl => - eval_static_operation_default op vl + match op as zz1, vl as zz2 return eval_static_operation_cases zz1 zz2 with + | Omove, v1::nil => eval_static_operation_case1 v1 + | Ointconst n, nil => eval_static_operation_case2 n + | Ofloatconst n, nil => eval_static_operation_case3 n + | Ocast8signed, I n1 :: nil => eval_static_operation_case4 n1 + | Ocast8unsigned, I n1 :: nil => eval_static_operation_case5 n1 + | Ocast16signed, I n1 :: nil => eval_static_operation_case6 n1 + | Ocast16unsigned, I n1 :: nil => eval_static_operation_case7 n1 + | Oneg, I n1 :: nil => eval_static_operation_case8 n1 + | Osub, I n1 :: I n2 :: nil => eval_static_operation_case9 n1 n2 + | Osub, G s1 n1 :: I n2 :: nil => eval_static_operation_case10 s1 n1 n2 + | Omul, I n1 :: I n2 :: nil => eval_static_operation_case11 n1 n2 + | Omulimm n, I n1 :: nil => eval_static_operation_case12 n n1 + | Odiv, I n1 :: I n2 :: nil => eval_static_operation_case13 n1 n2 + | Odivu, I n1 :: I n2 :: nil => eval_static_operation_case14 n1 n2 + | Omod, I n1 :: I n2 :: nil => eval_static_operation_case15 n1 n2 + | Omodu, I n1 :: I n2 :: nil => eval_static_operation_case16 n1 n2 + | Oand, I n1 :: I n2 :: nil => eval_static_operation_case17 n1 n2 + | Oandimm n, I n1 :: nil => eval_static_operation_case18 n n1 + | Oor, I n1 :: I n2 :: nil => eval_static_operation_case19 n1 n2 + | Oorimm n, I n1 :: nil => eval_static_operation_case20 n n1 + | Oxor, I n1 :: I n2 :: nil => eval_static_operation_case21 n1 n2 + | Oxorimm n, I n1 :: nil => eval_static_operation_case22 n n1 + | Oshl, I n1 :: I n2 :: nil => eval_static_operation_case23 n1 n2 + | Oshlimm n, I n1 :: nil => eval_static_operation_case24 n n1 + | Oshr, I n1 :: I n2 :: nil => eval_static_operation_case25 n1 n2 + | Oshrimm n, I n1 :: nil => eval_static_operation_case26 n n1 + | Oshrximm n, I n1 :: nil => eval_static_operation_case27 n n1 + | Oshru, I n1 :: I n2 :: nil => eval_static_operation_case28 n1 n2 + | Oshruimm n, I n1 :: nil => eval_static_operation_case29 n n1 + | Ororimm n, I n1 :: nil => eval_static_operation_case30 n n1 + | Olea mode, vl => eval_static_operation_case31 mode vl + | Onegf, F n1 :: nil => eval_static_operation_case32 n1 + | Oabsf, F n1 :: nil => eval_static_operation_case33 n1 + | Oaddf, F n1 :: F n2 :: nil => eval_static_operation_case34 n1 n2 + | Osubf, F n1 :: F n2 :: nil => eval_static_operation_case35 n1 n2 + | Omulf, F n1 :: F n2 :: nil => eval_static_operation_case36 n1 n2 + | Odivf, F n1 :: F n2 :: nil => eval_static_operation_case37 n1 n2 + | Osingleoffloat, F n1 :: nil => eval_static_operation_case38 n1 + | Ointoffloat, F n1 :: nil => eval_static_operation_case39 n1 + | Ofloatofint, I n1 :: nil => eval_static_operation_case40 n1 + | Ocmp c, vl => eval_static_operation_case41 c vl + | op, vl => eval_static_operation_default op vl end. Definition eval_static_operation (op: operation) (vl: list approx) := match eval_static_operation_match op vl with - | eval_static_operation_case1 v1 => + | eval_static_operation_case1 v1 => (* Omove, v1::nil *) v1 - | eval_static_operation_case2 n => + | eval_static_operation_case2 n => (* Ointconst n, nil *) I n - | eval_static_operation_case3 n => + | eval_static_operation_case3 n => (* Ofloatconst n, nil *) F n - | eval_static_operation_case4 n1 => + | eval_static_operation_case4 n1 => (* Ocast8signed, I n1 :: nil *) I(Int.sign_ext 8 n1) - | eval_static_operation_case5 n1 => + | eval_static_operation_case5 n1 => (* Ocast8unsigned, I n1 :: nil *) I(Int.zero_ext 8 n1) - | eval_static_operation_case6 n1 => + | eval_static_operation_case6 n1 => (* Ocast16signed, I n1 :: nil *) I(Int.sign_ext 16 n1) - | eval_static_operation_case7 n1 => + | eval_static_operation_case7 n1 => (* Ocast16unsigned, I n1 :: nil *) I(Int.zero_ext 16 n1) - | eval_static_operation_case8 n1 => + | eval_static_operation_case8 n1 => (* Oneg, I n1 :: nil *) I(Int.neg n1) - | eval_static_operation_case9 n1 n2 => + | eval_static_operation_case9 n1 n2 => (* Osub, I n1 :: I n2 :: nil *) I(Int.sub n1 n2) - | eval_static_operation_case10 s1 n1 n2 => - S s1 (Int.sub n1 n2) - | eval_static_operation_case11 n1 n2 => + | eval_static_operation_case10 s1 n1 n2 => (* Osub, G s1 n1 :: I n2 :: nil *) + G s1 (Int.sub n1 n2) + | eval_static_operation_case11 n1 n2 => (* Omul, I n1 :: I n2 :: nil *) I(Int.mul n1 n2) - | eval_static_operation_case12 n n1 => + | eval_static_operation_case12 n n1 => (* Omulimm n, I n1 :: nil *) I(Int.mul n1 n) - | eval_static_operation_case13 n1 n2 => + | eval_static_operation_case13 n1 n2 => (* Odiv, I n1 :: I n2 :: nil *) if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) - | eval_static_operation_case14 n1 n2 => + | eval_static_operation_case14 n1 n2 => (* Odivu, I n1 :: I n2 :: nil *) if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) - | eval_static_operation_case15 n1 n2 => + | eval_static_operation_case15 n1 n2 => (* Omod, I n1 :: I n2 :: nil *) if Int.eq n2 Int.zero then Unknown else I(Int.mods n1 n2) - | eval_static_operation_case16 n1 n2 => + | eval_static_operation_case16 n1 n2 => (* Omodu, I n1 :: I n2 :: nil *) if Int.eq n2 Int.zero then Unknown else I(Int.modu n1 n2) - | eval_static_operation_case17 n1 n2 => + | eval_static_operation_case17 n1 n2 => (* Oand, I n1 :: I n2 :: nil *) I(Int.and n1 n2) - | eval_static_operation_case18 n n1 => + | eval_static_operation_case18 n n1 => (* Oandimm n, I n1 :: nil *) I(Int.and n1 n) - | eval_static_operation_case19 n1 n2 => + | eval_static_operation_case19 n1 n2 => (* Oor, I n1 :: I n2 :: nil *) I(Int.or n1 n2) - | eval_static_operation_case20 n n1 => + | eval_static_operation_case20 n n1 => (* Oorimm n, I n1 :: nil *) I(Int.or n1 n) - | eval_static_operation_case21 n1 n2 => + | eval_static_operation_case21 n1 n2 => (* Oxor, I n1 :: I n2 :: nil *) I(Int.xor n1 n2) - | eval_static_operation_case22 n n1 => + | eval_static_operation_case22 n n1 => (* Oxorimm n, I n1 :: nil *) I(Int.xor n1 n) - | eval_static_operation_case23 n1 n2 => + | eval_static_operation_case23 n1 n2 => (* Oshl, I n1 :: I n2 :: nil *) if Int.ltu n2 Int.iwordsize then I(Int.shl n1 n2) else Unknown - | eval_static_operation_case24 n n1 => + | eval_static_operation_case24 n n1 => (* Oshlimm n, I n1 :: nil *) if Int.ltu n Int.iwordsize then I(Int.shl n1 n) else Unknown - | eval_static_operation_case25 n1 n2 => + | eval_static_operation_case25 n1 n2 => (* Oshr, I n1 :: I n2 :: nil *) if Int.ltu n2 Int.iwordsize then I(Int.shr n1 n2) else Unknown - | eval_static_operation_case26 n n1 => + | eval_static_operation_case26 n n1 => (* Oshrimm n, I n1 :: nil *) if Int.ltu n Int.iwordsize then I(Int.shr n1 n) else Unknown - | eval_static_operation_case27 n n1 => + | eval_static_operation_case27 n n1 => (* Oshrximm n, I n1 :: nil *) if Int.ltu n (Int.repr 31) then I(Int.shrx n1 n) else Unknown - | eval_static_operation_case28 n1 n2 => + | eval_static_operation_case28 n1 n2 => (* Oshru, I n1 :: I n2 :: nil *) if Int.ltu n2 Int.iwordsize then I(Int.shru n1 n2) else Unknown - | eval_static_operation_case29 n n1 => + | eval_static_operation_case29 n n1 => (* Oshruimm n, I n1 :: nil *) if Int.ltu n Int.iwordsize then I(Int.shru n1 n) else Unknown - | eval_static_operation_case30 n n1 => + | eval_static_operation_case30 n n1 => (* Ororimm n, I n1 :: nil *) if Int.ltu n Int.iwordsize then I(Int.ror n1 n) else Unknown - | eval_static_operation_case31 mode vl => + | eval_static_operation_case31 mode vl => (* Olea mode, vl *) eval_static_addressing mode vl - | eval_static_operation_case32 n1 => + | eval_static_operation_case32 n1 => (* Onegf, F n1 :: nil *) F(Float.neg n1) - | eval_static_operation_case33 n1 => + | eval_static_operation_case33 n1 => (* Oabsf, F n1 :: nil *) F(Float.abs n1) - | eval_static_operation_case34 n1 n2 => + | eval_static_operation_case34 n1 n2 => (* Oaddf, F n1 :: F n2 :: nil *) F(Float.add n1 n2) - | eval_static_operation_case35 n1 n2 => + | eval_static_operation_case35 n1 n2 => (* Osubf, F n1 :: F n2 :: nil *) F(Float.sub n1 n2) - | eval_static_operation_case36 n1 n2 => + | eval_static_operation_case36 n1 n2 => (* Omulf, F n1 :: F n2 :: nil *) F(Float.mul n1 n2) - | eval_static_operation_case37 n1 n2 => + | eval_static_operation_case37 n1 n2 => (* Odivf, F n1 :: F n2 :: nil *) F(Float.div n1 n2) - | eval_static_operation_case38 n1 => + | eval_static_operation_case38 n1 => (* Osingleoffloat, F n1 :: nil *) F(Float.singleoffloat n1) - | eval_static_operation_case39 n1 => - match Float.intoffloat n1 with Some x => I x | None => Unknown end - | eval_static_operation_case41 n1 => + | eval_static_operation_case39 n1 => (* Ointoffloat, F n1 :: nil *) + eval_static_intoffloat n1 + | eval_static_operation_case40 n1 => (* Ofloatofint, I n1 :: nil *) F(Float.floatofint n1) - | eval_static_operation_case43 c vl => - match eval_static_condition c vl with - | None => Unknown - | Some b => I(if b then Int.one else Int.zero) - end + | eval_static_operation_case41 c vl => (* Ocmp c, vl *) + eval_static_condition_val c vl | eval_static_operation_default op vl => Unknown end. + (** * Operator strength reduction *) (** We now define auxiliary functions for strength reduction of @@ -613,146 +465,178 @@ Section STRENGTH_REDUCTION. Variable app: reg -> approx. -Definition intval (r: reg) : option int := - match app r with I n => Some n | _ => None end. - -Inductive cond_strength_reduction_cases: condition -> list reg -> Type := - | csr_case1: - forall c r1 r2, - cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) - | csr_case2: - forall c r1 r2, - cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) - | csr_default: - forall c rl, - cond_strength_reduction_cases c rl. - -Definition cond_strength_reduction_match (cond: condition) (rl: list reg) := - match cond as x, rl as y return cond_strength_reduction_cases x y with - | Ccomp c, r1 :: r2 :: nil => - csr_case1 c r1 r2 - | Ccompu c, r1 :: r2 :: nil => - csr_case2 c r1 r2 - | cond, rl => - csr_default cond rl +(** Original definition: +<< +Nondetfunction cond_strength_reduction + (cond: condition) (args: list reg) (vl: list approx) := + match cond, args, vl with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompimm c n2, r1 :: nil) + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompuimm c n2, r1 :: nil) + | _, _, _ => + (cond, args) + end. +>> +*) + +Inductive cond_strength_reduction_cases: forall (cond: condition) (args: list reg) (vl: list approx), Type := + | cond_strength_reduction_case1: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | cond_strength_reduction_case2: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_case3: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | cond_strength_reduction_case4: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_default: forall (cond: condition) (args: list reg) (vl: list approx), cond_strength_reduction_cases cond args vl. + +Definition cond_strength_reduction_match (cond: condition) (args: list reg) (vl: list approx) := + match cond as zz1, args as zz2, vl as zz3 return cond_strength_reduction_cases zz1 zz2 zz3 with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case1 c r1 r2 n1 v2 + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case2 c r1 r2 v1 n2 + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case3 c r1 r2 n1 v2 + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case4 c r1 r2 v1 n2 + | cond, args, vl => cond_strength_reduction_default cond args vl end. -Definition cond_strength_reduction - (cond: condition) (args: list reg) : condition * list reg := - match cond_strength_reduction_match cond args with - | csr_case1 c r1 r2 => - match intval r1, intval r2 with - | Some n, _ => - (Ccompimm (swap_comparison c) n, r2 :: nil) - | _, Some n => - (Ccompimm c n, r1 :: nil) - | _, _ => - (cond, args) - end - | csr_case2 c r1 r2 => - match intval r1, intval r2 with - | Some n, _ => - (Ccompuimm (swap_comparison c) n, r2 :: nil) - | _, Some n => - (Ccompuimm c n, r1 :: nil) - | _, _ => - (cond, args) - end - | csr_default cond args => +Definition cond_strength_reduction (cond: condition) (args: list reg) (vl: list approx) := + match cond_strength_reduction_match cond args vl with + | cond_strength_reduction_case1 c r1 r2 n1 v2 => (* Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case2 c r1 r2 v1 n2 => (* Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompimm c n2, r1 :: nil) + | cond_strength_reduction_case3 c r1 r2 n1 v2 => (* Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case4 c r1 r2 v1 n2 => (* Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompuimm c n2, r1 :: nil) + | cond_strength_reduction_default cond args vl => (cond, args) end. -(* -Definition addr_strength_reduction (addr: addressing) (args: list reg) := - match addr, args with - | Aindexed ofs, r1 :: nil => (* Aindexed *) - | Aindexed2 ofs, r1 :: r2 :: nil => (* Aindexed2 *) - | Aindexed2scaled sc ofs, r1 :: r2 :: nil => (* Aindexed2scaled *) - | Abased id ofs, r1 :: nil => (* Abased *) - | Abasedscaled sc id ofs, r1 :: nil => (* Abasedscaled *) - | _, _ => (* default *) + +(** Original definition: +<< +Nondetfunction addr_strength_reduction + (addr: addressing) (args: list reg) (vl: list approx) := + match addr, args, vl with + + | Aindexed ofs, r1 :: nil, G symb n :: nil => + (Aglobal symb (Int.add n ofs), nil) + | Aindexed ofs, r1 :: nil, S n :: nil => + (Ainstack (Int.add n ofs), nil) + + | Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil => + (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: G symb n2 :: nil => + (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, S n1 :: I n2 :: nil => + (Ainstack (Int.add (Int.add n1 n2) ofs), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: S n2 :: nil => + (Ainstack (Int.add (Int.add n1 n2) ofs), nil) + | Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil => + (Abased symb (Int.add n1 ofs), r2 :: nil) + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: G symb n2 :: nil => + (Abased symb (Int.add n2 ofs), r1 :: nil) + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Aindexed (Int.add n1 ofs), r2 :: nil) + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Aindexed (Int.add n2 ofs), r1 :: nil) + + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil => + (Aglobal symb (Int.add (Int.add n1 (Int.mul n2 sc)) ofs), nil) + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil => + (Abasedscaled sc symb (Int.add n1 ofs), r2 :: nil) + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Aindexed (Int.add (Int.mul n2 sc) ofs), r1 :: nil) + + | Abased id ofs, r1 :: nil, I n1 :: nil => + (Aglobal id (Int.add ofs n1), nil) + + | Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil => + (Aglobal id (Int.add ofs (Int.mul sc n1)), nil) + + | _, _ => + (addr, args) end. +>> *) -Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg), Type := - | addr_strength_reduction_case1: - forall ofs r1, - addr_strength_reduction_cases (Aindexed ofs) (r1 :: nil) - | addr_strength_reduction_case2: - forall ofs r1 r2, - addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) - | addr_strength_reduction_case3: - forall sc ofs r1 r2, - addr_strength_reduction_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) - | addr_strength_reduction_case4: - forall id ofs r1, - addr_strength_reduction_cases (Abased id ofs) (r1 :: nil) - | addr_strength_reduction_case5: - forall sc id ofs r1, - addr_strength_reduction_cases (Abasedscaled sc id ofs) (r1 :: nil) - | addr_strength_reduction_default: - forall (addr: addressing) (args: list reg), - addr_strength_reduction_cases addr args. - -Definition addr_strength_reduction_match (addr: addressing) (args: list reg) := - match addr as z1, args as z2 return addr_strength_reduction_cases z1 z2 with - | Aindexed ofs, r1 :: nil => - addr_strength_reduction_case1 ofs r1 - | Aindexed2 ofs, r1 :: r2 :: nil => - addr_strength_reduction_case2 ofs r1 r2 - | Aindexed2scaled sc ofs, r1 :: r2 :: nil => - addr_strength_reduction_case3 sc ofs r1 r2 - | Abased id ofs, r1 :: nil => - addr_strength_reduction_case4 id ofs r1 - | Abasedscaled sc id ofs, r1 :: nil => - addr_strength_reduction_case5 sc id ofs r1 - | addr, args => - addr_strength_reduction_default addr args +Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg) (vl: list approx), Type := + | addr_strength_reduction_case1: forall ofs r1 symb n, addr_strength_reduction_cases (Aindexed ofs) (r1 :: nil) (G symb n :: nil) + | addr_strength_reduction_case2: forall ofs r1 n, addr_strength_reduction_cases (Aindexed ofs) (r1 :: nil) (S n :: nil) + | addr_strength_reduction_case3: forall ofs r1 r2 symb n1 n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (G symb n1 :: I n2 :: nil) + | addr_strength_reduction_case4: forall ofs r1 r2 n1 symb n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (I n1 :: G symb n2 :: nil) + | addr_strength_reduction_case5: forall ofs r1 r2 n1 n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (S n1 :: I n2 :: nil) + | addr_strength_reduction_case6: forall ofs r1 r2 n1 n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (I n1 :: S n2 :: nil) + | addr_strength_reduction_case7: forall ofs r1 r2 symb n1 v2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (G symb n1 :: v2 :: nil) + | addr_strength_reduction_case8: forall ofs r1 r2 v1 symb n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (v1 :: G symb n2 :: nil) + | addr_strength_reduction_case9: forall ofs r1 r2 n1 v2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | addr_strength_reduction_case10: forall ofs r1 r2 v1 n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | addr_strength_reduction_case11: forall sc ofs r1 r2 symb n1 n2, addr_strength_reduction_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (G symb n1 :: I n2 :: nil) + | addr_strength_reduction_case12: forall sc ofs r1 r2 symb n1 v2, addr_strength_reduction_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (G symb n1 :: v2 :: nil) + | addr_strength_reduction_case13: forall sc ofs r1 r2 v1 n2, addr_strength_reduction_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | addr_strength_reduction_case14: forall id ofs r1 n1, addr_strength_reduction_cases (Abased id ofs) (r1 :: nil) (I n1 :: nil) + | addr_strength_reduction_case15: forall sc id ofs r1 n1, addr_strength_reduction_cases (Abasedscaled sc id ofs) (r1 :: nil) (I n1 :: nil) + | addr_strength_reduction_default: forall (addr: addressing) (args: list reg) (vl: list approx), addr_strength_reduction_cases addr args vl. + +Definition addr_strength_reduction_match (addr: addressing) (args: list reg) (vl: list approx) := + match addr as zz1, args as zz2, vl as zz3 return addr_strength_reduction_cases zz1 zz2 zz3 with + | Aindexed ofs, r1 :: nil, G symb n :: nil => addr_strength_reduction_case1 ofs r1 symb n + | Aindexed ofs, r1 :: nil, S n :: nil => addr_strength_reduction_case2 ofs r1 n + | Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil => addr_strength_reduction_case3 ofs r1 r2 symb n1 n2 + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: G symb n2 :: nil => addr_strength_reduction_case4 ofs r1 r2 n1 symb n2 + | Aindexed2 ofs, r1 :: r2 :: nil, S n1 :: I n2 :: nil => addr_strength_reduction_case5 ofs r1 r2 n1 n2 + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: S n2 :: nil => addr_strength_reduction_case6 ofs r1 r2 n1 n2 + | Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil => addr_strength_reduction_case7 ofs r1 r2 symb n1 v2 + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: G symb n2 :: nil => addr_strength_reduction_case8 ofs r1 r2 v1 symb n2 + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => addr_strength_reduction_case9 ofs r1 r2 n1 v2 + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => addr_strength_reduction_case10 ofs r1 r2 v1 n2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil => addr_strength_reduction_case11 sc ofs r1 r2 symb n1 n2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil => addr_strength_reduction_case12 sc ofs r1 r2 symb n1 v2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => addr_strength_reduction_case13 sc ofs r1 r2 v1 n2 + | Abased id ofs, r1 :: nil, I n1 :: nil => addr_strength_reduction_case14 id ofs r1 n1 + | Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil => addr_strength_reduction_case15 sc id ofs r1 n1 + | addr, args, vl => addr_strength_reduction_default addr args vl end. -Definition addr_strength_reduction (addr: addressing) (args: list reg) := - match addr_strength_reduction_match addr args with - | addr_strength_reduction_case1 ofs r1 => - (* Aindexed *) - match app r1 with - | S symb n => (Aglobal symb (Int.add ofs n), nil) - | _ => (addr, args) - end - | addr_strength_reduction_case2 ofs r1 r2 => - (* Aindexed2 *) - match app r1, app r2 with - | S symb n1, I n2 => (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) - | I n1, S symb n2 => (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) - | S symb n1, _ => (Abased symb (Int.add n1 ofs), r2 :: nil) - | _, S symb n2 => (Abased symb (Int.add n2 ofs), r1 :: nil) - | I n1, _ => (Aindexed (Int.add n1 ofs), r2 :: nil) - | _, I n2 => (Aindexed (Int.add n2 ofs), r1 :: nil) - | _, _ => (addr, args) - end - | addr_strength_reduction_case3 sc ofs r1 r2 => - (* Aindexed2scaled *) - match app r1, app r2 with - | S symb n1, I n2 => (Aglobal symb (Int.add (Int.add n1 (Int.mul n2 sc)) ofs), nil) - | S symb n1, _ => (Abasedscaled sc symb (Int.add n1 ofs), r2 :: nil) - | _, I n2 => (Aindexed (Int.add (Int.mul n2 sc) ofs), r1 :: nil) - | _, _ => (addr, args) - end - | addr_strength_reduction_case4 id ofs r1 => - (* Abased *) - match app r1 with - | I n1 => (Aglobal id (Int.add ofs n1), nil) - | _ => (addr, args) - end - | addr_strength_reduction_case5 sc id ofs r1 => - (* Abasedscaled *) - match app r1 with - | I n1 => (Aglobal id (Int.add ofs (Int.mul sc n1)), nil) - | _ => (addr, args) - end - | addr_strength_reduction_default addr args => +Definition addr_strength_reduction (addr: addressing) (args: list reg) (vl: list approx) := + match addr_strength_reduction_match addr args vl with + | addr_strength_reduction_case1 ofs r1 symb n => (* Aindexed ofs, r1 :: nil, G symb n :: nil *) + (Aglobal symb (Int.add n ofs), nil) + | addr_strength_reduction_case2 ofs r1 n => (* Aindexed ofs, r1 :: nil, S n :: nil *) + (Ainstack (Int.add n ofs), nil) + | addr_strength_reduction_case3 ofs r1 r2 symb n1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil *) + (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) + | addr_strength_reduction_case4 ofs r1 r2 n1 symb n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: G symb n2 :: nil *) + (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil) + | addr_strength_reduction_case5 ofs r1 r2 n1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, S n1 :: I n2 :: nil *) + (Ainstack (Int.add (Int.add n1 n2) ofs), nil) + | addr_strength_reduction_case6 ofs r1 r2 n1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: S n2 :: nil *) + (Ainstack (Int.add (Int.add n1 n2) ofs), nil) + | addr_strength_reduction_case7 ofs r1 r2 symb n1 v2 => (* Aindexed2 ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil *) + (Abased symb (Int.add n1 ofs), r2 :: nil) + | addr_strength_reduction_case8 ofs r1 r2 v1 symb n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, v1 :: G symb n2 :: nil *) + (Abased symb (Int.add n2 ofs), r1 :: nil) + | addr_strength_reduction_case9 ofs r1 r2 n1 v2 => (* Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Aindexed (Int.add n1 ofs), r2 :: nil) + | addr_strength_reduction_case10 ofs r1 r2 v1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Aindexed (Int.add n2 ofs), r1 :: nil) + | addr_strength_reduction_case11 sc ofs r1 r2 symb n1 n2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: I n2 :: nil *) + (Aglobal symb (Int.add (Int.add n1 (Int.mul n2 sc)) ofs), nil) + | addr_strength_reduction_case12 sc ofs r1 r2 symb n1 v2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, G symb n1 :: v2 :: nil *) + (Abasedscaled sc symb (Int.add n1 ofs), r2 :: nil) + | addr_strength_reduction_case13 sc ofs r1 r2 v1 n2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Aindexed (Int.add (Int.mul n2 sc) ofs), r1 :: nil) + | addr_strength_reduction_case14 id ofs r1 n1 => (* Abased id ofs, r1 :: nil, I n1 :: nil *) + (Aglobal id (Int.add ofs n1), nil) + | addr_strength_reduction_case15 sc id ofs r1 n1 => (* Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil *) + (Aglobal id (Int.add ofs (Int.mul sc n1)), nil) + | addr_strength_reduction_default addr args vl => (addr, args) end. + Definition make_addimm (n: int) (r: reg) := if Int.eq n Int.zero then (Omove, r :: nil) @@ -800,211 +684,122 @@ Definition make_xorimm (n: int) (r: reg) := then (Omove, r :: nil) else (Oxorimm n, r :: nil). -(* -Definition op_strength_reduction (op: operation) (args: list reg) := - match op, args with - | Osub, r1 :: r2 :: nil => (* Osub *) - | Omul, r1 :: r2 :: nil => (* Omul *) - | Odiv, r1 :: r2 :: nil => (* Odiv *) - | Odivu, r1 :: r2 :: nil => (* Odivu *) - | Omodu, r1 :: r2 :: nil => (* Omodu *) - | Oand, r1 :: r2 :: nil => (* Oand *) - | Oor, r1 :: r2 :: nil => (* Oor *) - | Oxor, r1 :: r2 :: nil => (* Oxor *) - | Oshl, r1 :: r2 :: nil => (* Oshl *) - | Oshr, r1 :: r2 :: nil => (* Oshr *) - | Oshru, r1 :: r2 :: nil => (* Oshru *) - | Olea addr, args => (* Olea *) - | Ocmp c, args => (* Ocmp *) - | _, _ => (* default *) +Definition make_divimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => if Int.ltu l (Int.repr 31) + then (Oshrximm l, r1 :: nil) + else (Odiv, r1 :: r2 :: nil) + | None => (Odiv, r1 :: r2 :: nil) + end. + +Definition make_divuimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => make_shruimm l r1 + | None => (Odivu, r1 :: r2 :: nil) end. -*) -Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg), Type := - | op_strength_reduction_case2: - forall r1 r2, - op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) - | op_strength_reduction_case3: - forall r1 r2, - op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) - | op_strength_reduction_case4: - forall r1 r2, - op_strength_reduction_cases (Odiv) (r1 :: r2 :: nil) - | op_strength_reduction_case5: - forall r1 r2, - op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) - | op_strength_reduction_case7: - forall r1 r2, - op_strength_reduction_cases (Omodu) (r1 :: r2 :: nil) - | op_strength_reduction_case8: - forall r1 r2, - op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) - | op_strength_reduction_case9: - forall r1 r2, - op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) - | op_strength_reduction_case10: - forall r1 r2, - op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) - | op_strength_reduction_case11: - forall r1 r2, - op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) - | op_strength_reduction_case12: - forall r1 r2, - op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) - | op_strength_reduction_case13: - forall r1 r2, - op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) - | op_strength_reduction_case14: - forall addr args, - op_strength_reduction_cases (Olea addr) (args) - | op_strength_reduction_case15: - forall c args, - op_strength_reduction_cases (Ocmp c) (args) - | op_strength_reduction_default: - forall (op: operation) (args: list reg), - op_strength_reduction_cases op args. - -Definition op_strength_reduction_match (op: operation) (args: list reg) := - match op as z1, args as z2 return op_strength_reduction_cases z1 z2 with - | Osub, r1 :: r2 :: nil => - op_strength_reduction_case2 r1 r2 - | Omul, r1 :: r2 :: nil => - op_strength_reduction_case3 r1 r2 - | Odiv, r1 :: r2 :: nil => - op_strength_reduction_case4 r1 r2 - | Odivu, r1 :: r2 :: nil => - op_strength_reduction_case5 r1 r2 - | Omodu, r1 :: r2 :: nil => - op_strength_reduction_case7 r1 r2 - | Oand, r1 :: r2 :: nil => - op_strength_reduction_case8 r1 r2 - | Oor, r1 :: r2 :: nil => - op_strength_reduction_case9 r1 r2 - | Oxor, r1 :: r2 :: nil => - op_strength_reduction_case10 r1 r2 - | Oshl, r1 :: r2 :: nil => - op_strength_reduction_case11 r1 r2 - | Oshr, r1 :: r2 :: nil => - op_strength_reduction_case12 r1 r2 - | Oshru, r1 :: r2 :: nil => - op_strength_reduction_case13 r1 r2 - | Olea addr, args => - op_strength_reduction_case14 addr args - | Ocmp c, args => - op_strength_reduction_case15 c args - | op, args => - op_strength_reduction_default op args +Definition make_moduimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) + | None => (Omodu, r1 :: r2 :: nil) end. (** We must be careful to preserve 2-address constraints over the RTL code, which means that commutative operations cannot be specialized if their first argument is a constant. *) -Definition op_strength_reduction (op: operation) (args: list reg) := - match op_strength_reduction_match op args with - | op_strength_reduction_case2 r1 r2 => - (* Osub *) - match intval r2 with - | Some n => make_addimm (Int.neg n) r1 - | _ => (op, args) - end - | op_strength_reduction_case3 r1 r2 => - (* Omul *) - match intval r2 with - | Some n => make_mulimm n r1 - | _ => (op, args) - end - | op_strength_reduction_case4 r1 r2 => - (* Odiv *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => if Int.ltu l (Int.repr 31) - then (Oshrximm l, r1 :: nil) - else (op, args) - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case5 r1 r2 => - (* Odivu *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => make_shruimm l r1 - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case7 r1 r2 => - (* Omodu *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case8 r1 r2 => - (* Oand *) - match intval r2 with - | Some n => make_andimm n r1 - | _ => (op, args) - end - | op_strength_reduction_case9 r1 r2 => - (* Oor *) - match intval r2 with - | Some n => make_orimm n r1 - | _ => (op, args) - end - | op_strength_reduction_case10 r1 r2 => - (* Oxor *) - match intval r2 with - | Some n => make_xorimm n r1 - | _ => (op, args) - end - | op_strength_reduction_case11 r1 r2 => - (* Oshl *) - match intval r2 with - | Some n => - if Int.ltu n Int.iwordsize - then make_shlimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case12 r1 r2 => - (* Oshr *) - match intval r2 with - | Some n => - if Int.ltu n Int.iwordsize - then make_shrimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case13 r1 r2 => - (* Oshru *) - match intval r2 with - | Some n => - if Int.ltu n Int.iwordsize - then make_shruimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case14 addr args => - (* Olea *) - let (addr', args') := addr_strength_reduction addr args in +(** Original definition: +<< +Nondetfunction op_strength_reduction + (op: operation) (args: list reg) (vl: list approx) := + match op, args, vl with + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 + | Olea addr, args, vl => + let (addr', args') := addr_strength_reduction addr args vl in (Olea addr', args') - | op_strength_reduction_case15 c args => - (* Ocmp *) - let (c', args') := cond_strength_reduction c args in + | Ocmp c, args, vl => + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args') - | op_strength_reduction_default op args => - (* default *) + | _, _, _ => (op, args) + end. +>> +*) + +Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg) (vl: list approx), Type := + | op_strength_reduction_case1: forall r1 r2 v1 n2, op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case2: forall r1 r2 v1 n2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case3: forall r1 r2 v1 n2, op_strength_reduction_cases (Odiv) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case4: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case5: forall r1 r2 v1 n2, op_strength_reduction_cases (Omodu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case6: forall r1 r2 v1 n2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case7: forall r1 r2 v1 n2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case8: forall r1 r2 v1 n2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case9: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case10: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case11: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case12: forall addr args vl, op_strength_reduction_cases (Olea addr) (args) (vl) + | op_strength_reduction_case13: forall c args vl, op_strength_reduction_cases (Ocmp c) (args) (vl) + | op_strength_reduction_default: forall (op: operation) (args: list reg) (vl: list approx), op_strength_reduction_cases op args vl. + +Definition op_strength_reduction_match (op: operation) (args: list reg) (vl: list approx) := + match op as zz1, args as zz2, vl as zz3 return op_strength_reduction_cases zz1 zz2 zz3 with + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case1 r1 r2 v1 n2 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case2 r1 r2 v1 n2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case3 r1 r2 v1 n2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case4 r1 r2 v1 n2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case5 r1 r2 v1 n2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case6 r1 r2 v1 n2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case7 r1 r2 v1 n2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case8 r1 r2 v1 n2 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case9 r1 r2 v1 n2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case10 r1 r2 v1 n2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case11 r1 r2 v1 n2 + | Olea addr, args, vl => op_strength_reduction_case12 addr args vl + | Ocmp c, args, vl => op_strength_reduction_case13 c args vl + | op, args, vl => op_strength_reduction_default op args vl + end. + +Definition op_strength_reduction (op: operation) (args: list reg) (vl: list approx) := + match op_strength_reduction_match op args vl with + | op_strength_reduction_case1 r1 r2 v1 n2 => (* Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_addimm (Int.neg n2) r1 + | op_strength_reduction_case2 r1 r2 v1 n2 => (* Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_mulimm n2 r1 + | op_strength_reduction_case3 r1 r2 v1 n2 => (* Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_divimm n2 r1 r2 + | op_strength_reduction_case4 r1 r2 v1 n2 => (* Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_divuimm n2 r1 r2 + | op_strength_reduction_case5 r1 r2 v1 n2 => (* Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_moduimm n2 r1 r2 + | op_strength_reduction_case6 r1 r2 v1 n2 => (* Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_andimm n2 r1 + | op_strength_reduction_case7 r1 r2 v1 n2 => (* Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_orimm n2 r1 + | op_strength_reduction_case8 r1 r2 v1 n2 => (* Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_xorimm n2 r1 + | op_strength_reduction_case9 r1 r2 v1 n2 => (* Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shlimm n2 r1 + | op_strength_reduction_case10 r1 r2 v1 n2 => (* Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shrimm n2 r1 + | op_strength_reduction_case11 r1 r2 v1 n2 => (* Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shruimm n2 r1 + | op_strength_reduction_case12 addr args vl => (* Olea addr, args, vl *) + let (addr', args') := addr_strength_reduction addr args vl in (Olea addr', args') + | op_strength_reduction_case13 c args vl => (* Ocmp c, args, vl *) + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args') + | op_strength_reduction_default op args vl => (op, args) end. + End STRENGTH_REDUCTION. diff --git a/ia32/ConstpropOpproof.v b/ia32/ConstpropOpproof.v index 79e1537..afb284a 100644 --- a/ia32/ConstpropOpproof.v +++ b/ia32/ConstpropOpproof.v @@ -30,6 +30,7 @@ Require Import Constprop. Section ANALYSIS. Variable ge: genv. +Variable sp: val. (** We first show that the dataflow analysis is correct with respect to the dynamic semantics: the approximations (sets of values) @@ -43,7 +44,8 @@ Definition val_match_approx (a: approx) (v: val) : Prop := | Unknown => True | I p => v = Vint p | F p => v = Vfloat p - | S symb ofs => exists b, Genv.find_symbol ge symb = Some b /\ v = Vptr b ofs + | G symb ofs => v = symbol_address ge symb ofs + | S ofs => v = Val.add sp (Vint ofs) | _ => False end. @@ -62,12 +64,10 @@ Ltac SimplVMA := simpl in H; (try subst v); SimplVMA | H: (val_match_approx (F _) ?v) |- _ => simpl in H; (try subst v); SimplVMA - | H: (val_match_approx (S _ _) ?v) |- _ => - simpl in H; - (try (elim H; - let b := fresh "b" in let A := fresh in let B := fresh in - (intros b [A B]; subst v; clear H))); - SimplVMA + | H: (val_match_approx (G _ _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA + | H: (val_match_approx (S _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA | _ => idtac end. @@ -75,9 +75,9 @@ Ltac SimplVMA := Ltac InvVLMA := match goal with | H: (val_list_match_approx nil ?vl) |- _ => - inversion H + inv H | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ => - inversion H; SimplVMA; InvVLMA + inv H; SimplVMA; InvVLMA | _ => idtac end. @@ -99,28 +99,39 @@ Proof. InvVLMA; simpl; congruence. Qed. +Remark shift_symbol_address: + forall symb ofs n, + symbol_address ge symb (Int.add ofs n) = Val.add (symbol_address ge symb ofs) (Vint n). +Proof. + unfold symbol_address; intros. destruct (Genv.find_symbol ge symb); auto. +Qed. + Lemma eval_static_addressing_correct: - forall addr sp al vl v, + forall addr al vl v, val_list_match_approx al vl -> eval_addressing ge sp addr vl = Some v -> val_match_approx (eval_static_addressing addr al) v. Proof. intros until v. unfold eval_static_addressing. case (eval_static_addressing_match addr al); intros; - InvVLMA; simpl in *; FuncInv; try congruence. - inv H4. exists b0; auto. - inv H4. inv H14. exists b0; auto. - inv H4. inv H13. exists b0; auto. - inv H4. inv H14. exists b0; auto. - destruct (Genv.find_symbol ge id); inv H0. exists b; auto. - inv H4. destruct (Genv.find_symbol ge id); inv H0. exists b; auto. - inv H4. destruct (Genv.find_symbol ge id); inv H0. - exists b; split; auto. rewrite Int.mul_commut; auto. - auto. + InvVLMA; simpl in *; FuncInv; try subst v; auto. + rewrite shift_symbol_address; auto. + rewrite Val.add_assoc. auto. + repeat rewrite shift_symbol_address. auto. + fold (Val.add (Vint n1) (symbol_address ge id ofs)). + repeat rewrite shift_symbol_address. repeat rewrite Val.add_assoc. rewrite Val.add_permut. auto. + repeat rewrite Val.add_assoc. decEq; simpl. rewrite Int.add_assoc. auto. + fold (Val.add (Vint n1) (Val.add sp (Vint ofs))). + rewrite Val.add_assoc. rewrite Val.add_permut. rewrite Val.add_assoc. + simpl. rewrite Int.add_assoc; auto. + rewrite shift_symbol_address. auto. + rewrite Val.add_assoc. auto. + rewrite shift_symbol_address. auto. + rewrite shift_symbol_address. rewrite Int.mul_commut; auto. Qed. Lemma eval_static_operation_correct: - forall op sp al vl m v, + forall op al vl m v, val_list_match_approx al vl -> eval_operation ge sp op vl m = Some v -> val_match_approx (eval_static_operation op al) v. @@ -128,65 +139,29 @@ Proof. intros until v. unfold eval_static_operation. case (eval_static_operation_match op al); intros; - InvVLMA; simpl in *; FuncInv; try congruence. - - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - - exists b. split. auto. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - destruct (Int.ltu n Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. - - replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - destruct (Int.ltu n Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. - - destruct (Int.ltu n (Int.repr 31)). - injection H0; intro; subst v. simpl. congruence. discriminate. - - replace n2 with i0. destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - destruct (Int.ltu n Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. - - destruct (Int.ltu n Int.iwordsize). - injection H0; intro; subst v. simpl. congruence. discriminate. - + InvVLMA; simpl in *; FuncInv; try subst v; auto. + + rewrite Int.sub_add_opp. rewrite shift_symbol_address. rewrite Val.sub_add_opp. auto. + destruct (Int.eq n2 Int.zero); inv H0; simpl; auto. + destruct (Int.eq n2 Int.zero); inv H0; simpl; auto. + destruct (Int.eq n2 Int.zero); inv H0; simpl; auto. + destruct (Int.eq n2 Int.zero); inv H0; simpl; auto. + destruct (Int.ltu n2 Int.iwordsize); simpl; auto. + destruct (Int.ltu n Int.iwordsize); simpl; auto. + destruct (Int.ltu n2 Int.iwordsize); simpl; auto. + destruct (Int.ltu n Int.iwordsize); simpl; auto. + destruct (Int.ltu n (Int.repr 31)); inv H0. simpl; auto. + destruct (Int.ltu n2 Int.iwordsize); simpl; auto. + destruct (Int.ltu n Int.iwordsize); simpl; auto. + destruct (Int.ltu n Int.iwordsize); simpl; auto. eapply eval_static_addressing_correct; eauto. - - rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence. - - inv H4. destruct (Float.intoffloat f); inv H0. red; auto. - - caseEq (eval_static_condition c vl0). - intros. generalize (eval_static_condition_correct _ _ _ m _ H H1). - intro. rewrite H2 in H0. - destruct b; injection H0; intro; subst v; simpl; auto. - intros; simpl; auto. - - auto. + unfold eval_static_intoffloat. + destruct (Float.intoffloat n1) as []_eqn; simpl in H0; inv H0. + simpl; auto. + unfold eval_static_condition_val. destruct (eval_static_condition c vl0) as [b|]_eqn. + rewrite (eval_static_condition_correct _ _ _ m _ H Heqo). + destruct b; simpl; auto. + simpl; auto. Qed. (** * Correctness of strength reduction *) @@ -199,299 +174,248 @@ Qed. Section STRENGTH_REDUCTION. -Variable app: reg -> approx. -Variable sp: val. +Variable app: D.t. Variable rs: regset. Variable m: mem. -Hypothesis MATCH: forall r, val_match_approx (app r) rs#r. +Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r. -Lemma intval_correct: - forall r n, - intval app r = Some n -> rs#r = Vint n. -Proof. - intros until n. - unfold intval. caseEq (app r); intros; try discriminate. - generalize (MATCH r). unfold val_match_approx. rewrite H. - congruence. -Qed. +Ltac InvApproxRegs := + match goal with + | [ H: _ :: _ = _ :: _ |- _ ] => + injection H; clear H; intros; InvApproxRegs + | [ H: ?v = approx_reg app ?r |- _ ] => + generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs + | _ => idtac + end. Lemma cond_strength_reduction_correct: - forall cond args, - let (cond', args') := cond_strength_reduction app cond args in + forall cond args vl, + vl = approx_regs app args -> + let (cond', args') := cond_strength_reduction cond args vl in eval_condition cond' rs##args' m = eval_condition cond rs##args m. Proof. - intros. unfold cond_strength_reduction. - case (cond_strength_reduction_match cond args); intros. - caseEq (intval app r1); intros. - simpl. rewrite (intval_correct _ _ H). - destruct (rs#r2); auto. rewrite Int.swap_cmp. auto. - caseEq (intval app r2); intros. - simpl. rewrite (intval_correct _ _ H0). auto. - auto. - caseEq (intval app r1); intros. - simpl. rewrite (intval_correct _ _ H). - destruct (rs#r2); auto. rewrite Int.swap_cmpu. auto. - destruct c; reflexivity. - caseEq (intval app r2); intros. - simpl. rewrite (intval_correct _ _ H0). auto. - auto. + intros until vl. unfold cond_strength_reduction. + case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVMA. + rewrite H0. apply Val.swap_cmp_bool. + rewrite H. auto. + rewrite H0. apply Val.swap_cmpu_bool. + rewrite H. auto. auto. Qed. -Ltac KnownApprox := - match goal with - | H: ?approx ?r = ?a |- _ => - generalize (MATCH r); rewrite H; intro; clear H; KnownApprox - | _ => idtac - end. - Lemma addr_strength_reduction_correct: - forall addr args, - let (addr', args') := addr_strength_reduction app addr args in + forall addr args vl, + vl = approx_regs app args -> + let (addr', args') := addr_strength_reduction addr args vl in eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args. Proof. - intros. - - unfold addr_strength_reduction. destruct (addr_strength_reduction_match addr args). - - generalize (MATCH r1); caseEq (app r1); intros; auto. - simpl in H0. destruct H0 as [b [A B]]. simpl. rewrite A; rewrite B. - rewrite Int.add_commut; auto. - - generalize (MATCH r1) (MATCH r2); caseEq (app r1); auto; caseEq (app r2); auto; - simpl val_match_approx; intros; try contradiction; simpl. - rewrite H2. destruct (rs#r1); auto. rewrite Int.add_assoc; auto. rewrite Int.add_assoc; auto. - destruct H2 as [b [A B]]. rewrite A; rewrite B. - destruct (rs#r1); auto. repeat rewrite Int.add_assoc. decEq. decEq. decEq. apply Int.add_commut. - rewrite H1. destruct (rs#r2); auto. - rewrite Int.add_assoc; auto. rewrite Int.add_permut. auto. - rewrite Int.add_assoc; auto. - rewrite H1; rewrite H2. rewrite Int.add_permut. rewrite Int.add_assoc. auto. - rewrite H1; rewrite H2. auto. - destruct H2 as [b [A B]]. rewrite A; rewrite B. rewrite H1. do 3 decEq. apply Int.add_commut. - rewrite H1; auto. - rewrite H1; auto. - destruct H1 as [b [A B]]. rewrite A; rewrite B. destruct (rs#r2); auto. - repeat rewrite Int.add_assoc. do 3 decEq. apply Int.add_commut. - destruct H1 as [b [A B]]. rewrite A; rewrite B; rewrite H2. auto. - rewrite H2. destruct (rs#r1); auto. - destruct H1 as [b [A B]]. destruct H2 as [b' [A' B']]. - rewrite A; rewrite B; rewrite B'. auto. - - generalize (MATCH r1) (MATCH r2); caseEq (app r1); auto; caseEq (app r2); auto; - simpl val_match_approx; intros; try contradiction; simpl. - rewrite H2. destruct (rs#r1); auto. - rewrite H1; rewrite H2. auto. - rewrite H1. auto. - destruct H1 as [b [A B]]. rewrite A; rewrite B. - destruct (rs#r2); auto. rewrite Int.add_assoc. do 3 decEq. apply Int.add_commut. - destruct H1 as [b [A B]]. rewrite A; rewrite B; rewrite H2. rewrite Int.add_assoc. auto. - rewrite H2. destruct (rs#r1); auto. - destruct H1 as [b [A B]]. destruct H2 as [b' [A' B']]. - rewrite A; rewrite B; rewrite B'. auto. - - generalize (MATCH r1); caseEq (app r1); auto; - simpl val_match_approx; intros; try contradiction; simpl. - rewrite H0. auto. - - generalize (MATCH r1); caseEq (app r1); auto; - simpl val_match_approx; intros; try contradiction; simpl. - rewrite H0. rewrite Int.mul_commut. auto. - + intros until vl. unfold addr_strength_reduction. + destruct (addr_strength_reduction_match addr args vl); simpl; intros; InvApproxRegs; SimplVMA. + rewrite shift_symbol_address; congruence. + rewrite H. rewrite Val.add_assoc; auto. + rewrite H; rewrite H0. repeat rewrite shift_symbol_address. auto. + rewrite H; rewrite H0. rewrite Int.add_assoc. rewrite Int.add_permut. repeat rewrite shift_symbol_address. + rewrite Val.add_assoc. rewrite Val.add_permut. auto. + rewrite H; rewrite H0. repeat rewrite Val.add_assoc. rewrite Int.add_assoc. auto. + rewrite H; rewrite H0. repeat rewrite Val.add_assoc. rewrite Val.add_permut. + rewrite Int.add_assoc. auto. + rewrite H0. rewrite shift_symbol_address. repeat rewrite Val.add_assoc. + decEq; decEq. apply Val.add_commut. + rewrite H. rewrite shift_symbol_address. repeat rewrite Val.add_assoc. + rewrite (Val.add_permut (rs#r1)). decEq; decEq. apply Val.add_commut. + rewrite H0. rewrite Val.add_assoc. rewrite Val.add_permut. auto. + rewrite H. rewrite Val.add_assoc. auto. + rewrite H; rewrite H0. rewrite Int.add_assoc. repeat rewrite shift_symbol_address. auto. + rewrite H0. rewrite shift_symbol_address. rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. + rewrite H. auto. + rewrite H. rewrite shift_symbol_address. auto. + rewrite H. rewrite shift_symbol_address. rewrite Int.mul_commut; auto. auto. Qed. +Lemma make_addimm_correct: + forall n r, + let (op, args) := make_addimm n r in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v. +Proof. + intros. unfold make_addimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto. + exists (Val.add rs#r (Vint n)); auto. +Qed. + Lemma make_shlimm_correct: - forall n r v, - let (op, args) := make_shlimm n r in - eval_operation ge sp Oshl (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1, + let (op, args) := make_shlimm n r1 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v. Proof. intros; unfold make_shlimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shl_zero in H. congruence. - simpl in *. auto. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto. + econstructor; split. simpl. eauto. auto. Qed. Lemma make_shrimm_correct: - forall n r v, - let (op, args) := make_shrimm n r in - eval_operation ge sp Oshr (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1, + let (op, args) := make_shrimm n r1 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v. Proof. intros; unfold make_shrimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shr_zero in H. congruence. - assumption. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto. + econstructor; split; eauto. simpl. auto. Qed. Lemma make_shruimm_correct: - forall n r v, - let (op, args) := make_shruimm n r in - eval_operation ge sp Oshru (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1, + let (op, args) := make_shruimm n r1 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v. Proof. intros; unfold make_shruimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shru_zero in H. congruence. - assumption. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto. + econstructor; split; eauto. simpl. congruence. Qed. Lemma make_mulimm_correct: - forall n r v, - let (op, args) := make_mulimm n r in - eval_operation ge sp Omul (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + forall n r1, + let (op, args) := make_mulimm n r1 in + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v. Proof. intros; unfold make_mulimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in H0. FuncInv. rewrite Int.mul_zero in H. simpl. congruence. - generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros. - subst n. simpl in H1. simpl. FuncInv. rewrite Int.mul_one in H0. congruence. - caseEq (Int.is_power2 n); intros. - replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil) m) - with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil) m). - apply make_shlimm_correct. - simpl. generalize (Int.is_power2_range _ _ H1). - change (Z_of_nat Int.wordsize) with 32. intro. rewrite H2. - destruct rs#r; auto. rewrite (Int.mul_pow2 i0 _ _ H1). auto. - exact H2. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. + exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto. + destruct (Int.is_power2 n) as []_eqn; intros. + rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). apply make_shlimm_correct; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_divimm_correct: + forall n r1 r2 v, + Val.divs rs#r1 rs#r2 = Some v -> + rs#r2 = Vint n -> + let (op, args) := make_divimm n r1 r2 in + exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divimm. + destruct (Int.is_power2 n) as []_eqn. + destruct (Int.ltu i (Int.repr 31)) as []_eqn. + exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divuimm_correct: + forall n r1 r2 v, + Val.divu rs#r1 rs#r2 = Some v -> + rs#r2 = Vint n -> + let (op, args) := make_divuimm n r1 r2 in + exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divuimm. + destruct (Int.is_power2 n) as []_eqn. + replace v with (Val.shru rs#r1 (Vint i)). + eapply make_shruimm_correct; eauto. + eapply Val.divu_pow2; eauto. congruence. + exists v; auto. +Qed. + +Lemma make_moduimm_correct: + forall n r1 r2 v, + Val.modu rs#r1 rs#r2 = Some v -> + rs#r2 = Vint n -> + let (op, args) := make_moduimm n r1 r2 in + exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_moduimm. + destruct (Int.is_power2 n) as []_eqn. + exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence. + exists v; auto. Qed. Lemma make_andimm_correct: - forall n r v, + forall n r, let (op, args) := make_andimm n r in - eval_operation ge sp Oand (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v. Proof. intros; unfold make_andimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.and_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. rewrite Int.and_mone in H0. congruence. - exact H1. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto. + econstructor; split; eauto. auto. Qed. Lemma make_orimm_correct: - forall n r v, + forall n r, let (op, args) := make_orimm n r in - eval_operation ge sp Oor (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v. Proof. intros; unfold make_orimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.or_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. rewrite Int.or_mone in H0. congruence. - exact H1. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto. + econstructor; split; eauto. auto. Qed. Lemma make_xorimm_correct: - forall n r v, + forall n r, let (op, args) := make_xorimm n r in - eval_operation ge sp Oxor (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. + exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v. Proof. intros; unfold make_xorimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.xor_zero in H. congruence. - exact H0. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto. + econstructor; split; eauto. auto. Qed. Lemma op_strength_reduction_correct: - forall op args v, - let (op', args') := op_strength_reduction app op args in + forall op args vl v, + vl = approx_regs app args -> eval_operation ge sp op rs##args m = Some v -> - eval_operation ge sp op' rs##args' m = Some v. + let (op', args') := op_strength_reduction op args vl in + exists w, eval_operation ge sp op' rs##args' m = Some w /\ Val.lessdef v w. Proof. - intros; unfold op_strength_reduction; - case (op_strength_reduction_match op args); intros; simpl List.map. - (* Osub *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). - unfold make_addimm. generalize (Int.eq_spec (Int.neg i) Int.zero). - destruct (Int.eq (Int.neg i) (Int.zero)); intros. - assert (i = Int.zero). rewrite <- (Int.neg_involutive i). rewrite H0. reflexivity. - subst i. simpl in *. destruct (rs#r1); inv H1; rewrite Int.sub_zero_l; auto. - simpl in *. destruct (rs#r1); inv H1; rewrite Int.sub_add_opp; auto. - auto. - (* Omul *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). apply make_mulimm_correct. - assumption. - (* Odiv *) - caseEq (intval app r2); intros. - caseEq (Int.is_power2 i); intros. - caseEq (Int.ltu i0 (Int.repr 31)); intros. - rewrite (intval_correct _ _ H) in H2. - simpl in *; FuncInv. destruct (Int.eq i Int.zero). congruence. - rewrite H1. rewrite (Int.divs_pow2 i1 _ _ H0) in H2. auto. - assumption. - assumption. - assumption. - (* Odivu *) - caseEq (intval app r2); intros. - caseEq (Int.is_power2 i); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil) m) - with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil) m). - apply make_shruimm_correct. - simpl. destruct rs#r1; auto. - rewrite (Int.is_power2_range _ _ H0). - generalize (Int.eq_spec i Int.zero); case (Int.eq i Int.zero); intros. - subst i. discriminate. - rewrite (Int.divu_pow2 i1 _ _ H0). auto. - assumption. - assumption. - (* Omodu *) - caseEq (intval app r2); intros. - caseEq (Int.is_power2 i); intros. - rewrite (intval_correct _ _ H) in H1. - simpl in *; FuncInv. destruct (Int.eq i Int.zero). congruence. - rewrite (Int.modu_and i1 _ _ H0) in H1. auto. - assumption. - assumption. - - (* Oand *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). apply make_andimm_correct. - assumption. - (* Oor *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). apply make_orimm_correct. - assumption. - (* Oxor *) - caseEq (intval app r2); intros. - rewrite (intval_correct _ _ H). apply make_xorimm_correct. - assumption. - (* Oshl *) - caseEq (intval app r2); intros. - caseEq (Int.ltu i Int.iwordsize); intros. - rewrite (intval_correct _ _ H). apply make_shlimm_correct. - assumption. - assumption. - (* Oshr *) - caseEq (intval app r2); intros. - caseEq (Int.ltu i Int.iwordsize); intros. - rewrite (intval_correct _ _ H). apply make_shrimm_correct. - assumption. - assumption. - (* Oshru *) - caseEq (intval app r2); intros. - caseEq (Int.ltu i Int.iwordsize); intros. - rewrite (intval_correct _ _ H). apply make_shruimm_correct. - assumption. - assumption. - (* Olea *) - generalize (addr_strength_reduction_correct addr args0). - destruct (addr_strength_reduction app addr args0) as [addr' args']. - intros. simpl in *. congruence. - (* Ocmp *) - generalize (cond_strength_reduction_correct c args0). - destruct (cond_strength_reduction app c args0). - simpl. intro. rewrite H. auto. - (* default *) - assumption. + intros until v; unfold op_strength_reduction; + case (op_strength_reduction_match op args vl); simpl; intros. +(* sub *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. rewrite Val.sub_add_opp. apply make_addimm_correct; auto. +(* mul *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_mulimm_correct; auto. +(* divs *) + assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto. + apply make_divimm_correct; auto. +(* divu *) + assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto. + apply make_divuimm_correct; auto. +(* modu *) + assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto. + apply make_moduimm_correct; auto. +(* and *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_andimm_correct; auto. +(* or *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_orimm_correct; auto. +(* xor *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_xorimm_correct; auto. +(* shl *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shlimm_correct; auto. +(* shr *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shrimm_correct; auto. +(* shru *) + InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shruimm_correct; auto. +(* lea *) + generalize (addr_strength_reduction_correct addr args0 vl0 H). + destruct (addr_strength_reduction addr args0 vl0) as [addr' args']. + intro EQ. exists v; split; auto. simpl. congruence. +(* cond *) + generalize (cond_strength_reduction_correct c args0 vl0 H). + destruct (cond_strength_reduction c args0 vl0) as [c' args']; intros. + rewrite <- H1 in H0; auto. econstructor; split; eauto. +(* default *) + exists v; auto. Qed. End STRENGTH_REDUCTION. diff --git a/ia32/Op.v b/ia32/Op.v index 6c301a8..6389567 100644 --- a/ia32/Op.v +++ b/ia32/Op.v @@ -114,6 +114,7 @@ Inductive operation : Type := (** Derived operators. *) Definition Oaddrsymbol (id: ident) (ofs: int) : operation := Olea (Aglobal id ofs). +Definition Oaddrstack (ofs: int) : operation := Olea (Ainstack ofs). Definition Oaddimm (n: int) : operation := Olea (Aindexed n). (** Comparison functions (used in module [CSE]). *) @@ -136,97 +137,52 @@ Proof. apply eq_addressing. Qed. -(** Evaluation of conditions, operators and addressing modes applied - to lists of values. Return [None] when the computation is undefined: - wrong number of arguments, arguments of the wrong types, undefined - operations such as division by zero. [eval_condition] returns a boolean, - [eval_operation] and [eval_addressing] return a value. *) +(** * Evaluation functions *) -Definition eval_compare_mismatch (c: comparison) : option bool := - match c with Ceq => Some false | Cne => Some true | _ => None end. +Definition symbol_address (F V: Type) (genv: Genv.t F V) (id: ident) (ofs: int) : val := + match Genv.find_symbol genv id with + | Some b => Vptr b ofs + | None => Vundef + end. -Definition eval_compare_null (c: comparison) (n: int) : option bool := - if Int.eq n Int.zero then eval_compare_mismatch c else None. +(** 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 := +Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := match cond, vl with - | Ccomp c, Vint n1 :: Vint n2 :: nil => - Some (Int.cmp c n1 n2) - | Ccompu c, Vint n1 :: Vint n2 :: nil => - Some (Int.cmpu c n1 n2) - | Ccompu c, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if Mem.valid_pointer m b1 (Int.unsigned n1) - && Mem.valid_pointer m b2 (Int.unsigned n2) then - if eq_block b1 b2 - then Some (Int.cmpu c n1 n2) - else eval_compare_mismatch c - else None - | Ccompu c, Vptr b1 n1 :: Vint n2 :: nil => - eval_compare_null c n2 - | Ccompu c, Vint n1 :: Vptr b2 n2 :: nil => - eval_compare_null c n1 - | Ccompimm c n, Vint n1 :: nil => - Some (Int.cmp c n1 n) - | Ccompuimm c n, Vint n1 :: nil => - Some (Int.cmpu c n1 n) - | Ccompuimm c n, Vptr b1 n1 :: nil => - eval_compare_null c n - | Ccompf c, Vfloat f1 :: Vfloat f2 :: nil => - Some (Float.cmp c f1 f2) - | Cnotcompf c, Vfloat f1 :: Vfloat f2 :: nil => - Some (negb (Float.cmp c f1 f2)) - | Cmaskzero n, Vint n1 :: nil => - Some (Int.eq (Int.and n1 n) Int.zero) - | Cmasknotzero n, Vint n1 :: nil => - Some (negb (Int.eq (Int.and n1 n) Int.zero)) - | _, _ => - None - end. - -Definition offset_sp (sp: val) (delta: int) : option val := - match sp with - | Vptr b n => Some (Vptr b (Int.add n delta)) - | _ => None + | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 + | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 + | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n) + | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n) + | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2 + | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2) + | Cmaskzero n, Vint n1 :: nil => Some (Int.eq (Int.and n1 n) Int.zero) + | Cmasknotzero n, Vint n1 :: nil => Some (negb (Int.eq (Int.and n1 n) Int.zero)) + | _, _ => None end. Definition eval_addressing (F V: Type) (genv: Genv.t F V) (sp: val) (addr: addressing) (vl: list val) : option val := match addr, vl with - | Aindexed n, Vint n1 :: nil => - Some (Vint (Int.add n1 n)) - | Aindexed n, Vptr b1 n1 :: nil => - Some (Vptr b1 (Int.add n1 n)) - | Aindexed2 n, Vint n1 :: Vint n2 :: nil => - Some (Vint (Int.add (Int.add n1 n2) n)) - | Aindexed2 n, Vptr b1 n1 :: Vint n2 :: nil => - Some (Vptr b1 (Int.add (Int.add n1 n2) n)) - | Aindexed2 n, Vint n1 :: Vptr b2 n2 :: nil => - Some (Vptr b2 (Int.add (Int.add n2 n1) n)) - | Ascaled sc ofs, Vint n1 :: nil => - Some (Vint (Int.add (Int.mul n1 sc) ofs)) - | Aindexed2scaled sc ofs, Vint n1 :: Vint n2 :: nil => - Some (Vint (Int.add n1 (Int.add (Int.mul n2 sc) ofs))) - | Aindexed2scaled sc ofs, Vptr b1 n1 :: Vint n2 :: nil => - Some (Vptr b1 (Int.add n1 (Int.add (Int.mul n2 sc) ofs))) + | Aindexed n, v1::nil => + Some (Val.add v1 (Vint n)) + | Aindexed2 n, v1::v2::nil => + Some (Val.add (Val.add v1 v2) (Vint n)) + | Ascaled sc ofs, v1::nil => + Some (Val.add (Val.mul v1 (Vint sc)) (Vint ofs)) + | Aindexed2scaled sc ofs, v1::v2::nil => + Some(Val.add v1 (Val.add (Val.mul v2 (Vint sc)) (Vint ofs))) | Aglobal s ofs, nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b ofs) - end - | Abased s ofs, Vint n1 :: nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b (Int.add ofs n1)) - end - | Abasedscaled sc s ofs, Vint n1 :: nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b (Int.add ofs (Int.mul n1 sc))) - end + Some (symbol_address genv s ofs) + | Abased s ofs, v1::nil => + Some (Val.add (symbol_address genv s ofs) v1) + | Abasedscaled sc s ofs, v1::nil => + Some (Val.add (symbol_address genv s ofs) (Val.mul v1 (Vint sc))) | Ainstack ofs, nil => - offset_sp sp ofs + Some(Val.add sp (Vint ofs)) | _, _ => None end. @@ -241,78 +197,42 @@ Definition eval_operation | Ocast8unsigned, v1 :: nil => Some (Val.zero_ext 8 v1) | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) | Ocast16unsigned, v1 :: nil => Some (Val.zero_ext 16 v1) - | Oneg, Vint n1 :: nil => Some (Vint (Int.neg n1)) - | Osub, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub n1 n2)) - | Osub, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.sub n1 n2)) - | Osub, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if eq_block b1 b2 then Some (Vint (Int.sub n1 n2)) else None - | Omul, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.mul n1 n2)) - | Omulimm n, Vint n1 :: nil => Some (Vint (Int.mul n1 n)) - | Odiv, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divs n1 n2)) - | Odivu, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2)) - | Omod, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.mods n1 n2)) - | Omodu, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.modu n1 n2)) - | Oand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 n2)) - | Oandimm n, Vint n1 :: nil => Some (Vint (Int.and n1 n)) - | Oor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 n2)) - | Oorimm n, Vint n1 :: nil => Some (Vint (Int.or n1 n)) - | Oxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 n2)) - | Oxorimm n, Vint n1 :: nil => Some (Vint (Int.xor n1 n)) - | Oshl, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shl n1 n2)) else None - | Oshlimm n, Vint n1 :: nil => - if Int.ltu n Int.iwordsize then Some (Vint (Int.shl n1 n)) else None - | Oshr, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shr n1 n2)) else None - | Oshrimm n, Vint n1 :: nil => - if Int.ltu n Int.iwordsize then Some (Vint (Int.shr n1 n)) else None - | Oshrximm n, Vint n1 :: nil => - if Int.ltu n (Int.repr 31) then Some (Vint (Int.shrx n1 n)) else None - | Oshru, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shru n1 n2)) else None - | Oshruimm n, Vint n1 :: nil => - if Int.ltu n Int.iwordsize then Some (Vint (Int.shru n1 n)) else None - | Ororimm n, Vint n1 :: nil => - if Int.ltu n Int.iwordsize then Some (Vint (Int.ror n1 n)) else None - | Olea addr, _ => - eval_addressing genv sp addr vl - | Onegf, Vfloat f1 :: nil => Some (Vfloat (Float.neg f1)) - | Oabsf, Vfloat f1 :: nil => Some (Vfloat (Float.abs f1)) - | Oaddf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.add f1 f2)) - | Osubf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.sub f1 f2)) - | Omulf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.mul f1 f2)) - | Odivf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.div f1 f2)) - | Osingleoffloat, v1 :: nil => - Some (Val.singleoffloat v1) - | Ointoffloat, Vfloat f1 :: nil => - option_map Vint (Float.intoffloat f1) - | Ofloatofint, Vint n1 :: nil => - Some (Vfloat (Float.floatofint n1)) - | Ocmp c, _ => - match eval_condition c vl m with - | None => None - | Some false => Some Vfalse - | Some true => Some Vtrue - end + | Oneg, v1::nil => Some (Val.neg v1) + | Osub, v1::v2::nil => Some (Val.sub v1 v2) + | Omul, v1::v2::nil => Some (Val.mul v1 v2) + | Omulimm n, v1::nil => Some (Val.mul v1 (Vint n)) + | Odiv, v1::v2::nil => Val.divs v1 v2 + | Odivu, v1::v2::nil => Val.divu v1 v2 + | Omod, v1::v2::nil => Val.mods v1 v2 + | Omodu, v1::v2::nil => Val.modu v1 v2 + | Oand, v1::v2::nil => Some(Val.and v1 v2) + | Oandimm n, v1::nil => Some (Val.and v1 (Vint n)) + | Oor, v1::v2::nil => Some(Val.or v1 v2) + | Oorimm n, v1::nil => Some (Val.or v1 (Vint n)) + | Oxor, v1::v2::nil => Some(Val.xor v1 v2) + | Oxorimm n, v1::nil => Some (Val.xor v1 (Vint n)) + | Oshl, v1::v2::nil => Some (Val.shl v1 v2) + | Oshlimm n, v1::nil => Some (Val.shl v1 (Vint n)) + | Oshr, v1::v2::nil => Some (Val.shr v1 v2) + | Oshrimm n, v1::nil => Some (Val.shr v1 (Vint n)) + | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Oshru, v1::v2::nil => Some (Val.shru v1 v2) + | Oshruimm n, v1::nil => Some (Val.shru v1 (Vint n)) + | Ororimm n, v1::nil => Some (Val.ror v1 (Vint n)) + | Olea addr, _ => eval_addressing genv sp addr vl + | Onegf, v1::nil => Some(Val.negf v1) + | Oabsf, v1::nil => Some(Val.absf v1) + | Oaddf, v1::v2::nil => Some(Val.addf v1 v2) + | Osubf, v1::v2::nil => Some(Val.subf v1 v2) + | Omulf, v1::v2::nil => Some(Val.mulf v1 v2) + | Odivf, v1::v2::nil => Some(Val.divf v1 v2) + | Osingleoffloat, v1::nil => Some(Val.singleoffloat v1) + | Ointoffloat, v1::nil => Val.intoffloat v1 + | Ofloatofint, v1::nil => Val.floatofint v1 + | Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m)) | _, _ => None end. -Definition negate_condition (cond: condition): condition := - match cond with - | Ccomp c => Ccomp(negate_comparison c) - | Ccompu c => Ccompu(negate_comparison c) - | Ccompimm c n => Ccompimm (negate_comparison c) n - | Ccompuimm c n => Ccompuimm (negate_comparison c) n - | Ccompf c => Cnotcompf c - | Cnotcompf c => Ccompf c - | Cmaskzero n => Cmasknotzero n - | Cmasknotzero n => Cmaskzero n - end. - Ltac FuncInv := match goal with | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => @@ -325,104 +245,7 @@ Ltac FuncInv := idtac end. -Remark eval_negate_compare_mismatch: - forall c b, - eval_compare_mismatch c = Some b -> - eval_compare_mismatch (negate_comparison c) = Some (negb b). -Proof. - intros until b. unfold eval_compare_mismatch. - destruct c; intro EQ; inv EQ; auto. -Qed. - -Remark eval_negate_compare_null: - forall c i b, - eval_compare_null c i = Some b -> - eval_compare_null (negate_comparison c) i = Some (negb b). -Proof. - unfold eval_compare_null; intros. - destruct (Int.eq i Int.zero). apply eval_negate_compare_mismatch; auto. congruence. -Qed. - -Lemma eval_negate_condition: - forall (cond: condition) (vl: list val) (b: bool) (m: mem), - eval_condition cond vl m = Some b -> - eval_condition (negate_condition cond) vl m = Some (negb b). -Proof. - intros. - destruct cond; simpl in H; FuncInv; try subst b; simpl. - rewrite Int.negate_cmp. auto. - rewrite Int.negate_cmpu. auto. - apply eval_negate_compare_null; auto. - apply eval_negate_compare_null; auto. - destruct (Mem.valid_pointer m b0 (Int.unsigned i) && - Mem.valid_pointer m b1 (Int.unsigned i0)); try discriminate. - destruct (eq_block b0 b1); try discriminate. - rewrite Int.negate_cmpu. congruence. - apply eval_negate_compare_mismatch; auto. - rewrite Int.negate_cmp. auto. - rewrite Int.negate_cmpu. auto. - apply eval_negate_compare_null; auto. - auto. - rewrite negb_elim. auto. - auto. - rewrite negb_elim. auto. -Qed. - -(** [eval_operation] and [eval_addressing] depend on a global environment - for resolving references to global symbols. We show that they give - the same results if a global environment is replaced by another that - assigns the same addresses to the same symbols. *) - -Section GENV_TRANSF. - -Variable F1 F2 V1 V2: Type. -Variable ge1: Genv.t F1 V1. -Variable ge2: Genv.t F2 V2. -Hypothesis agree_on_symbols: - forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. - -Lemma eval_addressing_preserved: - forall sp addr vl, - eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. -Proof. - intros. - unfold eval_addressing; destruct addr; try rewrite agree_on_symbols; - reflexivity. -Qed. - -Lemma eval_operation_preserved: - forall sp op vl m, - eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. -Proof. - intros. - unfold eval_operation; destruct op; try rewrite agree_on_symbols; auto. - apply eval_addressing_preserved. -Qed. - -End GENV_TRANSF. - -(** Recognition of move operations. *) - -Definition is_move_operation - (A: Type) (op: operation) (args: list A) : option A := - match op, args with - | Omove, arg :: nil => Some arg - | _, _ => None - end. - -Lemma is_move_operation_correct: - forall (A: Type) (op: operation) (args: list A) (a: A), - is_move_operation op args = Some a -> - op = Omove /\ args = a :: nil. -Proof. - intros until a. unfold is_move_operation; destruct op; - try (intros; discriminate). - destruct args. intros; discriminate. - destruct args. intros. intuition congruence. - intros; discriminate. -Qed. - -(** Static typing of conditions, operators and addressing modes. *) +(** * Static typing of conditions, operators and addressing modes. *) Definition type_of_condition (c: condition) : list typ := match c with @@ -505,12 +328,18 @@ Lemma type_of_addressing_sound: forall addr vl sp v, eval_addressing genv sp addr vl = Some v -> Val.has_type v Tint. -Proof. - intros. destruct addr; simpl in H; FuncInv; try subst v; try exact I. - destruct (Genv.find_symbol genv i); inv H; exact I. - destruct (Genv.find_symbol genv i); inv H; exact I. - destruct (Genv.find_symbol genv i0); inv H; exact I. - unfold offset_sp in H. destruct sp; inv H; exact I. +Proof with (try exact I). + intros. destruct addr; simpl in H; FuncInv; subst; simpl. + destruct v0... + destruct v0... destruct v1... destruct v1... + destruct v0... + destruct v0... destruct v1... destruct v1... + unfold symbol_address; destruct (Genv.find_symbol genv i)... + unfold symbol_address; destruct (Genv.find_symbol genv i)... + unfold symbol_address; destruct (Genv.find_symbol genv i)... destruct v0... + destruct v0... + unfold symbol_address; destruct (Genv.find_symbol genv i0)... destruct v0... + destruct sp... Qed. Lemma type_of_operation_sound: @@ -518,46 +347,49 @@ Lemma type_of_operation_sound: op <> Omove -> eval_operation genv sp op vl m = Some v -> Val.has_type v (snd (type_of_operation op)). -Proof. +Proof with (try exact I). intros. - destruct op; simpl in H0; FuncInv; try subst v; try exact I. + destruct op; simpl in H0; FuncInv; subst; simpl. congruence. - destruct v0; exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct (eq_block b b0). injection H0; intro; subst v; exact I. - discriminate. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i (Int.repr 31)). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i0 Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i Int.iwordsize). - injection H0; intro; subst v; exact I. discriminate. - simpl. eapply type_of_addressing_sound; eauto. - destruct v0; exact I. - destruct (Float.intoffloat f); simpl in H0; inv H0. exact I. - destruct (eval_condition c vl). - destruct b; injection H0; intro; subst v; exact I. - discriminate. + exact I. + exact I. + destruct v0... + destruct v0... + destruct v0... + destruct v0... + destruct v0... + destruct v0; destruct v1... simpl. destruct (zeq b b0)... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1... + destruct v0... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... + destruct v0; simpl in H0; try discriminate. destruct (Int.ltu i (Int.repr 31)); inv H0... + destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... + destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... + eapply type_of_addressing_sound; eauto. + destruct v0... + destruct v0... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0; destruct v1... + destruct v0... + destruct v0; simpl in H0; inv H0. destruct (Float.intoffloat f); inv H2... + destruct v0; simpl in H0; inv H0... + destruct (eval_condition c vl m); simpl... destruct b... Qed. Lemma type_of_chunk_correct: @@ -575,292 +407,61 @@ Qed. End SOUNDNESS. -(** Alternate definition of [eval_condition], [eval_op], [eval_addressing] - as total functions that return [Vundef] when not applicable - (instead of [None]). Used in the proof of [Asmgen]. *) +(** * Manipulating and transforming operations *) -Section EVAL_OP_TOTAL. - -Variable F V: Type. -Variable genv: Genv.t F V. - -Definition find_symbol_offset (id: ident) (ofs: int) : val := - match Genv.find_symbol genv id with - | Some b => Vptr b ofs - | None => Vundef - end. - -Definition eval_condition_total (cond: condition) (vl: list val) : val := - match cond, vl with - | Ccomp c, v1::v2::nil => Val.cmp c v1 v2 - | Ccompu c, v1::v2::nil => Val.cmpu c v1 v2 - | Ccompimm c n, v1::nil => Val.cmp c v1 (Vint n) - | Ccompuimm c n, v1::nil => Val.cmpu c v1 (Vint n) - | Ccompf c, v1::v2::nil => Val.cmpf c v1 v2 - | Cnotcompf c, v1::v2::nil => Val.notbool(Val.cmpf c v1 v2) - | Cmaskzero n, v1::nil => Val.notbool (Val.and v1 (Vint n)) - | Cmasknotzero n, v1::nil => Val.notbool(Val.notbool (Val.and v1 (Vint n))) - | _, _ => Vundef - end. - -Definition eval_addressing_total - (sp: val) (addr: addressing) (vl: list val) : val := - match addr, vl with - | Aindexed n, v1::nil => Val.add v1 (Vint n) - | Aindexed2 n, v1::v2::nil => Val.add (Val.add v1 v2) (Vint n) - | Ascaled sc ofs, v1::nil => Val.add (Val.mul v1 (Vint sc)) (Vint ofs) - | Aindexed2scaled sc ofs, v1::v2::nil => - Val.add v1 (Val.add (Val.mul v2 (Vint sc)) (Vint ofs)) - | Aglobal s ofs, nil => find_symbol_offset s ofs - | Abased s ofs, v1::nil => Val.add (find_symbol_offset s ofs) v1 - | Abasedscaled sc s ofs, v1::nil => Val.add (find_symbol_offset s ofs) (Val.mul v1 (Vint sc)) - | Ainstack ofs, nil => Val.add sp (Vint ofs) - | _, _ => Vundef - end. +(** Recognition of move operations. *) -Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val := - match op, vl with - | Omove, v1::nil => v1 - | Ointconst n, nil => Vint n - | Ofloatconst n, nil => Vfloat n - | Ocast8signed, v1::nil => Val.sign_ext 8 v1 - | Ocast8unsigned, v1::nil => Val.zero_ext 8 v1 - | Ocast16signed, v1::nil => Val.sign_ext 16 v1 - | Ocast16unsigned, v1::nil => Val.zero_ext 16 v1 - | Oneg, v1::nil => Val.neg v1 - | Osub, v1::v2::nil => Val.sub v1 v2 - | Omul, v1::v2::nil => Val.mul v1 v2 - | Omulimm n, v1::nil => Val.mul v1 (Vint n) - | Odiv, v1::v2::nil => Val.divs v1 v2 - | Odivu, v1::v2::nil => Val.divu v1 v2 - | Omod, v1::v2::nil => Val.mods v1 v2 - | Omodu, v1::v2::nil => Val.modu v1 v2 - | Oand, v1::v2::nil => Val.and v1 v2 - | Oandimm n, v1::nil => Val.and v1 (Vint n) - | Oor, v1::v2::nil => Val.or v1 v2 - | Oorimm n, v1::nil => Val.or v1 (Vint n) - | Oxor, v1::v2::nil => Val.xor v1 v2 - | Oxorimm n, v1::nil => Val.xor v1 (Vint n) - | Oshl, v1::v2::nil => Val.shl v1 v2 - | Oshlimm n, v1::nil => Val.shl v1 (Vint n) - | Oshr, v1::v2::nil => Val.shr v1 v2 - | Oshrimm n, v1::nil => Val.shr v1 (Vint n) - | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) - | Oshru, v1::v2::nil => Val.shru v1 v2 - | Oshruimm n, v1::nil => Val.shru v1 (Vint n) - | Ororimm n, v1::nil => Val.ror v1 (Vint n) - | Olea addr, _ => eval_addressing_total sp addr vl - | Onegf, v1::nil => Val.negf v1 - | Oabsf, v1::nil => Val.absf v1 - | Oaddf, v1::v2::nil => Val.addf v1 v2 - | Osubf, v1::v2::nil => Val.subf v1 v2 - | Omulf, v1::v2::nil => Val.mulf v1 v2 - | Odivf, v1::v2::nil => Val.divf v1 v2 - | Osingleoffloat, v1::nil => Val.singleoffloat v1 - | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ofloatofint, v1::nil => Val.floatofint v1 - | Ocmp c, _ => eval_condition_total c vl - | _, _ => Vundef +Definition is_move_operation + (A: Type) (op: operation) (args: list A) : option A := + match op, args with + | Omove, arg :: nil => Some arg + | _, _ => None end. -Lemma eval_compare_mismatch_weaken: - forall c b, - eval_compare_mismatch c = Some b -> - Val.cmp_mismatch c = Val.of_bool b. -Proof. - unfold eval_compare_mismatch. intros. destruct c; inv H; auto. -Qed. - -Lemma eval_compare_null_weaken: - forall n c b, - eval_compare_null c n = Some b -> - (if Int.eq n Int.zero then Val.cmp_mismatch c else Vundef) = Val.of_bool b. -Proof. - unfold eval_compare_null. - intros. destruct (Int.eq n Int.zero). apply eval_compare_mismatch_weaken. auto. - discriminate. -Qed. - -Lemma eval_condition_weaken: - forall c vl b m, - eval_condition c vl m = Some b -> - eval_condition_total c vl = Val.of_bool b. -Proof. - intros. - unfold eval_condition in H; destruct c; FuncInv; - try subst b; try reflexivity; simpl; - try (apply eval_compare_null_weaken; auto). - destruct (Mem.valid_pointer m b0 (Int.unsigned i) && - Mem.valid_pointer m b1 (Int.unsigned i0)); try discriminate. - unfold eq_block in H. destruct (zeq b0 b1). - congruence. - apply eval_compare_mismatch_weaken; auto. - symmetry. apply Val.notbool_negb_1. - symmetry. apply Val.notbool_negb_1. -Qed. - -Lemma eval_addressing_weaken: - forall sp addr vl v, - eval_addressing genv sp addr vl = Some v -> - eval_addressing_total sp addr vl = v. -Proof. - intros. - unfold eval_addressing in H; destruct addr; FuncInv; - try subst v; simpl; try reflexivity. - unfold find_symbol_offset. destruct (Genv.find_symbol genv i); congruence. - unfold find_symbol_offset. destruct (Genv.find_symbol genv i); simpl; congruence. - unfold find_symbol_offset. destruct (Genv.find_symbol genv i0); simpl; congruence. - unfold offset_sp in H. destruct sp; simpl; congruence. -Qed. - -Lemma eval_operation_weaken: - forall sp op vl v m, - eval_operation genv sp op vl m = Some v -> - eval_operation_total sp op vl = v. -Proof. - intros. - unfold eval_operation in H; destruct op; FuncInv; - try subst v; try reflexivity; simpl. - unfold eq_block in H. destruct (zeq b b0); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.ltu i0 Int.iwordsize); congruence. - destruct (Int.ltu i Int.iwordsize); congruence. - destruct (Int.ltu i0 Int.iwordsize); congruence. - destruct (Int.ltu i Int.iwordsize); congruence. - unfold Int.ltu in *. destruct (zlt (Int.unsigned i) (Int.unsigned (Int.repr 31))). - rewrite zlt_true. congruence. eapply Zlt_trans. eauto. compute; auto. - congruence. - destruct (Int.ltu i0 Int.iwordsize); congruence. - destruct (Int.ltu i Int.iwordsize); congruence. - destruct (Int.ltu i Int.iwordsize); congruence. - apply eval_addressing_weaken; auto. - destruct (Float.intoffloat f); simpl in H; inv H. auto. - caseEq (eval_condition c vl m); intros; rewrite H0 in H. - replace v with (Val.of_bool b). - eapply eval_condition_weaken; eauto. - destruct b; simpl; congruence. - discriminate. -Qed. - -Lemma eval_condition_total_is_bool: - forall cond vl, Val.is_bool (eval_condition_total cond vl). +Lemma is_move_operation_correct: + forall (A: Type) (op: operation) (args: list A) (a: A), + is_move_operation op args = Some a -> + op = Omove /\ args = a :: nil. Proof. - intros; destruct cond; - destruct vl; try apply Val.undef_is_bool; - destruct vl; try apply Val.undef_is_bool; - try (destruct vl; try apply Val.undef_is_bool); simpl. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmpf_is_bool. - apply Val.notbool_is_bool. - apply Val.notbool_is_bool. - apply Val.notbool_is_bool. + intros until a. unfold is_move_operation; destruct op; + try (intros; discriminate). + destruct args. intros; discriminate. + destruct args. intros. intuition congruence. + intros; discriminate. Qed. -End EVAL_OP_TOTAL. - -(** Compatibility of the evaluation functions with the - ``is less defined'' relation over values. *) - -Section EVAL_LESSDEF. - -Variable F V: Type. -Variable genv: Genv.t F V. - -Ltac InvLessdef := - match goal with - | [ H: Val.lessdef (Vint _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef (Vfloat _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef (Vptr _ _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef_list nil _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef_list (_ :: _) _ |- _ ] => - inv H; InvLessdef - | _ => idtac - end. - -Lemma eval_condition_lessdef: - forall cond vl1 vl2 b m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. destruct cond; simpl in *; FuncInv; InvLessdef; auto. - destruct (Mem.valid_pointer m1 b0 (Int.unsigned i) && - Mem.valid_pointer m1 b1 (Int.unsigned i0)) as [] _eqn; try discriminate. - destruct (andb_prop _ _ Heqb2) as [A B]. - assert (forall b ofs, Mem.valid_pointer m1 b ofs = true -> Mem.valid_pointer m2 b ofs = true). - intros until ofs. repeat rewrite Mem.valid_pointer_nonempty_perm. - apply Mem.perm_extends; auto. - rewrite (H _ _ A). rewrite (H _ _ B). auto. -Qed. +(** [negate_condition cond] returns a condition that is logically + equivalent to the negation of [cond]. *) -Ltac TrivialExists := - match goal with - | [ |- exists v2, Some ?v1 = Some v2 /\ Val.lessdef ?v1 v2 ] => - exists v1; split; [auto | constructor] - | _ => idtac +Definition negate_condition (cond: condition): condition := + match cond with + | Ccomp c => Ccomp(negate_comparison c) + | Ccompu c => Ccompu(negate_comparison c) + | Ccompimm c n => Ccompimm (negate_comparison c) n + | Ccompuimm c n => Ccompuimm (negate_comparison c) n + | Ccompf c => Cnotcompf c + | Cnotcompf c => Ccompf c + | Cmaskzero n => Cmasknotzero n + | Cmasknotzero n => Cmaskzero n end. -Lemma eval_addressing_lessdef: - forall sp addr vl1 vl2 v1, - Val.lessdef_list vl1 vl2 -> - eval_addressing genv sp addr vl1 = Some v1 -> - exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. -Proof. - intros. destruct addr; simpl in *; FuncInv; InvLessdef; TrivialExists. - destruct (Genv.find_symbol genv i); inv H0. TrivialExists. - destruct (Genv.find_symbol genv i); inv H0. TrivialExists. - destruct (Genv.find_symbol genv i0); inv H0. TrivialExists. - exists v1; auto. -Qed. - -Lemma eval_operation_lessdef: - forall sp op vl1 vl2 v1 m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> - eval_operation genv sp op vl1 m1 = Some v1 -> - exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. +Lemma eval_negate_condition: + forall cond vl m b, + eval_condition cond vl m = Some b -> + eval_condition (negate_condition cond) vl m = Some (negb b). Proof. - intros. destruct op; simpl in *; FuncInv; InvLessdef; TrivialExists. - exists v2; auto. - exists (Val.sign_ext 8 v2); split. auto. apply Val.sign_ext_lessdef; auto. - exists (Val.zero_ext 8 v2); split. auto. apply Val.zero_ext_lessdef; auto. - exists (Val.sign_ext 16 v2); split. auto. apply Val.sign_ext_lessdef; auto. - exists (Val.zero_ext 16 v2); split. auto. apply Val.zero_ext_lessdef; auto. - destruct (eq_block b b0); inv H1. TrivialExists. - destruct (Int.eq i0 Int.zero); inv H1; TrivialExists. - destruct (Int.eq i0 Int.zero); inv H1; TrivialExists. - destruct (Int.eq i0 Int.zero); inv H1; TrivialExists. - destruct (Int.eq i0 Int.zero); inv H1; TrivialExists. - destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialExists. - destruct (Int.ltu i Int.iwordsize); inv H1; TrivialExists. - destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialExists. - destruct (Int.ltu i Int.iwordsize); inv H1; TrivialExists. - destruct (Int.ltu i (Int.repr 31)); inv H1; TrivialExists. - destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialExists. - destruct (Int.ltu i Int.iwordsize); inv H1; TrivialExists. - destruct (Int.ltu i Int.iwordsize); inv H1; TrivialExists. - eapply eval_addressing_lessdef; eauto. - exists (Val.singleoffloat v2); split. auto. apply Val.singleoffloat_lessdef; auto. - exists v1; split; auto. - destruct (eval_condition c vl1 m1) as [] _eqn. - rewrite (eval_condition_lessdef c H H0 Heqo). - destruct b; inv H1; TrivialExists. - discriminate. + intros. + destruct cond; simpl in H; FuncInv; simpl. + rewrite Val.negate_cmp_bool; rewrite H; auto. + rewrite Val.negate_cmpu_bool; rewrite H; auto. + rewrite Val.negate_cmp_bool; rewrite H; auto. + rewrite Val.negate_cmpu_bool; rewrite H; auto. + rewrite H; auto. + destruct (Val.cmpf_bool c v v0); simpl in H; inv H. rewrite negb_elim; auto. + rewrite H0; auto. + rewrite <- H0. rewrite negb_elim; auto. Qed. -End EVAL_LESSDEF. - (** Shifting stack-relative references. This is used in [Stacking]. *) Definition shift_stack_addressing (delta: int) (addr: addressing) := @@ -887,132 +488,24 @@ Proof. intros. destruct op; auto. simpl. decEq. apply type_shift_stack_addressing. Qed. -(** Compatibility of the evaluation functions with memory injections. *) - -Section EVAL_INJECT. - -Variable F V: Type. -Variable genv: Genv.t F V. -Variable f: meminj. -Hypothesis globals: meminj_preserves_globals genv f. -Variable sp1: block. -Variable sp2: block. -Variable delta: Z. -Hypothesis sp_inj: f sp1 = Some(sp2, delta). - -Ltac InvInject := - match goal with - | [ H: val_inject _ (Vint _) _ |- _ ] => - inv H; InvInject - | [ H: val_inject _ (Vfloat _) _ |- _ ] => - inv H; InvInject - | [ H: val_inject _ (Vptr _ _) _ |- _ ] => - inv H; InvInject - | [ H: val_list_inject _ nil _ |- _ ] => - inv H; InvInject - | [ H: val_list_inject _ (_ :: _) _ |- _ ] => - inv H; InvInject - | _ => idtac - end. - -Lemma eval_condition_inject: - forall cond vl1 vl2 b m1 m2, - val_list_inject f vl1 vl2 -> - Mem.inject f m1 m2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. destruct cond; simpl in *; FuncInv; InvInject; auto. - destruct (Mem.valid_pointer m1 b0 (Int.unsigned i)) as [] _eqn; try discriminate. - destruct (Mem.valid_pointer m1 b1 (Int.unsigned i0)) as [] _eqn; try discriminate. - simpl in H1. - exploit Mem.valid_pointer_inject_val. eauto. eexact Heqb0. econstructor; eauto. - intros V1. rewrite V1. - exploit Mem.valid_pointer_inject_val. eauto. eexact Heqb2. econstructor; eauto. - intros V2. rewrite V2. - simpl. - destruct (eq_block b0 b1); inv H1. - rewrite H3 in H5; inv H5. rewrite dec_eq_true. - decEq. apply Int.translate_cmpu. - eapply Mem.valid_pointer_inject_no_overflow; eauto. - eapply Mem.valid_pointer_inject_no_overflow; eauto. - exploit Mem.different_pointers_inject; eauto. intros P. - destruct (eq_block b3 b4); auto. - destruct P. contradiction. - destruct c; unfold eval_compare_mismatch in *; inv H2. - unfold Int.cmpu. rewrite Int.eq_false; auto. congruence. - unfold Int.cmpu. rewrite Int.eq_false; auto. congruence. -Qed. - -Ltac TrivialExists2 := - match goal with - | [ |- exists v2, Some ?v1 = Some v2 /\ val_inject _ _ v2 ] => - exists v1; split; [auto | econstructor; eauto] - | _ => idtac - end. - -Lemma eval_addressing_inject: - forall addr vl1 vl2 v1, - val_list_inject f vl1 vl2 -> - eval_addressing genv (Vptr sp1 Int.zero) addr vl1 = Some v1 -> - exists v2, - eval_addressing genv (Vptr sp2 Int.zero) (shift_stack_addressing (Int.repr delta) addr) vl2 = Some v2 - /\ val_inject f v1 v2. +Lemma eval_shift_stack_addressing: + forall F V (ge: Genv.t F V) sp addr vl delta, + eval_addressing ge sp (shift_stack_addressing delta addr) vl = + eval_addressing ge (Val.add sp (Vint delta)) addr vl. Proof. - intros. destruct addr; simpl in *; FuncInv; InvInject; TrivialExists2. - repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - repeat rewrite Int.add_assoc. decEq. rewrite Int.add_commut. apply Int.add_assoc. - repeat rewrite Int.add_assoc. decEq. rewrite Int.add_commut. apply Int.add_assoc. - repeat rewrite Int.add_assoc. decEq. rewrite Int.add_commut. apply Int.add_assoc. - destruct (Genv.find_symbol genv i) as [] _eqn; inv H0. - TrivialExists2. eapply (proj1 globals); eauto. rewrite Int.add_zero; auto. - destruct (Genv.find_symbol genv i) as [] _eqn; inv H0. - TrivialExists2. eapply (proj1 globals); eauto. rewrite Int.add_zero; auto. - destruct (Genv.find_symbol genv i0) as [] _eqn; inv H0. - TrivialExists2. eapply (proj1 globals); eauto. rewrite Int.add_zero; auto. - rewrite Int.add_assoc. decEq. apply Int.add_commut. + intros. destruct addr; simpl; auto. + rewrite Val.add_assoc. simpl. auto. Qed. -Lemma eval_operation_inject: - forall op vl1 vl2 v1 m1 m2, - val_list_inject f vl1 vl2 -> - Mem.inject f m1 m2 -> - eval_operation genv (Vptr sp1 Int.zero) op vl1 m1 = Some v1 -> - exists v2, - eval_operation genv (Vptr sp2 Int.zero) (shift_stack_operation (Int.repr delta) op) vl2 m2 = Some v2 - /\ val_inject f v1 v2. +Lemma eval_shift_stack_operation: + forall F V (ge: Genv.t F V) sp op vl m delta, + eval_operation ge sp (shift_stack_operation delta op) vl m = + eval_operation ge (Val.add sp (Vint delta)) op vl m. Proof. - intros. destruct op; simpl in *; FuncInv; InvInject; TrivialExists2. - exists v'; auto. - exists (Val.sign_ext 8 v'); split; auto. inv H4; simpl; auto. - exists (Val.zero_ext 8 v'); split; auto. inv H4; simpl; auto. - exists (Val.sign_ext 16 v'); split; auto. inv H4; simpl; auto. - exists (Val.zero_ext 16 v'); split; auto. inv H4; simpl; auto. - rewrite Int.sub_add_l. auto. - destruct (eq_block b b0); inv H1. rewrite H3 in H5; inv H5. rewrite dec_eq_true. - rewrite Int.sub_shifted. TrivialExists2. - destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. - destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. - destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. - destruct (Int.eq i0 Int.zero); inv H1. TrivialExists2. - destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialExists2. - destruct (Int.ltu i Int.iwordsize); inv H1. TrivialExists2. - destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialExists2. - destruct (Int.ltu i Int.iwordsize); inv H1. TrivialExists2. - destruct (Int.ltu i (Int.repr 31)); inv H1. TrivialExists2. - destruct (Int.ltu i0 Int.iwordsize); inv H1. TrivialExists2. - destruct (Int.ltu i Int.iwordsize); inv H1. TrivialExists2. - destruct (Int.ltu i Int.iwordsize); inv H1. TrivialExists2. - eapply eval_addressing_inject; eauto. - exists (Val.singleoffloat v'); split; auto. inv H4; simpl; auto. - destruct (Float.intoffloat f0); simpl in *; inv H1. TrivialExists2. - destruct (eval_condition c vl1 m1) as [] _eqn; try discriminate. - exploit eval_condition_inject; eauto. intros EQ; rewrite EQ. - destruct b; inv H1; TrivialExists2. + intros. destruct op; simpl; auto. + apply eval_shift_stack_addressing. Qed. -End EVAL_INJECT. - (** Transformation of addressing modes with two operands or more into an equivalent arithmetic operation. This is used in the [Reload] pass when a store instruction cannot be reloaded directly because @@ -1037,6 +530,7 @@ Proof. intros. simpl. auto. Qed. + (** Two-address operations. Return [true] if the first argument and the result must be in the same location. *) @@ -1109,7 +603,387 @@ Lemma op_depends_on_memory_correct: eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. intros until m2. destruct op; simpl; try congruence. - destruct c; simpl; congruence. + destruct c; simpl; try congruence. reflexivity. Qed. +(** * Invariance and compatibility properties. *) + +(** [eval_operation] and [eval_addressing] depend on a global environment + for resolving references to global symbols. We show that they give + the same results if a global environment is replaced by another that + assigns the same addresses to the same symbols. *) + +Section GENV_TRANSF. + +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. +Hypothesis agree_on_symbols: + forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. + +Lemma eval_addressing_preserved: + forall sp addr vl, + eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. +Proof. + intros. + unfold eval_addressing, symbol_address; destruct addr; try rewrite agree_on_symbols; + reflexivity. +Qed. + +Lemma eval_operation_preserved: + forall sp op vl m, + eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. +Proof. + intros. + unfold eval_operation; destruct op; auto. + apply eval_addressing_preserved. +Qed. + +End GENV_TRANSF. + +(** Compatibility of the evaluation functions with value injections. *) + +Section EVAL_COMPAT. + +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. + +Hypothesis symbol_address_inj: + forall id ofs, + val_inject f (symbol_address genv id ofs) (symbol_address genv id ofs). + +Variable m1: mem. +Variable m2: mem. + +Hypothesis valid_pointer_inj: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + +Hypothesis valid_pointer_no_overflow: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + +Hypothesis valid_different_pointers_inj: + forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)). + +Ltac InvInject := + match goal with + | [ H: val_inject _ (Vint _) _ |- _ ] => + inv H; InvInject + | [ H: val_inject _ (Vfloat _) _ |- _ ] => + inv H; InvInject + | [ H: val_inject _ (Vptr _ _) _ |- _ ] => + inv H; InvInject + | [ H: val_list_inject _ nil _ |- _ ] => + inv H; InvInject + | [ H: val_list_inject _ (_ :: _) _ |- _ ] => + inv H; InvInject + | _ => idtac + end. + +Remark val_add_inj: + forall v1 v1' v2 v2', + val_inject f v1 v1' -> val_inject f v2 v2' -> val_inject f (Val.add v1 v2) (Val.add v1' v2'). +Proof. + intros. inv H; inv H0; simpl; econstructor; eauto. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. +Qed. + +Lemma eval_condition_inj: + forall cond vl1 vl2 b, + val_list_inject f vl1 vl2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. +Opaque Int.add. + assert (CMPU: + forall c v1 v2 v1' v2' b, + val_inject f v1 v1' -> + val_inject f v2 v2' -> + Val.cmpu_bool (Mem.valid_pointer m1) c v1 v2 = Some b -> + Val.cmpu_bool (Mem.valid_pointer m2) c v1' v2' = Some b). + intros. inv H; simpl in H1; try discriminate; inv H0; simpl in H1; try discriminate; simpl; auto. + destruct (Mem.valid_pointer m1 b1 (Int.unsigned ofs1)) as []_eqn; try discriminate. + destruct (Mem.valid_pointer m1 b0 (Int.unsigned ofs0)) as []_eqn; try discriminate. + rewrite (valid_pointer_inj _ H2 Heqb4). + rewrite (valid_pointer_inj _ H Heqb0). simpl. + destruct (zeq b1 b0); simpl in H1. + inv H1. rewrite H in H2; inv H2. rewrite zeq_true. + decEq. apply Int.translate_cmpu. + eapply valid_pointer_no_overflow; eauto. + eapply valid_pointer_no_overflow; eauto. + exploit valid_different_pointers_inj; eauto. intros P. + destruct (zeq b2 b3); auto. + destruct P. congruence. + destruct c; simpl in H1; inv H1. + simpl; decEq. rewrite Int.eq_false; auto. congruence. + simpl; decEq. rewrite Int.eq_false; auto. congruence. + + intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. + inv H3; inv H2; simpl in H0; inv H0; auto. + eauto. + inv H3; simpl in H0; inv H0; auto. + eauto. + inv H3; inv H2; simpl in H0; inv H0; auto. + inv H3; inv H2; simpl in H0; inv H0; auto. +Qed. + +Ltac TrivialExists := + match goal with + | [ |- exists v2, Some ?v1 = Some v2 /\ val_inject _ _ v2 ] => + exists v1; split; auto + | _ => idtac + end. + +Lemma eval_addressing_inj: + forall addr sp1 vl1 sp2 vl2 v1, + val_inject f sp1 sp2 -> + val_list_inject f vl1 vl2 -> + eval_addressing genv sp1 addr vl1 = Some v1 -> + exists v2, eval_addressing genv sp2 addr vl2 = Some v2 /\ val_inject f v1 v2. +Proof. + intros. destruct addr; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + apply val_add_inj; auto. + apply val_add_inj; auto. apply val_add_inj; auto. + apply val_add_inj; auto. inv H4; simpl; auto. + apply val_add_inj; auto. apply val_add_inj; auto. inv H2; simpl; auto. + apply val_add_inj; auto. + apply val_add_inj; auto. inv H4; simpl; auto. + apply val_add_inj; auto. +Qed. + +Lemma eval_operation_inj: + forall op sp1 vl1 sp2 vl2 v1, + val_inject f sp1 sp2 -> + val_list_inject f vl1 vl2 -> + eval_operation genv sp1 op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp2 op vl2 m2 = Some v2 /\ val_inject f v1 v2. +Proof. + intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. econstructor; eauto. + rewrite Int.sub_add_l. auto. + destruct (zeq b1 b0); auto. subst. rewrite H1 in H0. inv H0. rewrite zeq_true. + rewrite Int.sub_shifted. auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. + inv H4; simpl in H1; try discriminate. simpl. + destruct (Int.ltu i (Int.repr 31)); inv H1. TrivialExists. + inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. + inv H4; simpl; auto. destruct (Int.ltu i Int.iwordsize); auto. + eapply eval_addressing_inj; eauto. + inv H4; simpl; auto. + inv H4; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; inv H2; simpl; auto. + inv H4; simpl; auto. + inv H4; simpl in H1; inv H1. simpl. destruct (Float.intoffloat f0); simpl in H2; inv H2. + exists (Vint i); auto. + inv H4; simpl in H1; inv H1. simpl. TrivialExists. + subst v1. destruct (eval_condition c vl1 m1) as []_eqn. + exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. + destruct b; simpl; constructor. + simpl; constructor. +Qed. + +End EVAL_COMPAT. + +(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) + +Section EVAL_LESSDEF. + +Variable F V: Type. +Variable genv: Genv.t F V. + +Remark valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. +Proof. + intros. inv H0. rewrite Int.add_zero. eapply Mem.valid_pointer_extends; eauto. +Qed. + +Remark valid_pointer_no_overflow_extends: + forall m1 b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> + 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. +Proof. + intros. inv H. rewrite Zplus_0_r. apply Int.unsigned_range_2. +Qed. + +Remark valid_different_pointers_extends: + forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + Some(b1, 0) = Some (b1', delta1) -> + Some(b2, 0) = Some (b2', delta2) -> + b1' <> b2' \/ + Int.unsigned(Int.add ofs1 (Int.repr delta1)) <> Int.unsigned(Int.add ofs2 (Int.repr delta2)). +Proof. + intros. inv H2; inv H3. auto. +Qed. + +Lemma eval_condition_lessdef: + forall cond vl1 vl2 b m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1). + apply valid_pointer_extends; auto. + apply valid_pointer_no_overflow_extends; auto. + apply valid_different_pointers_extends; auto. + rewrite <- val_list_inject_lessdef. eauto. auto. +Qed. + +Lemma eval_operation_lessdef: + forall sp op vl1 vl2 v1 m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_operation genv sp op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. rewrite val_list_inject_lessdef in H. + assert (exists v2 : val, + eval_operation genv sp op vl2 m2 = Some v2 + /\ val_inject (fun b => Some(b, 0)) v1 v2). + eapply eval_operation_inj with (m1 := m1) (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + apply valid_pointer_extends; auto. + apply valid_pointer_no_overflow_extends; auto. + apply valid_different_pointers_extends; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + +Lemma eval_addressing_lessdef: + forall sp addr vl1 vl2 v1, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = Some v1 -> + exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. rewrite val_list_inject_lessdef in H. + assert (exists v2 : val, + eval_addressing genv sp addr vl2 = Some v2 + /\ val_inject (fun b => Some(b, 0)) v1 v2). + eapply eval_addressing_inj with (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + +End EVAL_LESSDEF. + +(** Compatibility of the evaluation functions with memory injections. *) + +Section EVAL_INJECT. + +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. +Hypothesis globals: meminj_preserves_globals genv f. +Variable sp1: block. +Variable sp2: block. +Variable delta: Z. +Hypothesis sp_inj: f sp1 = Some(sp2, delta). + +Remark symbol_address_inject: + forall id ofs, val_inject f (symbol_address genv id ofs) (symbol_address genv id ofs). +Proof. + intros. unfold symbol_address. destruct (Genv.find_symbol genv id) as []_eqn; auto. + exploit (proj1 globals); eauto. intros. + econstructor; eauto. rewrite Int.add_zero; auto. +Qed. + +Lemma eval_condition_inject: + forall cond vl1 vl2 b m1 m2, + val_list_inject f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. +Qed. + +Lemma eval_addressing_inject: + forall addr vl1 vl2 v1, + val_list_inject f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Int.zero) addr vl1 = Some v1 -> + exists v2, + eval_addressing genv (Vptr sp2 Int.zero) (shift_stack_addressing (Int.repr delta) addr) vl2 = Some v2 + /\ val_inject f v1 v2. +Proof. + intros. + rewrite eval_shift_stack_addressing. simpl. + eapply eval_addressing_inj with (sp1 := Vptr sp1 Int.zero); eauto. + exact symbol_address_inject. +Qed. + +Lemma eval_operation_inject: + forall op vl1 vl2 v1 m1 m2, + val_list_inject f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_operation genv (Vptr sp1 Int.zero) op vl1 m1 = Some v1 -> + exists v2, + eval_operation genv (Vptr sp2 Int.zero) (shift_stack_operation (Int.repr delta) op) vl2 m2 = Some v2 + /\ val_inject f v1 v2. +Proof. + intros. + rewrite eval_shift_stack_operation. simpl. + eapply eval_operation_inj with (sp1 := Vptr sp1 Int.zero) (m1 := m1); eauto. + exact symbol_address_inject. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. +Qed. + +End EVAL_INJECT. diff --git a/ia32/SelectOp.v b/ia32/SelectOp.v deleted file mode 100644 index c1f5703..0000000 --- a/ia32/SelectOp.v +++ /dev/null @@ -1,839 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Instruction selection for operators *) - -(** The instruction selection pass recognizes opportunities for using - combined arithmetic and logical operations and addressing modes - offered by the target processor. For instance, the expression [x + 1] - can take advantage of the "immediate add" instruction of the processor, - and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned - into a "rotate and mask" instruction. - - This file defines functions for building CminorSel expressions and - statements, especially expressions consisting of operator - applications. These functions examine their arguments to choose - cheaper forms of operators whenever possible. - - For instance, [add e1 e2] will return a CminorSel expression semantically - equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a - [Oaddimm] operator if one of the arguments is an integer constant, - or suppress the addition altogether if one of the arguments is the - null integer. In passing, we perform operator reassociation - ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount - of constant propagation. - - On top of the "smart constructor" functions defined below, - module [Selection] implements the actual instruction selection pass. -*) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Cminor. -Require Import Op. -Require Import CminorSel. - -Open Local Scope cminorsel_scope. - -(** ** Constants **) - -Definition addrsymbol (id: ident) (ofs: int) := - Eop (Olea (Aglobal id ofs)) Enil. - -Definition addrstack (ofs: int) := - Eop (Olea (Ainstack ofs)) Enil. - -(** ** Boolean negation *) - -Definition notbool_base (e: expr) := - Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil). - -Fixpoint notbool (e: expr) {struct e} : expr := - match e with - | Eop (Ointconst n) Enil => - Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil - | Eop (Ocmp cond) args => - Eop (Ocmp (negate_condition cond)) args - | Econdition e1 e2 e3 => - Econdition e1 (notbool e2) (notbool e3) - | _ => - notbool_base e - end. - -(** ** Integer addition and pointer addition *) - -Definition offset_addressing (a: addressing) (ofs: int) : addressing := - match a with - | Aindexed n => Aindexed (Int.add n ofs) - | Aindexed2 n => Aindexed2 (Int.add n ofs) - | Ascaled sc n => Ascaled sc (Int.add n ofs) - | Aindexed2scaled sc n => Aindexed2scaled sc (Int.add n ofs) - | Aglobal id n => Aglobal id (Int.add n ofs) - | Abased id n => Abased id (Int.add n ofs) - | Abasedscaled sc id n => Abasedscaled sc id (Int.add n ofs) - | Ainstack n => Ainstack (Int.add n ofs) - end. - -(** Addition of an integer constant *) - -(* -Definition addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match e with - | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil - | Eop (Olea addr) args => Eop (Olea (offset_addressing addr n)) args - | _ => Eop (Olea (Aindexed n)) (e ::: Enil) - end. -*) - -Inductive addimm_cases: forall (e: expr), Type := - | addimm_case1: - forall m, - addimm_cases (Eop (Ointconst m) Enil) - | addimm_case2: - forall addr args, - addimm_cases (Eop (Olea addr) args) - | addimm_default: - forall (e: expr), - addimm_cases e. - -Definition addimm_match (e: expr) := - match e as z1 return addimm_cases z1 with - | Eop (Ointconst m) Enil => - addimm_case1 m - | Eop (Olea addr) args => - addimm_case2 addr args - | e => - addimm_default e - end. - -Definition addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match addimm_match e with - | addimm_case1 m => - Eop (Ointconst(Int.add n m)) Enil - | addimm_case2 addr args => - Eop (Olea (offset_addressing addr n)) args - | addimm_default e => - Eop (Olea (Aindexed n)) (e ::: Enil) - end. - -(** Addition of two integer or pointer expressions *) - -(* -Definition add (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 - | t1, Eop (Ointconst n2) Enil => addimm n2 t1 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => Eop (Olea (Aindexed2 (Int.add n1 n2))) (t1:::t2:::Enil) - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t1:::t2:::Enil) - | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t2:::t1:::Enil) - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil) => Eop (Olea (Abased id (Int.add ofs n1))) (t1:::Enil) - | Eop (Olea (Aglobal id ofs)) Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => Eop (Olea (Abased id (Int.add ofs n2))) (t2:::Enil) - | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil) => Eop (Olea (Abasedscaled sc id (Int.add ofs n1))) (t1:::Enil) - | Eop (Olea (Aglobal id ofs)) Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => Eop (Olea (Abasedscaled sc id (Int.add ofs n2))) (t2:::Enil) - | Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 => Eop (Olea (Aindexed2scaled sc n)) (t2:::t1:::Enil) - | t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) => Eop (Olea (Aindexed2scaled sc n)) (t1:::t2:::Enil) - | Eop (Olea (Aindexed n)) (t1:::Enil), t2 => Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) - | t1, Eop (Olea (Aindexed n)) (t2:::Enil) => Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) - | _, _ => Eop (Olea (Aindexed2 Int.zero)) (e1:::e2:::Enil) - end. -*) - -Inductive add_cases: forall (e1: expr) (e2: expr), Type := - | add_case1: - forall n1 t2, - add_cases (Eop (Ointconst n1) Enil) (t2) - | add_case2: - forall t1 n2, - add_cases (t1) (Eop (Ointconst n2) Enil) - | add_case3: - forall n1 t1 n2 t2, - add_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Aindexed n2)) (t2:::Enil)) - | add_case4: - forall n1 t1 sc n2 t2, - add_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Ascaled sc n2)) (t2:::Enil)) - | add_case5: - forall sc n1 t1 n2 t2, - add_cases (Eop (Olea (Ascaled sc n1)) (t1:::Enil)) (Eop (Olea (Aindexed n2)) (t2:::Enil)) - | add_case6: - forall n1 t1 id ofs, - add_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Aglobal id ofs)) Enil) - | add_case7: - forall id ofs n2 t2, - add_cases (Eop (Olea (Aglobal id ofs)) Enil) (Eop (Olea (Aindexed n2)) (t2:::Enil)) - | add_case8: - forall sc n1 t1 id ofs, - add_cases (Eop (Olea (Ascaled sc n1)) (t1:::Enil)) (Eop (Olea (Aglobal id ofs)) Enil) - | add_case9: - forall id ofs sc n2 t2, - add_cases (Eop (Olea (Aglobal id ofs)) Enil) (Eop (Olea (Ascaled sc n2)) (t2:::Enil)) - | add_case10: - forall sc n t1 t2, - add_cases (Eop (Olea (Ascaled sc n)) (t1:::Enil)) (t2) - | add_case11: - forall t1 sc n t2, - add_cases (t1) (Eop (Olea (Ascaled sc n)) (t2:::Enil)) - | add_case12: - forall n t1 t2, - add_cases (Eop (Olea (Aindexed n)) (t1:::Enil)) (t2) - | add_case13: - forall t1 n t2, - add_cases (t1) (Eop (Olea (Aindexed n)) (t2:::Enil)) - | add_default: - forall (e1: expr) (e2: expr), - add_cases e1 e2. - -Definition add_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return add_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - add_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => - add_case2 t1 n2 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => - add_case3 n1 t1 n2 t2 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => - add_case4 n1 t1 sc n2 t2 - | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => - add_case5 sc n1 t1 n2 t2 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => - add_case6 n1 t1 id ofs - | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Aindexed n2)) (t2:::Enil) => - add_case7 id ofs n2 t2 - | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => - add_case8 sc n1 t1 id ofs - | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Ascaled sc n2)) (t2:::Enil) => - add_case9 id ofs sc n2 t2 - | Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 => - add_case10 sc n t1 t2 - | t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) => - add_case11 t1 sc n t2 - | Eop (Olea (Aindexed n)) (t1:::Enil), t2 => - add_case12 n t1 t2 - | t1, Eop (Olea (Aindexed n)) (t2:::Enil) => - add_case13 t1 n t2 - | e1, e2 => - add_default e1 e2 - end. - -Definition add (e1: expr) (e2: expr) := - match add_match e1 e2 with - | add_case1 n1 t2 => - addimm n1 t2 - | add_case2 t1 n2 => - addimm n2 t1 - | add_case3 n1 t1 n2 t2 => - Eop (Olea (Aindexed2 (Int.add n1 n2))) (t1:::t2:::Enil) - | add_case4 n1 t1 sc n2 t2 => - Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t1:::t2:::Enil) - | add_case5 sc n1 t1 n2 t2 => - Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t2:::t1:::Enil) - | add_case6 n1 t1 id ofs => - Eop (Olea (Abased id (Int.add ofs n1))) (t1:::Enil) - | add_case7 id ofs n2 t2 => - Eop (Olea (Abased id (Int.add ofs n2))) (t2:::Enil) - | add_case8 sc n1 t1 id ofs => - Eop (Olea (Abasedscaled sc id (Int.add ofs n1))) (t1:::Enil) - | add_case9 id ofs sc n2 t2 => - Eop (Olea (Abasedscaled sc id (Int.add ofs n2))) (t2:::Enil) - | add_case10 sc n t1 t2 => - Eop (Olea (Aindexed2scaled sc n)) (t2:::t1:::Enil) - | add_case11 t1 sc n t2 => - Eop (Olea (Aindexed2scaled sc n)) (t1:::t2:::Enil) - | add_case12 n t1 t2 => - Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) - | add_case13 t1 n t2 => - Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) - | add_default e1 e2 => - Eop (Olea (Aindexed2 Int.zero)) (e1:::e2:::Enil) - end. - -(** ** Integer and pointer subtraction *) - -(* -Definition sub (e1: expr) (e2: expr) := - match e1, e2 with - | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 => addimm n1 (Eop Osub (t1:::t2:::Enil)) - | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) - | _, _ => Eop Osub (e1:::e2:::Enil) - end. -*) - -Inductive sub_cases: forall (e1: expr) (e2: expr), Type := - | sub_case1: - forall t1 n2, - sub_cases (t1) (Eop (Ointconst n2) Enil) - | sub_case2: - forall n1 t1 n2 t2, - sub_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Aindexed n2)) (t2:::Enil)) - | sub_case3: - forall n1 t1 t2, - sub_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (t2) - | sub_case4: - forall t1 n2 t2, - sub_cases (t1) (Eop (Olea (Aindexed n2)) (t2:::Enil)) - | sub_default: - forall (e1: expr) (e2: expr), - sub_cases e1 e2. - -Definition sub_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return sub_cases z1 z2 with - | t1, Eop (Ointconst n2) Enil => - sub_case1 t1 n2 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => - sub_case2 n1 t1 n2 t2 - | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 => - sub_case3 n1 t1 t2 - | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) => - sub_case4 t1 n2 t2 - | e1, e2 => - sub_default e1 e2 - end. - -Definition sub (e1: expr) (e2: expr) := - match sub_match e1 e2 with - | sub_case1 t1 n2 => - addimm (Int.neg n2) t1 - | sub_case2 n1 t1 n2 t2 => - addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | sub_case3 n1 t1 t2 => - addimm n1 (Eop Osub (t1:::t2:::Enil)) - | sub_case4 t1 n2 t2 => - addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) - | sub_default e1 e2 => - Eop Osub (e1:::e2:::Enil) - end. - -(** ** Immediate shifts *) - -Definition shift_is_scale (n: int) : bool := - Int.eq n (Int.repr 1) || Int.eq n (Int.repr 2) || Int.eq n (Int.repr 3). - -(* -Definition shlimm (e1: expr) := - if Int.eq n Int.zero then e1 else - match e1 with - | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shl n1 n)) - | Eop (Oshlimm n1) (t1:::Enil) => if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - | Eop (Olea (Aindexed n1)) (t1:::Enil) => if shift_is_scale n then Eop (Olea (Ascaled (Int.shl Int.one n) (Int.shl n1 n))) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - | _ => if shift_is_scale n then Eop (Olea (Ascaled (Int.shl Int.one n) Int.zero) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - end. -*) - -Inductive shlimm_cases: forall (e1: expr), Type := - | shlimm_case1: - forall n1, - shlimm_cases (Eop (Ointconst n1) Enil) - | shlimm_case2: - forall n1 t1, - shlimm_cases (Eop (Oshlimm n1) (t1:::Enil)) - | shlimm_case3: - forall n1 t1, - shlimm_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) - | shlimm_default: - forall (e1: expr), - shlimm_cases e1. - -Definition shlimm_match (e1: expr) := - match e1 as z1 return shlimm_cases z1 with - | Eop (Ointconst n1) Enil => - shlimm_case1 n1 - | Eop (Oshlimm n1) (t1:::Enil) => - shlimm_case2 n1 t1 - | Eop (Olea (Aindexed n1)) (t1:::Enil) => - shlimm_case3 n1 t1 - | e1 => - shlimm_default e1 - end. - -Definition shlimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else - match shlimm_match e1 with - | shlimm_case1 n1 => - Eop (Ointconst(Int.shl n1 n)) Enil - | shlimm_case2 n1 t1 => - if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - | shlimm_case3 n1 t1 => - if shift_is_scale n then Eop (Olea (Ascaled (Int.shl Int.one n) (Int.shl n1 n))) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - | shlimm_default e1 => - if shift_is_scale n then Eop (Olea (Ascaled (Int.shl Int.one n) Int.zero)) (e1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - end. - -(* -Definition shruimm (e1: expr) := - if Int.eq n Int.zero then e1 else - match e1 with - | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shru n1 n)) - | Eop (Oshruimm n1) (t1:::Enil) => if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) else Eop (Oshruimm n) (e1:::Enil) - | _ => Eop (Oshruimm n) (e1:::Enil) - end. -*) - -Inductive shruimm_cases: forall (e1: expr), Type := - | shruimm_case1: - forall n1, - shruimm_cases (Eop (Ointconst n1) Enil) - | shruimm_case2: - forall n1 t1, - shruimm_cases (Eop (Oshruimm n1) (t1:::Enil)) - | shruimm_default: - forall (e1: expr), - shruimm_cases e1. - -Definition shruimm_match (e1: expr) := - match e1 as z1 return shruimm_cases z1 with - | Eop (Ointconst n1) Enil => - shruimm_case1 n1 - | Eop (Oshruimm n1) (t1:::Enil) => - shruimm_case2 n1 t1 - | e1 => - shruimm_default e1 - end. - -Definition shruimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else - match shruimm_match e1 with - | shruimm_case1 n1 => - Eop (Ointconst(Int.shru n1 n)) Enil - | shruimm_case2 n1 t1 => - if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) else Eop (Oshruimm n) (e1:::Enil) - | shruimm_default e1 => - Eop (Oshruimm n) (e1:::Enil) - end. - -(* -Definition shrimm (e1: expr) := - if Int.eq n Int.zero then e1 else - match e1 with - | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shr n1 n)) Enil - | Eop (Oshrimm n1) (t1:::Enil) => if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil) - | _ => Eop (Oshrimm n) (e1:::Enil) - end. -*) - -Inductive shrimm_cases: forall (e1: expr), Type := - | shrimm_case1: - forall n1, - shrimm_cases (Eop (Ointconst n1) Enil) - | shrimm_case2: - forall n1 t1, - shrimm_cases (Eop (Oshrimm n1) (t1:::Enil)) - | shrimm_default: - forall (e1: expr), - shrimm_cases e1. - -Definition shrimm_match (e1: expr) := - match e1 as z1 return shrimm_cases z1 with - | Eop (Ointconst n1) Enil => - shrimm_case1 n1 - | Eop (Oshrimm n1) (t1:::Enil) => - shrimm_case2 n1 t1 - | e1 => - shrimm_default e1 - end. - -Definition shrimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else - match shrimm_match e1 with - | shrimm_case1 n1 => - Eop (Ointconst(Int.shr n1 n)) Enil - | shrimm_case2 n1 t1 => - if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil) - | shrimm_default e1 => - Eop (Oshrimm n) (e1:::Enil) - end. - -(** ** Integer multiply *) - -Definition mulimm_base (n1: int) (e2: expr) := - match Int.one_bits n1 with - | i :: nil => - shlimm e2 i - | i :: j :: nil => - Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) - | _ => - Eop (Omulimm n1) (e2:::Enil) - end. - -(* -Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then - Eop (Ointconst Int.zero) Enil - else if Int.eq n1 Int.one then - e2 - else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil - | Eop (Olea (Aindexed n2)) (t2:::Enil) => if mul_is_scale n1 then Eop (Olea (Ascaled n1 (Int.mul n1 n2))) (t2:::Enil) else addimm (Int.mul n1 n2) (mulimm_base n1 t2) - | _ => mulimm_base n1 e2 - end. - -Definition mulimm (e2: expr) := - match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil - | Eop (Olea (Aindexed n2)) (t2:::Enil) => if mul_is_scale n1 then Eop (Olea (Ascaled n1 (Int.mul n1 n2))) (t2:::Enil) else addimm (Int.mul n1 n2) (mulimm_base n1 t2) - | _ => mulimm_base n1 e2 - end. -*) - -Inductive mulimm_cases: forall (e2: expr), Type := - | mulimm_case1: - forall n2, - mulimm_cases (Eop (Ointconst n2) Enil) - | mulimm_case2: - forall n2 t2, - mulimm_cases (Eop (Olea (Aindexed n2)) (t2:::Enil)) - | mulimm_default: - forall (e2: expr), - mulimm_cases e2. - -Definition mulimm_match (e2: expr) := - match e2 as z1 return mulimm_cases z1 with - | Eop (Ointconst n2) Enil => - mulimm_case1 n2 - | Eop (Olea (Aindexed n2)) (t2:::Enil) => - mulimm_case2 n2 t2 - | e2 => - mulimm_default e2 - end. - -Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then - Eop (Ointconst Int.zero) Enil - else if Int.eq n1 Int.one then - e2 - else match mulimm_match e2 with - | mulimm_case1 n2 => - Eop (Ointconst(Int.mul n1 n2)) Enil - | mulimm_case2 n2 t2 => - addimm (Int.mul n1 n2) (mulimm_base n1 t2) - | mulimm_default e2 => - mulimm_base n1 e2 - end. - -(* -Definition mul (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 - | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 - | _, _ => Eop Omul (e1:::e2:::Enil) - end. -*) - -Inductive mul_cases: forall (e1: expr) (e2: expr), Type := - | mul_case1: - forall (n1: int) (t2: expr), - mul_cases (Eop (Ointconst n1) Enil) (t2) - | mul_case2: - forall (t1: expr) (n2: int), - mul_cases (t1) (Eop (Ointconst n2) Enil) - | mul_default: - forall (e1: expr) (e2: expr), - mul_cases e1 e2. - -Definition mul_match_aux (e1: expr) (e2: expr) := - match e2 as z2 return mul_cases e1 z2 with - | Eop (Ointconst n2) Enil => - mul_case2 e1 n2 - | e2 => - mul_default e1 e2 - end. - -Definition mul_match (e1: expr) (e2: expr) := - match e1 as z1 return mul_cases z1 e2 with - | Eop (Ointconst n1) Enil => - mul_case1 n1 e2 - | e1 => - mul_match_aux e1 e2 - end. - -Definition mul (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => - mulimm n1 t2 - | mul_case2 t1 n2 => - mulimm n2 t1 - | mul_default e1 e2 => - Eop Omul (e1:::e2:::Enil) - end. - -(** ** Bitwise and, or, xor *) - -Definition orimm (n: int) (e: expr) := - if Int.eq n Int.zero then e - else if Int.eq n Int.mone then Eop (Ointconst Int.mone) Enil - else Eop (Oorimm n) (e:::Enil). - -Definition same_expr_pure (e1 e2: expr) := - match e1, e2 with - | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false - | _, _ => false - end. - -(* -Definition or (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 - | t1, Eop (Ointconst n2) Enil => orimm n2 t1 - | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil)) => ... - | Eop (Oshruimm n2) (t2:::Enil)), Eop (Oshlimm n1) (t1:::Enil) => ... - | _, _ => Eop Oor (e1:::e2:::Enil) - end. -*) - -Inductive or_cases: forall (e1: expr) (e2: expr), Type := - | or_case1: - forall n1 t2, - or_cases (Eop (Ointconst n1) Enil) (t2) - | or_case2: - forall t1 n2, - or_cases (t1) (Eop (Ointconst n2) Enil) - | or_case3: - forall n1 t1 n2 t2, - or_cases (Eop (Oshlimm n1) (t1:::Enil)) (Eop (Oshruimm n2) (t2:::Enil)) - | or_case4: - forall n2 t2 n1 t1, - or_cases (Eop (Oshruimm n2) (t2:::Enil)) (Eop (Oshlimm n1) (t1:::Enil)) - | or_default: - forall (e1: expr) (e2: expr), - or_cases e1 e2. - -Definition or_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return or_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - or_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => - or_case2 t1 n2 - | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => - or_case3 n1 t1 n2 t2 - | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => - or_case4 n2 t2 n1 t1 - | e1, e2 => - or_default e1 e2 - end. - -Definition or (e1: expr) (e2: expr) := - match or_match e1 e2 with - | or_case1 n1 t2 => - orimm n1 t2 - | or_case2 t1 n2 => - orimm n2 t1 - | or_case3 n1 t1 n2 t2 => - if Int.eq (Int.add n1 n2) Int.iwordsize - && same_expr_pure t1 t2 - then Eop (Ororimm n2) (t1:::Enil) - else Eop Oor (e1:::e2:::Enil) - | or_case4 n2 t2 n1 t1 => - if Int.eq (Int.add n1 n2) Int.iwordsize - && same_expr_pure t1 t2 - then Eop (Ororimm n2) (t1:::Enil) - else Eop Oor (e1:::e2:::Enil) - | or_default e1 e2 => - Eop Oor (e1:::e2:::Enil) - end. - -Definition andimm (n: int) (e: expr) := - if Int.eq n Int.zero then Eop (Ointconst Int.zero) Enil - else if Int.eq n Int.mone then e - else Eop (Oandimm n) (e:::Enil). - -Definition and (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => - andimm n1 t2 - | mul_case2 t1 n2 => - andimm n2 t1 - | mul_default e1 e2 => - Eop Oand (e1:::e2:::Enil) - end. - -Definition xorimm (n: int) (e: expr) := - if Int.eq n Int.zero then e - else Eop (Oxorimm n) (e:::Enil). - -Definition xor (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => - xorimm n1 t2 - | mul_case2 t1 n2 => - xorimm n2 t1 - | mul_default e1 e2 => - Eop Oxor (e1:::e2:::Enil) - end. - -(** ** General shifts *) - -Inductive shift_cases: forall (e1: expr), Type := - | shift_case1: - forall (n2: int), - shift_cases (Eop (Ointconst n2) Enil) - | shift_default: - forall (e1: expr), - shift_cases e1. - -Definition shift_match (e1: expr) := - match e1 as z1 return shift_cases z1 with - | Eop (Ointconst n2) Enil => - shift_case1 n2 - | e1 => - shift_default e1 - end. - -Definition shl (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shlimm e1 n2 - | shift_default e2 => - Eop Oshl (e1:::e2:::Enil) - end. - -Definition shru (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shruimm e1 n2 - | shift_default e2 => - Eop Oshru (e1:::e2:::Enil) - end. - -Definition shr (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shrimm e1 n2 - | shift_default e2 => - Eop Oshr (e1:::e2:::Enil) - end. - -(** ** Comparisons *) - -Inductive comp_cases: forall (e1: expr) (e2: expr), Type := - | comp_case1: - forall n1 t2, - comp_cases (Eop (Ointconst n1) Enil) (t2) - | comp_case2: - forall t1 n2, - comp_cases (t1) (Eop (Ointconst n2) Enil) - | comp_default: - forall (e1: expr) (e2: expr), - comp_cases e1 e2. - -Definition comp_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return comp_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - comp_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => - comp_case2 t1 n2 - | e1, e2 => - comp_default e1 e2 - end. - -Definition comp (c: comparison) (e1: expr) (e2: expr) := - match comp_match e1 e2 with - | comp_case1 n1 t2 => - Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2 ::: Enil) - | comp_case2 t1 n2 => - Eop (Ocmp (Ccompimm c n2)) (t1 ::: Enil) - | comp_default e1 e2 => - Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) - end. - -Definition compu (c: comparison) (e1: expr) (e2: expr) := - match comp_match e1 e2 with - | comp_case1 n1 t2 => - Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2 ::: Enil) - | comp_case2 t1 n2 => - Eop (Ocmp (Ccompuimm c n2)) (t1 ::: Enil) - | comp_default e1 e2 => - Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) - end. - -Definition compf (c: comparison) (e1: expr) (e2: expr) := - Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). - -(** ** Other operators, not optimized. *) - -Definition cast8unsigned (e: expr) := Eop Ocast8unsigned (e ::: Enil). -Definition cast8signed (e: expr) := Eop Ocast8signed (e ::: Enil). -Definition cast16unsigned (e: expr) := Eop Ocast16unsigned (e ::: Enil). -Definition cast16signed (e: expr) := Eop Ocast16signed (e ::: Enil). -Definition divu (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). -Definition modu (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). -Definition divs (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). -Definition mods (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). -Definition negint (e: expr) := Eop Oneg (e ::: Enil). -Definition notint (e: expr) := Eop (Oxorimm Int.mone) (e ::: Enil). -Definition negf (e: expr) := Eop Onegf (e ::: Enil). -Definition absf (e: expr) := Eop Oabsf (e ::: Enil). -Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). -Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). -Definition floatofint (e: expr) := Eop Ofloatofint (e ::: Enil). -Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). -Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). -Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). -Definition divf (e1 e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil). - -(** ** Conversions between unsigned ints and floats *) - -Definition intuoffloat (e: expr) := - let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in - Elet e - (Econdition (CEcond (Ccompf Clt) (Eletvar O ::: f ::: Enil)) - (intoffloat (Eletvar O)) - (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar O) f)))). - -Definition floatofintu (e: expr) := - let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in - Elet e - (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil)) - (floatofint (Eletvar O)) - (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f)). - -(** ** Addressing modes *) - -(* -Definition addressing (e: expr) := - match e with - | Eop (Olea addr) args => (addr, args) - | _ => (Aindexed Int.zero, e:::Enil) - end. -*) - -Inductive addressing_cases: forall (e: expr), Type := - | addressing_case1: - forall addr args, - addressing_cases (Eop (Olea addr) args) - | addressing_default: - forall (e: expr), - addressing_cases e. - -Definition addressing_match (e: expr) := - match e as z1 return addressing_cases z1 with - | Eop (Olea addr) args => - addressing_case1 addr args - | e => - addressing_default e - end. - -Definition addressing (chunk: memory_chunk) (e: expr) := - match addressing_match e with - | addressing_case1 addr args => - (addr, args) - | addressing_default e => - (Aindexed Int.zero, e:::Enil) - end. - diff --git a/ia32/SelectOp.vp b/ia32/SelectOp.vp new file mode 100644 index 0000000..71dc83b --- /dev/null +++ b/ia32/SelectOp.vp @@ -0,0 +1,416 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for operators *) + +(** The instruction selection pass recognizes opportunities for using + combined arithmetic and logical operations and addressing modes + offered by the target processor. For instance, the expression [x + 1] + can take advantage of the "immediate add" instruction of the processor, + and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned + into a "rotate and mask" instruction. + + This file defines functions for building CminorSel expressions and + statements, especially expressions consisting of operator + applications. These functions examine their arguments to choose + cheaper forms of operators whenever possible. + + For instance, [add e1 e2] will return a CminorSel expression semantically + equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a + [Oaddimm] operator if one of the arguments is an integer constant, + or suppress the addition altogether if one of the arguments is the + null integer. In passing, we perform operator reassociation + ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount + of constant propagation. + + On top of the "smart constructor" functions defined below, + module [Selection] implements the actual instruction selection pass. +*) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Cminor. +Require Import Op. +Require Import CminorSel. + +Open Local Scope cminorsel_scope. + +(** ** Constants **) + +Definition addrsymbol (id: ident) (ofs: int) := + Eop (Olea (Aglobal id ofs)) Enil. + +Definition addrstack (ofs: int) := + Eop (Olea (Ainstack ofs)) Enil. + +(** ** Integer logical negation *) + +Definition notint (e: expr) := Eop (Oxorimm Int.mone) (e ::: Enil). + +(** ** Boolean negation *) + +Fixpoint notbool (e: expr) {struct e} : expr := + let default := Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil) in + match e with + | Eop (Ointconst n) Enil => + Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil + | Eop (Ocmp cond) args => + Eop (Ocmp (negate_condition cond)) args + | Econdition e1 e2 e3 => + Econdition e1 (notbool e2) (notbool e3) + | _ => + default + end. + +(** ** Integer addition and pointer addition *) + +Definition offset_addressing (a: addressing) (ofs: int) : addressing := + match a with + | Aindexed n => Aindexed (Int.add n ofs) + | Aindexed2 n => Aindexed2 (Int.add n ofs) + | Ascaled sc n => Ascaled sc (Int.add n ofs) + | Aindexed2scaled sc n => Aindexed2scaled sc (Int.add n ofs) + | Aglobal id n => Aglobal id (Int.add n ofs) + | Abased id n => Abased id (Int.add n ofs) + | Abasedscaled sc id n => Abasedscaled sc id (Int.add n ofs) + | Ainstack n => Ainstack (Int.add n ofs) + end. + +Nondetfunction addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else + match e with + | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil + | Eop (Olea addr) args => Eop (Olea (offset_addressing addr n)) args + | _ => Eop (Olea (Aindexed n)) (e ::: Enil) + end. + +Nondetfunction add (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 + | t1, Eop (Ointconst n2) Enil => addimm n2 t1 + | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => + Eop (Olea (Aindexed2 (Int.add n1 n2))) (t1:::t2:::Enil) + | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => + Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t1:::t2:::Enil) + | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => + Eop (Olea (Aindexed2scaled sc (Int.add n1 n2))) (t2:::t1:::Enil) + | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => + Eop (Olea (Abased id (Int.add ofs n1))) (t1:::Enil) + | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Aindexed n2)) (t2:::Enil) => + Eop (Olea (Abased id (Int.add ofs n2))) (t2:::Enil) + | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => + Eop (Olea (Abasedscaled sc id (Int.add ofs n1))) (t1:::Enil) + | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Ascaled sc n2)) (t2:::Enil) => + Eop (Olea (Abasedscaled sc id (Int.add ofs n2))) (t2:::Enil) + | Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 => + Eop (Olea (Aindexed2scaled sc n)) (t2:::t1:::Enil) + | t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) => + Eop (Olea (Aindexed2scaled sc n)) (t1:::t2:::Enil) + | Eop (Olea (Aindexed n)) (t1:::Enil), t2 => + Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) + | t1, Eop (Olea (Aindexed n)) (t2:::Enil) => + Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) + | _, _ => + Eop (Olea (Aindexed2 Int.zero)) (e1:::e2:::Enil) + end. + +(** ** Integer and pointer subtraction *) + +Nondetfunction sub (e1: expr) (e2: expr) := + match e1, e2 with + | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1 + | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 => + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) => + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | _, _ => + Eop Osub (e1:::e2:::Enil) + end. + +Definition negint (e: expr) := Eop Oneg (e ::: Enil). + +(** ** Immediate shifts *) + +Definition shift_is_scale (n: int) : bool := + Int.eq n (Int.repr 1) || Int.eq n (Int.repr 2) || Int.eq n (Int.repr 3). + +Nondetfunction shlimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else + match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst(Int.shl n1 n)) Enil + | Eop (Oshlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshlimm n) (e1:::Enil) + | Eop (Olea (Aindexed n1)) (t1:::Enil) => + if shift_is_scale n + then Eop (Olea (Ascaled (Int.shl Int.one n) (Int.shl n1 n))) (t1:::Enil) + else Eop (Oshlimm n) (e1:::Enil) + | _ => + if shift_is_scale n + then Eop (Olea (Ascaled (Int.shl Int.one n) Int.zero)) (e1:::Enil) + else Eop (Oshlimm n) (e1:::Enil) + end. + +Nondetfunction shruimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else + match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst(Int.shru n1 n)) Enil + | Eop (Oshruimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshruimm n) (e1:::Enil) + | _ => + Eop (Oshruimm n) (e1:::Enil) + end. + +Nondetfunction shrimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else + match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst(Int.shr n1 n)) Enil + | Eop (Oshrimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrimm n) (e1:::Enil) + | _ => + Eop (Oshrimm n) (e1:::Enil) + end. + +(** ** Integer multiply *) + +Definition mulimm_base (n1: int) (e2: expr) := + match Int.one_bits n1 with + | i :: nil => + shlimm e2 i + | i :: j :: nil => + Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) + | _ => + Eop (Omulimm n1) (e2:::Enil) + end. + +Nondetfunction mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.one then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst(Int.mul n1 n2)) Enil + | Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | _ => mulimm_base n1 e2 + end. + +Nondetfunction mul (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 + | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 + | _, _ => Eop Omul (e1:::e2:::Enil) + end. + +(** ** Bitwise and, or, xor *) + +Nondetfunction andimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.mone then e2 + else match e2 with + | Eop (Ointconst n2) Enil => + Eop (Ointconst (Int.and n1 n2)) Enil + | Eop (Oandimm n2) (t2:::Enil) => + Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | Eop Ocast8unsigned (t2:::Enil) => + Eop (Oandimm (Int.and n1 (Int.repr 255))) (t2:::Enil) + | Eop Ocast16unsigned (t2:::Enil) => + Eop (Oandimm (Int.and n1 (Int.repr 65535))) (t2:::Enil) + | _ => + Eop (Oandimm n1) (e2:::Enil) + end. + +Nondetfunction and (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 + | t1, Eop (Ointconst n2) Enil => andimm n2 t1 + | _, _ => Eop Oand (e1:::e2:::Enil) + end. + +Nondetfunction orimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 + else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil + else match e2 with + | Eop (Ointconst n2) Enil => + Eop (Ointconst (Int.or n1 n2)) Enil + | Eop (Oorimm n2) (t2:::Enil) => + Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | _ => + Eop (Oorimm n1) (e2:::Enil) + end. + +Definition same_expr_pure (e1 e2: expr) := + match e1, e2 with + | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false + | _, _ => false + end. + +Nondetfunction or (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 + | t1, Eop (Ointconst n2) Enil => orimm n2 t1 + | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => + if Int.eq (Int.add n1 n2) Int.iwordsize + && same_expr_pure t1 t2 + then Eop (Ororimm n2) (t1:::Enil) + else Eop Oor (e1:::e2:::Enil) + | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => + if Int.eq (Int.add n1 n2) Int.iwordsize + && same_expr_pure t1 t2 + then Eop (Ororimm n2) (t1:::Enil) + else Eop Oor (e1:::e2:::Enil) + | _, _ => + Eop Oor (e1:::e2:::Enil) + end. + +Nondetfunction xorimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 + else match e2 with + | Eop (Ointconst n2) Enil => + Eop (Ointconst (Int.xor n1 n2)) Enil + | Eop (Oxorimm n2) (t2:::Enil) => + Eop (Oxorimm (Int.xor n1 n2)) (t2:::Enil) + | _ => + Eop (Oxorimm n1) (e2:::Enil) + end. + +Nondetfunction xor (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2 + | t1, Eop (Ointconst n2) Enil => xorimm n2 t1 + | _, _ => Eop Oxor (e1:::e2:::Enil) + end. + +(** ** Integer division and modulus *) + +Definition divu (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). +Definition modu (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). +Definition divs (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). +Definition mods (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). + +(** ** General shifts *) + +Nondetfunction shl (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shlimm e1 n2 + | _ => Eop Oshl (e1:::e2:::Enil) + end. + +Nondetfunction shr (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shrimm e1 n2 + | _ => Eop Oshr (e1:::e2:::Enil) + end. + +Nondetfunction shru (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shruimm e1 n2 + | _ => Eop Oshru (e1:::e2:::Enil) + end. + +(** ** Floating-point arithmetic *) + +Definition negf (e: expr) := Eop Onegf (e ::: Enil). +Definition absf (e: expr) := Eop Oabsf (e ::: Enil). +Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). +Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). +Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). +Definition divf (e1 e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil). + +(** ** Comparisons *) + +Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2 ::: Enil) + | t1, Eop (Ointconst n2) Enil => + Eop (Ocmp (Ccompimm c n2)) (t1 ::: Enil) + | _, _ => + Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) + end. + +Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2 ::: Enil) + | t1, Eop (Ointconst n2) Enil => + Eop (Ocmp (Ccompuimm c n2)) (t1 ::: Enil) + | _, _ => + Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) + end. + +Definition compf (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). + +(** ** Integer conversions *) + +Nondetfunction cast8unsigned (e: expr) := + match e with + | Eop (Oandimm n) (t:::Enil) => + Eop (Oandimm (Int.and (Int.repr 255) n)) (t:::Enil) + | _ => + Eop Ocast8unsigned (e:::Enil) + end. + +Definition cast8signed (e: expr) := Eop Ocast8signed (e ::: Enil). + +Nondetfunction cast16unsigned (e: expr) := + match e with + | Eop (Oandimm n) (t:::Enil) => + Eop (Oandimm (Int.and (Int.repr 65535) n)) (t:::Enil) + | _ => + Eop Ocast16unsigned (e:::Enil) + end. + +Definition cast16signed (e: expr) := Eop Ocast16signed (e ::: Enil). + +(** Floating-point conversions *) + +Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). +Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). +Definition floatofint (e: expr) := Eop Ofloatofint (e ::: Enil). + +Definition intuoffloat (e: expr) := + let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in + Elet e + (Econdition (CEcond (Ccompf Clt) (Eletvar O ::: f ::: Enil)) + (intoffloat (Eletvar O)) + (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar O) f)))). + +Definition floatofintu (e: expr) := + let f := Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil in + Elet e + (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil)) + (floatofint (Eletvar O)) + (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f)). + +(** ** Addressing modes *) + +Nondetfunction addressing (chunk: memory_chunk) (e: expr) := + match e with + | Eop (Olea addr) args => (addr, args) + | _ => (Aindexed Int.zero, e:::Enil) + end. + diff --git a/ia32/SelectOpproof.v b/ia32/SelectOpproof.v index 82bca26..f14b6a9 100644 --- a/ia32/SelectOpproof.v +++ b/ia32/SelectOpproof.v @@ -44,8 +44,6 @@ Variable m: mem. Ltac EvalOp := eapply eval_Eop; eauto with evalexpr. -Ltac TrivialOp cstr := unfold cstr; intros; EvalOp. - Ltac InvEval1 := match goal with | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => @@ -78,6 +76,12 @@ Ltac InvEval2 := Ltac InvEval := InvEval1; InvEval2; InvEval2. +Ltac TrivialExists := + match goal with + | [ |- exists v, _ /\ Val.lessdef ?a v ] => exists a; split; [EvalOp | auto] + end. + + (** * Correctness of the smart constructors *) (** We now show that the code generated by "smart constructor" functions @@ -100,66 +104,70 @@ Ltac InvEval := InvEval1; InvEval2; InvEval2. by the smart constructor. *) +Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. + +Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := + forall le a x b y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. + Theorem eval_addrsymbol: - forall le id ofs b, - Genv.find_symbol ge id = Some b -> - eval_expr ge sp e m le (addrsymbol id ofs) (Vptr b ofs). + forall le id ofs, + exists v, eval_expr ge sp e m le (addrsymbol id ofs) v /\ Val.lessdef (symbol_address ge id ofs) v. Proof. - intros. unfold addrsymbol. econstructor. constructor. - simpl. rewrite H. auto. + intros. unfold addrsymbol. econstructor; split. + EvalOp. simpl; eauto. + auto. Qed. Theorem eval_addrstack: - forall le ofs b n, - sp = Vptr b n -> - eval_expr ge sp e m le (addrstack ofs) (Vptr b (Int.add n ofs)). + forall le ofs, + exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.add sp (Vint ofs)) v. Proof. - intros. unfold addrstack. econstructor. constructor. - simpl. unfold offset_sp. rewrite H. auto. + intros. unfold addrstack. econstructor; split. + EvalOp. simpl; eauto. + auto. Qed. -Lemma eval_notbool_base: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_expr ge sp e m le (notbool_base a) (Val.of_bool (negb b)). -Proof. - TrivialOp notbool_base. simpl. - inv H0. - rewrite Int.eq_false; auto. - rewrite Int.eq_true; auto. - reflexivity. +Theorem eval_notint: unary_constructor_sound notint Val.notint. +Proof. + unfold notint; red; intros. TrivialExists. Qed. -Hint Resolve Val.bool_of_true_val Val.bool_of_false_val - Val.bool_of_true_val_inv Val.bool_of_false_val_inv: valboolof. - -Theorem eval_notbool: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_expr ge sp e m le (notbool a) (Val.of_bool (negb b)). +Theorem eval_notbool: unary_constructor_sound notbool Val.notbool. Proof. - induction a; simpl; intros; try (eapply eval_notbool_base; eauto). - destruct o; try (eapply eval_notbool_base; eauto). - - destruct e0. InvEval. - inv H0. rewrite Int.eq_false; auto. - simpl; eauto with evalexpr. - rewrite Int.eq_true; simpl; eauto with evalexpr. - eapply eval_notbool_base; eauto. + assert (DFL: + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (Eop (Ocmp (Ccompuimm Ceq Int.zero)) (a ::: Enil)) v + /\ Val.lessdef (Val.notbool x) v). + intros. TrivialExists. simpl. destruct x; simpl; auto. - inv H. eapply eval_Eop; eauto. - simpl. assert (eval_condition c vl m = Some b). - generalize H6. simpl. - case (eval_condition c vl); intros. - destruct b0; inv H1; inversion H0; auto; congruence. - congruence. - rewrite (Op.eval_negate_condition _ _ _ H). - destruct b; reflexivity. + red. induction a; simpl; intros; eauto. destruct o; eauto. +(* intconst *) + destruct e0; eauto. InvEval. TrivialExists. simpl. destruct (Int.eq i Int.zero); auto. +(* cmp *) + inv H. simpl in H5. + destruct (eval_condition c vl m) as []_eqn. + TrivialExists. simpl. rewrite (eval_negate_condition _ _ _ Heqo). destruct b; inv H5; auto. + inv H5. simpl. + destruct (eval_condition (negate_condition c) vl m) as []_eqn. + destruct b; [exists Vtrue | exists Vfalse]; split; auto; EvalOp; simpl. rewrite Heqo0; auto. rewrite Heqo0; auto. + exists Vundef; split; auto; EvalOp; simpl. rewrite Heqo0; auto. +(* condition *) + inv H. destruct v1. + exploit IHa1; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. + exploit IHa2; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. +Qed. - inv H. eapply eval_Econdition; eauto. - destruct v1; eauto. +Lemma shift_symbol_address: + forall id ofs n, symbol_address ge id (Int.add ofs n) = Val.add (symbol_address ge id ofs) (Vint n). +Proof. + intros. unfold symbol_address. destruct (Genv.find_symbol); auto. Qed. Lemma eval_offset_addressing: @@ -168,322 +176,247 @@ Lemma eval_offset_addressing: eval_addressing ge sp (offset_addressing addr n) args = Some (Val.add v (Vint n)). Proof. intros. destruct addr; simpl in *; FuncInv; subst; simpl. - rewrite Int.add_assoc. auto. - rewrite Int.add_assoc. auto. - rewrite <- Int.add_assoc. auto. - rewrite <- Int.add_assoc. auto. - rewrite <- Int.add_assoc. auto. - rewrite <- Int.add_assoc. auto. - rewrite <- Int.add_assoc. decEq. decEq. repeat rewrite Int.add_assoc. auto. - decEq. decEq. repeat rewrite Int.add_assoc. auto. - destruct (Genv.find_symbol ge i); inv H. auto. - destruct (Genv.find_symbol ge i); inv H. simpl. - repeat rewrite Int.add_assoc. decEq. decEq. decEq. apply Int.add_commut. - destruct (Genv.find_symbol ge i0); inv H. simpl. - repeat rewrite Int.add_assoc. decEq. decEq. decEq. apply Int.add_commut. - unfold offset_sp in *. destruct sp; inv H. simpl. rewrite Int.add_assoc. auto. + rewrite Val.add_assoc. auto. + repeat rewrite Val.add_assoc. auto. + rewrite Val.add_assoc. auto. + repeat rewrite Val.add_assoc. auto. + rewrite shift_symbol_address. auto. + rewrite shift_symbol_address. repeat rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. + rewrite shift_symbol_address. repeat rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. + rewrite Val.add_assoc. auto. Qed. Theorem eval_addimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (addimm n a) (Vint (Int.add x n)). -Proof. - unfold addimm; intros until x. - generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. - subst n. rewrite Int.add_zero. auto. - case (addimm_match a); intros; InvEval. - EvalOp. simpl. rewrite Int.add_commut. auto. - inv H0. EvalOp. simpl. rewrite (eval_offset_addressing _ _ _ _ H6). auto. - EvalOp. -Qed. - -Theorem eval_addimm_ptr: - forall le n a b ofs, - eval_expr ge sp e m le a (Vptr b ofs) -> - eval_expr ge sp e m le (addimm n a) (Vptr b (Int.add ofs n)). -Proof. - unfold addimm; intros until ofs. - generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. - subst n. rewrite Int.add_zero. auto. - case (addimm_match a); intros; InvEval. - inv H0. EvalOp. simpl. rewrite (eval_offset_addressing _ _ _ _ H6). auto. - EvalOp. -Qed. - -Theorem eval_add: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (add a b) (Vint (Int.add x y)). -Proof. - intros until y. + forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)). +Proof. + red; unfold addimm; intros until x. + predSpec Int.eq Int.eq_spec n Int.zero. + subst n. intros. exists x; split; auto. + destruct x; simpl; auto. rewrite Int.add_zero. auto. rewrite Int.add_zero. auto. + case (addimm_match a); intros; InvEval; simpl. + TrivialExists; simpl. rewrite Int.add_commut. auto. + inv H0. simpl in H6. TrivialExists. simpl. eapply eval_offset_addressing; eauto. + TrivialExists. +Qed. + +Theorem eval_add: binary_constructor_sound add Val.add. +Proof. + red; intros until y. unfold add; case (add_match a b); intros; InvEval. - rewrite Int.add_commut. apply eval_addimm. auto. - apply eval_addimm. auto. - subst. EvalOp. simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - subst. EvalOp. simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - subst. EvalOp. simpl. decEq. decEq. - rewrite Int.add_permut. rewrite Int.add_assoc. decEq. apply Int.add_permut. - destruct (Genv.find_symbol ge id); inv H0. - destruct (Genv.find_symbol ge id); inv H0. - destruct (Genv.find_symbol ge id); inv H0. - destruct (Genv.find_symbol ge id); inv H0. - subst. EvalOp. simpl. rewrite Int.add_commut. auto. - subst. EvalOp. - subst. EvalOp. simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. EvalOp. simpl. decEq. decEq. apply Int.add_assoc. - EvalOp. simpl. rewrite Int.add_zero. auto. -Qed. - -Theorem eval_add_ptr: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (add a b) (Vptr p (Int.add x y)). -Proof. - intros until y. unfold add; case (add_match a b); intros; InvEval. - apply eval_addimm_ptr; auto. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - destruct (Genv.find_symbol ge id); inv H0. - subst. EvalOp; simpl. destruct (Genv.find_symbol ge id); inv H0. - decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. EvalOp; simpl. destruct (Genv.find_symbol ge id); inv H0. - decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. EvalOp. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. auto. - EvalOp; simpl. rewrite Int.add_zero. auto. -Qed. - -Theorem eval_add_ptr_2: - forall le a b x p y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vptr p y) -> - eval_expr ge sp e m le (add a b) (Vptr p (Int.add y x)). -Proof. - intros until y. unfold add; case (add_match a b); intros; InvEval. - apply eval_addimm_ptr; auto. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. - rewrite (Int.add_commut n1 n2). apply Int.add_permut. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. - rewrite (Int.add_commut n1 n2). apply Int.add_permut. - subst. EvalOp; simpl. destruct (Genv.find_symbol ge id); inv H0. - decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut. - destruct (Genv.find_symbol ge id); inv H0. - subst. EvalOp; simpl. destruct (Genv.find_symbol ge id); inv H0. - decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. EvalOp. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. auto. - subst. EvalOp; simpl. decEq. decEq. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - EvalOp; simpl. rewrite Int.add_zero. auto. -Qed. - -Theorem eval_sub: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - rewrite Int.sub_add_opp. - apply eval_addimm. assumption. - replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm. EvalOp. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm. EvalOp. - subst x. rewrite Int.sub_add_l. auto. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm. EvalOp. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. -Qed. - -Theorem eval_sub_ptr_int: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (sub a b) (Vptr p (Int.sub x y)). -Proof. - intros until y. + rewrite Val.add_commut. apply eval_addimm; auto. + apply eval_addimm; auto. + subst. TrivialExists. simpl. rewrite Val.add_permut_4. auto. + subst. TrivialExists. simpl. rewrite Val.add_assoc. decEq; decEq. rewrite Val.add_permut. auto. + subst. TrivialExists. simpl. rewrite Val.add_permut_4. rewrite <- Val.add_permut. rewrite <- Val.add_assoc. auto. + subst. TrivialExists. simpl. rewrite shift_symbol_address. + rewrite Val.add_commut. rewrite Val.add_assoc. decEq. decEq. apply Val.add_commut. + subst. TrivialExists. simpl. rewrite shift_symbol_address. rewrite Val.add_assoc. + decEq; decEq. apply Val.add_commut. + subst. TrivialExists. simpl. rewrite shift_symbol_address. rewrite Val.add_commut. + rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. + subst. TrivialExists. simpl. rewrite shift_symbol_address. + rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. + subst. TrivialExists. simpl. rewrite Val.add_permut. rewrite Val.add_assoc. + decEq; decEq. apply Val.add_commut. + subst. TrivialExists. + subst. TrivialExists. simpl. repeat rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. + subst. TrivialExists. simpl. rewrite Val.add_assoc; auto. + TrivialExists. simpl. destruct x; destruct y; simpl; auto; rewrite Int.add_zero; auto. +Qed. + +Theorem eval_sub: binary_constructor_sound sub Val.sub. +Proof. + red; intros until y. unfold sub; case (sub_match a b); intros; InvEval. - rewrite Int.sub_add_opp. - apply eval_addimm_ptr. assumption. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm_ptr. EvalOp. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm_ptr. EvalOp. - subst x. rewrite Int.sub_add_l. auto. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm_ptr. EvalOp. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. -Qed. - -Theorem eval_sub_ptr_ptr: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vptr p y) -> - eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm. EvalOp. - simpl; unfold eq_block. subst b0; subst b1; rewrite zeq_true. auto. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm. EvalOp. - simpl. unfold eq_block. rewrite zeq_true. auto. - subst x. rewrite Int.sub_add_l. auto. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm. EvalOp. - simpl. unfold eq_block. rewrite zeq_true. auto. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. simpl. unfold eq_block. rewrite zeq_true. auto. + rewrite Val.sub_add_opp. apply eval_addimm; auto. + subst. rewrite Val.sub_add_l. rewrite Val.sub_add_r. + rewrite Val.add_assoc. simpl. rewrite Int.add_commut. rewrite <- Int.sub_add_opp. + apply eval_addimm; EvalOp. + subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp. + subst. rewrite Val.sub_add_r. apply eval_addimm; EvalOp. + TrivialExists. +Qed. + +Theorem eval_negint: unary_constructor_sound negint (fun v => Val.sub Vzero v). +Proof. + red; intros. unfold negint. TrivialExists. Qed. Theorem eval_shlimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n Int.iwordsize = true -> - eval_expr ge sp e m le (shlimm a n) (Vint (Int.shl x n)). -Proof. - intros until x; unfold shlimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero). - intros. subst n. rewrite Int.shl_zero. auto. - case (shlimm_match a); intros. - InvEval. EvalOp. - case_eq (Int.ltu (Int.add n n1) Int.iwordsize); intros. - InvEval. revert H8. case_eq (Int.ltu n1 Int.iwordsize); intros; inv H8. - EvalOp. simpl. rewrite H2. rewrite Int.shl_shl; auto; rewrite Int.add_commut; auto. - EvalOp. simpl. rewrite H1; auto. - InvEval. subst. - destruct (shift_is_scale n). - EvalOp. simpl. decEq. decEq. - rewrite (Int.shl_mul (Int.add i n1)); auto. rewrite (Int.shl_mul n1); auto. - rewrite Int.mul_add_distr_l. auto. - EvalOp. constructor. EvalOp. simpl. eauto. constructor. simpl. rewrite H1. auto. + forall n, unary_constructor_sound (fun a => shlimm a n) + (fun x => Val.shl x (Vint n)). +Proof. + red; intros until x. unfold shlimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shl_zero; auto. + destruct (shlimm_match a); intros; InvEval. + exists (Vint (Int.shl n1 n)); split. EvalOp. + simpl. destruct (Int.ltu n Int.iwordsize); auto. + destruct (Int.ltu (Int.add n n1) Int.iwordsize) as []_eqn. + exists (Val.shl v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) as []_eqn; simpl; auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; simpl; auto. + rewrite Int.add_commut. rewrite Int.shl_shl; auto. rewrite Int.add_commut; auto. + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + subst. destruct (shift_is_scale n). + econstructor; split. EvalOp. simpl. eauto. + destruct v1; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + rewrite Int.shl_mul. rewrite Int.mul_add_distr_l. rewrite (Int.shl_mul n1). auto. + TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. auto. destruct (shift_is_scale n). - EvalOp. simpl. decEq. decEq. - rewrite Int.add_zero. symmetry. apply Int.shl_mul. - EvalOp. simpl. rewrite H1; auto. + econstructor; split. EvalOp. simpl. eauto. + destruct x; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + rewrite Int.add_zero. rewrite Int.shl_mul. auto. + TrivialExists. Qed. Theorem eval_shruimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n Int.iwordsize = true -> - eval_expr ge sp e m le (shruimm a n) (Vint (Int.shru x n)). -Proof. - intros until x; unfold shruimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero). - intros. subst n. rewrite Int.shru_zero. auto. - case (shruimm_match a); intros. - InvEval. EvalOp. - case_eq (Int.ltu (Int.add n n1) Int.iwordsize); intros. - InvEval. revert H8. case_eq (Int.ltu n1 Int.iwordsize); intros; inv H8. - EvalOp. simpl. rewrite H2. rewrite Int.shru_shru; auto; rewrite Int.add_commut; auto. - EvalOp. simpl. rewrite H1; auto. - EvalOp. simpl. rewrite H1; auto. + forall n, unary_constructor_sound (fun a => shruimm a n) + (fun x => Val.shru x (Vint n)). +Proof. + red; intros until x. unfold shruimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto. + destruct (shruimm_match a); intros; InvEval. + exists (Vint (Int.shru n1 n)); split. EvalOp. + simpl. destruct (Int.ltu n Int.iwordsize); auto. + destruct (Int.ltu (Int.add n n1) Int.iwordsize) as []_eqn. + exists (Val.shru v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) as []_eqn; simpl; auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; simpl; auto. + rewrite Int.add_commut. rewrite Int.shru_shru; auto. rewrite Int.add_commut; auto. + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + TrivialExists. Qed. Theorem eval_shrimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n Int.iwordsize = true -> - eval_expr ge sp e m le (shrimm a n) (Vint (Int.shr x n)). -Proof. - intros until x; unfold shrimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero). - intros. subst n. rewrite Int.shr_zero. auto. - case (shrimm_match a); intros. - InvEval. EvalOp. - case_eq (Int.ltu (Int.add n n1) Int.iwordsize); intros. - InvEval. revert H8. case_eq (Int.ltu n1 Int.iwordsize); intros; inv H8. - EvalOp. simpl. rewrite H2. rewrite Int.shr_shr; auto; rewrite Int.add_commut; auto. - EvalOp. simpl. rewrite H1; auto. - EvalOp. simpl. rewrite H1; auto. + forall n, unary_constructor_sound (fun a => shrimm a n) + (fun x => Val.shr x (Vint n)). +Proof. + red; intros until x. unfold shrimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto. + destruct (shrimm_match a); intros; InvEval. + exists (Vint (Int.shr n1 n)); split. EvalOp. + simpl. destruct (Int.ltu n Int.iwordsize); auto. + destruct (Int.ltu (Int.add n n1) Int.iwordsize) as []_eqn. + exists (Val.shr v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) as []_eqn; simpl; auto. + destruct (Int.ltu n Int.iwordsize) as []_eqn; simpl; auto. + rewrite Int.add_commut. rewrite Int.shr_shr; auto. rewrite Int.add_commut; auto. + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + TrivialExists. Qed. Lemma eval_mulimm_base: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (mulimm_base n a) (Vint (Int.mul x n)). + forall n, unary_constructor_sound (mulimm_base n) (fun x => Val.mul x (Vint n)). Proof. - intros; unfold mulimm_base. + intros; red; intros; unfold mulimm_base. generalize (Int.one_bits_decomp n). generalize (Int.one_bits_range n). destruct (Int.one_bits n). - intros. EvalOp. + intros. TrivialExists. destruct l. intros. rewrite H1. simpl. - rewrite Int.add_zero. rewrite <- Int.shl_mul. - apply eval_shlimm. auto. auto with coqlib. + rewrite Int.add_zero. + replace (Vint (Int.shl Int.one i)) with (Val.shl Vone (Vint i)). rewrite Val.shl_mul. + apply eval_shlimm. auto. simpl. rewrite H0; auto with coqlib. destruct l. - intros. apply eval_Elet with (Vint x). auto. - rewrite H1. simpl. rewrite Int.add_zero. - rewrite Int.mul_add_distr_r. - apply eval_add. - rewrite <- Int.shl_mul. apply eval_shlimm. constructor. auto. auto with coqlib. - rewrite <- Int.shl_mul. apply eval_shlimm. constructor. auto. auto with coqlib. - intros. EvalOp. + intros. rewrite H1. simpl. + exploit (eval_shlimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]]. + exploit (eval_shlimm i0 (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]]. + exploit eval_add. eexact A1. eexact A2. intros [v3 [A3 B3]]. + exists v3; split. econstructor; eauto. + rewrite Int.add_zero. + replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one i0))) + with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint i0))). + rewrite Val.mul_add_distr_r. + repeat rewrite Val.shl_mul. + apply Val.lessdef_trans with (Val.add v1 v2); auto. apply Val.add_lessdef; auto. + simpl. repeat rewrite H0; auto with coqlib. + intros. TrivialExists. Qed. Theorem eval_mulimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (mulimm n a) (Vint (Int.mul x n)). -Proof. - intros until x; unfold mulimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.mul_zero. intros. EvalOp. - generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intro. - subst n. rewrite Int.mul_one. auto. + forall n, unary_constructor_sound (mulimm n) (fun x => Val.mul x (Vint n)). +Proof. + intros; red; intros until x; unfold mulimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.mul_zero. auto. + predSpec Int.eq Int.eq_spec n Int.one. + intros. exists x; split; auto. + destruct x; simpl; auto. subst n. rewrite Int.mul_one. auto. case (mulimm_match a); intros; InvEval. - EvalOp. rewrite Int.mul_commut. reflexivity. - subst. rewrite Int.mul_add_distr_l. - rewrite (Int.mul_commut n n2). apply eval_addimm. apply eval_mulimm_base. auto. - apply eval_mulimm_base. assumption. + TrivialExists. simpl. rewrite Int.mul_commut; auto. + subst. rewrite Val.mul_add_distr_l. + exploit eval_mulimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]]. + exploit (eval_addimm (Int.mul n n2) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]]. + exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.add_lessdef; eauto. + rewrite Val.mul_commut; auto. + apply eval_mulimm_base; auto. Qed. -Theorem eval_mul: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (mul a b) (Vint (Int.mul x y)). +Theorem eval_mul: binary_constructor_sound mul Val.mul. Proof. - intros until y. + red; intros until y. unfold mul; case (mul_match a b); intros; InvEval. - rewrite Int.mul_commut. apply eval_mulimm. auto. + rewrite Val.mul_commut. apply eval_mulimm. auto. apply eval_mulimm. auto. - EvalOp. + TrivialExists. Qed. -Lemma eval_orimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (orimm n a) (Vint (Int.or x n)). +Theorem eval_andimm: + forall n, unary_constructor_sound (andimm n) (fun x => Val.and x (Vint n)). Proof. - intros. unfold orimm. - predSpec Int.eq Int.eq_spec n Int.zero. - subst n. rewrite Int.or_zero. auto. + intros; red; intros until x. unfold andimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.and_zero. auto. + predSpec Int.eq Int.eq_spec n Int.mone. + intros. exists x; split; auto. + destruct x; simpl; auto. subst n. rewrite Int.and_mone. auto. + case (andimm_match a); intros; InvEval. + TrivialExists. simpl. rewrite Int.and_commut; auto. + subst. TrivialExists. simpl. rewrite Val.and_assoc. rewrite Int.and_commut. auto. + subst. rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. + rewrite Int.and_commut. auto. compute; auto. + subst. rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. + rewrite Int.and_commut. auto. compute; auto. + TrivialExists. +Qed. + +Theorem eval_and: binary_constructor_sound and Val.and. +Proof. + red; intros until y; unfold and; case (and_match a b); intros; InvEval. + rewrite Val.and_commut. apply eval_andimm; auto. + apply eval_andimm; auto. + TrivialExists. +Qed. + +Theorem eval_orimm: + forall n, unary_constructor_sound (orimm n) (fun x => Val.or x (Vint n)). +Proof. + intros; red; intros until x. unfold orimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists x; split. auto. + destruct x; simpl; auto. subst n. rewrite Int.or_zero. auto. predSpec Int.eq Int.eq_spec n Int.mone. - subst n. rewrite Int.or_mone. EvalOp. - EvalOp. + intros. exists (Vint Int.mone); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.or_mone. auto. + destruct (orimm_match a); intros; InvEval. + TrivialExists. simpl. rewrite Int.or_commut; auto. + subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists. + TrivialExists. Qed. Remark eval_same_expr: @@ -501,432 +434,283 @@ Proof. discriminate. Qed. -Theorem eval_or: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (or a b) (Vint (Int.or x y)). -Proof. - intros until y; unfold or; case (or_match a b); intros; InvEval. - - rewrite Int.or_commut. apply eval_orimm; auto. - apply eval_orimm; auto. - - revert H7; case_eq (Int.ltu n1 Int.iwordsize); intros; inv H7. - revert H6; case_eq (Int.ltu n2 Int.iwordsize); intros; inv H6. - caseEq (Int.eq (Int.add n1 n2) Int.iwordsize - && same_expr_pure t1 t2); intro. - destruct (andb_prop _ _ H1). - generalize (Int.eq_spec (Int.add n1 n2) Int.iwordsize); rewrite H4; intros. - exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. - EvalOp. simpl. rewrite H0. rewrite <- Int.or_ror; auto. - EvalOp. econstructor. EvalOp. simpl. rewrite H; eauto. - econstructor. EvalOp. simpl. rewrite H0; eauto. constructor. - simpl. auto. - - revert H7; case_eq (Int.ltu n2 Int.iwordsize); intros; inv H7. - revert H6; case_eq (Int.ltu n1 Int.iwordsize); intros; inv H6. - caseEq (Int.eq (Int.add n1 n2) Int.iwordsize - && same_expr_pure t1 t2); intro. - destruct (andb_prop _ _ H1). - generalize (Int.eq_spec (Int.add n1 n2) Int.iwordsize); rewrite H4; intros. - exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. - EvalOp. simpl. rewrite H. rewrite Int.or_commut. rewrite <- Int.or_ror; auto. - EvalOp. econstructor. EvalOp. simpl. rewrite H; eauto. - econstructor. EvalOp. simpl. rewrite H0; eauto. constructor. - simpl. auto. +Lemma eval_or: binary_constructor_sound or Val.or. +Proof. + red; intros until y; unfold or; case (or_match a b); intros. +(* intconst *) + InvEval. rewrite Val.or_commut. apply eval_orimm; auto. + InvEval. apply eval_orimm; auto. +(* shlimm - shruimm *) + destruct (Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2) as []_eqn. + destruct (andb_prop _ _ Heqb0). + generalize (Int.eq_spec (Int.add n1 n2) Int.iwordsize); rewrite H1; intros EQ. + InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. + exists (Val.ror v0 (Vint n2)); split. EvalOp. + destruct v0; simpl; auto. + destruct (Int.ltu n1 Int.iwordsize) as []_eqn; auto. + destruct (Int.ltu n2 Int.iwordsize) as []_eqn; auto. + simpl. rewrite <- Int.or_ror; auto. + TrivialExists. +(* shruimm - shlimm *) + destruct (Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2) as []_eqn. + destruct (andb_prop _ _ Heqb0). + generalize (Int.eq_spec (Int.add n1 n2) Int.iwordsize); rewrite H1; intros EQ. + InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. + exists (Val.ror v1 (Vint n2)); split. EvalOp. + destruct v1; simpl; auto. + destruct (Int.ltu n2 Int.iwordsize) as []_eqn; auto. + destruct (Int.ltu n1 Int.iwordsize) as []_eqn; auto. + simpl. rewrite Int.or_commut. rewrite <- Int.or_ror; auto. + TrivialExists. +(* default *) + TrivialExists. +Qed. + +Theorem eval_xorimm: + forall n, unary_constructor_sound (xorimm n) (fun x => Val.xor x (Vint n)). +Proof. + intros; red; intros until x. unfold xorimm. + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists x; split. auto. + destruct x; simpl; auto. subst n. rewrite Int.xor_zero. auto. + destruct (xorimm_match a); intros; InvEval. + TrivialExists. simpl. rewrite Int.xor_commut; auto. + subst. rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. TrivialExists. + TrivialExists. +Qed. + +Theorem eval_xor: binary_constructor_sound xor Val.xor. +Proof. + red; intros until y; unfold xor; case (xor_match a b); intros; InvEval. + rewrite Val.xor_commut. apply eval_xorimm; auto. + apply eval_xorimm; auto. + TrivialExists. +Qed. - EvalOp. +Theorem eval_divs: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divs x y = Some z -> + exists v, eval_expr ge sp e m le (divs a b) v /\ Val.lessdef z v. +Proof. + intros. unfold divs. exists z; split. EvalOp. auto. Qed. -Lemma eval_andimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (andimm n a) (Vint (Int.and x n)). +Theorem eval_divu: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divu x y = Some z -> + exists v, eval_expr ge sp e m le (divu a b) v /\ Val.lessdef z v. Proof. - intros. unfold andimm. - predSpec Int.eq Int.eq_spec n Int.zero. - subst n. rewrite Int.and_zero. EvalOp. - predSpec Int.eq Int.eq_spec n Int.mone. - subst n. rewrite Int.and_mone. auto. - EvalOp. + intros. unfold divu. exists z; split. EvalOp. auto. Qed. -Theorem eval_and: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (and a b) (Vint (Int.and x y)). +Theorem eval_mods: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.mods x y = Some z -> + exists v, eval_expr ge sp e m le (mods a b) v /\ Val.lessdef z v. Proof. - intros until y; unfold and. case (mul_match a b); intros. - InvEval. rewrite Int.and_commut. apply eval_andimm; auto. - InvEval. apply eval_andimm; auto. - EvalOp. + intros. unfold mods. exists z; split. EvalOp. auto. Qed. -Lemma eval_xorimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (xorimm n a) (Vint (Int.xor x n)). +Theorem eval_modu: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.modu x y = Some z -> + exists v, eval_expr ge sp e m le (modu a b) v /\ Val.lessdef z v. Proof. - intros. unfold xorimm. - predSpec Int.eq Int.eq_spec n Int.zero. - subst n. rewrite Int.xor_zero. auto. - EvalOp. + intros. unfold modu. exists z; split. EvalOp. auto. Qed. -Theorem eval_xor: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (xor a b) (Vint (Int.xor x y)). +Theorem eval_shl: binary_constructor_sound shl Val.shl. Proof. - intros until y; unfold xor. case (mul_match a b); intros. - InvEval. rewrite Int.xor_commut. apply eval_xorimm; auto. - InvEval. apply eval_xorimm; auto. - EvalOp. + red; intros until y; unfold shl; case (shl_match b); intros. + InvEval. apply eval_shlimm; auto. + TrivialExists. Qed. -Theorem eval_divu: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (divu a b) (Vint (Int.divu x y)). +Theorem eval_shr: binary_constructor_sound shr Val.shr. Proof. - intros; unfold divu; EvalOp. - simpl. rewrite Int.eq_false; auto. + red; intros until y; unfold shr; case (shr_match b); intros. + InvEval. apply eval_shrimm; auto. + TrivialExists. Qed. -Theorem eval_modu: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (modu a b) (Vint (Int.modu x y)). +Theorem eval_shru: binary_constructor_sound shru Val.shru. Proof. - intros; unfold modu; EvalOp. - simpl. rewrite Int.eq_false; auto. + red; intros until y; unfold shru; case (shru_match b); intros. + InvEval. apply eval_shruimm; auto. + TrivialExists. Qed. -Theorem eval_divs: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (divs a b) (Vint (Int.divs x y)). +Theorem eval_negf: unary_constructor_sound negf Val.negf. Proof. - TrivialOp divs. simpl. - predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. + red; intros. TrivialExists. Qed. -Theorem eval_mods: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (mods a b) (Vint (Int.mods x y)). +Theorem eval_absf: unary_constructor_sound absf Val.absf. Proof. - TrivialOp mods. simpl. - predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. + red; intros. TrivialExists. Qed. -Theorem eval_shl: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y Int.iwordsize = true -> - eval_expr ge sp e m le (shl a b) (Vint (Int.shl x y)). +Theorem eval_addf: binary_constructor_sound addf Val.addf. Proof. - intros until y; unfold shl; case (shift_match b); intros. - InvEval. apply eval_shlimm; auto. - EvalOp. simpl. rewrite H1. auto. + red; intros; TrivialExists. +Qed. + +Theorem eval_subf: binary_constructor_sound subf Val.subf. +Proof. + red; intros; TrivialExists. Qed. -Theorem eval_shru: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y Int.iwordsize = true -> - eval_expr ge sp e m le (shru a b) (Vint (Int.shru x y)). +Theorem eval_mulf: binary_constructor_sound mulf Val.mulf. Proof. - intros until y; unfold shru; case (shift_match b); intros. - InvEval. apply eval_shruimm; auto. - EvalOp. simpl. rewrite H1. auto. + red; intros; TrivialExists. Qed. -Theorem eval_shr: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y Int.iwordsize = true -> - eval_expr ge sp e m le (shr a b) (Vint (Int.shr x y)). +Theorem eval_divf: binary_constructor_sound divf Val.divf. Proof. - intros until y; unfold shr; case (shift_match b); intros. - InvEval. apply eval_shrimm; auto. - EvalOp. simpl. rewrite H1. auto. + red; intros; TrivialExists. Qed. Theorem eval_comp: - forall le c a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x y)). -Proof. - intros until y. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. -Qed. - -Theorem eval_compu_int: - forall le c a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)). -Proof. - intros until y. - unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. -Qed. - -Remark eval_compare_null_transf: - forall c x v, - Cminor.eval_compare_null c x = Some v -> - match eval_compare_null c x with - | Some true => Some Vtrue - | Some false => Some Vfalse - | None => None (A:=val) - end = Some v. -Proof. - unfold Cminor.eval_compare_null, eval_compare_null; intros. - destruct (Int.eq x Int.zero); try discriminate. - destruct c; try discriminate; auto. -Qed. - -Theorem eval_compu_ptr_int: - forall le c a x1 x2 b y v, - eval_expr ge sp e m le a (Vptr x1 x2) -> - eval_expr ge sp e m le b (Vint y) -> - Cminor.eval_compare_null c y = Some v -> - eval_expr ge sp e m le (compu c a b) v. -Proof. - intros until v. - unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. apply eval_compare_null_transf; auto. - EvalOp. simpl. apply eval_compare_null_transf; auto. -Qed. - -Remark eval_compare_null_swap: - forall c x, - Cminor.eval_compare_null (swap_comparison c) x = - Cminor.eval_compare_null c x. -Proof. - intros. unfold Cminor.eval_compare_null. - destruct (Int.eq x Int.zero). destruct c; auto. auto. -Qed. - -Theorem eval_compu_int_ptr: - forall le c a x b y1 y2 v, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vptr y1 y2) -> - Cminor.eval_compare_null c x = Some v -> - eval_expr ge sp e m le (compu c a b) v. -Proof. - intros until v. - unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. apply eval_compare_null_transf. - rewrite eval_compare_null_swap; auto. - EvalOp. simpl. apply eval_compare_null_transf. auto. -Qed. - -Theorem eval_compu_ptr_ptr: - forall le c a x1 x2 b y1 y2, - eval_expr ge sp e m le a (Vptr x1 x2) -> - eval_expr ge sp e m le b (Vptr y1 y2) -> - Mem.valid_pointer m x1 (Int.unsigned x2) - && Mem.valid_pointer m y1 (Int.unsigned y2) = true -> - x1 = y1 -> - eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x2 y2)). -Proof. - intros until y2. - unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite H1. subst y1. rewrite dec_eq_true. - destruct (Int.cmpu c x2 y2); reflexivity. -Qed. - -Theorem eval_compu_ptr_ptr_2: - forall le c a x1 x2 b y1 y2 v, - eval_expr ge sp e m le a (Vptr x1 x2) -> - eval_expr ge sp e m le b (Vptr y1 y2) -> - Mem.valid_pointer m x1 (Int.unsigned x2) - && Mem.valid_pointer m y1 (Int.unsigned y2) = true -> - x1 <> y1 -> - Cminor.eval_compare_mismatch c = Some v -> - eval_expr ge sp e m le (compu c a b) v. -Proof. - intros until y2. - unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto. - destruct c; simpl in H3; inv H3; auto. + forall c, binary_constructor_sound (comp c) (Val.cmp c). +Proof. + intros; red; intros until y. unfold comp; case (comp_match a b); intros; InvEval. + TrivialExists. simpl. rewrite Val.swap_cmp_bool. auto. + TrivialExists. + TrivialExists. Qed. -Theorem eval_compf: - forall le c a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (compf c a b) (Val.of_bool(Float.cmp c x y)). +Theorem eval_compu: + forall c, binary_constructor_sound (compu c) (Val.cmpu (Mem.valid_pointer m) c). Proof. - intros. unfold compf. EvalOp. simpl. - destruct (Float.cmp c x y); reflexivity. + intros; red; intros until y. unfold compu; case (compu_match a b); intros; InvEval. + TrivialExists. simpl. rewrite Val.swap_cmpu_bool. auto. + TrivialExists. + TrivialExists. Qed. -Theorem eval_cast8signed: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v). -Proof. intros; unfold cast8signed; EvalOp. Qed. - -Theorem eval_cast8unsigned: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v). -Proof. intros; unfold cast8unsigned; EvalOp. Qed. - -Theorem eval_cast16signed: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v). -Proof. intros; unfold cast16signed; EvalOp. Qed. +Theorem eval_compf: + forall c, binary_constructor_sound (compf c) (Val.cmpf c). +Proof. + intros; red; intros. unfold compf. TrivialExists. +Qed. -Theorem eval_cast16unsigned: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v). -Proof. intros; unfold cast16unsigned; EvalOp. Qed. -Theorem eval_singleoffloat: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v). -Proof. intros; unfold singleoffloat; EvalOp. Qed. +Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8). +Proof. + red; intros. unfold cast8signed. TrivialExists. +Qed. -Theorem eval_notint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (notint a) (Vint (Int.xor x Int.mone)). -Proof. intros; unfold notint; EvalOp. Qed. +Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). +Proof. + red; intros until x. unfold cast8unsigned. destruct (cast8unsigned_match a); intros; InvEval. + subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc. + rewrite Int.and_commut. TrivialExists. compute; auto. + TrivialExists. +Qed. -Theorem eval_negint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (negint a) (Vint (Int.neg x)). -Proof. intros; unfold negint; EvalOp. Qed. +Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). +Proof. + red; intros. unfold cast16signed. TrivialExists. +Qed. -Theorem eval_negf: - forall le a x, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le (negf a) (Vfloat (Float.neg x)). -Proof. intros; unfold negf; EvalOp. Qed. +Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). +Proof. + red; intros until x. unfold cast16unsigned. destruct (cast16unsigned_match a); intros; InvEval. + subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc. + rewrite Int.and_commut. TrivialExists. compute; auto. + TrivialExists. +Qed. -Theorem eval_absf: - forall le a x, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le (absf a) (Vfloat (Float.abs x)). -Proof. intros; unfold absf; EvalOp. Qed. +Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. +Proof. + red; intros. unfold singleoffloat. TrivialExists. +Qed. Theorem eval_intoffloat: - forall le a x n, - eval_expr ge sp e m le a (Vfloat x) -> - Float.intoffloat x = Some n -> - eval_expr ge sp e m le (intoffloat a) (Vint n). + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v. Proof. - intros; unfold intoffloat; EvalOp. - simpl. rewrite H0. auto. + intros; unfold intoffloat. TrivialExists. Qed. Theorem eval_floatofint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (floatofint a) (Vfloat (Float.floatofint x)). -Proof. intros; unfold floatofint; EvalOp. Qed. - -Theorem eval_addf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (addf a b) (Vfloat (Float.add x y)). -Proof. intros; unfold addf; EvalOp. Qed. - -Theorem eval_subf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (subf a b) (Vfloat (Float.sub x y)). -Proof. intros; unfold subf; EvalOp. Qed. - -Theorem eval_mulf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (mulf a b) (Vfloat (Float.mul x y)). -Proof. intros; unfold mulf; EvalOp. Qed. - -Theorem eval_divf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (divf a b) (Vfloat (Float.div x y)). -Proof. intros; unfold divf; EvalOp. Qed. + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofint x = Some y -> + exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v. +Proof. + intros; unfold floatofint. TrivialExists. +Qed. Theorem eval_intuoffloat: - forall le a x n, - eval_expr ge sp e m le a (Vfloat x) -> - Float.intuoffloat x = Some n -> - eval_expr ge sp e m le (intuoffloat a) (Vint n). -Proof. - intros. unfold intuoffloat. + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intuoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. +Proof. + intros. destruct x; simpl in H0; try discriminate. + destruct (Float.intuoffloat f) as [n|]_eqn; simpl in H0; inv H0. + exists (Vint n); split; auto. + unfold intuoffloat. econstructor. eauto. set (im := Int.repr Int.half_modulus). set (fm := Float.floatofintu im). - assert (eval_expr ge sp e m (Vfloat x :: le) (Eletvar O) (Vfloat x)). + assert (eval_expr ge sp e m (Vfloat f :: le) (Eletvar O) (Vfloat f)). constructor. auto. - apply eval_Econdition with (v1 := Float.cmp Clt x fm). + apply eval_Econdition with (v1 := Float.cmp Clt f fm). econstructor. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. simpl. auto. - caseEq (Float.cmp Clt x fm); intros. + destruct (Float.cmp Clt f fm) as []_eqn. exploit Float.intuoffloat_intoffloat_1; eauto. intro EQ. EvalOp. simpl. rewrite EQ; auto. exploit Float.intuoffloat_intoffloat_2; eauto. intro EQ. replace n with (Int.add (Int.sub n Float.ox8000_0000) Float.ox8000_0000). - apply eval_addimm. eapply eval_intoffloat; eauto. - apply eval_subf; auto. EvalOp. + exploit (eval_addimm Float.ox8000_0000 (Vfloat f :: le) + (intoffloat + (subf (Eletvar 0) + (Eop (Ofloatconst (Float.floatofintu Float.ox8000_0000)) Enil)))). + unfold intoffloat, subf. + EvalOp. constructor. EvalOp. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. + simpl. eauto. constructor. simpl. rewrite EQ. simpl; eauto. + intros [v [A B]]. simpl in B. inv B. auto. rewrite Int.sub_add_opp. rewrite Int.add_assoc. apply Int.add_zero. Qed. Theorem eval_floatofintu: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (floatofintu a) (Vfloat (Float.floatofintu x)). + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofintu x = Some y -> + exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v. Proof. - intros. unfold floatofintu. + intros. destruct x; simpl in H0; try discriminate. inv H0. + exists (Vfloat (Float.floatofintu i)); split; auto. econstructor. eauto. set (fm := Float.floatofintu Float.ox8000_0000). - assert (eval_expr ge sp e m (Vint x :: le) (Eletvar O) (Vint x)). + assert (eval_expr ge sp e m (Vint i :: le) (Eletvar O) (Vint i)). constructor. auto. - apply eval_Econdition with (v1 := Int.ltu x Float.ox8000_0000). + apply eval_Econdition with (v1 := Int.ltu i Float.ox8000_0000). econstructor. constructor. eauto. constructor. simpl. auto. - caseEq (Int.ltu x Float.ox8000_0000); intros. + destruct (Int.ltu i Float.ox8000_0000) as []_eqn. rewrite Float.floatofintu_floatofint_1; auto. - apply eval_floatofint; auto. - rewrite Float.floatofintu_floatofint_2; auto. - fold fm. apply eval_addf. apply eval_floatofint. - rewrite Int.sub_add_opp. apply eval_addimm; auto. - EvalOp. + unfold floatofint. EvalOp. + exploit (eval_addimm (Int.neg Float.ox8000_0000) (Vint i :: le) (Eletvar 0)); eauto. + simpl. intros [v [A B]]. inv B. + unfold addf. EvalOp. + constructor. unfold floatofint. EvalOp. simpl; eauto. + constructor. EvalOp. simpl; eauto. constructor. simpl; eauto. + fold fm. rewrite Float.floatofintu_floatofint_2; auto. + rewrite Int.sub_add_opp. auto. Qed. Theorem eval_addressing: -- cgit v1.2.3